code.delx.au - gnu-emacs/blob - lisp/ps-bdf.el

   1 ;;; ps-bdf.el --- BDF font file handler for ps-print
   2
   3 ;; Copyright (C) 1998, 1999, 2001, 2006 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1998, 1999, 2001, 2003
   5 ;;   National Institute of Advanced Industrial Science and Technology (AIST)
   6 ;;   Registration Number H14PRO021
   7
   8 ;; Keywords: wp, BDF, font, PostScript
   9 ;; Maintainer: Kenichi Handa <handa@m17n.org>
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; Functions for getting bitmap information from X's BDF font file are
  31 ;; provided.
  32
  33 ;;; Code:
  34
  35 (eval-and-compile
  36   (require 'ps-mule)
  37
  38   ;; to avoid XEmacs compilation gripes
  39   (defvar installation-directory nil)
  40   (defvar coding-system-for-read nil))
  41
  42 ;;;###autoload
  43 (defvar bdf-directory-list
  44   (if (memq system-type '(ms-dos windows-nt))
  45       (list (expand-file-name "fonts/bdf" installation-directory))
  46     '("/usr/local/share/emacs/fonts/bdf"))
  47   "*List of directories to search for `BDF' font files.
  48 The default value is '(\"/usr/local/share/emacs/fonts/bdf\").")
  49
  50 ;; MS-DOS and MS-Windows users like to move the binary around after
  51 ;; it's built, but the value above is computed at load-up time.
  52 (and (memq system-type '(ms-dos windows-nt))
  53      (setq bdf-directory-list
  54            (list (expand-file-name "fonts/bdf" installation-directory))))
  55
  56 (defun bdf-expand-file-name (bdfname)
  57   "Return an absolute path name of a `BDF' font file BDFNAME.
  58 It searches directories listed in the variable `bdf-directory-list'
  59 for BDFNAME."
  60   (if (file-name-absolute-p bdfname)
  61       (and (file-readable-p bdfname)
  62            bdfname)
  63     (let ((dir-list bdf-directory-list)
  64           dir)
  65       (while (and dir-list
  66                   (progn
  67                     (setq dir (expand-file-name bdfname (car dir-list)))
  68                     (not (file-readable-p dir))))
  69         (setq dir nil
  70               dir-list (cdr dir-list)))
  71       dir)))
  72
  73 (defsubst bdf-file-mod-time (filename)
  74   "Return modification time of FILENAME.
  75 The value is a list of two integers, the first integer has high-order
  76 16 bits, the second has low 16 bits."
  77   (nth 5 (file-attributes filename)))
  78
  79 (defun bdf-file-newer-than-time (filename mod-time)
  80   "Return non-nil if and only if FILENAME is newer than MOD-TIME.
  81 MOD-TIME is a modification time as a list of two integers, the first
  82 integer has high-order 16 bits, the second has low 16 bits."
  83   (let ((file-name (bdf-expand-file-name filename)))
  84     (and file-name
  85          (let* ((new-mod-time (bdf-file-mod-time file-name))
  86                 (new-time (car new-mod-time))
  87                 (time (car mod-time)))
  88            (or (> new-time time)
  89                (and (= new-time time)
  90                     (> (nth 1 new-mod-time) (nth 1 mod-time))))))))
  91
  92 (defun bdf-find-file (bdfname)
  93   "Return a buffer visiting a bdf file BDFNAME.
  94 If BDFNAME is not an absolute path, directories listed in
  95 `bdf-directory-list' is searched.
  96 If BDFNAME doesn't exist, return nil."
  97   (let ((file-name (bdf-expand-file-name bdfname)))
  98     (and file-name
  99          (let ((buf (generate-new-buffer " *bdf-work*"))
 100                (coding-system-for-read 'no-conversion))
 101            (save-excursion
 102              (set-buffer buf)
 103              (insert-file-contents file-name)
 104              buf)))))
 105
 106 (defvar bdf-cache-file (if (eq system-type 'ms-dos)
 107                            ;; convert-standard-filename doesn't
 108                            ;; guarantee that the .el extension will be
 109                            ;; preserved.
 110                            "~/_bdfcache.el"
 111                          (convert-standard-filename "~/.bdfcache.el"))
 112   "Name of cache file which contains information of `BDF' font files.")
 113
 114 (defvar bdf-cache nil
 115   "Cached information of `BDF' font files.  It is a list of FONT-INFO.
 116 FONT-INFO is a list of the following format:
 117     (BDFFILE ABSOLUTE-PATH MOD-TIME SIZE FONT-BOUNDING-BOX
 118      RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR)
 119 See the documentation of the function `bdf-read-font-info' for more detail.")
 120
 121 (defun bdf-read-cache ()
 122   "Return a cached information about `BDF' font files from a cache file.
 123 The variable `bdf-cache-file' holds the cache file name.
 124 If the cache file is not readable, this return nil."
 125   (setq bdf-cache nil)
 126   (condition-case nil
 127       (and (file-readable-p bdf-cache-file)
 128            (progn
 129              (load-file bdf-cache-file)
 130              (if (listp bdf-cache)
 131                  bdf-cache
 132                (setq bdf-cache nil))))
 133     (error nil)))
 134
 135 (defun bdf-write-cache ()
 136   "Write out cached information of `BDF' font file to a file.
 137 The variable `bdf-cache-file' holds the cache file name.
 138 The file is written if and only if the file already exists and writable."
 139   (and bdf-cache
 140        (file-exists-p bdf-cache-file)
 141        (file-writable-p bdf-cache-file)
 142        (write-region (format "(setq bdf-cache '%S)\n" bdf-cache)
 143                      nil bdf-cache-file)))
 144
 145 (defun bdf-set-cache (font-info)
 146   "Cache FONT-INFO as information about one `BDF' font file.
 147 FONT-INFO is a list of the following format:
 148     (BDFFILE ABSOLUTE-PATH MOD-TIME SIZE FONT-BOUNDING-BOX
 149      RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR)
 150 See the documentation of the function `bdf-read-font-info' for more detail."
 151   (let ((slot (assoc (car font-info) bdf-cache)))
 152     (if slot
 153         (setcdr slot (cdr font-info))
 154       (setq bdf-cache (cons font-info bdf-cache)))))
 155
 156 (defun bdf-initialize ()
 157   "Initialize `bdf' library."
 158   (and (bdf-read-cache)
 159        (add-hook 'kill-emacs-hook 'bdf-write-cache)))
 160
 161 (defun bdf-compact-code (code code-range)
 162   (if (or (< code (aref code-range 4))
 163           (> code (aref code-range 5)))
 164       (setq code (aref code-range 6)))
 165   (+ (* (- (lsh code -8) (aref code-range 0))
 166         (1+ (- (aref code-range 3) (aref code-range 2))))
 167      (- (logand code 255) (aref code-range 2))))
 168
 169 (defun bdf-expand-code (code code-range)
 170   (let ((code0-range (1+ (- (aref code-range 3) (aref code-range 2)))))
 171     (+ (* (+ (/ code code0-range) (aref code-range 0)) 256)
 172        (+ (% code code0-range) (aref code-range 2)))))
 173
 174 (defun bdf-search-and-read (match limit)
 175   (goto-char (point-min))
 176   (and (search-forward match limit t)
 177        (progn
 178          (goto-char (match-end 0))
 179          (read (current-buffer)))))
 180
 181 (defun bdf-read-font-info (bdfname)
 182   "Read `BDF' font file BDFNAME and return information (FONT-INFO) of the file.
 183 FONT-INFO is a list of the following format:
 184     (BDFFILE ABSOLUTE-PATH MOD-TIME FONT-BOUNDING-BOX
 185      RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR)
 186
 187 BDFFILE is a name of a font file (excluding directory part).
 188
 189 ABSOLUTE-PATH is an absolute path of the font file.
 190
 191 MOD-TIME is last modification time as a list of two integers, the
 192 first integer has high-order 16 bits, the second has low 16 bits.
 193
 194 SIZE is a size of the font.  This value is got from SIZE record of the
 195 font.
 196
 197 FONT-BOUNDING-BOX is the font bounding box as a list of four integers,
 198 BBX-WIDTH, BBX-HEIGHT, BBX-XOFF, and BBX-YOFF.
 199
 200 RELATIVE-COMPOSE is an integer value of the font's property
 201 `_MULE_RELATIVE_COMPOSE'.  If the font doesn't have this property, the
 202 value is 0.
 203
 204 BASELINE-OFFSET is an integer value of the font's property
 205 `_MULE_BASELINE_OFFSET'.  If the font doesn't have this property, the
 206 value is 0.
 207
 208 CODE-RANGE is a vector of minimum 1st byte, maximum 1st byte, minimum
 209 2nd byte, maximum 2nd byte, minimum code, maximum code, and default
 210 code.  For 1-byte fonts, the first two elements are 0.
 211
 212 MAXLEN is a maximum bytes of one glyph information in the font file.
 213
 214 OFFSET-VECTOR is a vector of a file position which starts bitmap data
 215 of the glyph in the font file.
 216
 217 Nth element of OFFSET-VECTOR is a file position for the glyph of code
 218 CODE, where N and CODE are in the following relation:
 219     (bdf-compact-code CODE) => N, (bdf-expand-code N) => CODE"
 220   (let* ((absolute-path (bdf-expand-file-name bdfname))
 221          (buf (and absolute-path (bdf-find-file absolute-path)))
 222          (maxlen 0)
 223          (relative-compose 'false)
 224          (baseline-offset 0)
 225          size
 226          font-bounding-box
 227          default-char
 228          code-range
 229          offset-vector)
 230     (if buf
 231         (message "Reading %s..." bdfname)
 232       (error "BDF file %s doesn't exist" bdfname))
 233     (unwind-protect
 234         (save-excursion
 235           (set-buffer buf)
 236           (goto-char (point-min))
 237           (search-forward "\nFONTBOUNDINGBOX")
 238           (setq font-bounding-box
 239                 (vector (read (current-buffer)) (read (current-buffer))
 240                         (read (current-buffer)) (read (current-buffer))))
 241           ;; The following kludgy code is to avoid bugs of fonts
 242           ;; jiskan16.bdf and jiskan24.bdf distributed with X.
 243           ;; They contain wrong FONTBOUNDINGBOX.
 244           (and (> (aref font-bounding-box 3) 0)
 245                (string-match "jiskan\\(16\\|24\\)" bdfname)
 246                (aset font-bounding-box 3
 247                      (- (aref font-bounding-box 3))))
 248
 249           (goto-char (point-min))
 250           (search-forward "\nSIZE ")
 251           (setq size (read (current-buffer)))
 252           ;; The following kludgy code is t avoid bugs of several
 253           ;; fonts which have wrong SIZE record.
 254           (and (<= size (/ (aref font-bounding-box 1) 3))
 255                (setq size (aref font-bounding-box 1)))
 256
 257           (setq default-char (bdf-search-and-read "\nDEFAULT_CHAR" nil))
 258
 259           (search-forward "\nSTARTCHAR")
 260           (forward-line -1)
 261           (let ((limit (point)))
 262             (setq relative-compose
 263                   (or (bdf-search-and-read "\n_MULE_RELATIVE_COMPOSE" limit)
 264                       'false)
 265                   baseline-offset
 266                   (or (bdf-search-and-read "\n_MULE_BASELINE_OFFSET" limit)
 267                       0)))
 268
 269           (let ((min-code0 256) (min-code1 256) (min-code 65536)
 270                 (max-code0 0) (max-code1 0) (max-code 0)
 271                 glyph glyph-list code0 code1 code offset)
 272
 273             (while (search-forward "\nSTARTCHAR" nil t)
 274               (setq offset (line-beginning-position))
 275               (search-forward "\nENCODING")
 276               (setq code (read (current-buffer)))
 277               (if (< code 0)
 278                   (search-forward "ENDCHAR")
 279                 (setq code0 (lsh code -8)
 280                       code1 (logand code 255)
 281                       min-code (min min-code code)
 282                       max-code (max max-code code)
 283                       min-code0 (min min-code0 code0)
 284                       max-code0 (max max-code0 code0)
 285                       min-code1 (min min-code1 code1)
 286                       max-code1 (max max-code1 code1))
 287                 (search-forward "ENDCHAR")
 288                 (setq maxlen (max maxlen (- (point) offset))
 289                       glyph-list (cons (cons code offset) glyph-list))))
 290
 291             (setq code-range
 292                   (vector min-code0 max-code0 min-code1 max-code1
 293                           min-code max-code (or default-char min-code))
 294                   offset-vector
 295                   (make-vector (1+ (bdf-compact-code max-code code-range))
 296                                nil))
 297
 298             (while glyph-list
 299               (setq glyph (car glyph-list)
 300                     glyph-list (cdr glyph-list))
 301               (aset offset-vector
 302                     (bdf-compact-code (car glyph) code-range)
 303                     (cdr glyph)))))
 304
 305     (kill-buffer buf))
 306   (message "Reading %s...done" bdfname)
 307   (list bdfname absolute-path (bdf-file-mod-time absolute-path)
 308         size font-bounding-box relative-compose baseline-offset
 309         code-range maxlen offset-vector)))
 310
 311 (defsubst bdf-info-absolute-path (font-info)     (nth 1 font-info))
 312 (defsubst bdf-info-mod-time (font-info)          (nth 2 font-info))
 313 (defsubst bdf-info-size (font-info)              (nth 3 font-info))
 314 (defsubst bdf-info-font-bounding-box (font-info) (nth 4 font-info))
 315 (defsubst bdf-info-relative-compose (font-info)  (nth 5 font-info))
 316 (defsubst bdf-info-baseline-offset (font-info)   (nth 6 font-info))
 317 (defsubst bdf-info-code-range (font-info)        (nth 7 font-info))
 318 (defsubst bdf-info-maxlen (font-info)            (nth 8 font-info))
 319 (defsubst bdf-info-offset-vector (font-info)     (nth 9 font-info))
 320
 321 (defun bdf-get-font-info (bdfname)
 322   "Return information about `BDF' font file BDFNAME.
 323 The value FONT-INFO is a list of the following format:
 324     (BDFFILE ABSOLUTE-PATH MOD-TIME SIZE FONT-BOUNDING-BOX
 325      RELATIVE-COMPOSE BASELINE-OFFSET CODE-RANGE MAXLEN OFFSET-VECTOR)
 326 See the documentation of the function `bdf-read-font-info' for more detail."
 327   (or bdf-cache
 328       (bdf-read-cache))
 329   (let ((font-info (assoc bdfname bdf-cache)))
 330     (if (or (not font-info)
 331             (not (file-readable-p (bdf-info-absolute-path font-info)))
 332             (bdf-file-newer-than-time bdfname (bdf-info-mod-time font-info)))
 333         (progn
 334           (setq font-info (bdf-read-font-info bdfname))
 335           (bdf-set-cache font-info)))
 336     font-info))
 337
 338 (defun bdf-find-font-info (bdfnames)
 339   "Return information about `BDF' font file with alternative names BDFNAMES.
 340
 341 If BDFNAMES is a list of file names, this function finds the first file
 342 in the list which exists and is readable, then calls `bdf-get-font-info'
 343 on that file name."
 344   (let ((fnlist bdfnames)
 345         (fname bdfnames))
 346     (if (consp fnlist)
 347         (while (and fnlist
 348                     (progn
 349                       (setq fname (car fnlist))
 350                       (null (bdf-expand-file-name fname))))
 351           (setq fname nil
 352                 fnlist (cdr fnlist))))
 353     (bdf-get-font-info (or fname (car bdfnames)))))
 354
 355 (defun bdf-read-bitmap (bdfname offset maxlen)
 356   "Read `BDF' font file BDFNAME to get bitmap data at file position OFFSET.
 357 BDFNAME is an absolute path name of the font file.
 358 MAXLEN specifies how many bytes we should read at least.
 359 The value is a list of DWIDTH, BBX, and BITMAP-STRING.
 360 DWIDTH is a pixel width of a glyph.
 361 BBX is a bounding box of the glyph.
 362 BITMAP-STRING is a string representing bits by hexadecimal digits."
 363   (let* ((coding-system-for-read 'no-conversion)
 364          (bbx (elt (bdf-get-font-info bdfname) 4))
 365          (dwidth (elt bbx 0))
 366          (bitmap-string "")
 367          height yoff)
 368     (condition-case nil
 369         (with-temp-buffer
 370           (insert-file-contents bdfname nil offset (+ offset maxlen))
 371           (goto-char (point-min))
 372           (search-forward "\nDWIDTH")
 373           (setq dwidth (read (current-buffer)))
 374           (goto-char (point-min))
 375           (search-forward "\nBBX")
 376           (setq bbx (vector (read (current-buffer)) (read (current-buffer))
 377                             (read (current-buffer)) (read (current-buffer)))
 378                 height (aref bbx 1)
 379                 yoff (aref bbx 3))
 380           (search-forward "\nBITMAP")
 381           (forward-line 1)
 382           (delete-region (point-min) (point))
 383           (and (looking-at "\\(0+\n\\)+")
 384                (progn
 385                  (setq height (- height (count-lines (point) (match-end 0))))
 386                  (delete-region (point) (match-end 0))))
 387           (or (looking-at "ENDCHAR")
 388               (progn
 389                 (search-forward "ENDCHAR" nil 'move)
 390                 (forward-line -1)
 391                 (while (looking-at "0+$")
 392                   (setq yoff (1+ yoff)
 393                         height (1- height))
 394                   (forward-line -1))
 395                 (forward-line 1)))
 396           (aset bbx 1 height)
 397           (aset bbx 3 yoff)
 398           (delete-region (point) (point-max))
 399           (goto-char (point-min))
 400           (while (not (eobp))
 401             (end-of-line)
 402             (delete-char 1))
 403           (setq bitmap-string (buffer-string)))
 404       (error nil))
 405     (list dwidth bbx bitmap-string)))
 406
 407 (defun bdf-get-bitmaps (bdfname codes)
 408   "Return bitmap information of glyphs of CODES in `BDF' font file BDFNAME.
 409 CODES is a list of encoding number of glyphs in the file.
 410 The value is a list of CODE, DWIDTH, BBX, and BITMAP-STRING.
 411 DWIDTH is a pixel width of a glyph.
 412 BBX is a bounding box of the glyph.
 413 BITMAP-STRING is a string representing bits by hexadecimal digits."
 414   (let* ((font-info (bdf-find-font-info bdfname))
 415          (absolute-path (bdf-info-absolute-path font-info))
 416          ;;(font-bounding-box (bdf-info-font-bounding-box font-info))
 417          (maxlen (bdf-info-maxlen font-info))
 418          (code-range (bdf-info-code-range font-info))
 419          (offset-vector (bdf-info-offset-vector font-info)))
 420     (mapcar '(lambda (x)
 421                (cons x (bdf-read-bitmap
 422                         absolute-path
 423                         (aref offset-vector (bdf-compact-code x code-range))
 424                         maxlen)))
 425             codes)))
 426
 427 ;;; Interface to ps-print.el
 428
 429 ;; Called from ps-mule-init-external-library.
 430 (defun bdf-generate-prologue ()
 431   (or bdf-cache
 432       (bdf-initialize))
 433   (ps-mule-generate-bitmap-prologue))
 434
 435 ;; Called from ps-mule-generate-font.
 436 (defun bdf-generate-font (charset font-spec)
 437   (let* ((font-name (ps-mule-font-spec-name font-spec))
 438          (font-info (bdf-find-font-info font-name))
 439          (font-name (if (consp font-name) (car font-name) font-name)))
 440     (ps-mule-generate-bitmap-font font-name
 441                                   (ps-mule-font-spec-bytes font-spec)
 442                                   (charset-width charset)
 443                                   (bdf-info-size font-info)
 444                                   (bdf-info-relative-compose font-info)
 445                                   (bdf-info-baseline-offset font-info)
 446                                   (bdf-info-font-bounding-box font-info))))
 447
 448 ;; Called from ps-mule-generate-glyphs.
 449 (defun bdf-generate-glyphs (font-spec code-list bytes)
 450   (let ((font-name (ps-mule-font-spec-name font-spec)))
 451     (mapcar '(lambda (x)
 452                (apply 'ps-mule-generate-bitmap-glyph
 453                       (if (consp font-name) (car font-name) font-name)
 454                       x))
 455             (bdf-get-bitmaps font-name code-list))))
 456
 457 (provide 'ps-bdf)
 458
 459 ;;; arch-tag: 9b875ba8-565a-4ecf-acaa-30cee732c898
 460 ;;; ps-bdf.el ends here