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