code.delx.au - gnu-emacs/blob - lisp/ps-mule.el

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