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