lisp/ps-bdf.el

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