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