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