lisp/ps-bdf.el

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