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