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