lisp/ps-mule.el

   1 ;;; ps-mule.el --- provide multi-byte character facility to ps-print
   2
   3 ;; Copyright (C) 1998,99,00,2001 Free Software Foundation, Inc.
   4
   5 ;; Author: Vinicius Jose Latorre <vinicius@cpqd.com.br>
   6 ;;      Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
   7 ;; Maintainer:  Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
   8 ;;      Vinicius Jose Latorre <vinicius@cpqd.com.br>
   9 ;; Keywords: wp, print, PostScript, multibyte, mule
  10 ;; Time-stamp: <2001/03/16 18:50:59 Handa>
  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., 59 Temple Place - Suite 330,
  27 ;; Boston, MA 02111-1307, USA.
  28
  29 ;;; Commentary:
  30
  31 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32 ;;
  33 ;; About ps-mule
  34 ;; -------------
  35 ;;
  36 ;; This package is used for ps-print to print multi-byte buffer.
  37 ;;
  38 ;; See also ps-print.el.
  39 ;;
  40 ;;
  41 ;; Printing Multi-byte Buffer
  42 ;; --------------------------
  43 ;;
  44 ;; The variable `ps-multibyte-buffer' specifies the ps-print multi-byte buffer
  45 ;; handling.
  46 ;;
  47 ;; Valid values for `ps-multibyte-buffer' are:
  48 ;;
  49 ;;  nil                     This is the value to use the default settings which
  50 ;;                          is by default for printing buffer with only ASCII
  51 ;;                          and Latin characters.   The default setting can be
  52 ;;                          changed by setting the variable
  53 ;;                          `ps-mule-font-info-database-default' differently.
  54 ;;                          The initial value of this variable is
  55 ;;                          `ps-mule-font-info-database-latin' (see
  56 ;;                          documentation).
  57 ;;
  58 ;;  `non-latin-printer'     This is the value to use when you have a japanese
  59 ;;                          or korean PostScript printer and want to print
  60 ;;                          buffer with ASCII, Latin-1, Japanese (JISX0208 and
  61 ;;                          JISX0201-Kana) and Korean characters.  At present,
  62 ;;                          it was not tested the Korean characters printing.
  63 ;;                          If you have a korean PostScript printer, please,
  64 ;;                          test it.
  65 ;;
  66 ;;  `bdf-font'              This is the value to use when you want to print
  67 ;;                          buffer with BDF fonts.  BDF fonts include both latin
  68 ;;                          and non-latin fonts.  BDF (Bitmap Distribution
  69 ;;                          Format) is a format used for distributing X's font
  70 ;;                          source file.  BDF fonts are included in
  71 ;;                          `intlfonts-1.2' which is a collection of X11 fonts
  72 ;;                          for all characters supported by Emacs.  In order to
  73 ;;                          use this value, be sure to have installed
  74 ;;                          `intlfonts-1.2' and set the variable
  75 ;;                          `bdf-directory-list' appropriately (see ps-bdf.el
  76 ;;                          for documentation of this variable).
  77 ;;
  78 ;;  `bdf-font-except-latin' This is like `bdf-font' except that it is used
  79 ;;                          PostScript default fonts to print ASCII and Latin-1
  80 ;;                          characters.  This is convenient when you want or
  81 ;;                          need to use both latin and non-latin characters on
  82 ;;                          the same buffer.  See `ps-font-family',
  83 ;;                          `ps-header-font-family' and `ps-font-info-database'.
  84 ;;
  85 ;; Any other value is treated as nil.
  86 ;;
  87 ;; The default is nil.
  88 ;;
  89 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  90
  91 ;;; Code:
  92
  93 (eval-and-compile
  94   (require 'ps-print)
  95
  96   ;; to avoid XEmacs compilation gripes
  97   (defvar leading-code-private-22 157)
  98   (or (fboundp 'charset-bytes)
  99       (defun charset-bytes (charset) 1)) ; ascii
 100   (or (fboundp 'charset-dimension)
 101       (defun charset-dimension (charset) 1)) ; ascii
 102   (or (fboundp 'charset-id)
 103       (defun charset-id (charset) 0))   ; ascii
 104   (or (fboundp 'charset-width)
 105       (defun charset-width (charset) 1)) ; ascii
 106   (or (fboundp 'find-charset-region)
 107       (defun find-charset-region (beg end &optional table)
 108         (list 'ascii)))
 109   (or (fboundp 'char-valid-p)
 110       (defun char-valid-p (char)
 111         (< (following-char) 256)))
 112   (or (fboundp 'split-char)
 113       (defun split-char (char)
 114         (list (if (char-valid-p char)
 115                   'ascii
 116                 'unknow)
 117               char)))
 118   (or (fboundp 'char-width)
 119       (defun char-width (char) 1))      ; ascii
 120   (or (fboundp 'chars-in-region)
 121       (defun chars-in-region (beg end)
 122         (- (max beg end) (min beg end))))
 123   (or (fboundp 'forward-point)
 124       (defun forward-point (arg)
 125         (save-excursion
 126           (let ((count (abs arg))
 127                 (step  (if (zerop arg)
 128                            0
 129                          (/ arg arg))))
 130             (while (and (> count 0)
 131                         (< (point-min) (point)) (< (point) (point-max)))
 132               (forward-char step)
 133               (setq count (1- count)))
 134             (+ (point) (* count step))))))
 135   (or (fboundp 'decompose-composite-char)
 136       (defun decompose-composite-char (char &optional type
 137                                             with-composition-rule)
 138         nil))
 139   (or (fboundp 'encode-coding-string)
 140       (defun encode-coding-string (string coding-system &optional nocopy)
 141         (if nocopy
 142             string
 143           (copy-sequence string))))
 144   (or (fboundp 'coding-system-p)
 145       (defun coding-system-p (obj) nil))
 146   (or (fboundp 'ccl-execute-on-string)
 147       (defun ccl-execute-on-string (ccl-prog status str
 148                                              &optional contin unibyte-p)
 149         str))
 150   (or (fboundp 'define-ccl-program)
 151       (defmacro define-ccl-program (name ccl-program &optional doc)
 152         `(defconst ,name nil ,doc)))
 153   (or (fboundp 'multibyte-string-p)
 154       (defun multibyte-string-p (str)
 155         (let ((len (length str))
 156               (i 0)
 157               multibyte)
 158           (while (and (< i len) (not (setq multibyte (> (aref str i) 255))))
 159             (setq i (1+ i)))
 160           multibyte)))
 161   (or (fboundp 'string-make-multibyte)
 162       (defalias 'string-make-multibyte 'copy-sequence)))
 163
 164
 165 ;;;###autoload
 166 (defcustom ps-multibyte-buffer nil
 167   "*Specifies the multi-byte buffer handling.
 168
 169 Valid values are:
 170
 171   nil                     This is the value to use the default settings which
 172                           is by default for printing buffer with only ASCII
 173                           and Latin characters.   The default setting can be
 174                           changed by setting the variable
 175                           `ps-mule-font-info-database-default' differently.
 176                           The initial value of this variable is
 177                           `ps-mule-font-info-database-latin' (see
 178                           documentation).
 179
 180   `non-latin-printer'     This is the value to use when you have a Japanese
 181                           or Korean PostScript printer and want to print
 182                           buffer with ASCII, Latin-1, Japanese (JISX0208 and
 183                           JISX0201-Kana) and Korean characters.  At present,
 184                           it was not tested the Korean characters printing.
 185                           If you have a korean PostScript printer, please,
 186                           test it.
 187
 188   `bdf-font'              This is the value to use when you want to print
 189                           buffer with BDF fonts.  BDF fonts include both latin
 190                           and non-latin fonts.  BDF (Bitmap Distribution
 191                           Format) is a format used for distributing X's font
 192                           source file.  BDF fonts are included in
 193                           `intlfonts-1.2' which is a collection of X11 fonts
 194                           for all characters supported by Emacs.  In order to
 195                           use this value, be sure to have installed
 196                           `intlfonts-1.2' and set the variable
 197                           `bdf-directory-list' appropriately (see ps-bdf.el for
 198                           documentation of this variable).
 199
 200   `bdf-font-except-latin' This is like `bdf-font' except that it is used
 201                           PostScript default fonts to print ASCII and Latin-1
 202                           characters.  This is convenient when you want or
 203                           need to use both latin and non-latin characters on
 204                           the same buffer.  See `ps-font-family',
 205                           `ps-header-font-family' and `ps-font-info-database'.
 206
 207 Any other value is treated as nil."
 208   :type '(choice (const non-latin-printer)     (const bdf-font)
 209                  (const bdf-font-except-latin) (const :tag "nil" nil))
 210   :group 'ps-print-font)
 211
 212
 213 (eval-and-compile
 214   ;; For Emacs 20.2 and the earlier version.
 215   (if (and (boundp 'mule-version)
 216            (not (string< (symbol-value 'mule-version) "4.0")))
 217       ;; mule package is loaded
 218       (progn
 219         (defalias 'ps-mule-next-point '1+)
 220         (defalias 'ps-mule-chars-in-string 'length)
 221         (defalias 'ps-mule-string-char 'aref)
 222         (defsubst ps-mule-next-index (str i) (1+ i)))
 223     ;; mule package isn't loaded or mule version lesser than 4.0
 224     (defun ps-mule-next-point (arg)
 225       (save-excursion (goto-char arg) (forward-char 1) (point)))
 226     (defun ps-mule-chars-in-string (string)
 227       (/ (length string)
 228          (charset-bytes (char-charset (string-to-char string)))))
 229     (defun ps-mule-string-char (string idx)
 230       (string-to-char (substring string idx)))
 231     (defun ps-mule-next-index (string i)
 232       (+ i (charset-bytes (char-charset (string-to-char string)))))
 233     )
 234   ;; For Emacs 20.4 and the earlier version.
 235   (if (and (boundp 'mule-version)
 236            (string< (symbol-value 'mule-version) "5.0"))
 237       ;; mule package is loaded and mule version is lesser than 5.0
 238       (progn
 239         (defun encode-composition-rule (rule)
 240           (if (= (car rule) 4) (setcar rule 10))
 241           (if (= (cdr rule) 4) (setcdr rule 10))
 242           (+ (* (car rule) 12) (cdr rule)))
 243         (defun find-composition (pos &rest ignore)
 244           (let ((ch (char-after pos)))
 245             (if (eq (char-charset ch) 'composition)
 246                 (let ((components (decompose-composite-char ch 'vector t)))
 247                   (list pos (ps-mule-next-point pos) components
 248                         (integerp (aref components 1)) nil
 249                         (char-width ch)))))))
 250     ;; mule package isn't loaded
 251     (or (fboundp 'encode-composition-rule)
 252         (defun encode-composition-rule (rule)
 253           130))
 254     (or (fboundp 'find-composition)
 255         (defun find-composition (pos &rest ignore)
 256           nil))
 257     ))
 258
 259 (defvar ps-mule-font-info-database
 260   nil
 261   "Alist of charsets with the corresponding font information.
 262 Each element has the form:
 263
 264         (CHARSET (FONT-TYPE FONT-SRC FONT-NAME ENCODING BYTES) ...)
 265
 266 Where
 267
 268 CHARSET is a charset (symbol) for this font family,
 269
 270 FONT-TYPE is a font type: normal, bold, italic, or bold-italic.
 271
 272 FONT-SRC is a font source: builtin, ps-bdf, vflib, or nil.
 273
 274   If FONT-SRC is builtin, FONT-NAME is a built-in PostScript font name.
 275
 276   If FONT-SRC is bdf, FONT-NAME is a BDF font file name, or a list of
 277   alternative font names.  To use this font, the external library `ps-bdf'
 278   is required.
 279
 280   If FONT-SRC is vflib, FONT-NAME is the name of a font that VFlib knows.
 281   To use this font, the external library `vflib' is required.
 282
 283   If FONT-SRC is nil, a proper ASCII font in the variable
 284   `ps-font-info-database' is used.  This is useful for Latin-1 characters.
 285
 286 ENCODING is a coding system to encode a string of characters of CHARSET into a
 287 proper string matching an encoding of the specified font.  ENCODING may be a
 288 function that does this encoding.  In this case, the function is called with
 289 one argument, the string to encode, and it should return an encoded string.
 290
 291 BYTES specifies how many bytes each character has in the encoded byte
 292 sequence; it should be 1 or 2.
 293
 294 All multi-byte characters are printed by fonts specified in this database
 295 regardless of a font family of ASCII characters.  The exception is Latin-1
 296 characters which are printed by the same font as ASCII characters, thus obey
 297 font family.
 298
 299 See also the variable `ps-font-info-database'.")
 300
 301 (defconst ps-mule-font-info-database-latin
 302   '((latin-iso8859-1
 303      (normal nil nil iso-latin-1)))
 304   "Sample setting of `ps-mule-font-info-database' to use latin fonts.")
 305
 306 (defcustom ps-mule-font-info-database-default
 307   ps-mule-font-info-database-latin
 308   "*The default setting to use when `ps-multibyte-buffer' is nil."
 309   :type '(symbol :tag "Multi-Byte Buffer Database Font Default")
 310   :group 'ps-print-font)
 311
 312 (defconst ps-mule-font-info-database-ps
 313   '((katakana-jisx0201
 314      (normal builtin "Ryumin-Light.Katakana" ps-mule-encode-7bit 1)
 315      (bold builtin "GothicBBB-Medium.Katakana" ps-mule-encode-7bit 1)
 316      (bold-italic builtin "GothicBBB-Medium.Katakana" ps-mule-encode-7bit 1))
 317     (latin-jisx0201
 318      (normal builtin "Ryumin-Light.Hankaku" ps-mule-encode-7bit 1)
 319      (bold builtin "GothicBBB-Medium.Hankaku" ps-mule-encode-7bit 1))
 320     (japanese-jisx0208
 321      (normal builtin "Ryumin-Light-H" ps-mule-encode-7bit 2)
 322      (bold builtin "GothicBBB-Medium-H" ps-mule-encode-7bit 2))
 323     (korean-ksc5601
 324      (normal builtin "Munhwa-Regular-KSC-EUC-H" ps-mule-encode-7bit 2)
 325      (bold builtin "Munhwa-Bold-KSC-EUC-H" ps-mule-encode-7bit 2))
 326     )
 327   "Sample setting of the `ps-mule-font-info-database' to use builtin PS font.
 328
 329 Currently, data for Japanese and Korean PostScript printers are listed.")
 330
 331 (defconst ps-mule-font-info-database-bdf
 332   '((ascii
 333      (normal bdf ("lt1-24-etl.bdf" "etl24-latin1.bdf") nil 1)
 334      (bold bdf ("lt1-16b-etl.bdf" "etl16b-latin1.bdf") nil 1)
 335      (italic bdf ("lt1-16i-etl.bdf" "etl16i-latin1.bdf") nil 1)
 336      (bold-italic bdf ("lt1-16bi-etl.bdf" "etl16bi-latin1.bdf") nil 1))
 337     (latin-iso8859-1
 338      (normal bdf ("lt1-24-etl.bdf" "etl24-latin1.bdf") iso-latin-1 1)
 339      (bold bdf ("lt1-16b-etl.bdf" "etl16b-latin1.bdf") iso-latin-1 1)
 340      (italic bdf ("lt1-16i-etl.bdf" "etl16i-latin1.bdf") iso-latin-1 1)
 341      (bold-italic bdf ("lt1-16bi-etl.bdf" "etl16bi-latin1.bdf") iso-latin-1 1))
 342     (latin-iso8859-2
 343      (normal bdf ("lt2-24-etl.bdf" "etl24-latin2.bdf") iso-latin-2 1))
 344     (latin-iso8859-3
 345      (normal bdf ("lt3-24-etl.bdf" "etl24-latin3.bdf") iso-latin-3 1))
 346     (latin-iso8859-4
 347      (normal bdf ("lt4-24-etl.bdf" "etl24-latin4.bdf") iso-latin-4 1))
 348     (thai-tis620
 349      (normal bdf ("thai24.bdf" "thai-24.bdf") thai-tis620 1))
 350     (greek-iso8859-7
 351      (normal bdf ("grk24-etl.bdf" "etl24-greek.bdf") greek-iso-8bit 1))
 352     ;; (arabic-iso8859-6        nil) ; not yet available
 353     (hebrew-iso8859-8
 354      (normal bdf ("heb24-etl.bdf" "etl24-hebrew.bdf") hebrew-iso-8bit 1))
 355     (katakana-jisx0201
 356      (normal bdf "12x24rk.bdf" ps-mule-encode-8bit 1))
 357     (latin-jisx0201
 358      (normal bdf "12x24rk.bdf" ps-mule-encode-7bit 1))
 359     (cyrillic-iso8859-5
 360      (normal bdf ("cyr24-etl.bdf" "etl24-cyrillic.bdf") cyrillic-iso-8bit 1))
 361     (latin-iso8859-9
 362      (normal bdf ("lt5-24-etl.bdf" "etl24-latin5.bdf") iso-latin-5 1))
 363     (japanese-jisx0208-1978
 364      (normal bdf "jiskan24.bdf" ps-mule-encode-7bit 2))
 365     (chinese-gb2312
 366      (normal bdf "gb24st.bdf" ps-mule-encode-7bit 2))
 367     (japanese-jisx0208
 368      (normal bdf "jiskan24.bdf" ps-mule-encode-7bit 2))
 369     (korean-ksc5601
 370      (normal bdf "hanglm24.bdf" ps-mule-encode-7bit 2))
 371     (japanese-jisx0212
 372      (normal bdf ("jksp40.bdf" "jisksp40.bdf") ps-mule-encode-7bit 2))
 373     (chinese-cns11643-1
 374      (normal bdf ("cns1-40.bdf" "cns-1-40.bdf") ps-mule-encode-7bit 2))
 375     (chinese-cns11643-2
 376      (normal bdf ("cns2-40.bdf" "cns-2-40.bdf") ps-mule-encode-7bit 2))
 377     (chinese-big5-1
 378      (normal bdf "taipei24.bdf" chinese-big5 2))
 379     (chinese-big5-2
 380      (normal bdf "taipei24.bdf" chinese-big5 2))
 381     (chinese-sisheng
 382      (normal bdf ("sish24-etl.bdf" "etl24-sisheng.bdf") ps-mule-encode-7bit 1))
 383     (ipa
 384      (normal bdf ("ipa24-etl.bdf" "etl24-ipa.bdf") ps-mule-encode-8bit 1))
 385     (vietnamese-viscii-lower
 386      (normal bdf ("visc24-etl.bdf" "etl24-viscii.bdf") vietnamese-viscii 1))
 387     (vietnamese-viscii-upper
 388      (normal bdf ("visc24-etl.bdf" "etl24-viscii.bdf") vietnamese-viscii 1))
 389     (arabic-digit
 390      (normal bdf ("arab24-0-etl.bdf" "etl24-arabic0.bdf") ps-mule-encode-7bit 1))
 391     (arabic-1-column
 392      (normal bdf ("arab24-1-etl.bdf" "etl24-arabic1.bdf") ps-mule-encode-7bit 1))
 393     ;; (ascii-right-to-left nil) ; not yet available
 394     (lao
 395      (normal bdf ("lao24-mule.bdf" "mule-lao-24.bdf") lao 1))
 396     (arabic-2-column
 397      (normal bdf ("arab24-2-etl.bdf" "etl24-arabic2.bdf") ps-mule-encode-7bit 1))
 398     (indian-is13194
 399      (normal bdf ("isci24-mule.bdf" "mule-iscii-24.bdf") ps-mule-encode-7bit 1))
 400     (indian-1-column
 401      (normal bdf ("ind1c24-mule.bdf" "mule-indian-1col-24.bdf") ps-mule-encode-7bit 2))
 402     (tibetan-1-column
 403      (normal bdf ("tib1c24-mule.bdf" "mule-tibmdx-1col-24.bdf") ps-mule-encode-7bit 2))
 404     (ethiopic
 405      (normal bdf ("ethio24f-uni.bdf" "ethiomx24f-uni.bdf") ps-mule-encode-ethiopic 2))
 406     (chinese-cns11643-3
 407      (normal bdf ("cns3-40.bdf" "cns-3-40.bdf") ps-mule-encode-7bit 2))
 408     (chinese-cns11643-4
 409      (normal bdf ("cns4-40.bdf" "cns-4-40.bdf") ps-mule-encode-7bit 2))
 410     (chinese-cns11643-5
 411      (normal bdf ("cns5-40.bdf" "cns-5-40.bdf") ps-mule-encode-7bit 2))
 412     (chinese-cns11643-6
 413      (normal bdf ("cns6-40.bdf" "cns-6-40.bdf") ps-mule-encode-7bit 2))
 414     (chinese-cns11643-7
 415      (normal bdf ("cns7-40.bdf" "cns-7-40.bdf") ps-mule-encode-7bit 2))
 416     (indian-2-column
 417      (normal bdf ("ind24-mule.bdf" "mule-indian-24.bdf") ps-mule-encode-7bit 2))
 418     (tibetan
 419      (normal bdf ("tib24p-mule.bdf" "tib24-mule.bdf" "mule-tibmdx-24.bdf")
 420              ps-mule-encode-7bit 2)))
 421   "Sample setting of the `ps-mule-font-info-database' to use BDF fonts.
 422 BDF (Bitmap Distribution Format) is a format used for distributing X's font
 423 source file.
 424
 425 Current default value list for BDF fonts is included in `intlfonts-1.2' which is
 426 a collection of X11 fonts for all characters supported by Emacs.
 427
 428 Using this list as default value to `ps-mule-font-info-database', all characters
 429 including ASCII and Latin-1 are printed by BDF fonts.
 430
 431 See also `ps-mule-font-info-database-ps-bdf'.")
 432
 433 (defconst ps-mule-font-info-database-ps-bdf
 434   (cons (car ps-mule-font-info-database-latin)
 435         (cdr (cdr ps-mule-font-info-database-bdf)))
 436   "Sample setting of the `ps-mule-font-info-database' to use BDF fonts.
 437
 438 Current default value list for BDF fonts is included in `intlfonts-1.2' which is
 439 a collection of X11 fonts for all characters supported by Emacs.
 440
 441 Using this list as default value to `ps-mule-font-info-database', all characters
 442 except ASCII and Latin-1 characters are printed by BDF fonts.  ASCII and Latin-1
 443 characters are printed by PostScript font specified by `ps-font-family' and
 444 `ps-header-font-family'.
 445
 446 See also `ps-mule-font-info-database-bdf'.")
 447
 448 ;; Two typical encoding functions for PostScript fonts.
 449
 450 (defun ps-mule-encode-7bit (string)
 451   (ps-mule-encode-bit string 0))
 452
 453 (defun ps-mule-encode-8bit (string)
 454   (ps-mule-encode-bit string 128))
 455
 456 (defun ps-mule-encode-bit (string delta)
 457   (let* ((dim (charset-dimension (char-charset (string-to-char string))))
 458          (len (* (ps-mule-chars-in-string string) dim))
 459          (str (make-string len 0))
 460          (i 0)
 461          (j 0))
 462     (if (= dim 1)
 463         (while (< j len)
 464           (aset str j
 465                 (+ (nth 1 (split-char (ps-mule-string-char string i))) delta))
 466           (setq i (ps-mule-next-index string i)
 467                 j (1+ j)))
 468       (while (< j len)
 469         (let ((split (split-char (ps-mule-string-char string i))))
 470           (aset str j (+ (nth 1 split) delta))
 471           (aset str (1+ j) (+ (nth 2 split) delta))
 472           (setq i (ps-mule-next-index string i)
 473                 j (+ j 2)))))
 474     str))
 475
 476 ;; Special encoding function for Ethiopic.
 477 (if (boundp 'mule-version)              ; only if mule package is loaded
 478     (define-ccl-program ccl-encode-ethio-unicode
 479       `(1
 480         ((read r2)
 481          (loop
 482           (if (r2 == ,leading-code-private-22)
 483               ((read r0)
 484                (if (r0 == ,(charset-id 'ethiopic))
 485                    ((read r1 r2)
 486                     (r1 &= 127) (r2 &= 127)
 487                     (call ccl-encode-ethio-font)
 488                     (write r1)
 489                     (write-read-repeat r2))
 490                  ((write r2 r0)
 491                   (repeat))))
 492             (write-read-repeat r2))))))
 493   ;; to avoid compilation gripes
 494   (defvar ccl-encode-ethio-unicode nil))
 495
 496 (if (boundp 'mule-version)
 497     ;; bound mule-version
 498     (defun ps-mule-encode-ethiopic (string)
 499       (ccl-execute-on-string (symbol-value 'ccl-encode-ethio-unicode)
 500                              (make-vector 9 nil)
 501                              string))
 502   ;; unbound mule-version
 503   (defun ps-mule-encode-ethiopic (string)
 504     string))
 505
 506 ;; A charset which we are now processing.
 507 (defvar ps-mule-current-charset nil)
 508
 509 (defun ps-mule-get-font-spec (charset font-type)
 510   "Return FONT-SPEC for printing characters CHARSET with FONT-TYPE.
 511 FONT-SPEC is a list that has the form:
 512
 513         (FONT-SRC FONT-NAME ENCODING BYTES)
 514
 515 FONT-SPEC is extracted from `ps-mule-font-info-database'.
 516
 517 See the documentation of `ps-mule-font-info-database' for the meaning of each
 518 element of the list."
 519   (let ((slot (cdr (assq charset ps-mule-font-info-database))))
 520     (and slot
 521          (cdr (or (assq font-type slot)
 522                   (and (eq font-type 'bold-italic)
 523                        (or (assq 'bold slot) (assq 'italic slot)))
 524                   (assq 'normal slot))))))
 525
 526 ;; Functions to access each element of FONT-SPEC.
 527 (defsubst ps-mule-font-spec-src (font-spec) (car font-spec))
 528 (defsubst ps-mule-font-spec-name (font-spec) (nth 1 font-spec))
 529 (defsubst ps-mule-font-spec-encoding (font-spec) (nth 2 font-spec))
 530 (defsubst ps-mule-font-spec-bytes (font-spec) (nth 3 font-spec))
 531
 532 (defsubst ps-mule-printable-p (charset)
 533   "Non-nil if characters in CHARSET is printable."
 534   (ps-mule-get-font-spec charset 'normal))
 535
 536 (defconst ps-mule-external-libraries
 537   '((builtin nil nil
 538              nil nil nil)
 539     (bdf ps-bdf nil
 540          bdf-generate-prologue bdf-generate-font bdf-generate-glyphs)
 541     (pcf nil nil
 542          pcf-generate-prologue pcf-generate-font pcf-generate-glyphs)
 543     (vflib nil nil
 544            vflib-generate-prologue vflib-generate-font vflib-generate-glyphs))
 545   "Alist of information of external libraries to support PostScript printing.
 546 Each element has the form:
 547
 548     (FONT-SRC FEATURE INITIALIZED-P PROLOGUE-FUNC FONT-FUNC GLYPHS-FUNC)
 549
 550 FONT-SRC is the font source: builtin, bdf, pcf, or vflib.
 551
 552 FEATURE is the feature that provide a facility to handle FONT-SRC.  Except for
 553 `builtin' FONT-SRC, this feature is automatically `require'd before handling
 554 FONT-SRC.  Currently, we only have the feature `ps-bdf'.
 555
 556 INITIALIZED-P indicates if this library is initialized or not.
 557
 558 PROLOGUE-FUNC is a function to generate PostScript code which define several
 559 PostScript procedures that will be called by FONT-FUNC and GLYPHS-FUNC.  It is
 560 called with no argument, and should return a list of strings.
 561
 562 FONT-FUNC is a function to generate PostScript code which define a new font.  It
 563 is called with one argument FONT-SPEC, and should return a list of strings.
 564
 565 GLYPHS-FUNC is a function to generate PostScript code which define glyphs of
 566 characters.  It is called with three arguments FONT-SPEC, CODE-LIST, and BYTES,
 567 and should return a list of strings.")
 568
 569 (defun ps-mule-init-external-library (font-spec)
 570   "Initialize external library specified by FONT-SPEC for PostScript printing.
 571 See the documentation of `ps-mule-get-font-spec' for FONT-SPEC's meaning."
 572   (let* ((font-src (ps-mule-font-spec-src font-spec))
 573          (slot (assq font-src ps-mule-external-libraries)))
 574     (or (not font-src)
 575         (nth 2 slot)
 576         (let ((func (nth 3 slot)))
 577           (if func
 578               (progn
 579                 (require (nth 1 slot))
 580                 (ps-output-prologue (funcall func))))
 581           (setcar (nthcdr 2 slot) t)))))
 582
 583 ;; Cached glyph information of fonts, alist of:
 584 ;;      (FONT-NAME ((FONT-TYPE-NUMBER . SCALED-FONT-NAME) ...)
 585 ;;       cache CODE0 CODE1 ...)
 586 (defvar ps-mule-font-cache nil)
 587
 588 (defun ps-mule-generate-font (font-spec charset &optional header-p)
 589   "Generate PostScript codes to define a new font in FONT-SPEC for CHARSET.
 590
 591 If optional 3rd arg HEADER-P is non-nil, generate codes to define a header
 592 font."
 593   (let* ((font-name (ps-mule-font-spec-name font-spec))
 594          (font-name (if (consp font-name) (car font-name) font-name))
 595          (font-cache (assoc font-name ps-mule-font-cache))
 596          (font-src (ps-mule-font-spec-src font-spec))
 597          (func (nth 4 (assq font-src ps-mule-external-libraries)))
 598          (font-size (if header-p (if (eq ps-current-font 0)
 599                                      ps-header-title-font-size-internal
 600                                    ps-header-font-size-internal)
 601                       ps-font-size-internal))
 602          (current-font (+ ps-current-font (if header-p 10 0)))
 603          (scaled-font-name
 604           (cond (header-p
 605                  (format "h%d" ps-current-font))
 606                 ((eq charset 'ascii)
 607                  (format "f%d" ps-current-font))
 608                 (t
 609                  (format "f%02x-%d" (charset-id charset) ps-current-font)))))
 610     (and func (not font-cache)
 611          (ps-output-prologue (funcall func charset font-spec)))
 612     (ps-output-prologue
 613      (list (format "/%s %f /%s Def%sFontMule\n"
 614                    scaled-font-name font-size font-name
 615                    (if (or header-p
 616                            (eq ps-mule-current-charset 'ascii))
 617                        "Ascii" ""))))
 618     (if font-cache
 619         (setcar (cdr font-cache)
 620                 (cons (cons current-font scaled-font-name)
 621                       (nth 1 font-cache)))
 622       (setq font-cache (list font-name
 623                              (list (cons current-font scaled-font-name))
 624                              'cache)
 625             ps-mule-font-cache (cons font-cache ps-mule-font-cache)))
 626     font-cache))
 627
 628 (defun ps-mule-generate-glyphs (font-spec code-list)
 629   "Generate PostScript codes which generate glyphs for CODE-LIST of FONT-SPEC."
 630   (let* ((font-src (ps-mule-font-spec-src font-spec))
 631          (func (nth 5 (assq font-src ps-mule-external-libraries))))
 632     (and func
 633          (ps-output-prologue
 634           (funcall func font-spec code-list
 635                    (ps-mule-font-spec-bytes font-spec))))))
 636
 637 (defun ps-mule-prepare-font (font-spec string charset
 638                                        &optional no-setfont header-p)
 639   "Generate PostScript codes to print STRING of CHARSET by font FONT-SPEC.
 640
 641 The generated code is inserted on prologue part except the code that sets the
 642 current font (using PostScript procedure `FM').
 643
 644 If optional 4th arg NO-SETFONT is non-nil, don't generate the code for setting
 645 the current font.
 646
 647 If optional 5th arg HEADER-P is non-nil, generate a code for setting a header
 648 font."
 649   (let* ((font-name (ps-mule-font-spec-name font-spec))
 650          (font-name (if (consp font-name) (car font-name) font-name))
 651          (current-font (+ ps-current-font (if header-p 10 0)))
 652          (font-cache (assoc font-name ps-mule-font-cache)))
 653     (or (and font-cache (assq current-font (nth 1 font-cache)))
 654         (setq font-cache (ps-mule-generate-font font-spec charset header-p)))
 655     (or no-setfont
 656         (let ((new-font (cdr (assq current-font (nth 1 font-cache)))))
 657           (or (equal new-font ps-last-font)
 658               (progn
 659                 (ps-output (format "/%s FM\n" new-font))
 660                 (setq ps-last-font new-font)))))
 661     (if (nth 5 (assq (ps-mule-font-spec-src font-spec)
 662                      ps-mule-external-libraries))
 663         ;; We have to generate PostScript codes which define glyphs.
 664         (let* ((cached-codes (nthcdr 2 font-cache))
 665                (bytes (ps-mule-font-spec-bytes font-spec))
 666                (len (length string))
 667                (i 0)
 668                newcodes code)
 669           (while (< i len)
 670             (setq code (if (= bytes 1)
 671                            (aref string i)
 672                          (+ (* (aref string i) 256) (aref string (1+ i)))))
 673             (or (memq code cached-codes)
 674                 (progn
 675                   (setq newcodes (cons code newcodes))
 676                   (setcdr cached-codes (cons code (cdr cached-codes)))))
 677             (setq i (+ i bytes)))
 678           (and newcodes
 679                (ps-mule-generate-glyphs font-spec newcodes))))))
 680
 681 ;;;###autoload
 682 (defun ps-mule-prepare-ascii-font (string)
 683   "Setup special ASCII font for STRING.
 684 STRING should contain only ASCII characters."
 685   (let ((font-spec
 686          (ps-mule-get-font-spec
 687           'ascii
 688           (car (nth ps-current-font (ps-font-alist 'ps-font-for-text))))))
 689     (and font-spec
 690          (ps-mule-prepare-font font-spec string 'ascii))))
 691
 692 ;;;###autoload
 693 (defun ps-mule-set-ascii-font ()
 694   (unless (eq ps-mule-current-charset 'ascii)
 695     (ps-set-font ps-current-font)
 696     (setq ps-mule-current-charset 'ascii)))
 697
 698 ;; List of charsets of multi-byte characters in a text being printed.
 699 ;; If the text doesn't contain any multi-byte characters (i.e. only ASCII),
 700 ;; the value is nil.
 701 (defvar ps-mule-charset-list nil)
 702
 703 ;; This is a PostScript code inserted in the header of generated PostScript.
 704 (defconst ps-mule-prologue
 705   "%%%% Start of Mule Section
 706
 707 %% Working dictionary for general use.
 708 /MuleDict 10 dict def
 709
 710 %% Adjust /RelativeCompose properly by checking /BaselineOffset.
 711 /AdjustRelativeCompose {        % fontdict  |-  fontdict
 712   dup length 2 add dict begin
 713     { 1 index /FID ne { def } { pop pop } ifelse } forall
 714     currentdict /BaselineOffset known {
 715         BaselineOffset false eq { /BaselineOffset 0 def } if
 716     } {
 717       /BaselineOffset 0 def
 718     } ifelse
 719     currentdict /RelativeCompose known not {
 720       /RelativeCompose [ 0 0.1 ] def
 721     } {
 722       RelativeCompose false ne {
 723         [ BaselineOffset RelativeCompose BaselineOffset add
 724           [ FontMatrix { FontSize div } forall ] transform ]
 725         /RelativeCompose exch def
 726       } if
 727     } ifelse
 728     currentdict
 729   end
 730 } def
 731
 732 %% Define already scaled font for non-ASCII character sets.
 733 /DefFontMule {                  % fontname size basefont  |-  --
 734   findfont exch scalefont AdjustRelativeCompose definefont pop
 735 } bind def
 736
 737 %% Define already scaled font for ASCII character sets.
 738 /DefAsciiFontMule {             % fontname size basefont  |-
 739   MuleDict begin
 740   findfont dup /Encoding get /ISOLatin1Encoding exch def
 741   exch scalefont AdjustRelativeCompose reencodeFontISO
 742   end
 743 } def
 744
 745 /CurrentFont false def
 746
 747 %% Set the specified font to use.
 748 %% For non-ASCII font, don't install Ascent, etc.
 749 /FM {                           %  fontname  |-  --
 750     /font exch def
 751     font /f0 eq font /f1 eq font /f2 eq font /f3 eq or or or {
 752       font F
 753     } {
 754       font findfont setfont
 755     } ifelse
 756 } bind def
 757
 758 %% Show vacant box for characters which don't have appropriate font.
 759 /SB {                           % count column |-  --
 760     SpaceWidth mul /w exch def
 761     1 exch 1 exch { %for
 762         pop
 763         gsave
 764         0 setlinewidth
 765         0 Descent rmoveto w 0 rlineto
 766         0 LineHeight rlineto w neg 0 rlineto closepath stroke
 767         grestore
 768         w 0 rmoveto
 769     } for
 770 } bind def
 771
 772 %% Flag to tell if we are now handling a composition.  This is
 773 %% defined here because both composition handler and bitmap font
 774 %% handler require it.
 775 /Composing false def
 776
 777 %%%% End of Mule Section
 778
 779 "
 780   "PostScript code for printing multi-byte characters.")
 781
 782 (defvar ps-mule-prologue-generated nil)
 783
 784 (defun ps-mule-prologue-generated ()
 785   (unless ps-mule-prologue-generated
 786     (ps-output-prologue ps-mule-prologue)
 787     (setq ps-mule-prologue-generated t)))
 788
 789 (defun ps-mule-find-wrappoint (from to char-width &optional composition)
 790   "Find the longest sequence which is printable in the current line.
 791
 792 The search starts at FROM and goes until TO.
 793
 794 Optional 4th arg COMPOSITION, if non-nil, is information of
 795 composition starting at FROM.
 796
 797 If COMPOSITION is nil, it is assumed that all characters between FROM
 798 and TO belong to a charset in `ps-mule-current-charset'.  Otherwise,
 799 it is assumed that all characters between FROM and TO belong to the
 800 same composition.
 801
 802 CHAR-WIDTH is the average width of ASCII characters in the current font.
 803
 804 Returns the value:
 805
 806         (ENDPOS . RUN-WIDTH)
 807
 808 Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
 809 the sequence."
 810   (if (or composition (eq ps-mule-current-charset 'composition))
 811       ;; We must draw one char by one.
 812       (let ((run-width (if composition
 813                            (nth 5 composition)
 814                          (* (char-width (char-after from)) char-width))))
 815         (if (> run-width ps-width-remaining)
 816             (cons from ps-width-remaining)
 817           (cons (if composition
 818                     (nth 1 composition)
 819                   (ps-mule-next-point from))
 820                 run-width)))
 821     ;; We assume that all characters in this range have the same width.
 822     (setq char-width (* char-width (charset-width ps-mule-current-charset)))
 823     (let ((run-width (* (chars-in-region from to) char-width)))
 824       (if (> run-width ps-width-remaining)
 825           (cons (min to
 826                      (save-excursion
 827                        (goto-char from)
 828                        (forward-point
 829                         (truncate (/ ps-width-remaining char-width)))))
 830                 ps-width-remaining)
 831         (cons to run-width)))))
 832
 833 ;;;###autoload
 834 (defun ps-mule-plot-string (from to &optional bg-color)
 835   "Generate PostScript code for plotting characters in the region FROM and TO.
 836
 837 It is assumed that all characters in this region belong to the same charset.
 838
 839 Optional argument BG-COLOR specifies background color.
 840
 841 Returns the value:
 842
 843         (ENDPOS . RUN-WIDTH)
 844
 845 Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
 846 the sequence."
 847   (setq ps-mule-current-charset (charset-after from))
 848   (let* ((wrappoint (ps-mule-find-wrappoint
 849                      from to (ps-avg-char-width 'ps-font-for-text)))
 850          (to (car wrappoint))
 851          (font-type (car (nth ps-current-font
 852                               (ps-font-alist 'ps-font-for-text))))
 853          (font-spec (ps-mule-get-font-spec ps-mule-current-charset font-type))
 854          (string (buffer-substring-no-properties from to)))
 855     (cond
 856      ((= from to)
 857       ;; We can't print any more characters in the current line.
 858       nil)
 859
 860      (font-spec
 861       ;; We surely have a font for printing this character set.
 862       (ps-output-string (ps-mule-string-encoding font-spec string))
 863       (ps-output " S\n"))
 864
 865      ((eq ps-mule-current-charset 'latin-iso8859-1)
 866       ;; Latin-1 can be printed by a normal ASCII font.
 867       (ps-output-string (ps-mule-string-ascii string))
 868       (ps-output " S\n"))
 869
 870      ;; This case is obsolete for Emacs 21.
 871      ((eq ps-mule-current-charset 'composition)
 872       (ps-mule-plot-composition from (ps-mule-next-point from) bg-color))
 873
 874      (t
 875       ;; No way to print this charset.  Just show a vacant box of an
 876       ;; appropriate width.
 877       (ps-output (format "%d %d SB\n"
 878                          (length string)
 879                          (if (eq ps-mule-current-charset 'composition)
 880                              (char-width (char-after from))
 881                            (charset-width ps-mule-current-charset))))))
 882     wrappoint))
 883
 884 ;;;###autoload
 885 (defun ps-mule-plot-composition (from to &optional bg-color)
 886   "Generate PostScript code for plotting composition in the region FROM and TO.
 887
 888 It is assumed that all characters in this region belong to the same
 889 composition.
 890
 891 Optional argument BG-COLOR specifies background color.
 892
 893 Returns the value:
 894
 895         (ENDPOS . RUN-WIDTH)
 896
 897 Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
 898 the sequence."
 899   (let* ((composition (find-composition from nil nil t))
 900          (wrappoint (ps-mule-find-wrappoint
 901                      from to (ps-avg-char-width 'ps-font-for-text)
 902                      composition))
 903          (to (car wrappoint))
 904          (font-type (car (nth ps-current-font
 905                               (ps-font-alist 'ps-font-for-text)))))
 906     (if (< from to)
 907         ;; We can print this composition in the current line.
 908         (let ((components (nth 2 composition)))
 909           (ps-mule-plot-components
 910            (ps-mule-prepare-font-for-components components font-type)
 911            (if (nth 3 composition) "RLC" "RBC"))))
 912     wrappoint))
 913
 914 ;; Prepare font of FONT-TYPE for printing COMPONENTS.  By side effect,
 915 ;; change character elements in COMPONENTS to the form:
 916 ;;      ENCODED-STRING or (FONTNAME . ENCODED-STRING)
 917 ;; and change rule elements to the encoded value (integer).
 918 ;; The latter form is used if we much change font for the character.
 919
 920 (defun ps-mule-prepare-font-for-components (components font-type)
 921   (let ((len (length components))
 922         (i 0)
 923         elt)
 924     (while (< i len)
 925       (setq elt (aref components i))
 926       (if (consp elt)
 927           ;; ELT is a composition rule.
 928           (setq elt (encode-composition-rule elt))
 929         ;; ELT is a glyph character.
 930         (let* ((charset (char-charset elt))
 931                (font (or (eq charset ps-mule-current-charset)
 932                          (if (eq charset 'ascii)
 933                              (format "/f%d" ps-current-font)
 934                            (format "/f%02x-%d"
 935                                    (charset-id charset) ps-current-font))))
 936                 str)
 937           (setq ps-mule-current-charset charset
 938                 str (ps-mule-string-encoding
 939                      (ps-mule-get-font-spec charset font-type)
 940                      (char-to-string elt)
 941                      'no-setfont))
 942           (if (stringp font)
 943               (setq elt (cons font str) ps-last-font font)
 944             (setq elt str))))
 945       (aset components i elt)
 946       (setq i (1+ i))))
 947   components)
 948
 949 (defun ps-mule-plot-components (components tail)
 950   (let ((elt (aref components 0))
 951         (len (length components))
 952         (i 1))
 953     (ps-output "[ ")
 954     (if (stringp elt)
 955         (ps-output-string elt)
 956       (ps-output (car elt) " ")
 957       (ps-output-string (cdr elt)))
 958     (while (< i len)
 959       (setq elt (aref components i) i (1+ i))
 960       (ps-output " ")
 961       (cond ((stringp elt)
 962              (ps-output-string elt))
 963             ((consp elt)
 964              (ps-output (car elt) " ")
 965              (ps-output-string (cdr elt)))
 966             (t                          ; i.e. (integerp elt)
 967              (ps-output (format "%d" elt)))))
 968     (ps-output " ] " tail "\n")))
 969
 970 ;; Composite font support
 971
 972 (defvar ps-mule-composition-prologue-generated nil)
 973
 974 (defconst ps-mule-composition-prologue
 975   "%%%% Character composition handler
 976 /RelativeCompositionSkip 0.4 def
 977
 978 %% Get a bounding box (relative to currentpoint) of STR.
 979 /GetPathBox {                   % str  |-  --
 980     gsave
 981     currentfont /FontType get 3 eq { %ifelse
 982         stringwidth pop pop
 983     } {
 984         currentpoint /y exch def /x exch def
 985         false charpath flattenpath pathbbox
 986         y sub /URY exch def x sub /URX exch def
 987         y sub /LLY exch def x sub /LLX exch def
 988     } ifelse
 989     grestore
 990 } bind def
 991
 992 %% Apply effects (underline, strikeout, overline, box) to the
 993 %% rectangle specified by TOP BOTTOM LEFT RIGHT.
 994 /SpecialEffect {                                        % --  |-  --
 995     currentpoint dup TOP add /yy exch def BOTTOM add /YY exch def
 996     dup LEFT add /xx exch def RIGHT add /XX exch def
 997     %% Adjust positions for future shadowing.
 998     Effect 8 and 0 ne {
 999         /yy yy Yshadow add def
1000         /XX XX Xshadow add def
1001     } if
1002     Effect 1 and 0 ne { UnderlinePosition Hline } if    % underline
1003     Effect 2 and 0 ne { StrikeoutPosition Hline } if    % strikeout
1004     Effect 4 and 0 ne { OverlinePosition  Hline } if    % overline
1005     bg {                                                % background
1006         true
1007         Effect 16 and 0 ne {SpaceBackground doBox} { xx yy XX YY doRect} ifelse
1008     } if
1009     Effect 16 and 0 ne { false 0 doBox } if             % box
1010 } def
1011
1012 %% Show STR with effects (shadow, outline).
1013 /ShowWithEffect {                                       % str  |-  --
1014     Effect 8 and 0 ne { dup doShadow } if
1015     Effect 32 and 0 ne { true doOutline } { show } ifelse
1016 } def
1017
1018 %% Draw COMPONENTS which have the form [ font0? [str0 xoff0 yoff0] ... ].
1019 /ShowComponents {                                       % components  |-  -
1020     LEFT 0 lt { LEFT neg 0 rmoveto } if
1021     {
1022         dup type /nametype eq {                         % font
1023             FM
1024         } {                                             % [ str xoff yoff ]
1025             gsave
1026             aload pop rmoveto ShowWithEffect
1027             grestore
1028         } ifelse
1029     } forall
1030     RIGHT 0 rmoveto
1031 } def
1032
1033 %% Show relative composition.
1034 /RLC {          % [ font0? str0 font1? str1 ... fontN? strN ]  |-  --
1035     /components exch def
1036     /Composing true def
1037     /first true def
1038     gsave
1039     [ components {
1040         /elt exch def
1041         elt type /nametype eq {                         % font
1042             elt dup FM
1043         } { first {                                     % first string
1044             /first false def
1045             elt GetPathBox
1046             %% Bounding box of overall glyphs.
1047             /LEFT LLX def
1048             /RIGHT URX def
1049             /TOP URY def
1050             /BOTTOM LLY def
1051             currentfont /RelativeCompose known {
1052                 /relative currentfont /RelativeCompose get def
1053             } {
1054                 %% Disable relative composition by setting sufficiently low
1055                 %% and high positions.
1056                 /relative [ -100000 100000 ] def
1057             } ifelse
1058             [ elt 0 0 ]
1059         } {                                             % other strings
1060             elt GetPathBox
1061             [ elt                                       % str
1062               LLX 0 lt { RIGHT } { 0 } ifelse           % xoff
1063               LLY relative 1 get ge {                   % compose on TOP
1064                   TOP LLY sub RelativeCompositionSkip add       % yoff
1065                   /TOP TOP URY LLY sub add RelativeCompositionSkip add def
1066               } { URY relative 0 get le {               % compose under BOTTOM
1067                   BOTTOM URY sub RelativeCompositionSkip sub % yoff
1068                   /BOTTOM BOTTOM URY LLY sub sub
1069                         RelativeCompositionSkip sub def
1070               } {
1071                   0                                     % yoff
1072                   URY TOP gt { /TOP URY def } if
1073                   LLY BOTTOM lt { /BOTTOM LLY def } if
1074               } ifelse } ifelse
1075               ]
1076             URX RIGHT gt { /RIGHT URX def } if
1077         } ifelse } ifelse
1078     } forall ] /components exch def
1079     grestore
1080
1081     %% Reflect special effects.
1082     SpecialEffect
1083
1084     %% Draw components while ignoring effects other than shadow and outline.
1085     components ShowComponents
1086     /Composing false def
1087
1088 } def
1089
1090 %% Show rule-base composition.
1091 /RBC {          % [ font0? str0 rule1 font1? str1 rule2 ... strN ]  |-  --
1092     /components exch def
1093     /Composing true def
1094     /first true def
1095     gsave
1096     [ components {
1097         /elt exch def
1098         elt type /nametype eq {                         % font
1099             elt dup FM
1100         } { elt type /integertype eq {                  % rule
1101             %% This RULE decoding should be compatible with macro
1102             %% COMPOSITION_DECODE_RULE in emacs/src/composite.h.
1103             elt 12 idiv dup 3 mod /grefx exch def 3 idiv /grefy exch def
1104             elt 12 mod dup 3 mod /nrefx exch def 3 idiv /nrefy exch def
1105         } { first {                                     % first string
1106             /first false def
1107             elt GetPathBox
1108             %% Bounding box of overall glyphs.
1109             /LEFT LLX def
1110             /RIGHT URX def
1111             /TOP URY def
1112             /BOTTOM LLY def
1113             /WIDTH RIGHT LEFT sub def
1114             [ elt 0 0 ]
1115         } {                                             % other strings
1116             elt GetPathBox
1117             /width URX LLX sub def
1118             /height URY LLY sub def
1119             /left LEFT [ 0 WIDTH 2 div WIDTH ] grefx get add
1120                 [ 0 width 2 div width ] nrefx get sub def
1121             /bottom [ TOP 0 BOTTOM TOP BOTTOM add 2 div ] grefy get
1122                 [ height LLY neg 0 height 2 div ] nrefy get sub def
1123             %% Update bounding box
1124             left LEFT lt { /LEFT left def } if
1125             left width add RIGHT gt { /RIGHT left width add def } if
1126             /WIDTH RIGHT LEFT sub def
1127             bottom BOTTOM lt { /BOTTOM bottom def } if
1128             bottom height add TOP gt { /TOP bottom height add def } if
1129             [ elt left LLX sub bottom LLY sub ]
1130         } ifelse } ifelse } ifelse
1131     } forall ] /components exch def
1132     grestore
1133
1134     %% Reflect special effects.
1135     SpecialEffect
1136
1137     %% Draw components while ignoring effects other than shadow and outline.
1138     components ShowComponents
1139
1140     /Composing false def
1141 } def
1142 %%%% End of character composition handler
1143
1144 "
1145   "PostScript code for printing character composition.")
1146
1147 (defun ps-mule-string-ascii (str)
1148   (ps-set-font ps-current-font)
1149   (string-as-unibyte (encode-coding-string str 'iso-latin-1)))
1150
1151 ;; Encode STR for a font specified by FONT-SPEC and return the result.
1152 ;; If necessary, it generates the PostScript code for the font and glyphs to
1153 ;; print STR.  If optional 4th arg HEADER-P is non-nil, it is assumed that STR
1154 ;; is for headers.
1155 (defun ps-mule-string-encoding (font-spec str &optional no-setfont header-p)
1156   (let ((encoding (ps-mule-font-spec-encoding font-spec)))
1157     (setq str
1158           (string-as-unibyte
1159            (cond ((coding-system-p encoding)
1160                   (encode-coding-string str encoding))
1161                  ((functionp encoding)
1162                   (funcall encoding str))
1163                  (encoding
1164                   (error "Invalid coding system or function: %s" encoding))
1165                  (t
1166                   str))))
1167     (if (ps-mule-font-spec-src font-spec)
1168         (ps-mule-prepare-font font-spec str ps-mule-current-charset
1169                               (or no-setfont header-p)
1170                               header-p)
1171       (or no-setfont
1172           (ps-set-font ps-current-font)))
1173     str))
1174
1175 ;; Bitmap font support
1176
1177 (defvar ps-mule-bitmap-prologue-generated nil)
1178
1179 (defconst ps-mule-bitmap-prologue
1180   "%%%% Bitmap font handler
1181
1182 /str7 7 string def              % working area
1183
1184 %% We grow the dictionary one bunch (1024 entries) by one.
1185 /BitmapDictArray 256 array def
1186 /BitmapDictLength 1024 def
1187 /BitmapDictIndex -1 def
1188
1189 /NewBitmapDict {                % --  |-  --
1190     /BitmapDictIndex BitmapDictIndex 1 add def
1191     BitmapDictArray BitmapDictIndex BitmapDictLength dict put
1192 } bind def
1193
1194 %% Make at least one dictionary.
1195 NewBitmapDict
1196
1197 /AddBitmap {                    % gloval-charname bitmap-data  |-  --
1198     BitmapDictArray BitmapDictIndex get
1199     dup length BitmapDictLength ge {
1200         pop
1201         NewBitmapDict
1202         BitmapDictArray BitmapDictIndex get
1203     } if
1204     3 1 roll put
1205 } bind def
1206
1207 /GetBitmap {                    % gloval-charname  |-  bitmap-data
1208     0 1 BitmapDictIndex { BitmapDictArray exch get begin } for
1209     load
1210     0 1 BitmapDictIndex { pop end } for
1211 } bind def
1212
1213 %% Return a global character name which can be used as a key in the
1214 %% bitmap dictionary.
1215 /GlobalCharName {               % fontidx code1 code2  |-  gloval-charname
1216     exch 256 mul add exch 65536 mul add 16777216 add 16 str7 cvrs 0 66 put
1217     str7 cvn
1218 } bind def
1219
1220 %% Character code holder for a 2-byte character.
1221 /FirstCode -1 def
1222
1223 %% Glyph rendering procedure
1224 /BuildGlyphCommon {             % fontdict charname  |-  --
1225     1 index /FontDimension get 1 eq { /FirstCode 0 store } if
1226     NameIndexDict exch get      % STACK: fontdict charcode
1227     FirstCode 0 lt { %ifelse
1228         %% This is the first byte of a 2-byte character.  Just
1229         %% remember it for the moment.
1230         /FirstCode exch store
1231         pop
1232         0 0 setcharwidth
1233     } {
1234         1 index /FontSize get /size exch def
1235         1 index /FontSpaceWidthRatio get /ratio exch def
1236         1 index /FontIndex get exch FirstCode exch
1237         GlobalCharName GetBitmap /bmp exch def
1238         %% bmp == [ DWIDTH BBX-WIDTH BBX-HEIGHT BBX-XOFF BBX-YOFF BITMAP ]
1239         Composing { %ifelse
1240             /FontMatrix get [ exch { size div } forall ] /mtrx exch def
1241             bmp 3 get bmp 4 get mtrx transform
1242             /LLY exch def /LLX exch def
1243             bmp 1 get bmp 3 get add bmp 2 get bmp 4 get add mtrx transform
1244             /URY exch def /URX exch def
1245         } {
1246             pop
1247         } ifelse
1248         /FirstCode -1 store
1249
1250         bmp 0 get SpaceWidthRatio ratio div mul size div 0      % wx wy
1251         setcharwidth                    % We can't use setcachedevice here.
1252
1253         bmp 1 get 0 gt bmp 2 get 0 gt and {
1254             bmp 1 get bmp 2 get         % width height
1255             true                        % polarity
1256             [ size 0 0 size neg bmp 3 get neg bmp 2 get bmp 4 get add ] % matrix
1257             bmp 5 1 getinterval cvx     % datasrc
1258             imagemask
1259         } if
1260     } ifelse
1261 } bind def
1262
1263 /BuildCharCommon {
1264     1 index /Encoding get exch get
1265     1 index /BuildGlyph get exec
1266 } bind def
1267
1268 %% Bitmap font creator
1269
1270 %% Common Encoding shared by all bitmap fonts.
1271 /EncodingCommon 256 array def
1272 %% Mapping table from character name to character code.
1273 /NameIndexDict 256 dict def
1274 0 1 255 { %for
1275     /idx exch def
1276     /idxname idx 256 add 16 (XXX) cvrs dup 0 67 put cvn def % `C' == 67
1277     EncodingCommon idx idxname put
1278     NameIndexDict idxname idx put
1279 } for
1280
1281 /GlobalFontIndex 0 def
1282
1283 %% fontname dim col fontsize relative-compose baseline-offset fbbx  |-  --
1284 /BitmapFont {
1285     15 dict begin
1286     /FontBBox exch def
1287     /BaselineOffset exch def
1288     /RelativeCompose exch def
1289     /FontSize exch def
1290     /FontBBox [ FontBBox { FontSize div } forall ] def
1291     FontBBox 2 get FontBBox 0 get sub exch div
1292     /FontSpaceWidthRatio exch def
1293     /FontDimension exch def
1294     /FontIndex GlobalFontIndex def
1295     /FontType 3 def
1296     /FontMatrix matrix def
1297     /Encoding EncodingCommon def
1298     /BuildGlyph { BuildGlyphCommon } def
1299     /BuildChar { BuildCharCommon } def
1300     currentdict end
1301     definefont pop
1302     /GlobalFontIndex GlobalFontIndex 1 add def
1303 } bind def
1304
1305 %% Define a new bitmap font.
1306 %% fontname dim col fontsize relative-compose baseline-offset fbbx  |-  --
1307 /NF {
1308     /fbbx exch def
1309     %% Convert BDF's FontBoundingBox to PostScript's FontBBox
1310     [ fbbx 2 get fbbx 3 get
1311       fbbx 2 get fbbx 0 get add fbbx 3 get fbbx 1 get add ]
1312     BitmapFont
1313 } bind def
1314
1315 %% Define a glyph for the specified font and character.
1316 /NG {                           % fontname charcode bitmap-data  |-  --
1317     /bmp exch def
1318     exch findfont dup /BaselineOffset get bmp 4 get add bmp exch 4 exch put
1319     /FontIndex get exch
1320     dup 256 idiv exch 256 mod GlobalCharName
1321     bmp AddBitmap
1322 } bind def
1323 %%%% End of bitmap font handler
1324
1325 ")
1326
1327 ;; External library support.
1328
1329 ;; The following three functions are to be called from external
1330 ;; libraries which support bitmap fonts (e.g. `bdf') to get
1331 ;; appropriate PostScript code.
1332
1333 (defun ps-mule-generate-bitmap-prologue ()
1334   (unless ps-mule-bitmap-prologue-generated
1335     (setq ps-mule-bitmap-prologue-generated t)
1336     (list ps-mule-bitmap-prologue)))
1337
1338 (defun ps-mule-generate-bitmap-font (&rest args)
1339   (list (apply 'format "/%s %d %d %f %S %d %S NF\n" args)))
1340
1341 (defun ps-mule-generate-bitmap-glyph (font-name code dwidth bbx bitmap)
1342   (format "/%s %d [ %d %d %d %d %d <%s> ] NG\n"
1343           font-name code
1344           dwidth (aref bbx 0) (aref bbx 1) (aref bbx 2) (aref bbx 3)
1345           bitmap))
1346
1347 ;; Mule specific initializers.
1348
1349 ;;;###autoload
1350 (defun ps-mule-initialize ()
1351   "Initialize global data for printing multi-byte characters."
1352   (setq ps-mule-font-cache nil
1353         ps-mule-prologue-generated nil
1354         ps-mule-composition-prologue-generated nil
1355         ps-mule-bitmap-prologue-generated nil)
1356   (mapcar `(lambda (x) (setcar (nthcdr 2 x) nil))
1357           ps-mule-external-libraries))
1358
1359 (defvar ps-mule-header-charsets nil)
1360
1361 ;;;###autoload
1362 (defun ps-mule-encode-header-string (string fonttag)
1363   "Generate PostScript code for ploting STRING by font FONTTAG.
1364 FONTTAG should be a string \"/h0\" or \"/h1\"."
1365   (setq string (if (multibyte-string-p string)
1366                    (copy-sequence string)
1367                  (string-make-multibyte string)))
1368   (when ps-mule-header-charsets
1369     (if (eq (car ps-mule-header-charsets) 'latin-iso8859-1)
1370         ;; Latin1 characters can be printed by the standard PostScript
1371         ;; font.  Converts the other non-ASCII characters to `?'.
1372         (let ((len (length string))
1373               (i 0))
1374           (while (< i len)
1375             (or (memq (char-charset (aref string i)) '(ascii latin-iso8859-1))
1376                 (aset string i ??))
1377             (setq i (1+ i)))
1378           (setq string (encode-coding-string string 'iso-latin-1)))
1379       ;; We must prepare a font for the first non-ASCII and non-Latin1
1380       ;; character in STRING.
1381       (let* ((ps-current-font (if (string= fonttag "/h0") 0 1))
1382              (ps-mule-current-charset (car ps-mule-header-charsets))
1383              (font-type (car (nth ps-current-font
1384                                   (ps-font-alist 'ps-font-for-header))))
1385              (font-spec (ps-mule-get-font-spec ps-mule-current-charset
1386                                                font-type)))
1387         (if (or (not font-spec)
1388                 (/= (charset-dimension ps-mule-current-charset) 1))
1389             ;; We don't have a proper font, or we can't print them on
1390             ;; header because this kind of charset is not ASCII
1391             ;; compatible.
1392             (let ((len (length string))
1393                   (i 0))
1394               (while (< i len)
1395                 (or (memq (char-charset (aref string i))
1396                           '(ascii latin-iso8859-1))
1397                     (aset string i ??))
1398                 (setq i (1+ i)))
1399               (setq string (encode-coding-string string 'iso-latin-1)))
1400           (let ((charsets (list 'ascii (car ps-mule-header-charsets)))
1401                 (len (length string))
1402                 (i 0))
1403             (while (< i len)
1404               (or (memq (char-charset (aref string i)) charsets)
1405                   (aset string i ??))
1406               (setq i (1+ i))))
1407           (setq string (ps-mule-string-encoding font-spec string nil t))))))
1408   string)
1409
1410 ;;;###autoload
1411 (defun ps-mule-header-string-charsets ()
1412   "Return a list of character sets that appears in header strings."
1413   (let ((str ""))
1414     (when ps-print-header
1415       (let ((tail (list ps-left-header ps-right-header)))
1416         (while tail
1417           ;; Simulate what is done by ps-generate-header-line to get a
1418           ;; string to plot.
1419           (let ((count 0)
1420                 (tmp (car tail)))
1421             (setq tail (cdr tail))
1422             (while (and tmp (< count ps-header-lines))
1423               (let ((elt (car tmp)))
1424                 (setq tmp (cdr tmp)
1425                       count (1+ count)
1426                       str (concat str
1427                                   (cond ((stringp elt) elt)
1428                                         ((and (symbolp elt) (fboundp elt))
1429                                          (funcall elt))
1430                                         ((and (symbolp elt) (boundp elt))
1431                                          (symbol-value elt))
1432                                         (t ""))))))))))
1433     (let ((len (length str))
1434           (i 0)
1435           charset-list)
1436       (while (< i len)
1437         (let ((charset (char-charset (aref str i))))
1438           (setq i (1+ i))
1439           (or (eq charset 'ascii)
1440               (memq charset charset-list)
1441               (setq charset-list (cons charset charset-list)))))
1442       charset-list)))
1443
1444 ;;;###autoload
1445 (defun ps-mule-begin-job (from to)
1446   "Start printing job for multi-byte chars between FROM and TO.
1447 This checks if all multi-byte characters in the region are printable or not."
1448   (setq ps-mule-charset-list nil
1449         ps-mule-header-charsets nil
1450         ps-mule-font-info-database
1451         (cond ((eq ps-multibyte-buffer 'non-latin-printer)
1452                ps-mule-font-info-database-ps)
1453               ((eq ps-multibyte-buffer 'bdf-font)
1454                ps-mule-font-info-database-bdf)
1455               ((eq ps-multibyte-buffer 'bdf-font-except-latin)
1456                ps-mule-font-info-database-ps-bdf)
1457               (t
1458                ps-mule-font-info-database-default)))
1459   (and (boundp 'enable-multibyte-characters)
1460        enable-multibyte-characters
1461        ;; Initialize `ps-mule-charset-list'.  If some characters aren't
1462        ;; printable, warn it.
1463        (let ((charsets (find-charset-region from to)))
1464          (setq charsets (delq 'ascii (delq 'unknown (delq nil charsets)))
1465                ps-mule-charset-list charsets)
1466          (save-excursion
1467            (goto-char from)
1468            (and (search-forward "\200" to t)
1469                 (setq ps-mule-charset-list
1470                       (cons 'composition ps-mule-charset-list))))
1471          ;; We also have to check non-ASCII charsets in the header strings.
1472          (let ((tail (ps-mule-header-string-charsets)))
1473            (while tail
1474              (unless (eq (car tail) 'ascii)
1475                (setq ps-mule-header-charsets
1476                      (cons (car tail) ps-mule-header-charsets))
1477                (or (memq (car tail) charsets)
1478                    (setq charsets (cons (car tail) charsets))))
1479              (setq tail (cdr tail))))
1480          (while charsets
1481            (setq charsets
1482                  (cond
1483                   ((or (eq (car charsets) 'composition)
1484                        (ps-mule-printable-p (car charsets)))
1485                    (cdr charsets))
1486                   ((y-or-n-p
1487                     "Font for some characters not found, continue anyway? ")
1488                    nil)
1489                   (t
1490                    (error "Printing cancelled")))))))
1491
1492   (setq ps-mule-current-charset 'ascii)
1493
1494   (if (and (nth 2 (find-composition from to))
1495            (not ps-mule-composition-prologue-generated))
1496       (progn
1497         (ps-mule-prologue-generated)
1498         (ps-output-prologue ps-mule-composition-prologue)
1499         (setq ps-mule-composition-prologue-generated t)))
1500
1501   (if (or ps-mule-charset-list ps-mule-header-charsets)
1502       (let ((the-list (append ps-mule-header-charsets ps-mule-charset-list))
1503             font-spec elt)
1504         (ps-mule-prologue-generated)
1505         ;; If external functions are necessary, generate prologues for them.
1506         (while the-list
1507           (setq elt (car the-list)
1508                 the-list (cdr the-list))
1509           (cond ((and (eq elt 'composition)
1510                       (not ps-mule-composition-prologue-generated))
1511                  (ps-output-prologue ps-mule-composition-prologue)
1512                  (setq ps-mule-composition-prologue-generated t))
1513                 ((setq font-spec (ps-mule-get-font-spec elt 'normal))
1514                  (ps-mule-init-external-library font-spec))))))
1515
1516   ;; If ASCII font is also specified in ps-mule-font-info-database,
1517   ;; use it instead of what specified in ps-font-info-database.
1518   (let ((font-spec (ps-mule-get-font-spec 'ascii 'normal)))
1519     (if font-spec
1520         (progn
1521           (ps-mule-prologue-generated)
1522           (ps-mule-init-external-library font-spec)
1523           (let ((font (ps-font-alist 'ps-font-for-text))
1524                 (ps-current-font 0))
1525             (while font
1526               ;; Be sure to download a glyph for SPACE in advance.
1527               (ps-mule-prepare-font (ps-mule-get-font-spec 'ascii (car font))
1528                                     " " 'ascii 'no-setfont)
1529               (setq font (cdr font)
1530                     ps-current-font (1+ ps-current-font)))))))
1531
1532   ;; If the header contains non-ASCII and non-Latin1 characters, prepare a font
1533   ;; and glyphs for the first occurance of such characters.
1534   (if (and ps-mule-header-charsets
1535            (not (eq (car ps-mule-header-charsets) 'latin-iso8859-1)))
1536       (let ((font-spec (ps-mule-get-font-spec (car ps-mule-header-charsets)
1537                                               'normal)))
1538         (if font-spec
1539             ;; Be sure to download glyphs for "0123456789/" in advance for page
1540             ;; numbering.
1541             (let ((ps-current-font 0))
1542               (ps-mule-prepare-font font-spec "0123456789/" 'ascii t t)))))
1543
1544   (if ps-mule-charset-list
1545       ;; We must change this regexp for multi-byte buffer.
1546       (setq ps-control-or-escape-regexp
1547             (cond ((eq ps-print-control-characters '8-bit)
1548                    "[^\040-\176]")
1549                   ((eq ps-print-control-characters 'control-8-bit)
1550                    (string-as-multibyte "[^\040-\176\240-\377]"))
1551                   ((eq ps-print-control-characters 'control)
1552                    (string-as-multibyte "[^\040-\176\200-\377]"))
1553                   (t (string-as-multibyte "[^\000-\011\013\015-\377]"))))))
1554
1555 ;;;###autoload
1556 (defun ps-mule-begin-page ()
1557   (setq ps-mule-current-charset 'ascii))
1558
1559
1560 (provide 'ps-mule)
1561
1562 ;;; ps-mule.el ends here