1 ;;; ps-print.el --- Print text from the buffer as PostScript
3 ;; Copyright (C) 1993, 94, 95, 96, 97, 1998 Free Software Foundation, Inc.
5 ;; Author: Jim Thompson (was <thompson@wg2.waii.com>)
6 ;; Author: Jacques Duthen (was <duthen@cegelec-red.fr>)
7 ;; Author: Vinicius Jose Latorre <vinicius@cpqd.com.br>
8 ;; Author: Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
9 ;; Maintainer: Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
10 ;; Maintainer: Vinicius Jose Latorre <vinicius@cpqd.com.br>
11 ;; Keywords: print, PostScript
12 ;; Time-stamp: <98/10/13 15:42:23 vinicius>
15 (defconst ps-print-version "4.1.1"
16 "ps-print.el, v 4.1.1 <98/10/13 vinicius>
18 Vinicius's last change version -- this file may have been edited as part of
19 Emacs without changes to the version number. When reporting bugs,
20 please also report the version of Emacs, if any, that ps-print was
23 Please send all bug fixes and enhancements to
24 Vinicius Jose Latorre <vinicius@cpqd.com.br>.
27 ;; This file is part of GNU Emacs.
29 ;; GNU Emacs is free software; you can redistribute it and/or modify
30 ;; it under the terms of the GNU General Public License as published by
31 ;; the Free Software Foundation; either version 2, or (at your option)
34 ;; GNU Emacs is distributed in the hope that it will be useful,
35 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
36 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
37 ;; GNU General Public License for more details.
39 ;; You should have received a copy of the GNU General Public License
40 ;; along with GNU Emacs; see the file COPYING. If not, write to the
41 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
42 ;; Boston, MA 02111-1307, USA.
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51 ;; This package provides printing of Emacs buffers on PostScript
52 ;; printers; the buffer's bold and italic text attributes are
53 ;; preserved in the printer output. ps-print is intended for use with
54 ;; Emacs 19 or Lucid Emacs, together with a fontifying package such as
55 ;; font-lock or hilit.
57 ;; ps-print uses the same face attributes defined through font-lock or hilit
58 ;; to print a PostScript file, but some faces are better seeing on the screen
59 ;; than on paper, specially when you have a black/white PostScript printer.
61 ;; ps-print allows a remap of face to another one that it is better to print,
62 ;; for example, the face font-lock-comment-face (if you are using font-lock)
63 ;; could have bold or italic attribute when printing, besides foreground color.
64 ;; This remap improves printing look (see How Ps-Print Maps Faces).
72 ;; ps-print provides eight commands for generating PostScript images
76 ;; ps-print-buffer-with-faces
78 ;; ps-print-region-with-faces
80 ;; ps-spool-buffer-with-faces
82 ;; ps-spool-region-with-faces
84 ;; These commands all perform essentially the same function: they
85 ;; generate PostScript images suitable for printing on a PostScript
86 ;; printer or displaying with GhostScript. These commands are
87 ;; collectively referred to as "ps-print- commands".
89 ;; The word "print" or "spool" in the command name determines when the
90 ;; PostScript image is sent to the printer:
92 ;; print - The PostScript image is immediately sent to the
95 ;; spool - The PostScript image is saved temporarily in an
96 ;; Emacs buffer. Many images may be spooled locally
97 ;; before printing them. To send the spooled images
98 ;; to the printer, use the command `ps-despool'.
100 ;; The spooling mechanism was designed for printing lots of small
101 ;; files (mail messages or netnews articles) to save paper that would
102 ;; otherwise be wasted on banner pages, and to make it easier to find
103 ;; your output at the printer (it's easier to pick up one 50-page
104 ;; printout than to find 50 single-page printouts).
106 ;; ps-print has a hook in the `kill-emacs-hook' so that you won't
107 ;; accidentally quit from Emacs while you have unprinted PostScript
108 ;; waiting in the spool buffer. If you do attempt to exit with
109 ;; spooled PostScript, you'll be asked if you want to print it, and if
110 ;; you decline, you'll be asked to confirm the exit; this is modeled
111 ;; on the confirmation that Emacs uses for modified buffers.
113 ;; The word "buffer" or "region" in the command name determines how
114 ;; much of the buffer is printed:
116 ;; buffer - Print the entire buffer.
118 ;; region - Print just the current region.
120 ;; The -with-faces suffix on the command name means that the command
121 ;; will include font, color, and underline information in the
122 ;; PostScript image, so the printed image can look as pretty as the
123 ;; buffer. The ps-print- commands without the -with-faces suffix
124 ;; don't include font, color, or underline information; images printed
125 ;; with these commands aren't as pretty, but are faster to generate.
127 ;; Two ps-print- command examples:
129 ;; ps-print-buffer - print the entire buffer,
130 ;; without font, color, or
131 ;; underline information, and
132 ;; send it immediately to the
135 ;; ps-spool-region-with-faces - print just the current region;
136 ;; include font, color, and
137 ;; underline information, and
138 ;; spool the image in Emacs to
139 ;; send to the printer later.
145 ;; To print your buffer, type
147 ;; M-x ps-print-buffer
149 ;; or substitute one of the other seven ps-print- commands. The
150 ;; command will generate the PostScript image and print or spool it as
151 ;; specified. By giving the command a prefix argument
153 ;; C-u M-x ps-print-buffer
155 ;; it will save the PostScript image to a file instead of sending it
156 ;; to the printer; you will be prompted for the name of the file to
157 ;; save the image to. The prefix argument is ignored by the commands
158 ;; that spool their images, but you may save the spooled images to a
159 ;; file by giving a prefix argument to `ps-despool':
161 ;; C-u M-x ps-despool
163 ;; When invoked this way, `ps-despool' will prompt you for the name of
164 ;; the file to save to.
166 ;; Any of the `ps-print-' commands can be bound to keys; I recommend
167 ;; binding `ps-spool-buffer-with-faces', `ps-spool-region-with-faces',
168 ;; and `ps-despool'. Here are the bindings I use on my Sun 4 keyboard:
170 ;; (global-set-key 'f22 'ps-spool-buffer-with-faces) ;f22 is prsc
171 ;; (global-set-key '(shift f22) 'ps-spool-region-with-faces)
172 ;; (global-set-key '(control f22) 'ps-despool)
175 ;; The Printer Interface
176 ;; ---------------------
178 ;; The variables `ps-lpr-command' and `ps-lpr-switches' determine what
179 ;; command is used to send the PostScript images to the printer, and
180 ;; what arguments to give the command. These are analogous to
181 ;; `lpr-command' and `lpr-switches'.
183 ;; Make sure that they contain appropriate values for your system;
184 ;; see the usage notes below and the documentation of these variables.
186 ;; The variable `ps-printer-name' determine the name of a local printer for
187 ;; printing PostScript files.
189 ;; NOTE: `ps-lpr-command' and `ps-lpr-switches' take their initial values
190 ;; from the variables `lpr-command' and `lpr-switches'. If you have
191 ;; `lpr-command' set to invoke a pretty-printer such as `enscript',
192 ;; then ps-print won't work properly. `ps-lpr-command' must name
193 ;; a program that does not format the files it prints.
194 ;; `ps-printer-name' takes its initial value from the variable
201 ;; All dimensions are floats in PostScript points.
202 ;; 1 inch == 2.54 cm == 72 points
203 ;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points
205 ;; The variable `ps-paper-type' determines the size of paper ps-print
206 ;; formats for; it should contain one of the symbols:
207 ;; `a4' `a3' `letter' `legal' `letter-small' `tabloid'
208 ;; `ledger' `statement' `executive' `a4small' `b4' `b5'
210 ;; The variable `ps-landscape-mode' determines the orientation
211 ;; of the printing on the page:
212 ;; nil means `portrait' mode, non-nil means `landscape' mode.
213 ;; There is no oblique mode yet, though this is easy to do in ps.
215 ;; In landscape mode, the text is NOT scaled: you may print 70 lines
216 ;; in portrait mode and only 50 lignes in landscape mode.
217 ;; The margins represent margins in the printed paper:
218 ;; the top margin is the margin between the top of the page
219 ;; and the printed header, whatever the orientation is.
221 ;; The variable `ps-number-of-columns' determines the number of columns
222 ;; both in landscape and portrait mode.
224 ;; - (the standard) one column portrait mode
225 ;; - (my favorite) two columns landscape mode (which spares trees)
227 ;; - one column landscape mode for files with very long lines.
228 ;; - multi-column portrait or landscape mode
234 ;; The horizontal layout is determined by the variables
235 ;; `ps-left-margin' `ps-inter-column' `ps-right-margin'
238 ;; ------------------------------------------
240 ;; | lm | text | ic | text | ic | text | rm |
242 ;; ------------------------------------------
244 ;; If `ps-number-of-columns' is 1, `ps-inter-column' is not relevant.
245 ;; Usually, lm = rm > 0 and ic = lm
246 ;; If (ic < 0), the text of adjacent columns can overlap.
252 ;; The vertical layout is determined by the variables
253 ;; `ps-bottom-margin' `ps-top-margin' `ps-header-offset'
256 ;; |--------| |--------|
258 ;; |--------| |--------|
262 ;; |--------| or | text |
266 ;; |--------| |--------|
268 ;; |--------| |--------|
270 ;; If `ps-print-header' is nil, `ps-header-offset' is not relevant.
271 ;; The margins represent margins in the printed paper:
272 ;; the top margin is the margin between the top of the page
273 ;; and the printed header, whatever the orientation is.
279 ;; ps-print can print headers at the top of each column or at the top
280 ;; of each page; the default headers contain the following four items:
281 ;; on the left, the name of the buffer and, if the buffer is visiting
282 ;; a file, the file's directory; on the right, the page number and
283 ;; date of printing. The default headers look something like this:
286 ;; /home/jct/emacs-lisp/ps/new 94/12/31
288 ;; When printing on duplex printers, left and right are reversed so
289 ;; that the page numbers are toward the outside (cf. `ps-spool-duplex').
291 ;; Headers are configurable:
292 ;; To turn them off completely, set `ps-print-header' to nil.
293 ;; To turn off the header's gaudy framing box,
294 ;; set `ps-print-header-frame' to nil.
296 ;; To print only one header at the top of each page,
297 ;; set `ps-print-only-one-header' to t.
299 ;; The font family and size of text in the header are determined
300 ;; by the variables `ps-header-font-family', `ps-header-font-size' and
301 ;; `ps-header-title-font-size' (see below).
303 ;; The variable `ps-header-line-pad' determines the portion of a header
304 ;; title line height to insert between the header frame and the text
305 ;; it contains, both in the vertical and horizontal directions:
306 ;; .5 means half a line.
308 ;; Page numbers are printed in `n/m' format, indicating page n of m pages;
309 ;; to omit the total page count and just print the page number,
310 ;; set `ps-show-n-of-n' to nil.
312 ;; The amount of information in the header can be changed by changing
313 ;; the number of lines. To show less, set `ps-header-lines' to 1, and
314 ;; the header will show only the buffer name and page number. To show
315 ;; more, set `ps-header-lines' to 3, and the header will show the time of
316 ;; printing below the date.
318 ;; To change the content of the headers, change the variables
319 ;; `ps-left-header' and `ps-right-header'.
320 ;; These variables are lists, specifying top-to-bottom the text
321 ;; to display on the left or right side of the header.
322 ;; Each element of the list should be a string or a symbol.
323 ;; Strings are inserted directly into the PostScript arrays,
324 ;; and should contain the PostScript string delimiters '(' and ')'.
326 ;; Symbols in the header format lists can either represent functions
327 ;; or variables. Functions are called, and should return a string to
328 ;; show in the header. Variables should contain strings to display in
329 ;; the header. In either case, function or variable, the PostScript
330 ;; string delimiters are added by ps-print, and should not be part of
331 ;; the returned value.
333 ;; Here's an example: say we want the left header to display the text
339 ;; where we have a function to return "Moe"
341 ;; (defun moe-func ()
344 ;; a variable specifying "Larry"
346 ;; (setq larry-var "Larry")
348 ;; and a literal for "Curly". Here's how `ps-left-header' should be
351 ;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)"))
353 ;; Note that Curly has the PostScript string delimiters inside his
354 ;; quotes -- those aren't misplaced lisp delimiters!
356 ;; Without them, PostScript would attempt to call the undefined
357 ;; function Curly, which would result in a PostScript error.
359 ;; Since most printers don't report PostScript errors except by
360 ;; aborting the print job, this kind of error can be hard to track down.
362 ;; Consider yourself warned!
365 ;; PostScript Prologue Header
366 ;; --------------------------
368 ;; It is possible to add PostScript prologue header comments besides that
369 ;; ps-print generates by setting the variable `ps-print-prologue-header'.
371 ;; `ps-print-prologue-header' may be a string or a symbol function which
372 ;; returns a string. Note that this string is inserted on PostScript prologue
373 ;; header section which is used to define some document characteristic through
374 ;; PostScript special comments, like "%%Requirements: jog\n".
376 ;; By default `ps-print-prologue-header' is nil.
378 ;; ps-print always inserts the %%Requirements: comment, so if you need to insert
379 ;; more requirements put them first in `ps-print-prologue-header' using the
380 ;; "%%+" comment. For example, if you need to set numcopies to 3 and jog on
381 ;; requirements and set %%LanguageLevel: to 2, do:
383 ;; (setq ps-print-prologue-header
384 ;; "%%+ numcopies(3) jog\n%%LanguageLevel: 2\n")
386 ;; The duplex requirement is inserted by ps-print (see section Duplex Printers).
388 ;; Do not forget to terminate the string with "\n".
390 ;; For more information about PostScript document comments, see:
391 ;; PostScript Language Reference Manual (2nd edition)
392 ;; Adobe Systems Incorporated
393 ;; Appendix G: Document Structuring Conventions -- Version 3.0
399 ;; If you have a duplex-capable printer (one that prints both sides of
400 ;; the paper), set `ps-spool-duplex' to t.
401 ;; ps-print will insert blank pages to make sure each buffer starts
402 ;; on the correct side of the paper.
403 ;; Don't forget to set `ps-lpr-switches' to select duplex printing
407 ;; Control And 8-bit Characters
408 ;; ----------------------------
410 ;; The variable `ps-print-control-characters' specifies whether you want to see
411 ;; a printable form for control and 8-bit characters, that is, instead of
412 ;; sending, for example, a ^D (\004) to printer, it is sent the string "^D".
414 ;; Valid values for `ps-print-control-characters' are:
416 ;; 8-bit This is the value to use when you want an ASCII encoding of
417 ;; any control or non-ASCII character. Control characters are
418 ;; encoded as "^D", and non-ASCII characters have an
421 ;; control-8-bit This is the value to use when you want an ASCII encoding of
422 ;; any control character, whether it is 7 or 8-bit.
423 ;; European 8-bits accented characters are printed according
426 ;; control Only ASCII control characters have an ASCII encoding.
427 ;; European 8-bits accented characters are printed according
430 ;; nil No ASCII encoding. Any character is printed according the
433 ;; Any other value is treated as nil.
435 ;; The default is `control-8-bit'.
437 ;; Characters TAB, NEWLINE and FORMFEED are always treated by ps-print engine.
440 ;; Printing Multi-byte Buffer
441 ;; --------------------------
443 ;; The variable `ps-multibyte-buffer' specifies the ps-print multi-byte buffer
446 ;; Valid values for `ps-multibyte-buffer' are:
448 ;; nil This is the value to use when you are printing
449 ;; buffer with only ASCII and Latin characters.
451 ;; `non-latin-printer' This is the value to use when you have a japanese
452 ;; or korean PostScript printer and want to print
453 ;; buffer with ASCII, Latin-1, Japanese (JISX0208 and
454 ;; JISX0201-Kana) and Korean characters. At present,
455 ;; it was not tested the Korean characters printing.
456 ;; If you have a korean PostScript printer, please,
459 ;; `bdf-font' This is the value to use when you want to print
460 ;; buffer with BDF fonts. BDF fonts include both latin
461 ;; and non-latin fonts. BDF (Bitmap Distribution
462 ;; Format) is a format used for distributing X's font
463 ;; source file. BDF fonts are included in
464 ;; `intlfonts-1.1' which is a collection of X11 fonts
465 ;; for all characters supported by Emacs. In order to
466 ;; use this value, be sure to have installed
467 ;; `intlfonts-1.1' and set the variable
468 ;; `bdf-directory-list' appropriately (see bdf.el for
469 ;; documentation of this variable).
471 ;; `bdf-font-except-latin' This is like `bdf-font' except that it is used
472 ;; PostScript default fonts to print ASCII and Latin-1
473 ;; characters. This is convenient when you want or
474 ;; need to use both latin and non-latin characters on
475 ;; the same buffer. See `ps-font-family',
476 ;; `ps-header-font-family' and `ps-font-info-database'.
478 ;; Any other value is treated as nil.
480 ;; The default is nil.
486 ;; The variable `ps-line-number' specifies whether to number each line;
487 ;; non-nil means do so. The default is nil (don't number each line).
493 ;; Zebra stripes are a kind of background that appear "underneath" the text
494 ;; and can make the text easier to read. They look like this:
496 ;; XXXXXXXXXXXXXXXXXXXXXXXX
497 ;; XXXXXXXXXXXXXXXXXXXXXXXX
498 ;; XXXXXXXXXXXXXXXXXXXXXXXX
502 ;; XXXXXXXXXXXXXXXXXXXXXXXX
503 ;; XXXXXXXXXXXXXXXXXXXXXXXX
504 ;; XXXXXXXXXXXXXXXXXXXXXXXX
506 ;; The blocks of X's represent rectangles filled with a light gray color.
507 ;; Each rectangle extends all the way across the page.
509 ;; The height, in lines, of each rectangle is controlled by
510 ;; the variable `ps-zebra-stripe-height', which is 3 by default.
511 ;; The distance between stripes equals the height of a stripe.
513 ;; The variable `ps-zebra-stripes' controls whether to print zebra stripes.
514 ;; Non-nil means yes, nil means no. The default is nil.
516 ;; See also section How Ps-Print Has A Text And/Or Image On Background.
522 ;; ps-print has the following hook variables:
525 ;; It is evaluated once before any printing process. This is the right
526 ;; place to initialize ps-print global data.
527 ;; For an example, see section Adding a New Font Family.
529 ;; `ps-print-begin-page-hook'
530 ;; It is evaluated on each real beginning of page, that is, ps-print
531 ;; considers each beginning of column as a beginning of page, and a real
532 ;; beginning of page is when the beginning of column coincides with a
533 ;; paper change on your printer.
535 ;; `ps-print-begin-column-hook'
536 ;; It is evaluated on each beginning of column, except in the beginning
537 ;; of column that `ps-print-begin-page-hook' is evaluated.
543 ;; ps-print now knows rather precisely some fonts:
544 ;; the variable `ps-font-info-database' contains information
545 ;; for a list of font families (currently mainly `Courier' `Helvetica'
546 ;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk').
547 ;; Each font family contains the font names for standard, bold, italic
548 ;; and bold-italic characters, a reference size (usually 10) and the
549 ;; corresponding line height, width of a space and average character width.
551 ;; The variable `ps-font-family' determines which font family
552 ;; is to be used for ordinary text.
553 ;; If its value does not correspond to a known font family,
554 ;; an error message is printed into the `*Messages*' buffer,
555 ;; which lists the currently available font families.
557 ;; The variable `ps-font-size' determines the size (in points)
558 ;; of the font for ordinary text, when generating PostScript.
559 ;; Its value is a float.
561 ;; Similarly, the variable `ps-header-font-family' determines
562 ;; which font family is to be used for text in the header.
563 ;; The variable `ps-header-font-size' determines the font size,
564 ;; in points, for text in the header.
565 ;; The variable `ps-header-title-font-size' determines the font size,
566 ;; in points, for the top line of text in the header.
569 ;; Adding a New Font Family
570 ;; ------------------------
572 ;; To use a new font family, you MUST first teach ps-print
573 ;; this font, i.e., add its information to `ps-font-info-database',
574 ;; otherwise ps-print cannot correctly place line and page breaks.
576 ;; For example, assuming `Helvetica' is unknown,
577 ;; you first need to do the following ONLY ONCE:
579 ;; - create a new buffer
580 ;; - generate the PostScript image to a file (C-u M-x ps-print-buffer)
581 ;; - open this file and find the line:
582 ;; `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage'
583 ;; - delete the leading `%' (which is the PostScript comment character)
584 ;; - replace in this line `Courier' by the new font (say `Helvetica')
586 ;; `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage'
587 ;; - send this file to the printer (or to ghostscript).
588 ;; You should read the following on the output page:
590 ;; For Helvetica 10 point, the line height is 11.56, the space width is 2.78
591 ;; and a crude estimate of average character width is 5.09243
593 ;; - Add these values to the `ps-font-info-database':
594 ;; (setq ps-font-info-database
596 ;; '((Helvetica ; the family key
597 ;; (fonts (normal . "Helvetica")
598 ;; (bold . "Helvetica-Bold")
599 ;; (italic . "Helvetica-Oblique")
600 ;; (bold-italic . "Helvetica-BoldOblique"))
602 ;; (line-height . 11.56)
603 ;; (space-width . 2.78)
604 ;; (avg-char-width . 5.09243)))
605 ;; ps-font-info-database))
606 ;; - Now you can use this font family with any size:
607 ;; (setq ps-font-family 'Helvetica)
608 ;; - if you want to use this family in another emacs session, you must
609 ;; put into your `~/.emacs':
610 ;; (require 'ps-print)
611 ;; (setq ps-font-info-database (append ...)))
612 ;; if you don't want to load ps-print, you have to copy the whole value:
613 ;; (setq ps-font-info-database '(<your stuff> <the standard stuff>))
614 ;; or, use `ps-print-hook' (see section Hooks):
615 ;; (add-hook 'ps-print-hook
616 ;; '(lambda () (setq ps-font-info-database (append ...))))
618 ;; You can create new `mixed' font families like:
620 ;; (fonts (normal . "Courier-Bold")
621 ;; (bold . "Helvetica")
622 ;; (italic . "Zapf-Chancery-MediumItalic")
623 ;; (bold-italic . "NewCenturySchlbk-BoldItalic")
624 ;; (w3-table-hack-x-face . "LineDrawNormal"))
626 ;; (line-height . 10.55)
627 ;; (space-width . 6.0)
628 ;; (avg-char-width . 6.0))
630 ;; Now you can use your new font family with any size:
631 ;; (setq ps-font-family 'my-mixed-family)
633 ;; Note that on above example the `w3-table-hack-x-face' entry refers to
634 ;; a face symbol, so when printing this face it'll be used the font
635 ;; `LineDrawNormal'. If the face `w3-table-hack-x-face' is remapped to
636 ;; use bold and/or italic attribute, the corresponding entry (bold, italic
637 ;; or bold-italic) will be used instead of `w3-table-hack-x-face' entry.
639 ;; Note also that the font family entry order is irrelevant, so the above
640 ;; example could also be written:
643 ;; (fonts (w3-table-hack-x-face . "LineDrawNormal")
644 ;; (bold . "Helvetica")
645 ;; (bold-italic . "NewCenturySchlbk-BoldItalic")
646 ;; (italic . "Zapf-Chancery-MediumItalic")
647 ;; (normal . "Courier-Bold"))
648 ;; (avg-char-width . 6.0)
649 ;; (space-width . 6.0)
650 ;; (line-height . 10.55))
652 ;; Despite the note above, it is recommended that some convention about
653 ;; entry order be used.
655 ;; You can get information on all the fonts resident in YOUR printer
656 ;; by uncommenting the line:
657 ;; % 3 cm 20 cm moveto ReportAllFontInfo showpage
659 ;; The PostScript file should be sent to YOUR PostScript printer.
660 ;; If you send it to ghostscript or to another PostScript printer,
661 ;; you may get slightly different results.
662 ;; Anyway, as ghostscript fonts are autoload, you won't get
666 ;; How Ps-Print Deals With Faces
667 ;; -----------------------------
669 ;; The ps-print-*-with-faces commands attempt to determine which faces
670 ;; should be printed in bold or italic, but their guesses aren't
671 ;; always right. For example, you might want to map colors into faces
672 ;; so that blue faces print in bold, and red faces in italic.
674 ;; It is possible to force ps-print to consider specific faces bold,
675 ;; italic or underline, no matter what font they are displayed in, by setting
676 ;; the variables `ps-bold-faces', `ps-italic-faces' and `ps-underlined-faces'.
677 ;; These variables contain lists of faces that ps-print should consider bold,
678 ;; italic or underline; to set them, put code like the following into your
681 ;; (setq ps-bold-faces '(my-blue-face))
682 ;; (setq ps-italic-faces '(my-red-face))
683 ;; (setq ps-underlined-faces '(my-green-face))
685 ;; Faces like bold-italic that are both bold and italic should go in
688 ;; ps-print keeps internal lists of which fonts are bold and which are
689 ;; italic; these lists are built the first time you invoke ps-print.
690 ;; For the sake of efficiency, the lists are built only once; the same
691 ;; lists are referred in later invocations of ps-print.
693 ;; Because these lists are built only once, it's possible for them to
694 ;; get out of sync, if a face changes, or if new faces are added. To
695 ;; get the lists back in sync, you can set the variable
696 ;; `ps-build-face-reference' to t, and the lists will be rebuilt the
697 ;; next time ps-print is invoked. If you need that the lists always be
698 ;; rebuilt when ps-print is invoked, set the variable
699 ;; `ps-always-build-face-reference' to t.
702 ;; How Ps-Print Deals With Color
703 ;; -----------------------------
705 ;; ps-print detects faces with foreground and background colors
706 ;; defined and embeds color information in the PostScript image.
707 ;; The default foreground and background colors are defined by the
708 ;; variables `ps-default-fg' and `ps-default-bg'.
709 ;; On black-and-white printers, colors are displayed in grayscale.
710 ;; To turn off color output, set `ps-print-color-p' to nil.
713 ;; How Ps-Print Maps Faces
714 ;; -----------------------
716 ;; As ps-print uses PostScript to print buffers, it is possible to have
717 ;; other attributes associated with faces. So the new attributes used
720 ;; strikeout - like underline, but the line is in middle of text.
721 ;; overline - like underline, but the line is over the text.
722 ;; shadow - text will have a shadow.
723 ;; box - text will be surrounded by a box.
724 ;; outline - print characters as hollow outlines.
726 ;; See the documentation for `ps-extend-face'.
728 ;; Let's, for example, remap font-lock-keyword-face to another foreground color
729 ;; and bold attribute:
731 ;; (ps-extend-face '(font-lock-keyword-face "RoyalBlue" nil bold) 'MERGE)
733 ;; If you want to use a new face, define it first with `defface',
734 ;; and then call `ps-extend-face' to specify how to print it.
737 ;; How Ps-Print Has A Text And/Or Image On Background
738 ;; --------------------------------------------------
740 ;; ps-print can print texts and/or EPS PostScript images on background; it is
741 ;; possible to define the following text attributes: font name, font size,
742 ;; initial position, angle, gray scale and pages to print.
744 ;; It has the following EPS PostScript images attributes: file name containing
745 ;; the image, initial position, X and Y scales, angle and pages to print.
747 ;; See documentation for `ps-print-background-text' and
748 ;; `ps-print-background-image'.
750 ;; For example, if we wish to print text "preliminary" on all pages and text
751 ;; "special" on page 5 and from page 11 to page 17, we could specify:
753 ;; (setq ps-print-background-text
756 ;; "LeftMargin" "BottomMargin PrintHeight add" ; X and Y position
757 ;; ; (upper left corner)
759 ;; "PrintHeight neg PrintPageWidth atan" ; angle
760 ;; 5 (11 . 17)) ; page list
763 ;; Similarly, we could print image "~/images/EPS-image1.ps" on all pages and
764 ;; image "~/images/EPS-image2.ps" on page 5 and from page 11 to page 17, we
767 ;; (setq ps-print-background-image
768 ;; '(("~/images/EPS-image1.ps"
769 ;; "LeftMargin" "BottomMargin") ; X and Y position (lower left corner)
770 ;; ("~/images/EPS-image2.ps"
771 ;; "LeftMargin" "BottomMargin PrintHeight 2 div add" ; X and Y position
772 ;; ; (upper left corner)
774 ;; 5 (11 . 17)) ; page list
777 ;; If it is not possible to read (or does not exist) an image file, that file
780 ;; The printing order is:
782 ;; 1. Print zebra stripes
783 ;; 2. Print background texts that it should be on all pages
784 ;; 3. Print background images that it should be on all pages
785 ;; 4. Print background texts only for current page (if any)
786 ;; 5. Print background images only for current page (if any)
788 ;; 7. Print buffer text (with faces, if specified) and line number
794 ;; Some tools are provided to help you customize your font setup.
796 ;; `ps-setup' returns (some part of) the current setup.
798 ;; To avoid wrapping too many lines, you may want to adjust the
799 ;; left and right margins and the font size. On UN*X systems, do:
800 ;; pr -t file | awk '{printf "%3d %s\n", length($0), $0}' | sort -r | head
801 ;; to determine the longest lines of your file.
802 ;; Then, the command `ps-line-lengths' will give you the correspondence
803 ;; between a line length (number of characters) and the maximum font
804 ;; size which doesn't wrap such a line with the current ps-print setup.
806 ;; The commands `ps-nb-pages-buffer' and `ps-nb-pages-region' display
807 ;; the correspondence between a number of pages and the maximum font
808 ;; size which allow the number of lines of the current buffer or of
809 ;; its current region to fit in this number of pages.
811 ;; NOTE: line folding is not taken into account in this process and could
812 ;; change the results.
815 ;; New since version 1.5
816 ;; ---------------------
818 ;; Color output capability.
819 ;; Automatic detection of font attributes (bold, italic).
820 ;; Configurable headers with page numbers.
822 ;; Support for different paper sizes.
823 ;; Better conformance to PostScript Document Structure Conventions.
826 ;; New since version 2.8
827 ;; ---------------------
829 ;; [vinicius] 980922 Vinicius Jose Latorre <vinicius@cpqd.com.br>
831 ;; PostScript prologue header comment insertion.
832 ;; Skip invisible text better.
834 ;; [keinichi] 980819 Kein'ichi Handa <handa@etl.go.jp>
836 ;; Multi-byte buffer handling.
838 ;; [vinicius] 980306 Vinicius Jose Latorre <vinicius@cpqd.com.br>
840 ;; Skip invisible text.
842 ;; [vinicius] 971130 Vinicius Jose Latorre <vinicius@cpqd.com.br>
844 ;; Hooks: `ps-print-hook', `ps-print-begin-page-hook' and
845 ;; `ps-print-begin-column-hook'.
846 ;; Put one header per page over the columns.
847 ;; Better database font management.
848 ;; Better control characters handling.
850 ;; [vinicius] 971121 Vinicius Jose Latorre <vinicius@cpqd.com.br>
852 ;; Dynamic evaluation at print time of `ps-lpr-switches'.
853 ;; Handle control characters.
855 ;; New face attributes.
858 ;; Text and/or image on background.
860 ;; [jack] 960517 Jacques Duthen <duthen@cegelec-red.fr>
862 ;; Font family and float size for text and header.
865 ;; Tools for page setup.
868 ;; Known bugs and limitations of ps-print
869 ;; --------------------------------------
871 ;; Although color printing will work in XEmacs 19.12, it doesn't work
872 ;; well; in particular, bold or italic fonts don't print in the right
875 ;; Invisible properties aren't correctly ignored in XEmacs 19.12.
877 ;; Automatic font-attribute detection doesn't work well, especially
878 ;; with hilit19 and older versions of get-create-face. Users having
879 ;; problems with auto-font detection should use the lists
880 ;; `ps-italic-faces', `ps-bold-faces' and `ps-underlined-faces' and/or
881 ;; turn off automatic detection by setting `ps-auto-font-detect' to nil.
883 ;; Automatic font-attribute detection doesn't work with XEmacs 19.12
884 ;; in tty mode; use the lists `ps-italic-faces', `ps-bold-faces' and
885 ;; `ps-underlined-faces' instead.
887 ;; Still too slow; could use some hand-optimization.
889 ;; Default background color isn't working.
891 ;; Faces are always treated as opaque.
893 ;; Epoch and Emacs 18 not supported. At all.
895 ;; Fixed-pitch fonts work better for line folding, but are not required.
897 ;; `ps-nb-pages-buffer' and `ps-nb-pages-region' don't take care
904 ;; 2-up and 4-up capabilities.
905 ;; Avoid page break inside a paragraph.
906 ;; Add `ps-non-bold-faces' and `ps-non-italic-faces' (should be easy).
907 ;; Improve the memory management for big files (hard?).
908 ;; `ps-nb-pages-buffer' and `ps-nb-pages-region' should take care
915 ;; Thanks to Kein'ichi Handa <handa@etl.go.jp> for multi-byte buffer handling.
917 ;; Thanks to Matthew O Persico <Matthew.Persico@lazard.com> for line number on
920 ;; Thanks to Theodore Jump <tjump@cais.com> for adjust PostScript code order on
923 ;; Thanks to Roland Ducournau <ducour@lirmm.fr> for
924 ;; `ps-print-control-characters' variable documentation.
926 ;; Thanks to Marcus G Daniels <marcus@cathcart.sysc.pdx.edu> for a better
927 ;; database font management.
929 ;; Thanks to Martin Boyer <gamin@videotron.ca> for some ideas on putting one
930 ;; header per page over the columns and correct line numbers when printing a
933 ;; Thanks to Steven L Baur <steve@miranova.com> for dynamic evaluation at
934 ;; print time of `ps-lpr-switches'.
936 ;; Thanks to Kevin Rodgers <kevinr@ihs.com> for handling control characters
937 ;; (his code was severely modified, but the main idea was kept).
939 ;; Thanks to some suggestions on:
940 ;; * Face color map: Marco Melgazzi <marco@techie.com>
941 ;; * XEmacs compatibility: William J. Henney <will@astrosmo.unam.mx>
942 ;; * Check `ps-paper-type': Sudhakar Frederick <sfrederi@asc.corp.mot.com>
944 ;; Thanks to Jacques Duthen <duthen@cegelec-red.fr> (Jack) for the 3.4 version
945 ;; I started from. [vinicius]
947 ;; Thanks to Jim Thompson <?@?> for the 2.8 version I started from.
950 ;; Thanks to Kevin Rodgers <kevinr@ihs.com> for adding support for
951 ;; color and the invisible property.
953 ;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing
954 ;; the initial port to Emacs 19. His code is no longer part of
955 ;; ps-print, but his work is still appreciated.
957 ;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org,
958 ;; for adding underline support. Their code also is no longer part of
959 ;; ps-print, but their efforts are not forgotten.
961 ;; Thanks also to all of you who mailed code to add features to
962 ;; ps-print; although I didn't use your code, I still appreciate your
963 ;; sharing it with me.
965 ;; Thanks to all who mailed comments, encouragement, and criticism.
966 ;; Thanks also to all who responded to my survey; I had too many
967 ;; responses to reply to them all, but I greatly appreciate your
971 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
975 (unless (featurep 'lisp-float-type)
976 (error "`ps-print' requires floating point support"))
978 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
981 ;;; Interface to the command system
983 (defgroup ps-print nil
984 "PostScript generator for Emacs 19"
988 (defgroup ps-print-horizontal nil
989 "Horizontal page layout"
994 (defgroup ps-print-vertical nil
995 "Vertical page layout"
1000 (defgroup ps-print-header nil
1006 (defgroup ps-print-font nil
1007 "Fonts customization"
1012 (defgroup ps-print-color nil
1013 "Color customization"
1018 (defgroup ps-print-face nil
1019 "Faces customization"
1026 (defcustom ps-multibyte-buffer nil
1027 "*Specifies the multi-byte buffer handling.
1031 nil This is the value to use when you are printing
1032 buffer with only ASCII and Latin characters.
1034 `non-latin-printer' This is the value to use when you have a japanese
1035 or korean PostScript printer and want to print
1036 buffer with ASCII, Latin-1, Japanese (JISX0208 and
1037 JISX0201-Kana) and Korean characters. At present,
1038 it was not tested the Korean characters printing.
1039 If you have a korean PostScript printer, please,
1042 `bdf-font' This is the value to use when you want to print
1043 buffer with BDF fonts. BDF fonts include both latin
1044 and non-latin fonts. BDF (Bitmap Distribution
1045 Format) is a format used for distributing X's font
1046 source file. BDF fonts are included in
1047 `intlfonts-1.1' which is a collection of X11 fonts
1048 for all characters supported by Emacs. In order to
1049 use this value, be sure to have installed
1050 `intlfonts-1.1' and set the variable
1051 `bdf-directory-list' appropriately (see bdf.el for
1052 documentation of this variable).
1054 `bdf-font-except-latin' This is like `bdf-font' except that it is used
1055 PostScript default fonts to print ASCII and Latin-1
1056 characters. This is convenient when you want or
1057 need to use both latin and non-latin characters on
1058 the same buffer. See `ps-font-family',
1059 `ps-header-font-family' and `ps-font-info-database'.
1061 Any other value is treated as nil."
1062 :type '(choice (const non-latin-printer) (const bdf-font)
1063 (const bdf-font-except-latin) (other :tag "nil" nil))
1064 :group 'ps-print-font)
1066 (defcustom ps-print-prologue-header nil
1067 "*PostScript prologue header comments besides that ps-print generates.
1069 `ps-print-prologue-header' may be a string or a symbol function which
1070 returns a string. Note that this string is inserted on PostScript prologue
1071 header section which is used to define some document characteristic through
1072 PostScript special comments, like \"%%Requirements: jog\\n\".
1074 ps-print always inserts the %%Requirements: comment, so if you need to insert
1075 more requirements put them first in `ps-print-prologue-header' using the
1076 \"%%+\" comment. For example, if you need to set numcopies to 3 and jog on
1077 requirements and set %%LanguageLevel: to 2, do:
1079 (setq ps-print-prologue-header
1080 \"%%+ numcopies(3) jog\\n%%LanguageLevel: 2\\n\")
1082 The duplex requirement is inserted by ps-print (see `ps-spool-duplex').
1084 Do not forget to terminate the string with \"\\n\".
1086 For more information about PostScript document comments, see:
1087 PostScript Language Reference Manual (2nd edition)
1088 Adobe Systems Incorporated
1089 Appendix G: Document Structuring Conventions -- Version 3.0"
1090 :type '(choice string symbol (other :tag "nil" nil))
1093 (defcustom ps-printer-name printer-name
1094 "*The name of a local printer for printing PostScript files.
1096 On Unix-like systems, a string value should be a name understood by
1097 lpr's -P option; otherwise the value should be nil.
1099 On MS-DOS and MS-Windows systems, if the value is a string, then it is
1100 taken as the name of the device to which PostScript files are written.
1101 By default it is the same as `printer-name'; typical non-default
1102 settings would be \"LPT1\" to \"LPT3\" for parallel printers, or
1103 \"COM1\" to \"COM4\" or \"AUX\" for serial printers, or
1104 \"//hostname/printer\" for a shared network printer. You can also set
1105 it to a name of a file, in which case the output gets appended to that
1106 file. \(Note that `ps-print' package already has facilities for
1107 printing to a file, so you might as well use them instead of changing
1108 the setting of this variable.\) If you want to silently discard the
1109 printed output, set this to \"NUL\".
1111 On DOS/Windows, if the value is anything but a string, PostScript files
1112 will be piped to the program given by `ps-lpr-command', with switches
1113 given by `ps-lpr-switches', which see."
1114 :type '(choice file (other :tag "Pipe to ps-lpr-command" pipe))
1117 (defcustom ps-lpr-command lpr-command
1118 "*The shell command for printing a PostScript file."
1122 (defcustom ps-lpr-switches lpr-switches
1123 "*A list of extra switches to pass to `ps-lpr-command'."
1124 :type '(repeat string)
1129 ;; All page dimensions are in PostScript points.
1130 ;; 1 inch == 2.54 cm == 72 points
1131 ;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points
1133 ;; Letter 8.5 inch x 11.0 inch
1134 ;; Legal 8.5 inch x 14.0 inch
1135 ;; A4 8.26 inch x 11.69 inch = 21.0 cm x 29.7 cm
1137 ;; LetterSmall 7.68 inch x 10.16 inch
1138 ;; Tabloid 11.0 inch x 17.0 inch
1139 ;; Ledger 17.0 inch x 11.0 inch
1140 ;; Statement 5.5 inch x 8.5 inch
1141 ;; Executive 7.5 inch x 10.0 inch
1142 ;; A3 11.69 inch x 16.5 inch = 29.7 cm x 42.0 cm
1143 ;; A4Small 7.47 inch x 10.85 inch
1144 ;; B4 10.125 inch x 14.33 inch
1145 ;; B5 7.16 inch x 10.125 inch
1147 (defcustom ps-page-dimensions-database
1148 (list (list 'a4 (/ (* 72 21.0) 2.54) (/ (* 72 29.7) 2.54))
1149 (list 'a3 (/ (* 72 29.7) 2.54) (/ (* 72 42.0) 2.54))
1150 (list 'letter (* 72 8.5) (* 72 11.0))
1151 (list 'legal (* 72 8.5) (* 72 14.0))
1152 (list 'letter-small (* 72 7.68) (* 72 10.16))
1153 (list 'tabloid (* 72 11.0) (* 72 17.0))
1154 (list 'ledger (* 72 17.0) (* 72 11.0))
1155 (list 'statement (* 72 5.5) (* 72 8.5))
1156 (list 'executive (* 72 7.5) (* 72 10.0))
1157 (list 'a4small (* 72 7.47) (* 72 10.85))
1158 (list 'b4 (* 72 10.125) (* 72 14.33))
1159 (list 'b5 (* 72 7.16) (* 72 10.125)))
1160 "*List associating a symbolic paper type to its width and height.
1161 see `ps-paper-type'."
1162 :type '(repeat (list :tag "Paper Type"
1163 (symbol :tag "Name")
1164 (number :tag "Width")
1165 (number :tag "Height")))
1169 (defcustom ps-paper-type 'letter
1170 "*Specifies the size of paper to format for.
1171 Should be one of the paper types defined in `ps-page-dimensions-database', for
1172 example `letter', `legal' or `a4'."
1173 :type '(symbol :validate (lambda (wid)
1174 (if (assq (widget-value wid)
1175 ps-page-dimensions-database)
1177 (widget-put wid :error "Unknown paper size")
1181 (defcustom ps-landscape-mode nil
1182 "*Non-nil means print in landscape mode."
1186 (defcustom ps-print-control-characters 'control-8-bit
1187 "*Specifies the printable form for control and 8-bit characters.
1188 That is, instead of sending, for example, a ^D (\004) to printer,
1189 it is sent the string \"^D\".
1193 `8-bit' This is the value to use when you want an ASCII encoding of
1194 any control or non-ASCII character. Control characters are
1195 encoded as \"^D\", and non-ASCII characters have an
1198 `control-8-bit' This is the value to use when you want an ASCII encoding of
1199 any control character, whether it is 7 or 8-bit.
1200 European 8-bits accented characters are printed according
1203 `control' Only ASCII control characters have an ASCII encoding.
1204 European 8-bits accented characters are printed according
1207 nil No ASCII encoding. Any character is printed according the
1210 Any other value is treated as nil."
1211 :type '(choice (const 8-bit) (const control-8-bit)
1212 (const control) (other :tag "nil" nil))
1215 (defcustom ps-number-of-columns (if ps-landscape-mode 2 1)
1216 "*Specifies the number of columns"
1220 (defcustom ps-zebra-stripes nil
1221 "*Non-nil means print zebra stripes.
1222 See also documentation for `ps-zebra-stripe-height'."
1226 (defcustom ps-zebra-stripe-height 3
1227 "*Number of zebra stripe lines.
1228 See also documentation for `ps-zebra-stripes'."
1232 (defcustom ps-line-number nil
1233 "*Non-nil means print line number."
1237 (defcustom ps-print-background-image nil
1238 "*EPS image list to be printed on background.
1242 (FILENAME X Y XSCALE YSCALE ROTATION PAGES...)
1244 FILENAME is a file name which contains an EPS image or some PostScript
1245 programming like EPS.
1246 FILENAME is ignored, if it doesn't exist or is read protected.
1248 X and Y are relative positions on paper to put the image.
1249 If X and Y are nil, the image is centralized on paper.
1251 XSCALE and YSCALE are scale factor to be applied to image before printing.
1252 If XSCALE and YSCALE are nil, the original size is used.
1254 ROTATION is the image rotation angle; if nil, the default is 0.
1256 PAGES designates the page to print background image.
1257 PAGES may be a number or a cons cell (FROM . TO) designating FROM page
1259 If PAGES is nil, print background image on all pages.
1261 X, Y, XSCALE, YSCALE and ROTATION may be a floating point number,
1262 an integer number or a string. If it is a string, the string should contain
1263 PostScript programming that returns a float or integer value.
1265 For example, if you wish to print an EPS image on all pages do:
1267 '((\"~/images/EPS-image.ps\"))"
1268 :type '(repeat (list file
1269 (choice :tag "X" number string (const nil))
1270 (choice :tag "Y" number string (const nil))
1271 (choice :tag "X Scale" number string (const nil))
1272 (choice :tag "Y Scale" number string (const nil))
1273 (choice :tag "Rotation" number string (const nil))
1274 (repeat :tag "Pages" :inline t
1277 (integer :tag "From")
1278 (integer :tag "To"))))))
1281 (defcustom ps-print-background-text nil
1282 "*Text list to be printed on background.
1286 (STRING X Y FONT FONTSIZE GRAY ROTATION PAGES...)
1288 STRING is the text to be printed on background.
1290 X and Y are positions on paper to put the text.
1291 If X and Y are nil, the text is positioned at lower left corner.
1293 FONT is a font name to be used on printing the text.
1294 If nil, \"Times-Roman\" is used.
1296 FONTSIZE is font size to be used, if nil, 200 is used.
1298 GRAY is the text gray factor (should be very light like 0.8).
1299 If nil, the default is 0.85.
1301 ROTATION is the text rotation angle; if nil, the angle is given by
1302 the diagonal from lower left corner to upper right corner.
1304 PAGES designates the page to print background text.
1305 PAGES may be a number or a cons cell (FROM . TO) designating FROM page
1307 If PAGES is nil, print background text on all pages.
1309 X, Y, FONTSIZE, GRAY and ROTATION may be a floating point number,
1310 an integer number or a string. If it is a string, the string should contain
1311 PostScript programming that returns a float or integer value.
1313 For example, if you wish to print text \"Preliminary\" on all pages do:
1315 '((\"Preliminary\"))"
1316 :type '(repeat (list string
1317 (choice :tag "X" number string (const nil))
1318 (choice :tag "Y" number string (const nil))
1319 (choice :tag "Font" string (const nil))
1320 (choice :tag "Fontsize" number string (const nil))
1321 (choice :tag "Gray" number string (const nil))
1322 (choice :tag "Rotation" number string (const nil))
1323 (repeat :tag "Pages" :inline t
1326 (integer :tag "From")
1327 (integer :tag "To"))))))
1330 ;;; Horizontal layout
1332 ;; ------------------------------------------
1334 ;; | lm | text | ic | text | ic | text | rm |
1336 ;; ------------------------------------------
1338 (defcustom ps-left-margin (/ (* 72 2.0) 2.54) ; 2 cm
1339 "*Left margin in points (1/72 inch)."
1341 :group 'ps-print-horizontal)
1343 (defcustom ps-right-margin (/ (* 72 2.0) 2.54) ; 2 cm
1344 "*Right margin in points (1/72 inch)."
1346 :group 'ps-print-horizontal)
1348 (defcustom ps-inter-column (/ (* 72 2.0) 2.54) ; 2 cm
1349 "*Horizontal space between columns in points (1/72 inch)."
1351 :group 'ps-print-horizontal)
1367 (defcustom ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
1368 "*Bottom margin in points (1/72 inch)."
1370 :group 'ps-print-vertical)
1372 (defcustom ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
1373 "*Top margin in points (1/72 inch)."
1375 :group 'ps-print-vertical)
1377 (defcustom ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm
1378 "*Vertical space in points (1/72 inch) between the main text and the header."
1380 :group 'ps-print-vertical)
1382 (defcustom ps-header-line-pad 0.15
1383 "*Portion of a header title line height to insert between the header frame
1384 and the text it contains, both in the vertical and horizontal directions."
1386 :group 'ps-print-vertical)
1390 (defcustom ps-print-header t
1391 "*Non-nil means print a header at the top of each page.
1392 By default, the header displays the buffer name, page number, and, if
1393 the buffer is visiting a file, the file's directory. Headers are
1394 customizable by changing variables `ps-left-header' and
1397 :group 'ps-print-header)
1399 (defcustom ps-print-only-one-header nil
1400 "*Non-nil means print only one header at the top of each page.
1401 This is useful when printing more than one column, so it is possible
1402 to have only one header over all columns or one header per column.
1403 See also `ps-print-header'."
1405 :group 'ps-print-header)
1407 (defcustom ps-print-header-frame t
1408 "*Non-nil means draw a gaudy frame around the header."
1410 :group 'ps-print-header)
1412 (defcustom ps-header-lines 2
1413 "*Number of lines to display in page header, when generating PostScript."
1415 :group 'ps-print-header)
1416 (make-variable-buffer-local 'ps-header-lines)
1418 (defcustom ps-show-n-of-n t
1419 "*Non-nil means show page numbers as N/M, meaning page N of M.
1420 NOTE: page numbers are displayed as part of headers,
1421 see variable `ps-print-headers'."
1423 :group 'ps-print-header)
1425 (defcustom ps-spool-duplex nil ; Not many people have duplex
1426 ; printers, so default to nil.
1427 "*Non-nil indicates spooling is for a two-sided printer.
1428 For a duplex printer, the `ps-spool-*' commands will insert blank pages
1429 as needed between print jobs so that the next buffer printed will
1430 start on the right page. Also, if headers are turned on, the headers
1431 will be reversed on duplex printers so that the page numbers fall to
1432 the left on even-numbered pages."
1434 :group 'ps-print-header)
1438 (defcustom ps-font-info-database
1439 '((Courier ; the family key
1440 (fonts (normal . "Courier")
1441 (bold . "Courier-Bold")
1442 (italic . "Courier-Oblique")
1443 (bold-italic . "Courier-BoldOblique"))
1445 (line-height . 10.55)
1447 (avg-char-width . 6.0))
1448 (Helvetica ; the family key
1449 (fonts (normal . "Helvetica")
1450 (bold . "Helvetica-Bold")
1451 (italic . "Helvetica-Oblique")
1452 (bold-italic . "Helvetica-BoldOblique"))
1454 (line-height . 11.56)
1455 (space-width . 2.78)
1456 (avg-char-width . 5.09243))
1458 (fonts (normal . "Times-Roman")
1459 (bold . "Times-Bold")
1460 (italic . "Times-Italic")
1461 (bold-italic . "Times-BoldItalic"))
1463 (line-height . 11.0)
1465 (avg-char-width . 4.71432))
1467 (fonts (normal . "Palatino-Roman")
1468 (bold . "Palatino-Bold")
1469 (italic . "Palatino-Italic")
1470 (bold-italic . "Palatino-BoldItalic"))
1472 (line-height . 12.1)
1474 (avg-char-width . 5.08676))
1476 (fonts (normal . "Helvetica-Narrow")
1477 (bold . "Helvetica-Narrow-Bold")
1478 (italic . "Helvetica-Narrow-Oblique")
1479 (bold-italic . "Helvetica-Narrow-BoldOblique"))
1481 (line-height . 11.56)
1482 (space-width . 2.2796)
1483 (avg-char-width . 4.17579))
1485 (fonts (normal . "NewCenturySchlbk-Roman")
1486 (bold . "NewCenturySchlbk-Bold")
1487 (italic . "NewCenturySchlbk-Italic")
1488 (bold-italic . "NewCenturySchlbk-BoldItalic"))
1490 (line-height . 12.15)
1491 (space-width . 2.78)
1492 (avg-char-width . 5.31162))
1493 ;; got no bold for the next ones
1495 (fonts (normal . "AvantGarde-Book")
1496 (italic . "AvantGarde-BookOblique"))
1498 (line-height . 11.77)
1499 (space-width . 2.77)
1500 (avg-char-width . 5.45189))
1502 (fonts (normal . "AvantGarde-Demi")
1503 (italic . "AvantGarde-DemiOblique"))
1505 (line-height . 12.72)
1507 (avg-char-width . 5.51351))
1509 (fonts (normal . "Bookman-Demi")
1510 (italic . "Bookman-DemiItalic"))
1512 (line-height . 11.77)
1514 (avg-char-width . 6.05946))
1516 (fonts (normal . "Bookman-Light")
1517 (italic . "Bookman-LightItalic"))
1519 (line-height . 11.79)
1521 (avg-char-width . 5.67027))
1522 ;; got no bold and no italic for the next ones
1524 (fonts (normal . "Symbol"))
1526 (line-height . 13.03)
1528 (avg-char-width . 3.24324))
1530 (fonts (normal . "Zapf-Dingbats"))
1532 (line-height . 9.63)
1533 (space-width . 2.78)
1534 (avg-char-width . 2.78))
1535 (Zapf-Chancery-MediumItalic
1536 (fonts (normal . "Zapf-Chancery-MediumItalic"))
1538 (line-height . 11.45)
1540 (avg-char-width . 4.10811))
1542 "*Font info database: font family (the key), name, bold, italic, bold-italic,
1543 reference size, line height, space width, average character width.
1544 To get the info for another specific font (say Helvetica), do the following:
1545 - create a new buffer
1546 - generate the PostScript image to a file (C-u M-x ps-print-buffer)
1547 - open this file and delete the leading `%' (which is the PostScript
1548 comment character) from the line
1549 `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage'
1551 `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage'
1552 - add the values to `ps-font-info-database'.
1553 You can get all the fonts of YOUR printer using `ReportAllFontInfo'."
1554 :type '(repeat (list :tag "Font Definition"
1555 (symbol :tag "Font Family")
1557 (const :format "" fonts)
1558 (repeat :tag "Faces"
1559 (cons (choice (const normal)
1563 (symbol :tag "Face"))
1564 (string :tag "Font Name"))))
1566 (const :format "" size)
1567 (number :tag "Reference Size"))
1569 (const :format "" line-height)
1570 (number :tag "Line Height"))
1572 (const :format "" space-width)
1573 (number :tag "Space Width"))
1575 (const :format "" avg-char-width)
1576 (number :tag "Average Character Width"))))
1577 :group 'ps-print-font)
1579 (defcustom ps-font-family 'Courier
1580 "*Font family name for ordinary text, when generating PostScript."
1582 :group 'ps-print-font)
1584 (defcustom ps-font-size (if ps-landscape-mode 7 8.5)
1585 "*Font size, in points, for ordinary text, when generating PostScript."
1587 :group 'ps-print-font)
1589 (defcustom ps-header-font-family 'Helvetica
1590 "*Font family name for text in the header, when generating PostScript."
1592 :group 'ps-print-font)
1594 (defcustom ps-header-font-size (if ps-landscape-mode 10 12)
1595 "*Font size, in points, for text in the header, when generating PostScript."
1597 :group 'ps-print-font)
1599 (defcustom ps-header-title-font-size (if ps-landscape-mode 12 14)
1600 "*Font size, in points, for the top line of text in header, in PostScript."
1602 :group 'ps-print-font)
1606 ;; Printing color requires x-color-values.
1607 (defcustom ps-print-color-p (or (fboundp 'x-color-values) ; Emacs
1608 (fboundp 'color-instance-rgb-components))
1610 "*If non-nil, print the buffer's text in color."
1612 :group 'ps-print-color)
1614 (defcustom ps-default-fg '(0.0 0.0 0.0)
1615 "*RGB values of the default foreground color. Defaults to black."
1616 :type '(list (number :tag "Red") (number :tag "Green") (number :tag "Blue"))
1617 :group 'ps-print-color)
1619 (defcustom ps-default-bg '(1.0 1.0 1.0)
1620 "*RGB values of the default background color. Defaults to white."
1621 :type '(list (number :tag "Red") (number :tag "Green") (number :tag "Blue"))
1622 :group 'ps-print-color)
1624 (defcustom ps-auto-font-detect t
1625 "*Non-nil means automatically detect bold/italic face attributes.
1626 If nil, we rely solely on the lists `ps-bold-faces', `ps-italic-faces',
1627 and `ps-underlined-faces'."
1629 :group 'ps-print-font)
1631 (defcustom ps-bold-faces
1632 (unless ps-print-color-p
1633 '(font-lock-function-name-face
1634 font-lock-builtin-face
1635 font-lock-variable-name-face
1636 font-lock-keyword-face
1637 font-lock-warning-face))
1638 "*A list of the \(non-bold\) faces that should be printed in bold font.
1639 This applies to generating PostScript."
1640 :type '(repeat face)
1641 :group 'ps-print-face)
1643 (defcustom ps-italic-faces
1644 (unless ps-print-color-p
1645 '(font-lock-variable-name-face
1647 font-lock-string-face
1648 font-lock-comment-face
1649 font-lock-warning-face))
1650 "*A list of the \(non-italic\) faces that should be printed in italic font.
1651 This applies to generating PostScript."
1652 :type '(repeat face)
1653 :group 'ps-print-face)
1655 (defcustom ps-underlined-faces
1656 (unless ps-print-color-p
1657 '(font-lock-function-name-face
1658 font-lock-constant-face
1659 font-lock-warning-face))
1660 "*A list of the \(non-underlined\) faces that should be printed underlined.
1661 This applies to generating PostScript."
1662 :type '(repeat face)
1663 :group 'ps-print-face)
1665 (defcustom ps-left-header
1666 (list 'ps-get-buffer-name 'ps-header-dirpart)
1667 "*The items to display (each on a line) on the left part of the page header.
1668 This applies to generating PostScript.
1670 The value should be a list of strings and symbols, each representing an
1671 entry in the PostScript array HeaderLinesLeft.
1673 Strings are inserted unchanged into the array; those representing
1674 PostScript string literals should be delimited with PostScript string
1675 delimiters '(' and ')'.
1677 For symbols with bound functions, the function is called and should
1678 return a string to be inserted into the array. For symbols with bound
1679 values, the value should be a string to be inserted into the array.
1680 In either case, function or variable, the string value has PostScript
1681 string delimiters added to it."
1682 :type '(repeat (choice string symbol))
1683 :group 'ps-print-header)
1684 (make-variable-buffer-local 'ps-left-header)
1686 (defcustom ps-right-header
1687 (list "/pagenumberstring load" 'time-stamp-mon-dd-yyyy 'time-stamp-hh:mm:ss)
1688 "*The items to display (each on a line) on the right part of the page header.
1689 This applies to generating PostScript.
1691 See the variable `ps-left-header' for a description of the format of
1693 :type '(repeat (choice string symbol))
1694 :group 'ps-print-header)
1695 (make-variable-buffer-local 'ps-right-header)
1697 (defcustom ps-razzle-dazzle t
1698 "*Non-nil means report progress while formatting buffer."
1702 (defcustom ps-adobe-tag "%!PS-Adobe-3.0\n"
1703 "*Contains the header line identifying the output as PostScript.
1704 By default, `ps-adobe-tag' contains the standard identifier. Some
1705 printers require slightly different versions of this line."
1709 (defcustom ps-build-face-reference t
1710 "*Non-nil means build the reference face lists.
1712 ps-print sets this value to nil after it builds its internal reference
1713 lists of bold and italic faces. By settings its value back to t, you
1714 can force ps-print to rebuild the lists the next time you invoke one
1715 of the ...-with-faces commands.
1717 You should set this value back to t after you change the attributes of
1718 any face, or create new faces. Most users shouldn't have to worry
1719 about its setting, though."
1721 :group 'ps-print-face)
1723 (defcustom ps-always-build-face-reference nil
1724 "*Non-nil means always rebuild the reference face lists.
1726 If this variable is non-nil, ps-print will rebuild its internal
1727 reference lists of bold and italic faces *every* time one of the
1728 ...-with-faces commands is called. Most users shouldn't need to set this
1731 :group 'ps-print-face)
1733 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1737 (defun ps-print-buffer (&optional filename)
1738 "Generate and print a PostScript image of the buffer.
1740 Interactively, when you use a prefix argument (C-u), the command
1741 prompts the user for a file name, and saves the PostScript image
1742 in that file instead of sending it to the printer.
1744 Noninteractively, the argument FILENAME is treated as follows: if it
1745 is nil, send the image to the printer. If FILENAME is a string, save
1746 the PostScript image in a file with that name."
1747 (interactive (list (ps-print-preprint current-prefix-arg)))
1748 (ps-print-without-faces (point-min) (point-max) filename))
1752 (defun ps-print-buffer-with-faces (&optional filename)
1753 "Generate and print a PostScript image of the buffer.
1754 Like `ps-print-buffer', but includes font, color, and underline
1755 information in the generated image. This command works only if you
1756 are using a window system, so it has a way to determine color values."
1757 (interactive (list (ps-print-preprint current-prefix-arg)))
1758 (ps-print-with-faces (point-min) (point-max) filename))
1762 (defun ps-print-region (from to &optional filename)
1763 "Generate and print a PostScript image of the region.
1764 Like `ps-print-buffer', but prints just the current region."
1765 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg)))
1766 (ps-print-without-faces from to filename t))
1770 (defun ps-print-region-with-faces (from to &optional filename)
1771 "Generate and print a PostScript image of the region.
1772 Like `ps-print-region', but includes font, color, and underline
1773 information in the generated image. This command works only if you
1774 are using a window system, so it has a way to determine color values."
1775 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg)))
1776 (ps-print-with-faces from to filename t))
1780 (defun ps-spool-buffer ()
1781 "Generate and spool a PostScript image of the buffer.
1782 Like `ps-print-buffer' except that the PostScript image is saved in a
1783 local buffer to be sent to the printer later.
1785 Use the command `ps-despool' to send the spooled images to the printer."
1787 (ps-spool-without-faces (point-min) (point-max)))
1791 (defun ps-spool-buffer-with-faces ()
1792 "Generate and spool a PostScript image of the buffer.
1793 Like `ps-spool-buffer', but includes font, color, and underline
1794 information in the generated image. This command works only if you
1795 are using a window system, so it has a way to determine color values.
1797 Use the command `ps-despool' to send the spooled images to the printer."
1799 (ps-spool-with-faces (point-min) (point-max)))
1803 (defun ps-spool-region (from to)
1804 "Generate a PostScript image of the region and spool locally.
1805 Like `ps-spool-buffer', but spools just the current region.
1807 Use the command `ps-despool' to send the spooled images to the printer."
1809 (ps-spool-without-faces from to t))
1813 (defun ps-spool-region-with-faces (from to)
1814 "Generate a PostScript image of the region and spool locally.
1815 Like `ps-spool-region', but includes font, color, and underline
1816 information in the generated image. This command works only if you
1817 are using a window system, so it has a way to determine color values.
1819 Use the command `ps-despool' to send the spooled images to the printer."
1821 (ps-spool-with-faces from to t))
1824 (defun ps-despool (&optional filename)
1825 "Send the spooled PostScript to the printer.
1827 Interactively, when you use a prefix argument (C-u), the command
1828 prompts the user for a file name, and saves the spooled PostScript
1829 image in that file instead of sending it to the printer.
1831 More specifically, the FILENAME argument is treated as follows: if it
1832 is nil, send the image to the printer. If FILENAME is a string, save
1833 the PostScript image in a file with that name."
1834 (interactive (list (ps-print-preprint current-prefix-arg)))
1835 (ps-do-despool filename))
1838 (defun ps-line-lengths ()
1839 "Display the correspondence between a line length and a font size,
1840 using the current ps-print setup.
1841 Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"
1843 (ps-line-lengths-internal))
1846 (defun ps-nb-pages-buffer (nb-lines)
1847 "Display number of pages to print this buffer, for various font heights.
1848 The table depends on the current ps-print setup."
1849 (interactive (list (count-lines (point-min) (point-max))))
1850 (ps-nb-pages nb-lines))
1853 (defun ps-nb-pages-region (nb-lines)
1854 "Display number of pages to print the region, for various font heights.
1855 The table depends on the current ps-print setup."
1856 (interactive (list (count-lines (mark) (point))))
1857 (ps-nb-pages nb-lines))
1861 "Return the current PostScript-generation setup."
1864 \(setq ps-print-color-p %s
1870 ps-landscape-mode %s
1871 ps-number-of-columns %s
1874 ps-zebra-stripe-height %s
1877 ps-print-control-characters %S
1879 ps-print-background-image %S
1881 ps-print-background-text %S
1883 ps-print-prologue-header %S
1891 ps-header-line-pad %s
1893 ps-print-only-one-header %s
1894 ps-print-header-frame %s
1899 ps-multibyte-buffer %S
1902 ps-header-font-family %S
1903 ps-header-font-size %s
1904 ps-header-title-font-size %s)
1908 (ps-print-quote ps-lpr-switches)
1910 (ps-print-quote ps-paper-type)
1912 ps-number-of-columns
1914 ps-zebra-stripe-height
1916 (ps-print-quote ps-print-control-characters)
1917 (ps-print-quote ps-print-background-image)
1918 (ps-print-quote ps-print-background-text)
1919 (ps-print-quote ps-print-prologue-header)
1928 ps-print-only-one-header
1929 ps-print-header-frame
1933 (ps-print-quote ps-multibyte-buffer)
1934 (ps-print-quote ps-font-family)
1936 (ps-print-quote ps-header-font-family)
1938 ps-header-title-font-size))
1940 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1941 ;; Utility functions and variables:
1943 (defun ps-print-quote (sym)
1945 (if (or (symbolp sym) (listp sym))
1949 (defvar ps-print-emacs-type
1950 (cond ((string-match "XEmacs" emacs-version) 'xemacs)
1951 ((string-match "Lucid" emacs-version) 'lucid)
1952 ((string-match "Epoch" emacs-version) 'epoch)
1955 (if (or (eq ps-print-emacs-type 'lucid)
1956 (eq ps-print-emacs-type 'xemacs))
1957 (if (< emacs-minor-version 12)
1958 (setq ps-print-color-p nil))
1959 (require 'faces)) ; face-font, face-underline-p,
1962 ;; Return t if the device (which can be changed during an emacs session)
1963 ;; can handle colors.
1964 ;; This is function is not yet implemented for GNU emacs.
1965 (cond ((and (eq ps-print-emacs-type 'xemacs)
1966 (>= emacs-minor-version 12)) ; xemacs
1967 (defun ps-color-device ()
1968 (eq (device-class) 'color))
1972 (defun ps-color-device ()
1977 (require 'time-stamp)
1979 (defvar ps-print-prologue-1
1980 "% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4:
1981 /ISOLatin1Encoding where { pop } {
1982 % -- The ISO Latin-1 encoding vector isn't known, so define it.
1983 % -- The first half is the same as the standard encoding,
1984 % -- except for minus instead of hyphen at code 055.
1986 StandardEncoding 0 45 getinterval aload pop
1988 StandardEncoding 46 82 getinterval aload pop
1989 %*** NOTE: the following are missing in the Adobe documentation,
1990 %*** but appear in the displayed table:
1991 %*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240.
1993 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
1994 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
1995 /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
1996 /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron
1998 /space /exclamdown /cent /sterling
1999 /currency /yen /brokenbar /section
2000 /dieresis /copyright /ordfeminine /guillemotleft
2001 /logicalnot /hyphen /registered /macron
2002 /degree /plusminus /twosuperior /threesuperior
2003 /acute /mu /paragraph /periodcentered
2004 /cedilla /onesuperior /ordmasculine /guillemotright
2005 /onequarter /onehalf /threequarters /questiondown
2007 /Agrave /Aacute /Acircumflex /Atilde
2008 /Adieresis /Aring /AE /Ccedilla
2009 /Egrave /Eacute /Ecircumflex /Edieresis
2010 /Igrave /Iacute /Icircumflex /Idieresis
2011 /Eth /Ntilde /Ograve /Oacute
2012 /Ocircumflex /Otilde /Odieresis /multiply
2013 /Oslash /Ugrave /Uacute /Ucircumflex
2014 /Udieresis /Yacute /Thorn /germandbls
2016 /agrave /aacute /acircumflex /atilde
2017 /adieresis /aring /ae /ccedilla
2018 /egrave /eacute /ecircumflex /edieresis
2019 /igrave /iacute /icircumflex /idieresis
2020 /eth /ntilde /ograve /oacute
2021 /ocircumflex /otilde /odieresis /divide
2022 /oslash /ugrave /uacute /ucircumflex
2023 /udieresis /yacute /thorn /ydieresis
2027 /reencodeFontISO { %def
2029 length 12 add dict % Make a new font (a new dict the same size
2030 % as the old one) with room for our new symbols.
2032 begin % Make the new font the current dictionary.
2036 { def } { pop pop } ifelse
2037 } forall % Copy each of the symbols from the old dictionary
2038 % to the new one except for the font ID.
2040 currentdict /FontType get 0 ne {
2041 /Encoding ISOLatin1Encoding def % Override the encoding with
2042 % the ISOLatin1 encoding.
2045 % Use the font's bounding box to determine the ascent, descent,
2046 % and overall height; don't forget that these values have to be
2047 % transformed using the font's matrix.
2054 % | | | | Ascent (usually > 0)
2056 % (0 0) -> +--+----+-------->
2058 % | | v Descent (usually < 0)
2059 % (x1 y1) --> +----+ - -
2061 currentdict /FontType get 0 ne {
2062 /FontBBox load aload pop % -- x1 y1 x2 y2
2063 FontMatrix transform /Ascent exch def pop
2064 FontMatrix transform /Descent exch def pop
2066 /PrimaryFont FDepVector 0 get def
2067 PrimaryFont /FontBBox get aload pop
2068 PrimaryFont /FontMatrix get transform /Ascent exch def pop
2069 PrimaryFont /FontMatrix get transform /Descent exch def pop
2072 /FontHeight Ascent Descent sub def % use `sub' because descent < 0
2074 % Define these in case they're not in the FontInfo
2075 % (also, here they're easier to get to).
2076 /UnderlinePosition Descent 0.70 mul def
2077 /OverlinePosition Descent UnderlinePosition sub Ascent add def
2078 /StrikeoutPosition Ascent 0.30 mul def
2079 /LineThickness FontHeight 0.05 mul def
2080 /Xshadow FontHeight 0.08 mul def
2081 /Yshadow FontHeight -0.09 mul def
2082 /SpaceBackground Descent neg UnderlinePosition add def
2083 /XBox Descent neg def
2084 /YBox LineThickness 0.7 mul def
2086 currentdict % Leave the new font on the stack
2087 end % Stop using the font as the current dictionary.
2088 definefont % Put the font into the font dictionary
2089 pop % Discard the returned font.
2092 /DefFont { % Font definition
2093 findfont exch scalefont reencodeFontISO
2096 /F { % Font selection
2098 dup /Ascent get /Ascent exch def
2099 dup /Descent get /Descent exch def
2100 dup /FontHeight get /FontHeight exch def
2101 dup /UnderlinePosition get /UnderlinePosition exch def
2102 dup /OverlinePosition get /OverlinePosition exch def
2103 dup /StrikeoutPosition get /StrikeoutPosition exch def
2104 dup /LineThickness get /LineThickness exch def
2105 dup /Xshadow get /Xshadow exch def
2106 dup /Yshadow get /Yshadow exch def
2107 dup /SpaceBackground get /SpaceBackground exch def
2108 dup /XBox get /XBox exch def
2109 dup /YBox get /YBox exch def
2113 /FG /setrgbcolor load def
2126 % | Ascent (usually > 0)
2128 % | Descent (usually < 0)
2132 /dobackground { % width --
2133 currentpoint % -- width x y
2137 0 Ascent rmoveto % B
2139 0 Descent Ascent sub rlineto % D
2142 bgcolor aload pop setrgbcolor
2147 /eolbg { % dobackground until right margin
2148 PrintWidth % -- x-eol
2149 currentpoint pop % -- cur-x
2150 sub % -- width until eol
2154 /PLN {PrintLineNumber {doLineNumber}if} def
2156 /SL { % Soft Linefeed
2158 0 currentpoint exch pop LineHeight sub moveto
2161 /HL {SL PLN} def % Hard Linefeed
2164 /dcp { currentpoint exch 40 string cvs print (, ) print = } def
2165 /dp { print 2 copy exch 40 string cvs print (, ) print = } def
2168 ( ) stringwidth % Get the width of a space in the current font.
2169 pop % Discard the Y component.
2170 mul % Multiply the width of a space
2171 % by the number of spaces to plot
2172 bg { dup dobackground } if
2177 /EF {/Effect exch def} def
2179 % stack: string |- --
2180 % effect: 1 - underline 2 - strikeout 4 - overline
2181 % 8 - shadow 16 - box 32 - outline
2183 /xx currentpoint dup Descent add /yy exch def
2184 Ascent add /YY exch def def
2185 dup stringwidth pop xx add /XX exch def
2187 /yy yy Yshadow add def
2188 /XX XX Xshadow add def
2193 {SpaceBackground doBox}
2194 {xx yy XX YY doRect}
2197 Effect 16 and 0 ne {false 0 doBox}if % box
2198 Effect 8 and 0 ne {dup doShadow}if % shadow
2200 {true doOutline} % outline
2201 {show} % normal text
2203 Effect 1 and 0 ne {UnderlinePosition Hline}if % underline
2204 Effect 2 and 0 ne {StrikeoutPosition Hline}if % strikeout
2205 Effect 4 and 0 ne {OverlinePosition Hline}if % overline
2208 % stack: position |- --
2210 currentpoint exch pop add dup
2216 LineThickness setlinewidth stroke
2220 % stack: fill-or-not delta |- --
2223 xx XBox sub dd sub yy YBox sub dd sub
2224 XX XBox add dd add YY YBox add dd add
2228 % stack: fill-or-not lower-x lower-y upper-x upper-y |- --
2241 % top of stack: fill-or-not
2243 {LineThickness setlinewidth stroke}
2248 % stack: string |- --
2251 Xshadow Yshadow rmoveto
2258 % stack: string fill-or-not |- --
2261 /-ox- currentpoint /-oy- exch def def
2263 LineThickness setlinewidth
2266 st dup true charpath
2267 -fillp- {gsave FillBgColor grestore}if
2269 -oy- add /-oy- exch def
2270 -ox- add /-ox- exch def
2278 /FillBgColor {bgcolor aload pop setrgbcolor fill} bind def
2280 /L0 6 /Times-Italic DefFont
2289 0.0 0.0 0.0 setrgbcolor
2290 /L0 findfont setfont
2293 {LineNumber 6 string cvs ( ) strcat}
2295 dup stringwidth pop neg 0 rmoveto
2299 /LineNumber LineNumber 1 add def
2307 /double-zebra ZebraHeight ZebraHeight add def
2308 /yiter double-zebra LineHeight mul neg def
2309 /xiter PrintWidth InterColumn add def
2310 NumberOfColumns {LinesPerColumn doColumnZebra xiter 0 rmoveto}repeat
2314 % stack: lines-per-column |- --
2317 dup double-zebra idiv {ZebraHeight doZebra 0 yiter rmoveto}repeat
2319 dup 0 le {pop}{dup ZebraHeight gt {pop ZebraHeight}if doZebra}ifelse
2323 % stack: zebra-height (in lines) |- --
2325 /zh exch 0.05 sub LineHeight mul def
2327 0 LineHeight 0.65 mul rmoveto
2328 PrintWidth 0 rlineto
2330 PrintWidth neg 0 rlineto
2336 % tx ty rotation xscale yscale xpos ypos BeginBackImage
2338 /-save-image- save def
2347 -save-image- restore
2350 % string fontsize fontname rotation gray xpos ypos ShowBackText
2356 findfont exch dup /-offset- exch -0.25 mul def scalefont setfont
2358 /-saveLineThickness- LineThickness def
2359 /LineThickness 1 def
2361 /LineThickness -saveLineThickness- def
2366 % ---- Remember space width of the normal text font `f0'.
2367 /SpaceWidth /f0 findfont setfont ( ) stringwidth pop def
2368 % ---- save the state of the document (useful for ghostscript!)
2370 /JackGhostscript where {pop 1 27.7 29.7 div scale}if
2371 % ---- [andrewi] set PageSize based on chosen dimensions
2372 /setpagedevice where {
2375 /PageSize [ PrintPageWidth LeftMargin add RightMargin add
2376 LandscapePageHeight ] put
2380 % ---- translate to bottom-right corner of Portrait page
2381 LandscapePageHeight 0 translate
2385 /ColumnWidth PrintWidth InterColumn add def
2386 % ---- translate to lower left corner of TEXT
2387 LeftMargin BottomMargin translate
2388 % ---- define where printing will start
2389 /f0 F % this installs Ascent
2390 /PrintStartY PrintHeight Ascent sub def
2395 % ---- on last page but not last column, spit out the page
2396 ColumnIndex 1 eq not { showpage } if
2397 % ---- restore the state of the document (useful for ghostscript!)
2402 % ---- when 1st column, save the state of the page
2403 ColumnIndex 1 eq { /pageState save def } if
2404 % ---- save the state of the column
2405 /columnState save def
2408 /PrintHeaderWidth PrintOnlyOneHeader{PrintPageWidth}{PrintWidth}ifelse def
2411 % ---- when 1st column, print all background effects
2413 0 PrintStartY moveto % move to where printing will start
2414 Zebra {printZebra}if
2415 printGlobalBackground
2416 printLocalBackground
2419 PrintOnlyOneHeader{ColumnIndex 1 eq}{true}ifelse {
2420 PrintHeaderFrame {HeaderFrame}if
2424 0 PrintStartY moveto % move to where printing will start
2433 ColumnIndex NumberOfColumns eq {
2434 % ---- on last column, spit out the page
2436 % ---- restore the state of the page
2440 % ---- restore the state of the current column
2442 % ---- and translate to the next column
2443 ColumnWidth 0 translate
2444 /ColumnIndex ColumnIndex 1 add def
2448 /SetHeaderLines { % nb-lines --
2449 /HeaderLines exch def
2452 HeaderLines 1 sub HeaderLineHeight mul add
2453 HeaderTitleLineHeight add
2455 /HeaderHeight exch def
2462 % |-+-------| <-- (x y)
2466 % |-+-------| <-- (0 0)
2470 /HeaderFrameStart { % -- x y
2471 0 PrintHeight HeaderOffset add
2475 PrintHeaderWidth 0 rlineto
2476 0 HeaderHeight rlineto
2477 PrintHeaderWidth neg 0 rlineto
2478 0 HeaderHeight neg rlineto
2484 % ---- fill a black rectangle (the shadow of the next one)
2485 HeaderFrameStart moveto
2489 % ---- do the next rectangle ...
2490 HeaderFrameStart moveto
2492 gsave 0.9 setgray fill grestore % filled with grey
2493 gsave 0 setgray stroke grestore % drawn with black
2499 exch HeaderPad add exch % horizontal pad
2501 HeaderPad add % vertical pad
2503 HeaderLineHeight HeaderLines 1 sub mul add
2507 dup length 3 -1 roll dup length dup 4 -1 roll add string dup
2508 0 5 -1 roll putinterval
2509 dup 4 2 roll exch putinterval
2513 PageNumber 32 string cvs
2516 PageCount 32 string cvs strcat
2523 HeaderLinesRight HeaderLinesLeft % -- rightLines leftLines
2525 % ---- hack: `PN 1 and' == `PN 2 modulo'
2527 % ---- if duplex and even page number, then exchange left and right
2528 Duplex PageNumber 1 and 0 eq and { exch } if
2530 { % ---- process the left lines
2534 dup xcheck { exec } if
2537 0 HeaderLineHeight neg rmoveto
2542 { % ---- process the right lines
2546 dup xcheck { exec } if
2548 PrintHeaderWidth exch sub HeaderPad 2 mul sub 0 rmoveto
2551 0 HeaderLineHeight neg rmoveto
2557 /t0 3 1 roll DefFont
2560 /sw ( ) stringwidth pop def
2561 /aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch
2562 stringwidth pop exch div def
2563 /t1 12 /Helvetica-Oblique DefFont
2570 ( point, the line height is ) show
2571 lh 32 string cvs show
2572 (, the space width is ) show
2573 sw 32 string cvs show
2576 0 FontHeight neg rmoveto
2578 (and a crude estimate of average character width is ) show
2579 aw 32 string cvs show
2582 0 FontHeight neg rmoveto
2589 /ReportAllFontInfo {
2591 { % key = font name value = font dictionary
2592 pop 10 exch ReportFontInfo
2596 % 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage
2597 % 3 cm 20 cm moveto ReportAllFontInfo showpage
2601 (defvar ps-print-prologue-2
2603 % ---- These lines must be kept together because...
2606 /HeaderTitleLineHeight FontHeight def
2609 /HeaderLineHeight FontHeight def
2610 /HeaderDescent Descent def
2612 % ---- ...because `F' has a side-effect on `FontHeight' and `Descent'
2616 ;; Start Editing Here:
2618 (defvar ps-source-buffer nil)
2619 (defvar ps-spool-buffer-name "*PostScript*")
2620 (defvar ps-spool-buffer nil)
2622 (defvar ps-output-head nil)
2623 (defvar ps-output-tail nil)
2625 (defvar ps-page-postscript 0)
2626 (defvar ps-page-count 0)
2627 (defvar ps-showline-count 1)
2629 (defvar ps-control-or-escape-regexp nil)
2631 (defvar ps-background-pages nil)
2632 (defvar ps-background-all-pages nil)
2633 (defvar ps-background-text-count 0)
2634 (defvar ps-background-image-count 0)
2636 (defvar ps-current-font 0)
2637 (defvar ps-default-color (and ps-print-color-p ps-default-fg)) ; black
2638 (defvar ps-current-color ps-default-color)
2639 (defvar ps-current-bg nil)
2641 (defvar ps-razchunk 0)
2643 (defvar ps-color-p nil)
2644 (defvar ps-color-format
2645 (if (eq ps-print-emacs-type 'emacs)
2647 ;; Emacs understands the %f format; we'll use it to limit color RGB
2648 ;; values to three decimals to cut down some on the size of the
2649 ;; PostScript output.
2652 ;; Lucid emacsen will have to make do with %s (princ) for floats.
2655 ;; These values determine how much print-height to deduct when headers
2656 ;; are turned on. This is a pretty clumsy way of handling it, but
2657 ;; it'll do for now.
2659 (defvar ps-header-pad 0
2660 "Vertical and horizontal space between the header frame and the text.
2661 This is in units of points (1/72 inch).")
2663 ;; Define accessors to the dimensions list.
2665 (defmacro ps-page-dimensions-get-width (dims) `(nth 0 ,dims))
2666 (defmacro ps-page-dimensions-get-height (dims) `(nth 1 ,dims))
2668 (defvar ps-landscape-page-height nil)
2670 (defvar ps-print-width nil)
2671 (defvar ps-print-height nil)
2673 (defvar ps-height-remaining nil)
2674 (defvar ps-width-remaining nil)
2676 (defvar ps-print-color-scale nil)
2679 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2680 ;; Internal Variables
2683 (defvar ps-print-face-extension-alist nil
2684 "Alist of symbolic faces *WITH* extension features (box, outline, etc).
2685 An element of this list has the following form:
2687 (FACE . [BITS FG BG])
2689 FACE is a symbol denoting a face name
2690 BITS is a bit vector, where each bit correspond
2691 to a feature (bold, underline, etc)
2692 (see documentation for `ps-print-face-map-alist')
2693 FG foreground color (string or nil)
2694 BG background color (string or nil)
2696 Don't change this list directly; instead,
2697 use `ps-extend-face' and `ps-extend-face-list'.
2698 See documentation for `ps-extend-face' for valid extension symbol.")
2701 (defvar ps-print-face-alist nil
2702 "Alist of symbolic faces *WITHOUT* extension features (box, outline, etc).
2704 An element of this list has the same form as an element of
2705 `ps-print-face-extension-alist'.
2707 Don't change this list directly; this list is used by `ps-face-attributes',
2708 `ps-map-face' and `ps-build-reference-face-lists'.")
2711 (defconst ps-print-face-map-alist
2720 "Alist of all features and the corresponding bit mask.
2721 Each symbol correspond to one bit in a bit vector.")
2724 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2729 (defun ps-extend-face-list (face-extension-list &optional merge-p)
2730 "Extend face in `ps-print-face-extension-alist'.
2732 If optional MERGE-P is non-nil, extensions in FACE-EXTENSION-LIST are merged
2733 with face extension in `ps-print-face-extension-alist'; otherwise, overrides.
2735 The elements in FACE-EXTENSION-LIST is like those for `ps-extend-face'.
2737 See `ps-extend-face' for documentation."
2738 (while face-extension-list
2739 (ps-extend-face (car face-extension-list) merge-p)
2740 (setq face-extension-list (cdr face-extension-list))))
2744 (defun ps-extend-face (face-extension &optional merge-p)
2745 "Extend face in `ps-print-face-extension-alist'.
2747 If optional MERGE-P is non-nil, extensions in FACE-EXTENSION list are merged
2748 with face extensions in `ps-print-face-extension-alist'; otherwise, overrides.
2750 The elements of FACE-EXTENSION list have the form:
2752 (FACE-NAME FOREGROUND BACKGROUND EXTENSION...)
2754 FACE-NAME is a face name symbol.
2756 FOREGROUND and BACKGROUND may be nil or a string that denotes the
2757 foreground and background colors respectively.
2759 EXTENSION is one of the following symbols:
2760 bold - use bold font.
2761 italic - use italic font.
2762 underline - put a line under text.
2763 strikeout - like underline, but the line is in middle of text.
2764 overline - like underline, but the line is over the text.
2765 shadow - text will have a shadow.
2766 box - text will be surrounded by a box.
2767 outline - print characters as hollow outlines.
2769 If EXTENSION is any other symbol, it is ignored."
2770 (let* ((face-name (nth 0 face-extension))
2771 (foreground (nth 1 face-extension))
2772 (background (nth 2 face-extension))
2773 (ps-face (cdr (assq face-name ps-print-face-extension-alist)))
2774 (face-vector (or ps-face (vector 0 nil nil)))
2775 (face-bit (ps-extension-bit face-extension)))
2777 (aset face-vector 0 (if merge-p
2778 (logior (aref face-vector 0) face-bit)
2780 (and foreground (stringp foreground) (aset face-vector 1 foreground))
2781 (and background (stringp background) (aset face-vector 2 background))
2782 ;; if face does not exist, insert it
2784 (setq ps-print-face-extension-alist
2785 (cons (cons face-name face-vector)
2786 ps-print-face-extension-alist)))))
2789 (defun ps-extension-bit (face-extension)
2791 ;; map valid symbol extension to bit vector
2792 (setq face-extension (cdr (cdr face-extension)))
2793 (while (setq face-extension (cdr face-extension))
2794 (setq face-bit (logior face-bit
2795 (or (cdr (assq (car face-extension)
2796 ps-print-face-map-alist))
2801 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2802 ;; Adapted from font-lock:
2803 ;; Originally face attributes were specified via `font-lock-face-attributes'.
2804 ;; Users then changed the default face attributes by setting that variable.
2805 ;; However, we try and be back-compatible and respect its value if set except
2806 ;; for faces where M-x customize has been used to save changes for the face.
2808 (defun ps-font-lock-face-attributes ()
2809 (and (boundp 'font-lock-mode) (symbol-value 'font-lock-mode)
2810 (boundp 'font-lock-face-attributes)
2811 (let ((face-attributes font-lock-face-attributes))
2812 (while face-attributes
2813 (let* ((face-attribute
2814 (car (prog1 face-attributes
2815 (setq face-attributes (cdr face-attributes)))))
2816 (face (car face-attribute)))
2817 ;; Rustle up a `defface' SPEC from a
2818 ;; `font-lock-face-attributes' entry.
2819 (unless (get face 'saved-face)
2820 (let ((foreground (nth 1 face-attribute))
2821 (background (nth 2 face-attribute))
2822 (bold-p (nth 3 face-attribute))
2823 (italic-p (nth 4 face-attribute))
2824 (underline-p (nth 5 face-attribute))
2827 (setq face-spec (cons ':foreground
2828 (cons foreground face-spec))))
2830 (setq face-spec (cons ':background
2831 (cons background face-spec))))
2833 (setq face-spec (append '(:bold t) face-spec)))
2835 (setq face-spec (append '(:italic t) face-spec)))
2837 (setq face-spec (append '(:underline t) face-spec)))
2838 (custom-declare-face face (list (list t face-spec)) nil)
2842 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2843 ;; Internal functions and variables
2846 (make-local-hook 'ps-print-hook)
2847 (make-local-hook 'ps-print-begin-page-hook)
2848 (make-local-hook 'ps-print-begin-column-hook)
2851 (defun ps-print-without-faces (from to &optional filename region-p)
2852 (ps-spool-without-faces from to region-p)
2853 (ps-do-despool filename))
2856 (defun ps-spool-without-faces (from to &optional region-p)
2857 (run-hooks 'ps-print-hook)
2858 (ps-printing-region region-p)
2859 (ps-generate (current-buffer) from to 'ps-generate-postscript))
2862 (defun ps-print-with-faces (from to &optional filename region-p)
2863 (ps-spool-with-faces from to region-p)
2864 (ps-do-despool filename))
2867 (defun ps-spool-with-faces (from to &optional region-p)
2868 (run-hooks 'ps-print-hook)
2869 (ps-printing-region region-p)
2870 (ps-generate (current-buffer) from to 'ps-generate-postscript-with-faces))
2873 (defsubst ps-count-lines (from to)
2874 (+ (count-lines from to)
2877 (if (= (current-column) 0) 1 0))))
2880 (defvar ps-printing-region nil
2881 "Variable used to indicate if ps-print is printing a region.
2882 If non-nil, it is a cons, the car of which is the line number
2883 where the region begins, and its cdr is the total number of lines
2884 in the buffer. Formatting functions can use this information
2885 to print the original line number (and not the number of lines printed),
2886 and to indicate in the header that the printout is of a partial file.")
2889 (defun ps-printing-region (region-p)
2890 (setq ps-printing-region
2892 (cons (ps-count-lines (point-min) (region-beginning))
2893 (ps-count-lines (point-min) (point-max))))))
2896 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2897 ;; Internal functions
2899 (defsubst ps-font-alist (font-sym)
2900 (get font-sym 'fonts))
2902 (defun ps-font (font-sym font-type)
2903 "Font family name for text of `font-type', when generating PostScript."
2904 (let* ((font-list (ps-font-alist font-sym))
2905 (normal-font (cdr (assq 'normal font-list))))
2906 (while (and font-list (not (eq font-type (car (car font-list)))))
2907 (setq font-list (cdr font-list)))
2908 (or (cdr (car font-list)) normal-font)))
2910 (defun ps-fonts (font-sym)
2911 (mapcar 'cdr (ps-font-alist font-sym)))
2913 (defun ps-font-number (font-sym font-type)
2914 (or (ps-alist-position font-type (ps-font-alist font-sym))
2917 (defsubst ps-line-height (font-sym)
2918 "The height of a line, for generating PostScript.
2919 This is the value that ps-print uses to determine the height,
2920 y-dimension, of the lines of text it has printed, and thus affects the
2921 point at which page-breaks are placed.
2922 The line-height is *not* the same as the point size of the font."
2923 (get font-sym 'line-height))
2925 (defsubst ps-title-line-height (font-sym)
2926 "The height of a `title' line, for generating PostScript.
2927 This is the value that ps-print uses to determine the height,
2928 y-dimension, of the lines of text it has printed, and thus affects the
2929 point at which page-breaks are placed.
2930 The title-line-height is *not* the same as the point size of the font."
2931 (get font-sym 'title-line-height))
2933 (defsubst ps-space-width (font-sym)
2934 "The width of a space character, for generating PostScript.
2935 This value is used in expanding tab characters."
2936 (get font-sym 'space-width))
2938 (defsubst ps-avg-char-width (font-sym)
2939 "The average width, in points, of a character, for generating PostScript.
2940 This is the value that ps-print uses to determine the length,
2941 x-dimension, of the text it has printed, and thus affects the point at
2942 which long lines wrap around."
2943 (get font-sym 'avg-char-width))
2946 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2947 ;; For handling multi-byte characters -- Begin.
2949 ;; The following comments apply only to this part (through the next ^L).
2950 ;; Author: Kenichi Handa <handa@etl.go.jp>
2951 ;; Maintainer: Kenichi Handa <handa@etl.go.jp>
2954 (if (not (string< mule-version "4.0"))
2956 (defalias 'ps-mule-next-point '1+)
2957 (defalias 'ps-mule-chars-in-string 'length)
2958 (defalias 'ps-mule-string-char 'aref)
2959 (defsubst ps-mule-next-index (str i) (1+ i)))
2960 (defun set-buffer-multibyte (arg)
2961 (setq enable-multibyte-characters arg))
2962 (defun string-as-unibyte (arg) arg)
2963 (defun string-as-multibyte (arg) arg)
2964 (defun charset-after (&optional arg)
2965 (char-charset (char-after arg)))
2966 (defun ps-mule-next-point (arg)
2967 (save-excursion (goto-char arg) (forward-char 1) (point)))
2968 (defun ps-mule-chars-in-string (string)
2970 (defalias 'ps-mule-string-char 'aref)
2971 (defun ps-mule-next-index (str i)
2975 (defvar ps-mule-font-info-database
2977 "Alist of charsets with the corresponding font information.
2978 Each element has the form:
2980 (CHARSET (FONT-TYPE FONT-SRC FONT-NAME ENCODING BYTES) ...)
2984 CHARSET is a charset (symbol) for this font family,
2986 FONT-TYPE is a font type: normal, bold, italic, or bold-italic.
2988 FONT-SRC is a font source: builtin, bdf, vflib, or nil.
2990 If FONT-SRC is builtin, FONT-NAME is a buitin PostScript font name.
2992 If FONT-SRC is bdf, FONT-NAME is a BDF font file name. To use this font,
2993 the external library `bdf' is required.
2995 If FONT-SRC is vflib, FONT-NAME is the name of a font that VFlib knows.
2996 To use this font, the external library `vflib' is required.
2998 If FONT-SRC is nil, a proper ASCII font in the variable
2999 `ps-font-info-database' is used. This is useful for Latin-1 characters.
3001 ENCODING is a coding system to encode a string of characters of CHARSET into a
3002 proper string matching an encoding of the specified font. ENCODING may be a
3003 function that does this encoding. In this case, the function is called with
3004 one argument, the string to encode, and it should return an encoded string.
3006 BYTES specifies how many bytes each character has in the encoded byte
3007 sequence; it should be 1 or 2.
3009 All multi-byte characters are printed by fonts specified in this database
3010 regardless of a font family of ASCII characters. The exception is Latin-1
3011 characters which are printed by the same font as ASCII characters, thus obey
3014 See also the variable `ps-font-info-database'.")
3016 (defconst ps-mule-font-info-database-latin
3018 (normal nil nil iso-latin-1)))
3019 "Sample setting of `ps-mule-font-info-database' to use latin fonts.")
3021 (defconst ps-mule-font-info-database-ps
3022 '((katakana-jisx0201
3023 (normal builtin "Ryumin-Light.Katakana" ps-mule-encode-7bit 1)
3024 (bold builtin "GothicBBB-Medium.Katakana" ps-mule-encode-7bit 1)
3025 (bold-italic builtin "GothicBBB-Medium.Katakana" ps-mule-encode-7bit 1))
3027 (normat builtin "Ryumin-Light.Hankaku" ps-mule-encode-7bit 1)
3028 (bold builtin "GothicBBB-Medium.Hankaku" ps-mule-encode-7bit 1))
3030 (normal builtin "Ryumin-Light-H" ps-mule-encode-7bit 2)
3031 (bold builtin "GothicBBB-Medium-H" ps-mule-encode-7bit 2))
3033 (normal builtin "Batang-Medium-KSC-H" ps-mule-encode-7bit 2)
3034 (bold builtin " Gulim-Medium-KSC-H" ps-mule-encode-7bit 2))
3036 "Sample setting of the `ps-mule-font-info-database' to use builtin PS font.
3038 Currently, data for Japanese and Korean PostScript printers are listed.")
3040 (defconst ps-mule-font-info-database-bdf
3042 (normal bdf "etl24-latin1.bdf" nil 1)
3043 (bold bdf "etl16b-latin1.bdf" iso-latin-1 1)
3044 (italic bdf "etl16i-latin1.bdf" iso-latin-1 1)
3045 (bold-italic bdf "etl16bi-latin1.bdf" iso-latin-1 1))
3047 (normal bdf "etl24-latin1.bdf" iso-latin-1 1)
3048 (bold bdf "etl16b-latin1.bdf" iso-latin-1 1)
3049 (italic bdf "etl16i-latin1.bdf" iso-latin-1 1)
3050 (bold-italic bdf "etl16bi-latin1.bdf" iso-latin-1 1))
3052 (normal bdf "etl24-latin2.bdf" iso-latin-2 1))
3054 (normal bdf "etl24-latin3.bdf" iso-latin-3 1))
3056 (normal bdf "etl24-latin4.bdf" iso-latin-4 1))
3058 (normal bdf "thai-24.bdf" thai-tis620 1))
3060 (normal bdf "etl24-greek.bdf" greek-iso-8bit 1))
3061 ;; (arabic-iso8859-6 nil) ; not yet available
3063 (normal bdf "etl24-hebrew.bdf" hebrew-iso-8bit 1))
3065 (normal bdf "12x24rk.bdf" ps-mule-encode-8bit 1))
3067 (normal bdf "12x24rk.bdf" ps-mule-encode-7bit 1))
3069 (normal bdf "etl24-cyrillic.bdf" cyrillic-iso-8bit 1))
3071 (normal bdf "etl24-latin5.bdf" iso-latin-5 1))
3072 (japanese-jisx0208-1978
3073 (normal bdf "jiskan24.bdf" ps-mule-encode-7bit 2))
3075 (normal bdf "gb24st.bdf" ps-mule-encode-7bit 2))
3077 (normal bdf "jiskan24.bdf" ps-mule-encode-7bit 2))
3079 (normal bdf "hanglm24.bdf" ps-mule-encode-7bit 2))
3081 (normal bdf "jisksp40.bdf" ps-mule-encode-7bit 2))
3083 (normal bdf "cns-1-40.bdf" ps-mule-encode-7bit 2))
3085 (normal bdf "cns-2-40.bdf" ps-mule-encode-7bit 2))
3087 (normal bdf "taipei24.bdf" chinese-big5 2))
3089 (normal bdf "taipei24.bdf" chinese-big5 2))
3091 (normal bdf "etl24-sisheng.bdf" ps-mule-encode-8bit 1))
3093 (normal bdf "etl24-ipa.bdf" ps-mule-encode-8bit 1))
3094 (vietnamese-viscii-lower
3095 (normal bdf "etl24-viscii.bdf" vietnamese-viscii 1))
3096 (vietnamese-viscii-upper
3097 (normal bdf "etl24-viscii.bdf" vietnamese-viscii 1))
3099 (normal bdf "etl24-arabic0.bdf" ps-mule-encode-7bit 1))
3101 (normal bdf "etl24-arabic1.bdf" ps-mule-encode-7bit 1))
3102 ;; (ascii-right-to-left nil) ; not yet available
3104 (normal bdf "mule-lao-24.bdf" lao 1))
3106 (normal bdf "etl24-arabic2.bdf" ps-mule-encode-7bit 1))
3108 (normal bdf "mule-iscii-24.bdf" ps-mule-encode-7bit 1))
3110 (normal bdf "mule-indian-1col-24.bdf" ps-mule-encode-7bit 2))
3112 (normal bdf "mule-tibmdx-1col-24.bdf" ps-mule-encode-7bit 2))
3114 (normal bdf "ethiomx24f-uni.bdf" ps-mule-encode-ethiopic 2))
3116 (normal bdf "cns-3-40.bdf" ps-mule-encode-7bit 2))
3118 (normal bdf "cns-4-40.bdf" ps-mule-encode-7bit 2))
3120 (normal bdf "cns-5-40.bdf" ps-mule-encode-7bit 2))
3122 (normal bdf "cns-6-40.bdf" ps-mule-encode-7bit 2))
3124 (normal bdf "cns-7-40.bdf" ps-mule-encode-7bit 2))
3126 (normal bdf "mule-indian-24.bdf" ps-mule-encode-7bit 2))
3128 (normal bdf "mule-tibmdx-24.bdf" ps-mule-encode-7bit 2)))
3129 "Sample setting of the `ps-mule-font-info-database' to use BDF fonts.
3130 BDF (Bitmap Distribution Format) is a format used for distributing X's font
3133 Current default value list for BDF fonts is included in `intlfonts-1.1' which is
3134 a collection of X11 fonts for all characters supported by Emacs.
3136 Using this list as default value to `ps-mule-font-info-database', all characters
3137 including ASCII and Latin-1 are printed by BDF fonts.
3139 See also `ps-mule-font-info-database-ps-bdf'.")
3141 (defconst ps-mule-font-info-database-ps-bdf
3142 (cons (car ps-mule-font-info-database-latin)
3143 (cdr (cdr ps-mule-font-info-database-bdf)))
3144 "Sample setting of the `ps-mule-font-info-database' to use BDF fonts.
3146 Current default value list for BDF fonts is included in `intlfonts-1.1' which is
3147 a collection of X11 fonts for all characters supported by Emacs.
3149 Using this list as default value to `ps-mule-font-info-database', all characters
3150 except ASCII and Latin-1 characters are printed by BDF fonts. ASCII and Latin-1
3151 characters are printed by PostScript font specified by `ps-font-family' and
3152 `ps-header-font-family'.
3154 See also `ps-mule-font-info-database-bdf'.")
3156 ;; Two typical encoding functions for PostScript fonts.
3158 (defun ps-mule-encode-7bit (string)
3159 (ps-mule-encode-bit string 0))
3161 (defun ps-mule-encode-8bit (string)
3162 (ps-mule-encode-bit string 128))
3164 (defun ps-mule-encode-bit (string delta)
3165 (let* ((dim (charset-dimension (char-charset (ps-mule-string-char string 0))))
3166 (len (* (ps-mule-chars-in-string string) dim))
3167 (str (make-string len 0))
3173 (+ (nth 1 (split-char (ps-mule-string-char string i))) delta))
3174 (setq i (ps-mule-next-index string i)
3177 (let ((split (split-char (ps-mule-string-char string i))))
3178 (aset str j (+ (nth 1 split) delta))
3179 (aset str (1+ j) (+ (nth 2 split) delta))
3180 (setq i (ps-mule-next-index string i)
3184 ;; Special encoding function for Ethiopic.
3185 (define-ccl-program ccl-encode-ethio-unicode
3189 (if (r2 == ,leading-code-private-22)
3191 (if (r0 == ,(charset-id 'ethiopic))
3193 (r1 &= 127) (r2 &= 127)
3194 (call ccl-encode-ethio-font)
3196 (write-read-repeat r2))
3199 (write-read-repeat r2))))))
3201 (defun ps-mule-encode-ethiopic (string)
3202 (ccl-execute-on-string (symbol-value 'ccl-encode-ethio-unicode)
3206 ;; A charset which we are now processing.
3207 (defvar ps-mule-current-charset nil)
3209 (defun ps-mule-get-font-spec (charset font-type)
3210 "Return FONT-SPEC for printing characters CHARSET with FONT-TYPE.
3211 FONT-SPEC is a list that has the form:
3213 (FONT-SRC FONT-NAME ENCODING BYTES)
3215 FONT-SPEC is extracted from `ps-mule-font-info-database'.
3217 See the documentation of `ps-mule-font-info-database' for the meaning of each
3218 element of the list."
3219 (let ((slot (cdr (assq charset ps-mule-font-info-database))))
3221 (cdr (or (assq font-type slot)
3222 (and (eq font-type 'bold-italic)
3223 (or (assq 'bold slot) (assq 'italic slot)))
3224 (assq 'normal slot))))))
3226 ;; Functions to access each element of FONT-SPEC.
3227 (defsubst ps-mule-font-spec-src (font-spec) (car font-spec))
3228 (defsubst ps-mule-font-spec-name (font-spec) (nth 1 font-spec))
3229 (defsubst ps-mule-font-spec-encoding (font-spec) (nth 2 font-spec))
3230 (defsubst ps-mule-font-spec-bytes (font-spec) (nth 3 font-spec))
3232 (defsubst ps-mule-printable-p (charset)
3233 "Non-nil if characters in CHARSET is printable."
3234 (ps-mule-get-font-spec charset 'normal))
3236 (defconst ps-mule-external-libraries
3240 bdf-generate-prologue bdf-generate-font bdf-generate-glyphs)
3242 pcf-generate-prologue pcf-generate-font pcf-generate-glyphs)
3244 vflib-generate-prologue vflib-generate-font vflib-generate-glyphs))
3245 "Alist of information of external libraries to support PostScript printing.
3246 Each element has the form:
3248 (FONT-SRC INITIALIZED-P PROLOGUE-FUNC FONT-FUNC GLYPHS-FUNC)
3250 FONT-SRC is the font source: builtin, bdf, pcf, or vflib. Except for `builtin',
3251 libraries must have the same name as indicated by FONT-SRC. Currently, we only
3252 have the `bdf' library.
3254 INITIALIZED-P indicates if this library is initialized or not.
3256 PROLOGUE-FUNC is a function to generate PostScript code which define several
3257 PostScript procedures that will be called by FONT-FUNC and GLYPHS-FUNC. It is
3258 called with no argument, and should return a list of strings.
3260 FONT-FUNC is a function to generate PostScript code which define a new font. It
3261 is called with one argument FONT-SPEC, and should return a list of strings.
3263 GLYPHS-FUNC is a function to generate PostScript code which define glyphs of
3264 characters. It is called with three arguments FONT-SPEC, CODE-LIST, and BYTES,
3265 and should return a list of strings.")
3267 (defun ps-mule-init-external-library (font-spec)
3268 "Initialize external library specified by FONT-SPEC for PostScript printing.
3269 See the documentation of `ps-mule-get-font-spec' for FONT-SPEC's meaning."
3270 (let* ((font-src (ps-mule-font-spec-src font-spec))
3271 (slot (assq font-src ps-mule-external-libraries)))
3274 (let ((func (nth 2 slot)))
3277 (or (featurep font-src) (require font-src))
3278 (ps-output-prologue (funcall func))))
3279 (setcar (cdr slot) t)))))
3281 ;; Cached glyph information of fonts, alist of:
3282 ;; (FONT-NAME ((FONT-TYPE-NUMBER . SCALED-FONT-NAME) ...)
3283 ;; cache CODE0 CODE1 ...)
3284 (defvar ps-mule-font-cache nil)
3286 (defun ps-mule-generate-font (font-spec charset)
3287 "Generate PostScript codes to define a new font in FONT-SPEC for CHARSET."
3288 (let* ((font-cache (assoc (ps-mule-font-spec-name font-spec)
3289 ps-mule-font-cache))
3290 (font-src (ps-mule-font-spec-src font-spec))
3291 (font-name (ps-mule-font-spec-name font-spec))
3292 (func (nth 3 (assq font-src ps-mule-external-libraries)))
3294 (if (eq charset 'ascii)
3295 (format "f%d" ps-current-font)
3297 (charset-id charset) ps-current-font))))
3298 (and func (not font-cache)
3299 (ps-output-prologue (funcall func charset font-spec)))
3301 (list (format "/%s %f /%s Def%sFontMule\n"
3302 scaled-font-name ps-font-size font-name
3303 (if (eq ps-mule-current-charset 'ascii) "Ascii" ""))))
3305 (setcar (cdr font-cache)
3306 (cons (cons ps-current-font scaled-font-name)
3307 (nth 1 font-cache)))
3308 (setq font-cache (list font-name
3309 (list (cons ps-current-font scaled-font-name))
3311 ps-mule-font-cache (cons font-cache ps-mule-font-cache)))
3314 (defun ps-mule-generate-glyphs (font-spec code-list)
3315 "Generate PostScript codes which generate glyphs for CODE-LIST of FONT-SPEC."
3316 (let* ((font-src (ps-mule-font-spec-src font-spec))
3317 (func (nth 4 (assq font-src ps-mule-external-libraries))))
3320 (funcall func font-spec code-list
3321 (ps-mule-font-spec-bytes font-spec))))))
3323 (defvar ps-last-font nil)
3325 (defun ps-mule-prepare-font (font-spec string charset &optional no-setfont)
3326 "Generate PostScript codes to print STRING of CHARSET by font FONT-SPEC.
3328 The generated code is inserted on prologue part except the code that sets the
3329 current font (using PostScript procedure `FM').
3331 If optional arg NO-SETFONT is non-nil, don't generate the code for setting the
3333 (let ((font-cache (assoc (ps-mule-font-spec-name font-spec)
3334 ps-mule-font-cache)))
3335 (or (and font-cache (assq ps-current-font (nth 1 font-cache)))
3336 (setq font-cache (ps-mule-generate-font font-spec charset)))
3338 (let ((new-font (cdr (assq ps-current-font (nth 1 font-cache)))))
3339 (or (equal new-font ps-last-font)
3341 (ps-output (format "/%s FM\n" new-font))
3342 (setq ps-last-font new-font)))))
3343 (if (nth 4 (assq (ps-mule-font-spec-src font-spec)
3344 ps-mule-external-libraries))
3345 ;; We have to generate PostScript codes which define glyphs.
3346 (let* ((cached-codes (nthcdr 2 font-cache))
3348 (bytes (ps-mule-font-spec-bytes font-spec))
3349 (len (length string))
3353 (setq code (if (= bytes 1)
3355 (+ (* (aref string i) 256) (aref string (1+ i)))))
3356 (or (memq code cached-codes)
3358 (setq newcodes (cons code newcodes))
3359 (setcdr cached-codes (cons code (cdr cached-codes)))))
3360 (setq i (+ i bytes)))
3362 (ps-mule-generate-glyphs font-spec newcodes))))))
3364 ;; List of charsets of multi-byte characters in a text being printed.
3365 ;; If the text doesn't contain any multi-byte characters (i.e. only
3366 ;; ASCII), the value is nil.
3367 (defvar ps-mule-charset-list nil)
3369 (defvar ps-mule-prologue-generated nil)
3371 ;; This is a PostScript code inserted in the header of generated PostScript.
3372 (defconst ps-mule-prologue
3373 "%%%% Start of Mule Section
3375 %% Working dictionary for general use.
3376 /MuleDict 10 dict def
3378 %% Define already scaled font for non-ASCII character sets.
3379 /DefFontMule { % fontname size basefont |- --
3380 findfont exch scalefont definefont pop
3383 %% Define already scaled font for ASCII character sets.
3384 /DefAsciiFontMule { % fontname size basefont |-
3386 findfont dup /Encoding get /ISOLatin1Encoding exch def
3387 exch scalefont reencodeFontISO
3391 %% Set the specified non-ASCII font to use. It doesn't install
3393 /FM { % fontname |- --
3397 %% Show vacant box for characters which don't have appropriate font.
3398 /SB { % count column |- --
3399 SpaceWidth mul /w exch def
3400 1 exch 1 exch { %for
3404 0 Descent rmoveto w 0 rlineto
3405 0 LineHeight rlineto w neg 0 rlineto closepath stroke
3411 %% Flag to tell if we are now handling a composite character. This is
3412 %% defined here because both composite character handler and bitmap font
3413 %% handler require it.
3416 %%%% End of Mule Section
3419 "PostScript code for printing multi-byte characters.")
3421 (defun ps-mule-skip-same-charset (charset)
3422 "Skip characters of CHARSET following the current point."
3423 (while (eq (charset-after) charset)
3426 (defun ps-mule-find-wrappoint (from to char-width)
3427 "Find the longest sequence which is printable in the current line.
3429 The search starts at FROM and goes until TO. It is assumed that all characters
3430 between FROM and TO belong to a charset in `ps-mule-current-charset'.
3432 CHAR-WIDTH is the average width of ASCII characters in the current font.
3436 (ENDPOS . RUN-WIDTH)
3438 Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
3441 (if (eq ps-mule-current-charset 'composition)
3442 ;; We must draw one char by one.
3443 (let ((ch (char-after from)))
3444 (setq run-width (* (char-width ch) char-width))
3445 (if (> run-width ps-width-remaining)
3446 (setq run-width ps-width-remaining)
3447 (setq from (ps-mule-next-point from))))
3448 ;; We assume that all characters in this range have the same width.
3449 (let ((width (charset-width ps-mule-current-charset)))
3450 (setq run-width (* (- to from) char-width width))
3451 (if (> run-width ps-width-remaining)
3453 (+ from (truncate (/ ps-width-remaining char-width)))
3455 run-width ps-width-remaining)
3457 (cons from run-width)))
3459 (defun ps-mule-plot-string (from to &optional bg-color)
3460 "Generate PostScript code for ploting characters in the region FROM and TO.
3462 It is assumed that all characters in this region belong to a charset in
3463 `ps-mule-current-charset'.
3465 Optional argument BG-COLOR specifies background color.
3469 (ENDPOS . RUN-WIDTH)
3471 Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
3473 (let* ((wrappoint (ps-mule-find-wrappoint
3474 from to (ps-avg-char-width 'ps-font-for-text)))
3475 (to (car wrappoint))
3476 (font-type (car (nth ps-current-font
3477 (ps-font-alist 'ps-font-for-text))))
3478 (font-spec (ps-mule-get-font-spec ps-mule-current-charset font-type))
3479 (string (buffer-substring-no-properties from to)))
3482 ;; We can't print any more characters in the current line.
3486 ;; We surely have a font for printing this character set.
3487 (ps-output-string (ps-mule-string-encoding font-spec string))
3490 ((eq ps-mule-current-charset 'latin-iso8859-1)
3491 ;; Latin-1 can be printed by a normal ASCII font.
3492 (ps-output-string (ps-mule-string-ascii string))
3495 ((eq ps-mule-current-charset 'composition)
3496 (let* ((ch (char-after from))
3497 (width (char-width ch))
3498 (ch-list (decompose-composite-char ch 'list t)))
3499 (if (consp (nth 1 ch-list))
3500 (ps-mule-plot-rule-cmpchar ch-list width font-type)
3501 (ps-mule-plot-cmpchar ch-list width t font-type))))
3504 ;; No way to print this charset. Just show a vacant box of an
3505 ;; appropriate width.
3506 (ps-output (format "%d %d SB\n"
3508 (if (eq ps-mule-current-charset 'composition)
3509 (char-width (char-after from))
3510 (charset-width ps-mule-current-charset))))))
3513 ;; Composite font support
3515 (defvar ps-mule-cmpchar-prologue-generated nil)
3517 (defconst ps-mule-cmpchar-prologue
3518 "%%%% Composite character handler
3520 /CmpcharRelativeCompose 0 def
3521 /CmpcharRelativeSkip 0.4 def
3523 %% Get a bounding box (relative to currentpoint) of STR.
3524 /GetPathBox { % str |- --
3526 currentfont /FontType get 3 eq { %ifelse
3529 currentpoint /y exch def pop
3530 false charpath flattenpath pathbbox
3531 y sub /URY exch def pop
3532 y sub /LLY exch def pop
3537 %% Beginning of composite char.
3538 /BC { % str xoff width |- --
3540 /CmpcharWidth exch def
3541 currentfont /RelativeCompose known {
3542 /CmpcharRelativeCompose currentfont /RelativeCompose get def
3544 /CmpcharRelativeCompose false def
3546 /bgsave bg def /bgcolorsave bgcolor def
3547 /Effectsave Effect def
3548 gsave % Reflect effect only at first
3549 /Effect Effect 1 2 add 4 add 16 add and def
3550 /f0 findfont setfont ( ) 0 CmpcharWidth getinterval S
3552 /Effect Effectsave 8 32 add and def % enable only shadow and outline
3554 gsave SpaceWidth mul 0 rmoveto dup GetPathBox S grestore
3555 /y currentpoint exch pop def
3556 /HIGH URY y add def /LOW LLY y add def
3559 %% End of composite char.
3561 /bg bgsave def /bgcolor bgcolorsave def
3562 /Effect Effectsave def
3564 CmpcharWidth SpaceWidth mul 0 rmoveto
3567 %% Rule base composition
3568 /RBC { % str xoff gref nref |- --
3569 /nref exch def /gref exch def
3571 SpaceWidth mul 0 rmoveto
3574 [ HIGH currentpoint exch pop LOW HIGH LOW add 2 div ] gref get
3575 [ URY LLY sub LLY neg 0 URY LLY sub 2 div ] nref get
3577 /top btm URY LLY sub add def
3578 top HIGH gt { /HIGH top def } if
3579 btm LOW lt { /LOW btm def } if
3580 currentpoint pop btm LLY sub moveto
3585 %% Relative composition
3589 CmpcharRelativeCompose type /integertype eq {
3590 LLY CmpcharRelativeCompose gt { % compose on top
3591 currentpoint pop HIGH LLY sub CmpcharRelativeSkip add moveto
3592 /HIGH HIGH URY LLY sub add CmpcharRelativeSkip add def
3593 } { URY 0 le { % compose under bottom
3594 currentpoint pop LOW LLY add CmpcharRelativeSkip sub moveto
3595 /LOW LOW URY LLY sub sub CmpcharRelativeSkip sub def
3600 %%%% End of composite character handler
3603 "PostScript code for printing composite characters.")
3605 (defun ps-mule-plot-rule-cmpchar (ch-rule-list total-width font-type)
3606 (let* ((leftmost 0.0)
3607 (rightmost (float (char-width (car ch-rule-list))))
3608 (the-list (cons '(3 . 3) ch-rule-list))
3609 (cmpchar-elements nil))
3611 (let* ((this (car the-list))
3614 ;; X-axis info (0:left, 1:center, 2:right)
3617 ;; Y-axis info (0:top, 1:base, 2:bottom, 3:center)
3618 (gref-y (if (= gref 4) 3 (/ gref 3)))
3619 (nref-y (if (= nref 4) 3 (/ nref 3)))
3620 (width (float (char-width (car (cdr the-list)))))
3622 (setq left (+ leftmost
3623 (/ (* (- rightmost leftmost) gref-x) 2.0)
3624 (- (/ (* nref-x width) 2.0)))
3625 cmpchar-elements (cons (list (car (cdr the-list))
3628 leftmost (min left leftmost)
3629 rightmost (max (+ left width) rightmost)
3630 the-list (nthcdr 2 the-list))))
3632 (let ((the-list cmpchar-elements))
3634 (setcar (cdr (car the-list))
3635 (- (nth 1 (car the-list)) leftmost))
3636 (setq the-list (cdr the-list)))))
3637 (ps-mule-plot-cmpchar (nreverse cmpchar-elements)
3638 total-width nil font-type)))
3640 (defun ps-mule-plot-cmpchar (elements total-width relativep font-type)
3641 (let* ((elt (car elements))
3642 (ch (if relativep elt (car elt))))
3643 (ps-output-string (ps-mule-prepare-cmpchar-font ch font-type))
3644 (ps-output (format " %d %d BC "
3645 (if relativep 0 (nth 1 elt))
3647 (while (setq elements (cdr elements))
3648 (setq elt (car elements)
3649 ch (if relativep elt (car elt)))
3650 (ps-output-string (ps-mule-prepare-cmpchar-font ch font-type))
3651 (ps-output (if relativep
3653 (format " %d %d %d RBC "
3654 (nth 1 elt) (nth 2 elt) (nth 3 elt))))))
3657 (defun ps-mule-prepare-cmpchar-font (char font-type)
3658 (let* ((ps-mule-current-charset (char-charset char))
3659 (font-spec (ps-mule-get-font-spec ps-mule-current-charset font-type)))
3661 (ps-mule-string-encoding font-spec (char-to-string char)))
3663 ((eq ps-mule-current-charset 'latin-iso8859-1)
3664 (ps-mule-string-ascii (char-to-string char)))
3667 ;; No font for CHAR.
3668 (ps-set-font ps-current-font)
3671 (defun ps-mule-string-ascii (str)
3672 (ps-set-font ps-current-font)
3673 (string-as-unibyte (encode-coding-string str 'iso-latin-1)))
3675 (defun ps-mule-string-encoding (font-spec str)
3676 (let ((encoding (ps-mule-font-spec-encoding font-spec)))
3677 (cond ((coding-system-p encoding)
3678 (setq str (encode-coding-string str encoding)))
3679 ((functionp encoding)
3680 (setq str (funcall encoding str)))
3682 (error "Invalid coding system or function: %s" encoding)))
3683 (setq str (string-as-unibyte str))
3684 (if (ps-mule-font-spec-src font-spec)
3685 (ps-mule-prepare-font font-spec str ps-mule-current-charset)
3686 (ps-set-font ps-current-font))
3689 ;; Bitmap font support
3691 (defvar ps-mule-bitmap-prologue-generated nil)
3693 (defconst ps-mule-bitmap-prologue
3694 "%%%% Bitmap font handler
3696 /str7 7 string def % working area
3698 %% We grow the dictionary one bunch (1024 entries) by one.
3699 /BitmapDictArray 256 array def
3700 /BitmapDictLength 1024 def
3701 /BitmapDictIndex -1 def
3703 /NewBitmapDict { % -- |- --
3704 /BitmapDictIndex BitmapDictIndex 1 add def
3705 BitmapDictArray BitmapDictIndex BitmapDictLength dict put
3708 %% Make at least one dictionary.
3711 /AddBitmap { % gloval-charname bitmap-data |- --
3712 BitmapDictArray BitmapDictIndex get
3713 dup length BitmapDictLength ge {
3716 BitmapDictArray BitmapDictIndex get
3721 /GetBitmap { % gloval-charname |- bitmap-data
3722 0 1 BitmapDictIndex { BitmapDictArray exch get begin } for
3724 0 1 BitmapDictIndex { pop end } for
3727 %% Return a global character name which can be used as a key in the
3728 %% bitmap dictionary.
3729 /GlobalCharName { % fontidx code1 code2 |- gloval-charname
3730 exch 256 mul add exch 65536 mul add 16777216 add 16 str7 cvrs 0 66 put
3734 %% Character code holder for a 2-byte character.
3737 %% Glyph rendering procedure
3738 /BuildGlyphCommon { % fontdict charname |- --
3739 1 index /FontDimension get 1 eq { /FirstCode 0 store } if
3740 NameIndexDict exch get % STACK: fontdict charcode
3741 FirstCode 0 lt { %ifelse
3742 %% This is the first byte of a 2-byte character. Just
3743 %% remember it for the moment.
3744 /FirstCode exch store
3748 1 index /FontSize get /size exch def
3749 1 index /FontSpaceWidthRatio get /ratio exch def
3750 1 index /FontIndex get exch FirstCode exch
3751 GlobalCharName GetBitmap /bmp exch def
3752 %% bmp == [ DWIDTH BBX-WIDTH BBX-HEIGHT BBX-XOFF BBX-YOFF BITMAP ]
3754 /FontMatrix get [ exch { size div } forall ] /mtrx exch def
3755 bmp 3 get bmp 4 get mtrx transform
3757 bmp 1 get bmp 3 get add bmp 2 get bmp 4 get add mtrx transform
3764 bmp 0 get SpaceWidthRatio ratio div mul size div 0 % wx wy
3765 setcharwidth % We can't use setcachedevice here.
3767 bmp 1 get 0 gt bmp 2 get 0 gt and {
3768 bmp 1 get bmp 2 get % width height
3770 [ size 0 0 size neg bmp 3 get neg bmp 2 get bmp 4 get add ] % matrix
3771 bmp 5 1 getinterval cvx % datasrc
3778 1 index /Encoding get exch get
3779 1 index /BuildGlyph get exec
3782 %% Bitmap font creater
3784 %% Common Encoding shared by all bitmap fonts.
3785 /EncodingCommon 256 array def
3786 %% Mapping table from character name to character code.
3787 /NameIndexDict 256 dict def
3790 /idxname idx 256 add 16 (XXX) cvrs dup 0 67 put cvn def % `C' == 67
3791 EncodingCommon idx idxname put
3792 NameIndexDict idxname idx put
3795 /GlobalFontIndex 0 def
3797 %% fontname dim col fontsize relative-compose baseline-offset fbbx |- --
3801 /BaselineOffset exch def
3802 /RelativeCompose exch def
3804 /FontBBox [ FontBBox { FontSize div } forall ] def
3805 FontBBox 2 get FontBBox 0 get sub exch div
3806 /FontSpaceWidthRatio exch def
3807 /FontDimension exch def
3808 /FontIndex GlobalFontIndex def
3810 /FontMatrix matrix def
3811 /Encoding EncodingCommon def
3812 /BuildGlyph { BuildGlyphCommon } def
3813 /BuildChar { BuildCharCommon } def
3816 /GlobalFontIndex GlobalFontIndex 1 add def
3819 %% Define a new bitmap font.
3820 %% fontname dim col fontsize relative-compose baseline-offset fbbx |- --
3823 %% Convert BDF's FontBoundingBox to PostScript's FontBBox
3824 [ fbbx 2 get fbbx 3 get
3825 fbbx 2 get fbbx 0 get add fbbx 3 get fbbx 1 get add ]
3829 %% Define a glyph for the specified font and character.
3830 /NG { % fontname charcode bitmap-data |- --
3832 exch findfont dup /BaselineOffset get bmp 4 get add bmp exch 4 exch put
3834 dup 256 idiv exch 256 mod GlobalCharName
3837 %%%% End of bitmap font handler
3841 ;; External library support.
3843 ;; The following three functions are to be called from external
3844 ;; libraries which support bitmap fonts (e.g. `bdf') to get
3845 ;; appropriate PostScript code.
3847 (defun ps-mule-generate-bitmap-prologue ()
3848 (unless ps-mule-bitmap-prologue-generated
3849 (setq ps-mule-bitmap-prologue-generated t)
3850 (list ps-mule-bitmap-prologue)))
3852 (defun ps-mule-generate-bitmap-font (&rest args)
3853 (list (apply 'format "/%s %d %d %f %S %d %S NF\n" args)))
3855 (defun ps-mule-generate-bitmap-glyph (font-name code dwidth bbx bitmap)
3856 (format "/%s %d [ %d %d %d %d %d <%s> ] NG\n"
3858 dwidth (aref bbx 0) (aref bbx 1) (aref bbx 2) (aref bbx 3)
3861 ;; Mule specific initializers.
3863 (defun ps-mule-initialize ()
3864 "Produce Poscript code in the prologue part for multi-byte characters."
3865 (setq ps-mule-font-info-database
3866 (cond ((eq ps-multibyte-buffer 'non-latin-printer)
3867 ps-mule-font-info-database-ps)
3868 ((eq ps-multibyte-buffer 'bdf-font)
3869 ps-mule-font-info-database-bdf)
3870 ((eq ps-multibyte-buffer 'bdf-font-except-latin)
3871 ps-mule-font-info-database-ps-bdf)
3873 ps-mule-font-info-database-latin))
3874 ps-mule-current-charset 'ascii
3875 ps-mule-font-cache nil
3876 ps-mule-prologue-generated nil
3877 ps-mule-cmpchar-prologue-generated nil
3878 ps-mule-bitmap-prologue-generated nil)
3879 (mapcar `(lambda (x) (setcar (cdr x) nil))
3880 ps-mule-external-libraries))
3882 (defun ps-mule-begin (from to)
3883 (and (boundp 'enable-multibyte-characters)
3884 enable-multibyte-characters
3885 ;; Initialize `ps-mule-charset-list'. If some characters aren't
3886 ;; printable, warn it.
3887 (let ((charsets (delete 'ascii (find-charset-region from to))))
3888 (setq ps-mule-charset-list charsets)
3891 (and (search-forward "\200" to t)
3892 (setq ps-mule-charset-list
3893 (cons 'composition ps-mule-charset-list))))
3896 ((or (eq (car charsets) 'composition)
3897 (ps-mule-printable-p (car charsets)))
3898 (setq charsets (cdr charsets)))
3899 ((y-or-n-p "Font for some characters not found, continue anyway? ")
3900 (setq charsets nil))
3902 (error "Printing cancelled"))))))
3904 (if ps-mule-charset-list
3905 (let ((the-list ps-mule-charset-list)
3907 (unless ps-mule-prologue-generated
3908 (ps-output-prologue ps-mule-prologue)
3909 (setq ps-mule-prologue-generated t))
3910 ;; If external functions are necessary, generate prologues for them.
3912 (cond ((and (eq (car the-list) 'composition)
3913 (not ps-mule-cmpchar-prologue-generated))
3914 (ps-output-prologue ps-mule-cmpchar-prologue)
3915 (setq ps-mule-cmpchar-prologue-generated t))
3916 ((setq font-spec (ps-mule-get-font-spec (car the-list) 'normal))
3917 (ps-mule-init-external-library font-spec)))
3918 (setq the-list (cdr the-list)))))
3920 ;; If ASCII font is also specified in ps-mule-font-info-database,
3921 ;; use it istead of what specified in ps-font-info-database.
3922 (let ((font-spec (ps-mule-get-font-spec 'ascii 'normal)))
3925 (unless ps-mule-prologue-generated
3926 (ps-output-prologue ps-mule-prologue)
3927 (setq ps-mule-prologue-generated t))
3928 (ps-mule-init-external-library font-spec)
3929 (let ((font (ps-font-alist 'ps-font-for-text))
3932 (let ((ps-current-font i))
3933 ;; Be sure to download a glyph for SPACE in advance.
3934 (ps-mule-prepare-font
3935 (ps-mule-get-font-spec 'ascii (car font))
3936 " " 'ascii 'no-setfont))
3937 (setq font (cdr font)
3940 ;; For handling multi-byte characters -- End.
3941 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3944 (defun ps-line-lengths-internal ()
3945 "Display the correspondence between a line length and a font size,
3946 using the current ps-print setup.
3947 Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"
3948 (let ((buf (get-buffer-create "*Line-lengths*"))
3949 (ifs ps-font-size) ; initial font size
3950 (icw (ps-avg-char-width 'ps-font-for-text)) ; initial character width
3951 (print-width (progn (ps-get-page-dimensions)
3953 (ps-setup (ps-setup)) ; setup for the current buffer
3954 (fs-min 5) ; minimum font size
3955 cw-min ; minimum character width
3956 nb-cpl-max ; maximum nb of characters per line
3957 (fs-max 14) ; maximum font size
3958 cw-max ; maximum character width
3959 nb-cpl-min ; minimum nb of characters per line
3960 fs ; current font size
3961 cw ; current character width
3962 nb-cpl ; current nb of characters per line
3964 (setq cw-min (/ (* icw fs-min) ifs)
3965 nb-cpl-max (floor (/ print-width cw-min))
3966 cw-max (/ (* icw fs-max) ifs)
3967 nb-cpl-min (floor (/ print-width cw-max))
3970 (goto-char (point-max))
3971 (or (bolp) (insert "\n"))
3973 "nb char per line / font size\n")
3974 (while (<= nb-cpl nb-cpl-max)
3975 (setq cw (/ print-width (float nb-cpl))
3976 fs (/ (* ifs cw) icw))
3977 (insert (format "%3s %s\n" nb-cpl fs))
3978 (setq nb-cpl (1+ nb-cpl)))
3980 (display-buffer buf 'not-this-window)))
3982 (defun ps-nb-pages (nb-lines)
3983 "Display correspondence between font size and the number of pages.
3984 The correspondence is based on having NB-LINES lines of text,
3985 and on the current ps-print setup."
3986 (let ((buf (get-buffer-create "*Nb-Pages*"))
3987 (ifs ps-font-size) ; initial font size
3988 (ilh (ps-line-height 'ps-font-for-text)) ; initial line height
3989 (page-height (progn (ps-get-page-dimensions)
3991 (ps-setup (ps-setup)) ; setup for the current buffer
3992 (fs-min 4) ; minimum font size
3993 lh-min ; minimum line height
3994 nb-lpp-max ; maximum nb of lines per page
3995 nb-page-min ; minimum nb of pages
3996 (fs-max 14) ; maximum font size
3997 lh-max ; maximum line height
3998 nb-lpp-min ; minimum nb of lines per page
3999 nb-page-max ; maximum nb of pages
4000 fs ; current font size
4001 lh ; current line height
4002 nb-lpp ; current nb of lines per page
4003 nb-page ; current nb of pages
4005 (setq lh-min (/ (* ilh fs-min) ifs)
4006 nb-lpp-max (floor (/ page-height lh-min))
4007 nb-page-min (ceiling (/ (float nb-lines) nb-lpp-max))
4008 lh-max (/ (* ilh fs-max) ifs)
4009 nb-lpp-min (floor (/ page-height lh-max))
4010 nb-page-max (ceiling (/ (float nb-lines) nb-lpp-min))
4011 nb-page nb-page-min)
4013 (goto-char (point-max))
4014 (or (bolp) (insert "\n"))
4016 (format "%d lines\n" nb-lines)
4017 "nb page / font size\n")
4018 (while (<= nb-page nb-page-max)
4019 (setq nb-lpp (ceiling (/ nb-lines (float nb-page)))
4020 lh (/ page-height nb-lpp)
4021 fs (/ (* ifs lh) ilh))
4022 (insert (format "%s %s\n" nb-page fs))
4023 (setq nb-page (1+ nb-page)))
4025 (display-buffer buf 'not-this-window)))
4027 ;; macros used in `ps-select-font'
4028 (defmacro ps-lookup (key) `(cdr (assq ,key font-entry)))
4029 (defmacro ps-size-scale (key) `(/ (* (ps-lookup ,key) font-size) size))
4031 (defun ps-select-font (font-family sym font-size title-font-size)
4032 (let ((font-entry (cdr (assq font-family ps-font-info-database))))
4034 (error "Don't have data to scale font %s. Known fonts families are %s"
4036 (mapcar 'car ps-font-info-database)))
4037 (let ((size (ps-lookup 'size)))
4038 (put sym 'fonts (ps-lookup 'fonts))
4039 (put sym 'space-width (ps-size-scale 'space-width))
4040 (put sym 'avg-char-width (ps-size-scale 'avg-char-width))
4041 (put sym 'line-height (ps-size-scale 'line-height))
4042 (put sym 'title-line-height
4043 (/ (* (ps-lookup 'line-height) title-font-size) size)))))
4045 (defun ps-get-page-dimensions ()
4046 (let ((page-dimensions (cdr (assq ps-paper-type ps-page-dimensions-database)))
4047 page-width page-height)
4049 ((null page-dimensions)
4050 (error "`ps-paper-type' must be one of:\n%s"
4051 (mapcar 'car ps-page-dimensions-database)))
4052 ((< ps-number-of-columns 1)
4053 (error "The number of columns %d should be positive"
4054 ps-number-of-columns)))
4056 (ps-select-font ps-font-family 'ps-font-for-text
4057 ps-font-size ps-font-size)
4058 (ps-select-font ps-header-font-family 'ps-font-for-header
4059 ps-header-font-size ps-header-title-font-size)
4061 (setq page-width (ps-page-dimensions-get-width page-dimensions)
4062 page-height (ps-page-dimensions-get-height page-dimensions))
4065 (if ps-landscape-mode
4066 ;; exchange width and height
4067 (setq page-width (prog1 page-height (setq page-height page-width))))
4069 ;; It is used to get the lower right corner (only in landscape mode)
4070 (setq ps-landscape-page-height page-height)
4072 ;; | lm | text | ic | text | ic | text | rm |
4073 ;; page-width == lm + n * pw + (n - 1) * ic + rm
4074 ;; => pw == (page-width - lm -rm - (n - 1) * ic) / n
4075 (setq ps-print-width (/ (- page-width
4076 ps-left-margin ps-right-margin
4077 (* (1- ps-number-of-columns) ps-inter-column))
4078 ps-number-of-columns))
4079 (if (<= ps-print-width 0)
4080 (error "Bad horizontal layout:
4082 ps-left-margin == %s
4083 ps-right-margin == %s
4084 ps-inter-column == %s
4085 ps-number-of-columns == %s
4086 | lm | text | ic | text | ic | text | rm |
4087 page-width == lm + n * print-width + (n - 1) * ic + rm
4088 => print-width == %d !"
4093 ps-number-of-columns
4096 (setq ps-print-height
4097 (- page-height ps-bottom-margin ps-top-margin))
4098 (if (<= ps-print-height 0)
4099 (error "Bad vertical layout:
4101 ps-bottom-margin == %s
4102 page-height == bm + print-height + tm
4103 => print-height == %d !"
4107 ;; If headers are turned on, deduct the height of the header from
4108 ;; the print height.
4110 (setq ps-header-pad (* ps-header-line-pad
4111 (ps-title-line-height 'ps-font-for-header))
4112 ps-print-height (- ps-print-height
4115 (ps-title-line-height 'ps-font-for-header)
4116 (* (ps-line-height 'ps-font-for-header)
4117 (1- ps-header-lines))
4119 (if (<= ps-print-height 0)
4120 (error "Bad vertical layout:
4122 ps-bottom-margin == %s
4123 ps-header-offset == %s
4126 page-height == bm + print-height + tm - ho - hh
4127 => print-height == %d !"
4133 (ps-title-line-height 'ps-font-for-header)
4134 (* (ps-line-height 'ps-font-for-header)
4135 (1- ps-header-lines))
4139 (defun ps-print-preprint (&optional filename)
4141 (or (numberp filename)
4143 (let* ((name (concat (file-name-nondirectory (or (buffer-file-name)
4146 (prompt (format "Save PostScript to file: (default %s) " name))
4147 (res (read-file-name prompt default-directory name nil)))
4148 (while (cond ((not (file-writable-p res))
4150 (setq prompt "is unwritable"))
4151 ((file-exists-p res)
4152 (setq prompt "exists")
4153 (not (y-or-n-p (format "File `%s' exists; overwrite? "
4156 (setq res (read-file-name
4157 (format "File %s; save PostScript to file: " prompt)
4158 (file-name-directory res) nil nil
4159 (file-name-nondirectory res))))
4160 (if (file-directory-p res)
4161 (expand-file-name name (file-name-as-directory res))
4164 ;; The following functions implement a simple list-buffering scheme so
4165 ;; that ps-print doesn't have to repeatedly switch between buffers
4166 ;; while spooling. The functions `ps-output' and `ps-output-string' build
4167 ;; up the lists; the function `ps-flush-output' takes the lists and
4168 ;; insert its contents into the spool buffer (*PostScript*).
4170 (defvar ps-string-escape-codes
4171 (let ((table (make-vector 256 nil))
4173 ;; control characters
4174 (while (<= char ?\037)
4175 (aset table char (format "\\%03o" char))
4176 (setq char (1+ char)))
4177 ;; printable characters
4178 (while (< char ?\177)
4179 (aset table char (format "%c" char))
4180 (setq char (1+ char)))
4181 ;; DEL and 8-bit characters
4182 (while (<= char ?\377)
4183 (aset table char (format "\\%o" char))
4184 (setq char (1+ char)))
4185 ;; Override ASCII formatting characters with named escape code:
4186 (aset table ?\n "\\n") ; [NL] linefeed
4187 (aset table ?\r "\\r") ; [CR] carriage return
4188 (aset table ?\t "\\t") ; [HT] horizontal tab
4189 (aset table ?\b "\\b") ; [BS] backspace
4190 (aset table ?\f "\\f") ; [NP] form feed
4191 ;; Escape PostScript escape and string delimiter characters:
4192 (aset table ?\\ "\\\\")
4193 (aset table ?\( "\\(")
4194 (aset table ?\) "\\)")
4196 "Vector used to map characters to PostScript string escape codes.")
4198 (defun ps-output-string-prim (string)
4199 (insert "(") ;insert start-string delimiter
4200 (save-excursion ;insert string
4201 (insert (string-as-unibyte string)))
4202 ;; Find and quote special characters as necessary for PS
4203 ;; This skips everything except control chars, non-ASCII chars, (, ) and \.
4204 (while (progn (skip-chars-forward " -'*-[]-~") (not (eobp)))
4205 (let ((special (following-char)))
4207 (insert (aref ps-string-escape-codes special))))
4208 (goto-char (point-max))
4209 (insert ")")) ;insert end-string delimiter
4211 (defun ps-init-output-queue ()
4212 (setq ps-output-head '("")
4213 ps-output-tail ps-output-head))
4215 (defun ps-output (&rest args)
4216 (setcdr ps-output-tail args)
4217 (while (cdr ps-output-tail)
4218 (setq ps-output-tail (cdr ps-output-tail))))
4220 (defun ps-output-string (string)
4221 (ps-output t string))
4223 (defun ps-output-list (the-list)
4224 (mapcar 'ps-output the-list))
4226 ;; Output strings in the list ARGS in the PostScript prologue part.
4227 (defun ps-output-prologue (args)
4228 (ps-output 'prologue (if (stringp args) (list args) args)))
4230 (defun ps-flush-output ()
4232 (set-buffer ps-spool-buffer)
4233 (goto-char (point-max))
4234 (while ps-output-head
4235 (let ((it (car ps-output-head)))
4238 (setq ps-output-head (cdr ps-output-head))
4239 (ps-output-string-prim (car ps-output-head)))
4241 (setq ps-output-head (cdr ps-output-head))
4243 (search-backward "\nBeginDoc")
4245 (apply 'insert (car ps-output-head))))
4248 (setq ps-output-head (cdr ps-output-head))))
4249 (ps-init-output-queue))
4251 (defun ps-insert-file (fname)
4253 ;; Check to see that the file exists and is readable; if not, throw
4255 (or (file-readable-p fname)
4256 (error "Could not read file `%s'" fname))
4258 (set-buffer ps-spool-buffer)
4259 (goto-char (point-max))
4260 (insert-file fname)))
4262 ;; These functions insert the arrays that define the contents of the
4265 (defun ps-generate-header-line (fonttag &optional content)
4266 (ps-output " [ " fonttag " ")
4268 ;; Literal strings should be output as is -- the string must
4269 ;; contain its own PS string delimiters, '(' and ')', if necessary.
4271 (ps-output content))
4273 ;; Functions are called -- they should return strings; they will be
4274 ;; inserted as strings and the PS string delimiters added.
4275 ((and (symbolp content) (fboundp content))
4276 (ps-output-string (funcall content)))
4278 ;; Variables will have their contents inserted. They should
4279 ;; contain strings, and will be inserted as strings.
4280 ((and (symbolp content) (boundp content))
4281 (ps-output-string (symbol-value content)))
4283 ;; Anything else will get turned into an empty string.
4285 (ps-output-string "")))
4288 (defun ps-generate-header (name contents)
4289 (ps-output "/" name " [\n")
4290 (if (> ps-header-lines 0)
4292 (ps-generate-header-line "/h0" (car contents))
4293 (while (and (< count ps-header-lines)
4294 (setq contents (cdr contents)))
4295 (ps-generate-header-line "/h1" (car contents))
4296 (setq count (1+ count)))
4297 (ps-output "] def\n"))))
4299 (defun ps-output-boolean (name bool)
4300 (ps-output (format "/%s %s def\n" name (if bool "true" "false"))))
4303 (defun ps-background-pages (page-list func)
4307 (let ((start (if (consp pages) (car pages) pages))
4308 (end (if (consp pages) (cdr pages) pages)))
4309 (and (integerp start) (integerp end) (<= start end)
4310 (add-to-list 'ps-background-pages (vector start end func)))))
4312 (setq ps-background-all-pages (cons func ps-background-all-pages))))
4315 (defun ps-get-boundingbox ()
4317 (set-buffer ps-spool-buffer)
4319 (if (re-search-forward
4320 "^%%BoundingBox:\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)"
4322 (vector (string-to-number ; lower x
4323 (buffer-substring (match-beginning 1) (match-end 1)))
4324 (string-to-number ; lower y
4325 (buffer-substring (match-beginning 2) (match-end 2)))
4326 (string-to-number ; upper x
4327 (buffer-substring (match-beginning 3) (match-end 3)))
4328 (string-to-number ; upper y
4329 (buffer-substring (match-beginning 4) (match-end 4))))
4330 (vector 0 0 0 0)))))
4333 ;; Emacs understands the %f format; we'll use it to limit color RGB values
4334 ;; to three decimals to cut down some on the size of the PostScript output.
4335 ;; Lucid emacsen will have to make do with %s (princ) for floats.
4337 (defvar ps-float-format (if (eq ps-print-emacs-type 'emacs)
4339 "%s ")) ; Lucid emacsen
4342 (defun ps-float-format (value &optional default)
4343 (let ((literal (or value default)))
4345 (format (if (numberp literal)
4352 (defun ps-background-text ()
4355 (setq ps-background-text-count (1+ ps-background-text-count))
4356 (ps-output (format "/ShowBackText-%d {\n" ps-background-text-count))
4357 (ps-output-string (nth 0 text)) ; text
4360 (ps-float-format (nth 4 text) 200.0) ; font size
4361 (format "/%s " (or (nth 3 text) "Times-Roman")) ; font name
4362 (ps-float-format (nth 6 text)
4363 "PrintHeight PrintPageWidth atan") ; rotation
4364 (ps-float-format (nth 5 text) 0.85) ; gray
4365 (ps-float-format (nth 1 text) "0") ; x position
4366 (ps-float-format (nth 2 text) "BottomMargin") ; y position
4367 "\nShowBackText} def\n")
4368 (ps-background-pages (nthcdr 7 text) ; page list
4369 (format "ShowBackText-%d\n"
4370 ps-background-text-count)))
4371 ps-print-background-text))
4374 (defun ps-background-image ()
4377 (let ((image-file (expand-file-name (nth 0 image))))
4378 (if (file-readable-p image-file)
4380 (setq ps-background-image-count (1+ ps-background-image-count))
4382 (format "/ShowBackImage-%d {\n--back-- " ps-background-image-count)
4383 (ps-float-format (nth 5 image) 0.0) ; rotation
4384 (ps-float-format (nth 3 image) 1.0) ; x scale
4385 (ps-float-format (nth 4 image) 1.0) ; y scale
4386 (ps-float-format (nth 1 image) ; x position
4387 "PrintPageWidth 2 div")
4388 (ps-float-format (nth 2 image) ; y position
4389 "PrintHeight 2 div BottomMargin add")
4390 "\nBeginBackImage\n")
4391 (ps-insert-file image-file)
4392 ;; coordinate adjustment to centralize image
4393 ;; around x and y position
4394 (let ((box (ps-get-boundingbox)))
4396 (set-buffer ps-spool-buffer)
4398 (if (re-search-backward "^--back--" nil t)
4402 (- (+ (/ (- (aref box 2) (aref box 0)) 2.0)
4405 (- (+ (/ (- (aref box 3) (aref box 1)) 2.0)
4408 (ps-output "\nEndBackImage} def\n")
4409 (ps-background-pages (nthcdr 6 image) ; page list
4410 (format "ShowBackImage-%d\n"
4411 ps-background-image-count))))))
4412 ps-print-background-image))
4415 (defun ps-background (page-number)
4416 (let (has-local-background)
4417 (mapcar '(lambda (range)
4418 (and (<= (aref range 0) page-number)
4419 (<= page-number (aref range 1))
4420 (if has-local-background
4421 (ps-output (aref range 2))
4422 (setq has-local-background t)
4423 (ps-output "/printLocalBackground {\n"
4425 ps-background-pages)
4426 (and has-local-background (ps-output "} def\n"))))
4429 ;; Return a list of the distinct elements of LIST.
4430 ;; Elements are compared with `equal'.
4431 (defun ps-remove-duplicates (list)
4432 (let (new (tail list))
4434 (or (member (car tail) new)
4435 (setq new (cons (car tail) new)))
4436 (setq tail (cdr tail)))
4440 ;; Find the first occurrence of ITEM in LIST.
4441 ;; Return the index of the matching item, or nil if not found.
4442 ;; Elements are compared with `eq'.
4443 (defun ps-alist-position (item list)
4444 (let ((tail list) (index 0) found)
4446 (if (setq found (eq (car (car tail)) item))
4448 (setq index (1+ index)
4453 (defun ps-begin-file ()
4454 (ps-get-page-dimensions)
4455 (setq ps-page-postscript 0
4456 ps-background-text-count 0
4457 ps-background-image-count 0
4458 ps-background-pages nil
4459 ps-background-all-pages nil)
4461 (ps-output ps-adobe-tag
4462 "%%Title: " (buffer-name) ; Take job name from name of
4463 ; first buffer printed
4464 "\n%%Creator: " (user-full-name)
4465 " (using ps-print v" ps-print-version
4466 ")\n%%CreationDate: "
4467 (time-stamp-hh:mm:ss) " " (time-stamp-mon-dd-yyyy)
4469 (if ps-landscape-mode "Landscape" "Portrait")
4470 "\n%%DocumentNeededResources: font Times-Roman Times-Italic\n%%+ font "
4471 (mapconcat 'identity
4472 (ps-remove-duplicates
4473 (append (ps-fonts 'ps-font-for-text)
4474 (list (ps-font 'ps-font-for-header 'normal)
4475 (ps-font 'ps-font-for-header 'bold))))
4477 "\n%%Pages: (atend)\n%%Requirements:"
4478 (if ps-spool-duplex " duplex\n" "\n"))
4480 (let ((comments (if (functionp ps-print-prologue-header)
4481 (funcall ps-print-prologue-header)
4482 ps-print-prologue-header)))
4483 (and (stringp comments)
4484 (ps-output comments)))
4486 (ps-output "%%EndComments\n\n%%BeginPrologue\n\n")
4488 (ps-output-boolean "LandscapeMode" ps-landscape-mode)
4489 (ps-output (format "/NumberOfColumns %d def\n" ps-number-of-columns)
4491 (format "/LandscapePageHeight %s def\n" ps-landscape-page-height)
4492 (format "/PrintPageWidth %s def\n"
4493 (- (* (+ ps-print-width ps-inter-column)
4494 ps-number-of-columns)
4496 (format "/PrintWidth %s def\n" ps-print-width)
4497 (format "/PrintHeight %s def\n" ps-print-height)
4499 (format "/LeftMargin %s def\n" ps-left-margin)
4500 (format "/RightMargin %s def\n" ps-right-margin) ; not used
4501 (format "/InterColumn %s def\n" ps-inter-column)
4503 (format "/BottomMargin %s def\n" ps-bottom-margin)
4504 (format "/TopMargin %s def\n" ps-top-margin) ; not used
4505 (format "/HeaderOffset %s def\n" ps-header-offset)
4506 (format "/HeaderPad %s def\n" ps-header-pad))
4508 (ps-output-boolean "PrintHeader" ps-print-header)
4509 (ps-output-boolean "PrintOnlyOneHeader" ps-print-only-one-header)
4510 (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame)
4511 (ps-output-boolean "ShowNofN" ps-show-n-of-n)
4512 (ps-output-boolean "Duplex" ps-spool-duplex)
4514 (let ((line-height (ps-line-height 'ps-font-for-text)))
4515 (ps-output (format "/LineHeight %s def\n" line-height)
4516 (format "/LinesPerColumn %d def\n"
4517 (round (/ (+ ps-print-height
4518 (* line-height 0.45))
4521 (ps-output-boolean "Zebra" ps-zebra-stripes)
4522 (ps-output-boolean "PrintLineNumber" ps-line-number)
4523 (ps-output (format "/ZebraHeight %d def\n" ps-zebra-stripe-height))
4525 (ps-background-text)
4526 (ps-background-image)
4527 (setq ps-background-all-pages (nreverse ps-background-all-pages)
4528 ps-background-pages (nreverse ps-background-pages))
4530 (ps-output ps-print-prologue-1)
4532 (ps-output "/printGlobalBackground {\n")
4533 (ps-output-list ps-background-all-pages)
4534 (ps-output "} def\n/printLocalBackground {\n} def\n")
4537 (ps-output (format "/h0 %s (%s) cvn DefFont\n" ; /h0 14 /Helvetica-Bold DefFont
4538 ps-header-title-font-size (ps-font 'ps-font-for-header
4540 (format "/h1 %s (%s) cvn DefFont\n" ; /h1 12 /Helvetica DefFont
4541 ps-header-font-size (ps-font 'ps-font-for-header
4544 (ps-output ps-print-prologue-2)
4547 (let ((font (ps-font-alist 'ps-font-for-text))
4550 (ps-output (format "/f%d %s (%s) cvn DefFont\n"
4553 (ps-font 'ps-font-for-text (car (car font)))))
4554 (setq font (cdr font)
4557 (let ((font-entry (cdr (assq ps-font-family ps-font-info-database))))
4558 (ps-output (format "/SpaceWidthRatio %f def\n"
4559 (/ (ps-lookup 'space-width) (ps-lookup 'size)))))
4561 (ps-mule-initialize)
4563 (ps-output "%%EndPrologue\n%%BeginSetup\nBeginDoc\n%%EndSetup\n\n"))
4565 (defun ps-header-dirpart ()
4566 (let ((fname (buffer-file-name)))
4568 (if (string-equal (buffer-name) (file-name-nondirectory fname))
4569 (file-name-directory fname)
4573 (defun ps-get-buffer-name ()
4575 ;; Indulge Jim this little easter egg:
4576 ((string= (buffer-name) "ps-print.el")
4577 "Hey, Cool! It's ps-print.el!!!")
4578 ;; Indulge Jack this other little easter egg:
4579 ((string= (buffer-name) "sokoban.el")
4580 "Super! C'est sokoban.el!")
4582 (and ps-printing-region "Subset of: ")
4584 (and (buffer-modified-p) " (unsaved)")))))
4586 (defun ps-begin-job ()
4588 (set-buffer ps-spool-buffer)
4589 (goto-char (point-max))
4590 (and (re-search-backward "^%%Trailer$" nil t)
4591 (delete-region (match-beginning 0) (point-max))))
4592 (setq ps-showline-count (if ps-printing-region (car ps-printing-region) 1)
4594 ps-control-or-escape-regexp
4595 (if ps-mule-charset-list
4596 (cond ((eq ps-print-control-characters '8-bit)
4598 ((eq ps-print-control-characters 'control-8-bit)
4599 (string-as-multibyte "[^\040-\176\240-\377]"))
4600 ((eq ps-print-control-characters 'control)
4601 (string-as-multibyte "[^\040-\176\200-\377]"))
4602 (t (string-as-multibyte "[^\000-\011\013\015-\377")))
4603 (cond ((eq ps-print-control-characters '8-bit)
4604 (string-as-unibyte "[\000-\037\177-\377]"))
4605 ((eq ps-print-control-characters 'control-8-bit)
4606 (string-as-unibyte "[\000-\037\177-\237]"))
4607 ((eq ps-print-control-characters 'control)
4611 (defmacro ps-page-number ()
4612 `(1+ (/ (1- ps-page-count) ps-number-of-columns)))
4614 (defun ps-end-file ()
4615 (ps-output "\n%%Trailer\n%%Pages: "
4616 (format "%d" ps-page-postscript)
4617 "\n\nEndDoc\n\n%%EOF\n"))
4620 (defun ps-next-page ()
4625 (defun ps-header-page ()
4626 ;; set total line and page number when printing has finished
4627 ;; (see `ps-generate')
4629 (zerop (mod ps-page-count ps-number-of-columns))
4630 (setq ps-page-count (1+ ps-page-count)))
4631 ;; Print only when a new real page begins.
4633 (setq ps-page-postscript (1+ ps-page-postscript))
4634 (ps-output (format "\n%%%%Page: %d %d\n"
4635 ps-page-postscript ps-page-postscript))
4636 (ps-output "/Lines 0 def\n/PageCount 0 def\nBeginDSCPage\n")
4637 (ps-background ps-page-postscript)
4638 (run-hooks 'ps-print-begin-page-hook))
4639 ;; Print when any other page begins.
4640 (ps-output "/Lines 0 def\n/PageCount 0 def\nBeginDSCPage\n")
4641 (run-hooks 'ps-print-begin-column-hook)))
4643 (defun ps-begin-page ()
4644 (ps-get-page-dimensions)
4645 (setq ps-width-remaining ps-print-width
4646 ps-height-remaining ps-print-height
4647 ps-mule-current-charset 'ascii)
4651 (ps-output (format "/LineNumber %d def\n" ps-showline-count)
4652 (format "/PageNumber %d def\n" (if ps-print-only-one-header
4656 (when ps-print-header
4657 (ps-generate-header "HeaderLinesLeft" ps-left-header)
4658 (ps-generate-header "HeaderLinesRight" ps-right-header)
4659 (ps-output (format "%d SetHeaderLines\n" ps-header-lines)))
4661 (ps-output "BeginPage\n")
4662 (ps-set-font ps-current-font)
4663 (ps-set-bg ps-current-bg)
4664 (ps-set-color ps-current-color))
4666 (defun ps-end-page ()
4667 (ps-output "EndPage\nEndDSCPage\n"))
4669 (defun ps-dummy-page ()
4671 (ps-output "/PrintHeader false def
4676 (defun ps-next-line ()
4677 (setq ps-showline-count (1+ ps-showline-count))
4678 (let ((lh (ps-line-height 'ps-font-for-text)))
4679 (if (< ps-height-remaining lh)
4681 (setq ps-width-remaining ps-print-width
4682 ps-height-remaining (- ps-height-remaining lh))
4683 (ps-output "HL\n"))))
4685 (defun ps-continue-line ()
4686 (let ((lh (ps-line-height 'ps-font-for-text)))
4687 (if (< ps-height-remaining lh)
4689 (setq ps-width-remaining ps-print-width
4690 ps-height-remaining (- ps-height-remaining lh))
4691 (ps-output "SL\n"))))
4693 (defun ps-find-wrappoint (from to char-width)
4694 (let ((avail (truncate (/ ps-width-remaining char-width)))
4697 (cons to (* todo char-width))
4698 (cons (+ from avail) ps-width-remaining))))
4700 (defun ps-basic-plot-string (from to &optional bg-color)
4701 (let* ((wrappoint (ps-find-wrappoint from to
4702 (ps-avg-char-width 'ps-font-for-text)))
4703 (to (car wrappoint))
4704 (string (buffer-substring-no-properties from to))
4706 (ps-mule-get-font-spec
4708 (car (nth ps-current-font (ps-font-alist 'ps-font-for-text))))))
4710 (ps-mule-prepare-font font-spec string 'ascii))
4711 (ps-output-string string)
4715 (defun ps-basic-plot-whitespace (from to &optional bg-color)
4716 (let* ((wrappoint (ps-find-wrappoint from to
4717 (ps-space-width 'ps-font-for-text)))
4718 (to (car wrappoint)))
4719 (ps-output (format "%d W\n" (- to from)))
4722 (defun ps-plot (plotfunc from to &optional bg-color)
4724 (let* ((wrappoint (funcall plotfunc from to bg-color))
4725 (plotted-to (car wrappoint))
4726 (plotted-width (cdr wrappoint)))
4727 (setq from plotted-to
4728 ps-width-remaining (- ps-width-remaining plotted-width))
4730 (ps-continue-line))))
4731 (if ps-razzle-dazzle
4732 (let* ((q-todo (- (point-max) (point-min)))
4733 (q-done (- (point) (point-min)))
4734 (chunkfrac (/ q-todo 8))
4735 (chunksize (min chunkfrac 1000)))
4736 (if (> (- q-done ps-razchunk) chunksize)
4738 (setq ps-razchunk q-done)
4739 (message "Formatting...%3d%%"
4741 (/ (* 100 q-done) q-todo)
4742 (/ q-done (/ q-todo 100)))
4745 (defun ps-set-font (font)
4746 (setq ps-last-font (format "f%d" (setq ps-current-font font)))
4747 (ps-output (format "/%s F\n" ps-last-font)))
4749 (defun ps-set-bg (color)
4750 (if (setq ps-current-bg color)
4751 (ps-output (format ps-color-format
4752 (nth 0 color) (nth 1 color) (nth 2 color))
4754 (ps-output "false BG\n")))
4756 (defun ps-set-color (color)
4757 (setq ps-current-color (or color ps-default-fg))
4758 (ps-output (format ps-color-format
4759 (nth 0 ps-current-color)
4760 (nth 1 ps-current-color) (nth 2 ps-current-color))
4764 (defvar ps-current-effect 0)
4767 (defun ps-plot-region (from to font &optional fg-color bg-color effects)
4768 (if (not (equal font ps-current-font))
4771 ;; Specify a foreground color only if one's specified and it's
4772 ;; different than the current.
4773 (if (not (equal fg-color ps-current-color))
4774 (ps-set-color fg-color))
4776 (if (not (equal bg-color ps-current-bg))
4777 (ps-set-bg bg-color))
4779 ;; Specify effects (underline, overline, box, etc)
4781 ((not (integerp effects))
4782 (ps-output "0 EF\n")
4783 (setq ps-current-effect 0))
4784 ((/= effects ps-current-effect)
4785 (ps-output (number-to-string effects) " EF\n")
4786 (setq ps-current-effect effects)))
4788 (setq ps-mule-current-charset 'ascii)
4790 ;; Starting at the beginning of the specified region...
4794 ;; ...break the region up into chunks separated by tabs, linefeeds,
4795 ;; pagefeeds, control characters, and plot each chunk.
4797 (if (re-search-forward ps-control-or-escape-regexp to t)
4798 ;; region with some control characters or some multi-byte characters
4799 (let* ((match-point (match-beginning 0))
4800 (match (char-after match-point)))
4801 (when (< from match-point)
4802 (unless (eq ps-mule-current-charset 'ascii)
4803 (ps-set-font ps-current-font)
4804 (setq ps-mule-current-charset 'ascii))
4805 (ps-plot 'ps-basic-plot-string from match-point bg-color))
4807 ((= match ?\t) ; tab
4808 (let ((linestart (line-beginning-position)))
4810 (setq from (+ linestart (current-column)))
4811 (when (re-search-forward "[ \t]+" to t)
4812 (unless (eq ps-mule-current-charset 'ascii)
4813 (ps-set-font ps-current-font)
4814 (setq ps-mule-current-charset 'ascii))
4815 (ps-plot 'ps-basic-plot-whitespace
4816 from (+ linestart (current-column))
4819 ((= match ?\n) ; newline
4822 ((= match ?\f) ; form feed
4823 ;; do not skip page if previous character is NEWLINE and
4824 ;; it is a beginning of page.
4825 (or (and (= (char-after (1- match-point)) ?\n)
4826 (= ps-height-remaining ps-print-height))
4829 ((> match 255) ; a multi-byte character
4830 (let ((charset (char-charset match)))
4831 (or (eq charset 'composition)
4832 (ps-mule-skip-same-charset charset))
4833 (setq ps-mule-current-charset charset)
4834 (ps-plot 'ps-mule-plot-string match-point (point) bg-color)))
4835 ; characters from ^@ to ^_ and
4836 (t ; characters from 127 to 255
4837 (ps-control-character match)))
4838 (setq from (point)))
4839 ;; region without control characters nor multi-byte characters
4840 (when (not (eq ps-mule-current-charset 'ascii))
4841 (ps-set-font ps-current-font)
4842 (setq ps-mule-current-charset 'ascii))
4843 (ps-plot 'ps-basic-plot-string from to bg-color)
4846 (defvar ps-string-control-codes
4847 (let ((table (make-vector 256 nil))
4849 ;; control character
4850 (while (<= char ?\037)
4851 (aset table char (format "^%c" (+ char ?@)))
4852 (setq char (1+ char)))
4853 ;; printable character
4854 (while (< char ?\177)
4855 (aset table char (format "%c" char))
4856 (setq char (1+ char)))
4858 (aset table char "^?")
4860 (while (<= (setq char (1+ char)) ?\377)
4861 (aset table char (format "\\%o" char)))
4863 "Vector used to map characters to a printable string.")
4865 (defun ps-control-character (char)
4866 (let* ((str (aref ps-string-control-codes char))
4870 (char-width (ps-avg-char-width 'ps-font-for-text))
4871 (wrappoint (ps-find-wrappoint from to char-width)))
4872 (if (< (car wrappoint) to)
4874 (setq ps-width-remaining (- ps-width-remaining (* len char-width)))
4875 (ps-output-string str)
4876 (ps-output " S\n")))
4878 (defun ps-color-value (x-color-value)
4879 ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
4880 (/ x-color-value ps-print-color-scale))
4883 (cond ((eq ps-print-emacs-type 'emacs) ; emacs
4885 (defun ps-color-values (x-color)
4886 (if (fboundp 'x-color-values)
4887 (x-color-values x-color)
4888 (error "No available function to determine X color values.")))
4893 (defun ps-color-values (x-color)
4894 (cond ((fboundp 'x-color-values)
4895 (x-color-values x-color))
4896 ((and (fboundp 'color-instance-rgb-components)
4898 (color-instance-rgb-components
4899 (if (color-instance-p x-color)
4901 (make-color-instance
4902 (if (color-specifier-p x-color)
4903 (color-name x-color)
4905 (t (error "No available function to determine X color values."))))
4909 (defun ps-face-attributes (face)
4910 "Return face attribute vector.
4912 If FACE is not in `ps-print-face-extension-alist' or in
4913 `ps-print-face-alist', insert it on `ps-print-face-alist' and
4914 return the attribute vector.
4916 If FACE is not a valid face name, it is used default face."
4917 (cdr (or (assq face ps-print-face-extension-alist)
4918 (assq face ps-print-face-alist)
4919 (let* ((the-face (if (facep face) face 'default))
4920 (new-face (ps-screen-to-bit-face the-face)))
4921 (or (and (eq the-face 'default)
4922 (assq the-face ps-print-face-alist))
4923 (setq ps-print-face-alist (cons new-face ps-print-face-alist)))
4927 (defun ps-face-attribute-list (face-or-list)
4928 (if (listp face-or-list)
4931 foreground background face-attr)
4933 (setq face-attr (ps-face-attributes (car face-or-list))
4934 effects (logior effects (aref face-attr 0)))
4935 (or foreground (setq foreground (aref face-attr 1)))
4936 (or background (setq background (aref face-attr 2)))
4937 (setq face-or-list (cdr face-or-list)))
4938 (vector effects foreground background))
4940 (ps-face-attributes face-or-list)))
4943 (defconst ps-font-type (vector nil 'bold 'italic 'bold-italic))
4946 (defun ps-plot-with-face (from to face)
4948 ((null face) ; print text with null face
4949 (ps-plot-region from to 0))
4950 ((eq face 'emacs--invisible--face)) ; skip invisible text!!!
4951 (t ; otherwise, text has a valid face
4952 (let* ((face-bit (ps-face-attribute-list face))
4953 (effect (aref face-bit 0))
4954 (foreground (aref face-bit 1))
4955 (background (aref face-bit 2))
4956 (fg-color (if (and ps-color-p foreground)
4957 (mapcar 'ps-color-value
4958 (ps-color-values foreground))
4960 (bg-color (and ps-color-p background
4961 (mapcar 'ps-color-value
4962 (ps-color-values background)))))
4965 (ps-font-number 'ps-font-for-text
4966 (or (aref ps-font-type (logand effect 3))
4968 fg-color bg-color (lsh effect -2)))))
4972 (cond ((eq ps-print-emacs-type 'emacs) ; emacs
4974 (defun ps-face-bold-p (face)
4975 (or (face-bold-p face)
4976 (memq face ps-bold-faces)))
4978 (defun ps-face-italic-p (face)
4979 (or (face-italic-p face)
4980 (memq face ps-italic-faces)))
4985 (defun ps-xemacs-face-kind-p (face kind kind-regex kind-list)
4986 (let* ((frame-font (or (face-font-instance face)
4987 (face-font-instance 'default)))
4988 (kind-cons (and frame-font
4990 (font-instance-properties frame-font))))
4991 (kind-spec (cdr-safe kind-cons))
4992 (case-fold-search t))
4993 (or (and kind-spec (string-match kind-regex kind-spec))
4994 ;; Kludge-compatible:
4995 (memq face kind-list))))
4997 (defun ps-face-bold-p (face)
4998 (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold"
5001 (defun ps-face-italic-p (face)
5002 (or (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o" ps-italic-faces)
5003 (ps-xemacs-face-kind-p face 'SLANT "i\\|o" ps-italic-faces)))
5007 (defun ps-face-underlined-p (face)
5008 (or (face-underline-p face)
5009 (memq face ps-underlined-faces)))
5012 ;; Ensure that face-list is fbound.
5013 (or (fboundp 'face-list) (defalias 'face-list 'list-faces))
5016 (defun ps-build-reference-face-lists ()
5017 ;; Ensure that face database is updated with faces on
5018 ;; `font-lock-face-attributes' (obsolete stuff)
5019 (ps-font-lock-face-attributes)
5020 ;; Now, rebuild reference face lists
5021 (setq ps-print-face-alist nil)
5022 (if ps-auto-font-detect
5023 (mapcar 'ps-map-face (face-list))
5024 (mapcar 'ps-set-face-bold ps-bold-faces)
5025 (mapcar 'ps-set-face-italic ps-italic-faces)
5026 (mapcar 'ps-set-face-underline ps-underlined-faces))
5027 (setq ps-build-face-reference nil))
5030 (defun ps-set-face-bold (face)
5031 (ps-set-face-attribute face 1))
5033 (defun ps-set-face-italic (face)
5034 (ps-set-face-attribute face 2))
5036 (defun ps-set-face-underline (face)
5037 (ps-set-face-attribute face 4))
5040 (defun ps-set-face-attribute (face effect)
5041 (let ((face-bit (cdr (ps-map-face face))))
5042 (aset face-bit 0 (logior (aref face-bit 0) effect))))
5045 (defun ps-map-face (face)
5046 (let* ((face-map (ps-screen-to-bit-face face))
5047 (ps-face-bit (cdr (assq (car face-map) ps-print-face-alist))))
5049 ;; if face exists, merge both
5050 (let ((face-bit (cdr face-map)))
5051 (aset ps-face-bit 0 (logior (aref ps-face-bit 0) (aref face-bit 0)))
5052 (or (aref ps-face-bit 1) (aset ps-face-bit 1 (aref face-bit 1)))
5053 (or (aref ps-face-bit 2) (aset ps-face-bit 2 (aref face-bit 2))))
5054 ;; if face does not exist, insert it
5055 (setq ps-print-face-alist (cons face-map ps-print-face-alist)))
5059 (defun ps-screen-to-bit-face (face)
5061 (vector (logior (if (ps-face-bold-p face) 1 0) ; bold
5062 (if (ps-face-italic-p face) 2 0) ; italic
5063 (if (ps-face-underlined-p face) 4 0)) ; underline
5064 (face-foreground face)
5065 (face-background face))))
5068 (cond ((not (eq ps-print-emacs-type 'emacs))
5072 (defun ps-mapper (extent list)
5073 (nconc list (list (list (extent-start-position extent) 'push extent)
5074 (list (extent-end-position extent) 'pull extent)))
5077 (defun ps-extent-sorter (a b)
5078 (< (extent-priority a) (extent-priority b)))
5082 (defun ps-print-ensure-fontified (start end)
5083 (and (boundp 'lazy-lock-mode) (symbol-value 'lazy-lock-mode)
5084 (lazy-lock-fontify-region start end)))
5086 (defun ps-generate-postscript-with-faces (from to)
5087 ;; Some initialization...
5088 (setq ps-current-effect 0)
5090 ;; Build the reference lists of faces if necessary.
5091 (if (or ps-always-build-face-reference
5092 ps-build-face-reference)
5094 (message "Collecting face information...")
5095 (ps-build-reference-face-lists)))
5096 ;; Set the color scale. We do it here instead of in the defvar so
5097 ;; that ps-print can be dumped into emacs. This expression can't be
5098 ;; evaluated at dump-time because X isn't initialized.
5099 (setq ps-color-p (and ps-print-color-p (ps-color-device))
5100 ps-print-color-scale (if ps-color-p
5101 (float (car (ps-color-values "white")))
5103 ;; Generate some PostScript.
5105 (narrow-to-region from to)
5106 (ps-print-ensure-fontified from to)
5107 (let ((face 'default)
5110 ((or (eq ps-print-emacs-type 'lucid)
5111 (eq ps-print-emacs-type 'xemacs))
5112 ;; Build the list of extents...
5113 (let ((a (cons 'dummy nil))
5114 record type extent extent-list)
5115 (map-extents 'ps-mapper nil from to a)
5116 (setq a (sort (cdr a) 'car-less-than-car)
5119 ;; Loop through the extents...
5121 (setq record (car a)
5123 position (car record)
5129 extent (car record))
5131 ;; Plot up to this record.
5132 ;; XEmacs 19.12: for some reason, we're getting into a
5133 ;; situation in which some of the records have
5134 ;; positions less than 'from'. Since we've narrowed
5135 ;; the buffer, this'll generate errors. This is a
5136 ;; hack, but don't call ps-plot-with-face unless from >
5138 (and (>= from (point-min)) (<= position (point-max))
5139 (ps-plot-with-face from position face))
5143 (and (extent-face extent)
5144 (setq extent-list (sort (cons extent extent-list)
5145 'ps-extent-sorter))))
5148 (setq extent-list (sort (delq extent extent-list)
5149 'ps-extent-sorter))))
5151 (setq face (if extent-list
5152 (extent-face (car extent-list))
5157 ((eq ps-print-emacs-type 'emacs)
5158 (let ((property-change from)
5159 (overlay-change from)
5160 (save-buffer-invisibility-spec buffer-invisibility-spec)
5161 (buffer-invisibility-spec nil))
5163 (and (< property-change to) ; Don't search for property change
5164 ; unless previous search succeeded.
5165 (setq property-change (next-property-change from nil to)))
5166 (and (< overlay-change to) ; Don't search for overlay change
5167 ; unless previous search succeeded.
5168 (setq overlay-change (min (next-overlay-change from) to)))
5169 (setq position (min property-change overlay-change))
5170 ;; The code below is not quite correct,
5171 ;; because a non-nil overlay invisible property
5172 ;; which is inactive according to the current value
5173 ;; of buffer-invisibility-spec nonetheless overrides
5174 ;; a face text property.
5176 (cond ((let ((prop (get-text-property from 'invisible)))
5177 ;; Decide whether this invisible property
5178 ;; really makes the text invisible.
5179 (if (eq save-buffer-invisibility-spec t)
5181 (or (memq prop save-buffer-invisibility-spec)
5182 (assq prop save-buffer-invisibility-spec))))
5183 'emacs--invisible--face)
5184 ((get-text-property from 'face))
5186 (let ((overlays (overlays-at from))
5187 (face-priority -1)) ; text-property
5188 (while (and overlays
5189 (not (eq face 'emacs--invisible--face)))
5190 (let* ((overlay (car overlays))
5191 (overlay-invisible (overlay-get overlay 'invisible))
5192 (overlay-priority (or (overlay-get overlay 'priority)
5194 (and (> overlay-priority face-priority)
5196 (cond ((if (eq save-buffer-invisibility-spec t)
5197 (not (null overlay-invisible))
5198 (or (memq overlay-invisible
5199 save-buffer-invisibility-spec)
5200 (assq overlay-invisible
5201 save-buffer-invisibility-spec)))
5202 'emacs--invisible--face)
5203 ((overlay-get overlay 'face))
5205 face-priority overlay-priority)))
5206 (setq overlays (cdr overlays))))
5207 ;; Plot up to this record.
5208 (ps-plot-with-face from position face)
5209 (setq from position)))))
5210 (ps-plot-with-face from to face))))
5212 (defun ps-generate-postscript (from to)
5213 (ps-plot-region from to 0 nil))
5215 (defun ps-generate (buffer from to genfunc)
5217 (let ((from (min to from))
5219 ;; This avoids trouble if chars with read-only properties
5220 ;; are copied into ps-spool-buffer.
5221 (inhibit-read-only t))
5223 (narrow-to-region from to)
5224 (and ps-razzle-dazzle
5225 (message "Formatting...%3d%%" (setq ps-razchunk 0)))
5226 (setq ps-source-buffer buffer
5227 ps-spool-buffer (get-buffer-create ps-spool-buffer-name))
5228 (ps-init-output-queue)
5229 (let (safe-marker completed-safely needs-begin-file)
5232 (set-buffer ps-spool-buffer)
5233 (set-buffer-multibyte nil)
5235 ;; Get a marker and make it point to the current end of the
5236 ;; buffer, If an error occurs, we'll delete everything from
5237 ;; the end of this marker onwards.
5238 (setq safe-marker (make-marker))
5239 (set-marker safe-marker (point-max))
5241 (goto-char (point-min))
5242 (or (looking-at (regexp-quote ps-adobe-tag))
5243 (setq needs-begin-file t))
5245 (set-buffer ps-source-buffer)
5246 (and needs-begin-file (ps-begin-file))
5247 (ps-mule-begin from to)
5250 (set-buffer ps-source-buffer)
5251 (funcall genfunc from to)
5254 (and ps-spool-duplex (= (mod ps-page-count 2) 1)
5259 ;; Back to the PS output buffer to set the page count
5260 (let ((total-lines (if ps-printing-region
5261 (cdr ps-printing-region)
5262 (ps-count-lines (point-min) (point-max))))
5263 (total-pages (if ps-print-only-one-header
5266 (set-buffer ps-spool-buffer)
5267 (goto-char (point-min))
5268 (while (re-search-forward "^/Lines 0 def\n/PageCount 0 def$"
5270 (replace-match (format "/Lines %d def\n/PageCount %d def"
5271 total-lines total-pages) t)))
5273 ;; Setting this variable tells the unwind form that the
5274 ;; the PostScript was generated without error.
5275 (setq completed-safely t))
5277 ;; Unwind form: If some bad mojo occurred while generating
5278 ;; PostScript, delete all the PostScript that was generated.
5279 ;; This protects the previously spooled files from getting
5281 (and (markerp safe-marker) (not completed-safely)
5283 (set-buffer ps-spool-buffer)
5284 (delete-region (marker-position safe-marker) (point-max))))))
5286 (and ps-razzle-dazzle (message "Formatting...done"))))))
5289 ;; Permit dynamic evaluation at print time of `ps-lpr-switches'.
5290 (defun ps-do-despool (filename)
5291 (if (or (not (boundp 'ps-spool-buffer))
5292 (not (symbol-value 'ps-spool-buffer)))
5293 (message "No spooled PostScript to print")
5296 (and ps-razzle-dazzle (message "Saving..."))
5297 (set-buffer ps-spool-buffer)
5298 (setq filename (expand-file-name filename))
5299 (let ((coding-system-for-write 'raw-text-unix))
5300 (write-region (point-min) (point-max) filename))
5301 (and ps-razzle-dazzle (message "Wrote %s" filename)))
5302 ;; Else, spool to the printer
5303 (and ps-razzle-dazzle (message "Printing..."))
5305 (set-buffer ps-spool-buffer)
5306 (let* ((coding-system-for-write 'raw-text-unix)
5307 (ps-printer-name (or ps-printer-name printer-name))
5309 (append (and (stringp ps-printer-name)
5310 (list (concat "-P" ps-printer-name)))
5312 (if (and (memq system-type '(ms-dos windows-nt))
5313 (stringp ps-printer-name))
5314 (write-region (point-min) (point-max) ps-printer-name t 0)
5315 (apply 'call-process-region
5316 (point-min) (point-max) ps-lpr-command nil
5317 (and (fboundp 'start-process) 0)
5319 (ps-flatten-list ; dynamic evaluation
5320 (mapcar 'ps-eval-switch ps-lpr-switches))))))
5321 (and ps-razzle-dazzle (message "Printing...done")))
5322 (kill-buffer ps-spool-buffer)))
5324 ;; Dynamic evaluation
5325 (defun ps-eval-switch (arg)
5326 (cond ((stringp arg) arg)
5327 ((functionp arg) (apply arg nil))
5328 ((symbolp arg) (symbol-value arg))
5329 ((consp arg) (apply (car arg) (cdr arg)))
5332 ;; `ps-flatten-list' is defined here (copied from "message.el" and
5333 ;; enhanced to handle dotted pairs as well) until we can get some
5334 ;; sensible autoloads, or `flatten-list' gets put somewhere decent.
5336 ;; (ps-flatten-list '((a . b) c (d . e) (f g h) i . j))
5337 ;; => (a b c d e f g h i j)
5339 (defun ps-flatten-list (&rest list)
5340 (ps-flatten-list-1 list))
5342 (defun ps-flatten-list-1 (list)
5343 (cond ((null list) nil)
5344 ((consp list) (append (ps-flatten-list-1 (car list))
5345 (ps-flatten-list-1 (cdr list))))
5348 (defun ps-kill-emacs-check ()
5350 (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
5351 (buffer-modified-p ps-buffer)
5352 (y-or-n-p "Unprinted PostScript waiting; print now? ")
5354 (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
5355 (buffer-modified-p ps-buffer)
5356 (not (yes-or-no-p "Unprinted PostScript waiting; exit anyway? "))
5357 (error "Unprinted PostScript"))))
5359 (cond ((fboundp 'add-hook)
5360 (funcall 'add-hook 'kill-emacs-hook 'ps-kill-emacs-check))
5362 (message "Won't override existing `kill-emacs-hook'"))
5364 (setq kill-emacs-hook 'ps-kill-emacs-check)))
5366 ;;; Sample Setup Code:
5368 ;; This stuff is for anybody that's brave enough to look this far,
5369 ;; and able to figure out how to use it. It isn't really part of
5370 ;; ps-print, but I'll leave it here in hopes it might be useful:
5372 ;; WARNING!!! The following code is *sample* code only. Don't use it
5373 ;; unless you understand what it does!
5375 (defmacro ps-prsc ()
5376 `(if (eq ps-print-emacs-type 'emacs) [f22] 'f22))
5377 (defmacro ps-c-prsc ()
5378 `(if (eq ps-print-emacs-type 'emacs) [C-f22] '(control f22)))
5379 (defmacro ps-s-prsc ()
5380 `(if (eq ps-print-emacs-type 'emacs) [S-f22] '(shift f22)))
5382 ;; A hook to bind to `rmail-mode-hook' to locally bind prsc and set the
5383 ;; `ps-left-headers' specially for mail messages.
5384 (defun ps-rmail-mode-hook ()
5385 (local-set-key (ps-prsc) 'ps-rmail-print-message-from-summary)
5386 (setq ps-header-lines 3
5388 ;; The left headers will display the message's subject, its
5389 ;; author, and the name of the folder it was in.
5390 '(ps-article-subject ps-article-author buffer-name)))
5392 ;; See `ps-gnus-print-article-from-summary'. This function does the
5393 ;; same thing for rmail.
5394 (defun ps-rmail-print-message-from-summary ()
5396 (ps-print-message-from-summary 'rmail-summary-buffer "RMAIL"))
5398 ;; Used in `ps-rmail-print-article-from-summary',
5399 ;; `ps-gnus-print-article-from-summary' and `ps-vm-print-message-from-summary'.
5400 (defun ps-print-message-from-summary (summary-buffer summary-default)
5401 (let ((ps-buf (or (and (boundp summary-buffer)
5402 (symbol-value summary-buffer))
5404 (and (get-buffer ps-buf)
5407 (ps-spool-buffer-with-faces)))))
5409 ;; Look in an article or mail message for the Subject: line. To be
5410 ;; placed in `ps-left-headers'.
5411 (defun ps-article-subject ()
5413 (goto-char (point-min))
5414 (if (re-search-forward "^Subject:[ \t]+\\(.*\\)$" nil t)
5415 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
5418 ;; Look in an article or mail message for the From: line. Sorta-kinda
5419 ;; understands RFC-822 addresses and can pull the real name out where
5420 ;; it's provided. To be placed in `ps-left-headers'.
5421 (defun ps-article-author ()
5423 (goto-char (point-min))
5424 (if (re-search-forward "^From:[ \t]+\\(.*\\)$" nil t)
5425 (let ((fromstring (buffer-substring-no-properties (match-beginning 1)
5429 ;; Try first to match addresses that look like
5430 ;; thompson@wg2.waii.com (Jim Thompson)
5431 ((string-match ".*[ \t]+(\\(.*\\))" fromstring)
5432 (substring fromstring (match-beginning 1) (match-end 1)))
5434 ;; Next try to match addresses that look like
5435 ;; Jim Thompson <thompson@wg2.waii.com>
5436 ((string-match "\\(.*\\)[ \t]+<.*>" fromstring)
5437 (substring fromstring (match-beginning 1) (match-end 1)))
5439 ;; Couldn't find a real name -- show the address instead.
5443 ;; A hook to bind to `gnus-article-prepare-hook'. This will set the
5444 ;; `ps-left-headers' specially for gnus articles. Unfortunately,
5445 ;; `gnus-article-mode-hook' is called only once, the first time the *Article*
5446 ;; buffer enters that mode, so it would only work for the first time
5447 ;; we ran gnus. The second time, this hook wouldn't get set up. The
5448 ;; only alternative is `gnus-article-prepare-hook'.
5449 (defun ps-gnus-article-prepare-hook ()
5450 (setq ps-header-lines 3
5452 ;; The left headers will display the article's subject, its
5453 ;; author, and the newsgroup it was in.
5454 '(ps-article-subject ps-article-author gnus-newsgroup-name)))
5456 ;; A hook to bind to `vm-mode-hook' to locally bind prsc and set the
5457 ;; `ps-left-headers' specially for mail messages.
5458 (defun ps-vm-mode-hook ()
5459 (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary)
5460 (setq ps-header-lines 3
5462 ;; The left headers will display the message's subject, its
5463 ;; author, and the name of the folder it was in.
5464 '(ps-article-subject ps-article-author buffer-name)))
5466 ;; Every now and then I forget to switch from the *Summary* buffer to
5467 ;; the *Article* before hitting prsc, and a nicely formatted list of
5468 ;; article subjects shows up at the printer. This function, bound to
5469 ;; prsc for the gnus *Summary* buffer means I don't have to switch
5471 ;; sb: Updated for Gnus 5.
5472 (defun ps-gnus-print-article-from-summary ()
5474 (ps-print-message-from-summary 'gnus-article-buffer "*Article*"))
5476 ;; See `ps-gnus-print-article-from-summary'. This function does the
5477 ;; same thing for vm.
5478 (defun ps-vm-print-message-from-summary ()
5480 (ps-print-message-from-summary 'vm-mail-buffer ""))
5482 ;; A hook to bind to bind to `gnus-summary-setup-buffer' to locally bind
5484 (defun ps-gnus-summary-setup ()
5485 (local-set-key (ps-prsc) 'ps-gnus-print-article-from-summary))
5487 ;; Look in an article or mail message for the Subject: line. To be
5488 ;; placed in `ps-left-headers'.
5489 (defun ps-info-file ()
5491 (goto-char (point-min))
5492 (if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)" nil t)
5493 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
5496 ;; Look in an article or mail message for the Subject: line. To be
5497 ;; placed in `ps-left-headers'.
5498 (defun ps-info-node ()
5500 (goto-char (point-min))
5501 (if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)" nil t)
5502 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
5505 (defun ps-info-mode-hook ()
5506 (setq ps-left-header
5507 ;; The left headers will display the node name and file name.
5508 '(ps-info-node ps-info-file)))
5510 ;; WARNING! The following function is a *sample* only, and is *not*
5511 ;; meant to be used as a whole unless you understand what the effects
5512 ;; will be! (In fact, this is a copy of Jim's setup for ps-print --
5513 ;; I'd be very surprised if it was useful to *anybody*, without
5516 (defun ps-jts-ps-setup ()
5517 (global-set-key (ps-prsc) 'ps-spool-buffer-with-faces) ;f22 is prsc
5518 (global-set-key (ps-s-prsc) 'ps-spool-region-with-faces)
5519 (global-set-key (ps-c-prsc) 'ps-despool)
5520 (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook)
5521 (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup)
5522 (add-hook 'vm-mode-hook 'ps-vm-mode-hook)
5523 (add-hook 'vm-mode-hooks 'ps-vm-mode-hook)
5524 (add-hook 'Info-mode-hook 'ps-info-mode-hook)
5525 (setq ps-spool-duplex t
5526 ps-print-color-p nil
5527 ps-lpr-command "lpr"
5528 ps-lpr-switches '("-Jjct,duplex_long"))
5531 ;; WARNING! The following function is a *sample* only, and is *not*
5532 ;; meant to be used as a whole unless it corresponds to your needs.
5533 ;; (In fact, this is a copy of Jack's setup for ps-print --
5534 ;; I would not be that surprised if it was useful to *anybody*,
5535 ;; without modification.)
5537 (defun ps-jack-setup ()
5538 (setq ps-print-color-p nil
5539 ps-lpr-command "lpr"
5544 ps-number-of-columns 2
5546 ps-left-margin (/ (* 72 1.0) 2.54) ; 1.0 cm
5547 ps-right-margin (/ (* 72 1.0) 2.54) ; 1.0 cm
5548 ps-inter-column (/ (* 72 1.0) 2.54) ; 1.0 cm
5549 ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
5550 ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
5551 ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm
5552 ps-header-line-pad .15
5554 ps-print-header-frame t
5559 ps-font-family 'Courier
5561 ps-header-font-family 'Helvetica
5562 ps-header-font-size 6
5563 ps-header-title-font-size 8)
5568 ;;; ps-print.el ends here