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 <duthen@cegelec-red.fr>
7 ;; Author: Vinicius Jose Latorre <vinicius@cpqd.com.br>
8 ;; Author: Kenichi Handa <handa@etl.go.jp> (multibyte characters)
9 ;; Maintainer: Kenichi Handa <handa@etl.go.jp> (multibyte characters)
10 ;; Maintainer: Vinicius Jose Latorre <vinicius@cpqd.com.br>
11 ;; Keywords: print, PostScript
12 ;; Time-stamp: <98/09/18 9:51:23 vinicius>
15 (defconst ps-print-version
"4.1"
16 "ps-print.el, v 4.1 <98/09/18 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 ;; NOTE: `ps-lpr-command' and `ps-lpr-switches' take their initial values
187 ;; from the variables `lpr-command' and `lpr-switches'. If you have
188 ;; `lpr-command' set to invoke a pretty-printer such as `enscript',
189 ;; then ps-print won't work properly. `ps-lpr-command' must name
190 ;; a program that does not format the files it prints.
196 ;; All dimensions are floats in PostScript points.
197 ;; 1 inch == 2.54 cm == 72 points
198 ;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points
200 ;; The variable `ps-paper-type' determines the size of paper ps-print
201 ;; formats for; it should contain one of the symbols:
202 ;; `a4' `a3' `letter' `legal' `letter-small' `tabloid'
203 ;; `ledger' `statement' `executive' `a4small' `b4' `b5'
205 ;; The variable `ps-landscape-mode' determines the orientation
206 ;; of the printing on the page:
207 ;; nil means `portrait' mode, non-nil means `landscape' mode.
208 ;; There is no oblique mode yet, though this is easy to do in ps.
210 ;; In landscape mode, the text is NOT scaled: you may print 70 lines
211 ;; in portrait mode and only 50 lignes in landscape mode.
212 ;; The margins represent margins in the printed paper:
213 ;; the top margin is the margin between the top of the page
214 ;; and the printed header, whatever the orientation is.
216 ;; The variable `ps-number-of-columns' determines the number of columns
217 ;; both in landscape and portrait mode.
219 ;; - (the standard) one column portrait mode
220 ;; - (my favorite) two columns landscape mode (which spares trees)
222 ;; - one column landscape mode for files with very long lines.
223 ;; - multi-column portrait or landscape mode
229 ;; The horizontal layout is determined by the variables
230 ;; `ps-left-margin' `ps-inter-column' `ps-right-margin'
233 ;; ------------------------------------------
235 ;; | lm | text | ic | text | ic | text | rm |
237 ;; ------------------------------------------
239 ;; If `ps-number-of-columns' is 1, `ps-inter-column' is not relevant.
240 ;; Usually, lm = rm > 0 and ic = lm
241 ;; If (ic < 0), the text of adjacent columns can overlap.
247 ;; The vertical layout is determined by the variables
248 ;; `ps-bottom-margin' `ps-top-margin' `ps-header-offset'
251 ;; |--------| |--------|
253 ;; |--------| |--------|
257 ;; |--------| or | text |
261 ;; |--------| |--------|
263 ;; |--------| |--------|
265 ;; If `ps-print-header' is nil, `ps-header-offset' is not relevant.
266 ;; The margins represent margins in the printed paper:
267 ;; the top margin is the margin between the top of the page
268 ;; and the printed header, whatever the orientation is.
274 ;; Ps-print can print headers at the top of each column or at the top
275 ;; of each page; the default headers contain the following four items:
276 ;; on the left, the name of the buffer and, if the buffer is visiting
277 ;; a file, the file's directory; on the right, the page number and
278 ;; date of printing. The default headers look something like this:
281 ;; /home/jct/emacs-lisp/ps/new 94/12/31
283 ;; When printing on duplex printers, left and right are reversed so
284 ;; that the page numbers are toward the outside (cf. `ps-spool-duplex').
286 ;; Headers are configurable:
287 ;; To turn them off completely, set `ps-print-header' to nil.
288 ;; To turn off the header's gaudy framing box,
289 ;; set `ps-print-header-frame' to nil.
291 ;; To print only one header at the top of each page,
292 ;; set `ps-print-only-one-header' to t.
294 ;; The font family and size of text in the header are determined
295 ;; by the variables `ps-header-font-family', `ps-header-font-size' and
296 ;; `ps-header-title-font-size' (see below).
298 ;; The variable `ps-header-line-pad' determines the portion of a header
299 ;; title line height to insert between the header frame and the text
300 ;; it contains, both in the vertical and horizontal directions:
301 ;; .5 means half a line.
303 ;; Page numbers are printed in `n/m' format, indicating page n of m pages;
304 ;; to omit the total page count and just print the page number,
305 ;; set `ps-show-n-of-n' to nil.
307 ;; The amount of information in the header can be changed by changing
308 ;; the number of lines. To show less, set `ps-header-lines' to 1, and
309 ;; the header will show only the buffer name and page number. To show
310 ;; more, set `ps-header-lines' to 3, and the header will show the time of
311 ;; printing below the date.
313 ;; To change the content of the headers, change the variables
314 ;; `ps-left-header' and `ps-right-header'.
315 ;; These variables are lists, specifying top-to-bottom the text
316 ;; to display on the left or right side of the header.
317 ;; Each element of the list should be a string or a symbol.
318 ;; Strings are inserted directly into the PostScript arrays,
319 ;; and should contain the PostScript string delimiters '(' and ')'.
321 ;; Symbols in the header format lists can either represent functions
322 ;; or variables. Functions are called, and should return a string to
323 ;; show in the header. Variables should contain strings to display in
324 ;; the header. In either case, function or variable, the PostScript
325 ;; string delimiters are added by ps-print, and should not be part of
326 ;; the returned value.
328 ;; Here's an example: say we want the left header to display the text
334 ;; where we have a function to return "Moe"
336 ;; (defun moe-func ()
339 ;; a variable specifying "Larry"
341 ;; (setq larry-var "Larry")
343 ;; and a literal for "Curly". Here's how `ps-left-header' should be
346 ;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)"))
348 ;; Note that Curly has the PostScript string delimiters inside his
349 ;; quotes -- those aren't misplaced lisp delimiters!
351 ;; Without them, PostScript would attempt to call the undefined
352 ;; function Curly, which would result in a PostScript error.
354 ;; Since most printers don't report PostScript errors except by
355 ;; aborting the print job, this kind of error can be hard to track down.
357 ;; Consider yourself warned!
363 ;; If you have a duplex-capable printer (one that prints both sides of
364 ;; the paper), set `ps-spool-duplex' to t.
365 ;; Ps-print will insert blank pages to make sure each buffer starts
366 ;; on the correct side of the paper.
367 ;; Don't forget to set `ps-lpr-switches' to select duplex printing
371 ;; Control And 8-bit Characters
372 ;; ----------------------------
374 ;; The variable `ps-print-control-characters' specifies whether you want to see
375 ;; a printable form for control and 8-bit characters, that is, instead of
376 ;; sending, for example, a ^D (\004) to printer, it is sent the string "^D".
378 ;; Valid values for `ps-print-control-characters' are:
380 ;; 8-bit This is the value to use when you want an ASCII encoding of
381 ;; any control or non-ASCII character. Control characters are
382 ;; encoded as "^D", and non-ASCII characters have an
385 ;; control-8-bit This is the value to use when you want an ASCII encoding of
386 ;; any control character, whether it is 7 or 8-bit.
387 ;; European 8-bits accented characters are printed according
390 ;; control Only ASCII control characters have an ASCII encoding.
391 ;; European 8-bits accented characters are printed according
394 ;; nil No ASCII encoding. Any character is printed according the
397 ;; Any other value is treated as nil.
399 ;; The default is `control-8-bit'.
401 ;; Characters TAB, NEWLINE and FORMFEED are always treated by ps-print engine.
404 ;; Printing Multi-Byte Buffer
405 ;; --------------------------
407 ;; ps-print can print multi-byte buffer.
409 ;; If you are using only Latin-1 characters, you don't need to do anything else.
411 ;; If you have a japanese or korean PostScript printer, you can print ASCII,
412 ;; Latin-1, Japanese (JISX0208, and JISX0201-Kana) and Korean characters by
415 ;; (setq ps-mule-font-info-database ps-mule-font-info-database-ps)
417 ;; At present, it was not tested the korean characters printing. If you have
418 ;; a korean PostScript printer, please verify it.
420 ;; If you use any other kind of character, you need to install intlfonts-1.1.
421 ;; So you can print using BDF fonts contained in intlfonts-1.1. To print using
422 ;; BDF fonts, do the following settings:
424 ;; (1) Set the variable `bdf-directory-list' appropriately (see bdf.el for
425 ;; documentation of this variable).
427 ;; (2) (setq ps-mule-font-info-database-ps ps-mule-font-info-database-bdf)
433 ;; The variable `ps-line-number' specifies whether to number each line;
434 ;; non-nil means do so. The default is nil (don't number each line).
440 ;; Zebra stripes are a kind of background that appear "underneath" the text
441 ;; and can make the text easier to read. They look like this:
443 ;; XXXXXXXXXXXXXXXXXXXXXXXX
444 ;; XXXXXXXXXXXXXXXXXXXXXXXX
445 ;; XXXXXXXXXXXXXXXXXXXXXXXX
449 ;; XXXXXXXXXXXXXXXXXXXXXXXX
450 ;; XXXXXXXXXXXXXXXXXXXXXXXX
451 ;; XXXXXXXXXXXXXXXXXXXXXXXX
453 ;; The blocks of X's represent rectangles filled with a light gray color.
454 ;; Each rectangle extends all the way across the page.
456 ;; The height, in lines, of each rectangle is controlled by
457 ;; the variable `ps-zebra-stripe-height', which is 3 by default.
458 ;; The distance between stripes equals the height of a stripe.
460 ;; The variable `ps-zebra-stripes' controls whether to print zebra stripes.
461 ;; Non-nil means yes, nil means no. The default is nil.
463 ;; See also section How Ps-Print Has A Text And/Or Image On Background.
469 ;; Ps-print has the following hook variables:
472 ;; It is evaluated once before any printing process. This is the right
473 ;; place to initialize ps-print global data.
474 ;; For an example, see section Adding a New Font Family.
476 ;; `ps-print-begin-page-hook'
477 ;; It is evaluated on each real beginning of page, that is, ps-print
478 ;; considers each beginning of column as a beginning of page, and a real
479 ;; beginning of page is when the beginning of column coincides with a
480 ;; paper change on your printer.
482 ;; `ps-print-begin-column-hook'
483 ;; It is evaluated on each beginning of column, except in the beginning
484 ;; of column that `ps-print-begin-page-hook' is evaluated.
490 ;; Ps-print now knows rather precisely some fonts:
491 ;; the variable `ps-font-info-database' contains information
492 ;; for a list of font families (currently mainly `Courier' `Helvetica'
493 ;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk').
494 ;; Each font family contains the font names for standard, bold, italic
495 ;; and bold-italic characters, a reference size (usually 10) and the
496 ;; corresponding line height, width of a space and average character width.
498 ;; The variable `ps-font-family' determines which font family
499 ;; is to be used for ordinary text.
500 ;; If its value does not correspond to a known font family,
501 ;; an error message is printed into the `*Messages*' buffer,
502 ;; which lists the currently available font families.
504 ;; The variable `ps-font-size' determines the size (in points)
505 ;; of the font for ordinary text, when generating PostScript.
506 ;; Its value is a float.
508 ;; Similarly, the variable `ps-header-font-family' determines
509 ;; which font family is to be used for text in the header.
510 ;; The variable `ps-header-font-size' determines the font size,
511 ;; in points, for text in the header.
512 ;; The variable `ps-header-title-font-size' determines the font size,
513 ;; in points, for the top line of text in the header.
516 ;; Adding a New Font Family
517 ;; ------------------------
519 ;; To use a new font family, you MUST first teach ps-print
520 ;; this font, i.e., add its information to `ps-font-info-database',
521 ;; otherwise ps-print cannot correctly place line and page breaks.
523 ;; For example, assuming `Helvetica' is unknown,
524 ;; you first need to do the following ONLY ONCE:
526 ;; - create a new buffer
527 ;; - generate the PostScript image to a file (C-u M-x ps-print-buffer)
528 ;; - open this file and find the line:
529 ;; `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage'
530 ;; - delete the leading `%' (which is the PostScript comment character)
531 ;; - replace in this line `Courier' by the new font (say `Helvetica')
533 ;; `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage'
534 ;; - send this file to the printer (or to ghostscript).
535 ;; You should read the following on the output page:
537 ;; For Helvetica 10 point, the line height is 11.56, the space width is 2.78
538 ;; and a crude estimate of average character width is 5.09243
540 ;; - Add these values to the `ps-font-info-database':
541 ;; (setq ps-font-info-database
543 ;; '((Helvetica ; the family key
544 ;; (fonts (normal . "Helvetica")
545 ;; (bold . "Helvetica-Bold")
546 ;; (italic . "Helvetica-Oblique")
547 ;; (bold-italic . "Helvetica-BoldOblique"))
549 ;; (line-height . 11.56)
550 ;; (space-width . 2.78)
551 ;; (avg-char-width . 5.09243)))
552 ;; ps-font-info-database))
553 ;; - Now you can use this font family with any size:
554 ;; (setq ps-font-family 'Helvetica)
555 ;; - if you want to use this family in another emacs session, you must
556 ;; put into your `~/.emacs':
557 ;; (require 'ps-print)
558 ;; (setq ps-font-info-database (append ...)))
559 ;; if you don't want to load ps-print, you have to copy the whole value:
560 ;; (setq ps-font-info-database '(<your stuff> <the standard stuff>))
561 ;; or, use `ps-print-hook' (see section Hooks):
562 ;; (add-hook 'ps-print-hook
563 ;; '(lambda () (setq ps-font-info-database (append ...))))
565 ;; You can create new `mixed' font families like:
567 ;; (fonts (normal . "Courier-Bold")
568 ;; (bold . "Helvetica")
569 ;; (italic . "Zapf-Chancery-MediumItalic")
570 ;; (bold-italic . "NewCenturySchlbk-BoldItalic")
571 ;; (w3-table-hack-x-face . "LineDrawNormal"))
573 ;; (line-height . 10.55)
574 ;; (space-width . 6.0)
575 ;; (avg-char-width . 6.0))
576 ;; Now you can use your new font family with any size:
577 ;; (setq ps-font-family 'my-mixed-family)
579 ;; Note that on above example the `w3-table-hack-x-face' entry refers to
580 ;; a face symbol, so when printing this face it'll be used the font
581 ;; `LineDrawNormal'. If the face `w3-table-hack-x-face' is remapped to
582 ;; use bold and/or italic attribute, the corresponding entry (bold, italic
583 ;; or bold-italic) will be used instead of `w3-table-hack-x-face' entry.
585 ;; Note also that the font family entry order is irrelevant, so the above
586 ;; example could also be written:
589 ;; (fonts (w3-table-hack-x-face . "LineDrawNormal")
590 ;; (bold . "Helvetica")
591 ;; (bold-italic . "NewCenturySchlbk-BoldItalic")
592 ;; (italic . "Zapf-Chancery-MediumItalic")
593 ;; (normal . "Courier-Bold"))
594 ;; (avg-char-width . 6.0)
595 ;; (space-width . 6.0)
596 ;; (line-height . 10.55))
598 ;; Despite the note above, it is recommended that some convention about
599 ;; entry order be used.
601 ;; You can get information on all the fonts resident in YOUR printer
602 ;; by uncommenting the line:
603 ;; % 3 cm 20 cm moveto ReportAllFontInfo showpage
605 ;; The PostScript file should be sent to YOUR PostScript printer.
606 ;; If you send it to ghostscript or to another PostScript printer,
607 ;; you may get slightly different results.
608 ;; Anyway, as ghostscript fonts are autoload, you won't get
612 ;; How Ps-Print Deals With Faces
613 ;; -----------------------------
615 ;; The ps-print-*-with-faces commands attempt to determine which faces
616 ;; should be printed in bold or italic, but their guesses aren't
617 ;; always right. For example, you might want to map colors into faces
618 ;; so that blue faces print in bold, and red faces in italic.
620 ;; It is possible to force ps-print to consider specific faces bold,
621 ;; italic or underline, no matter what font they are displayed in, by setting
622 ;; the variables `ps-bold-faces', `ps-italic-faces' and `ps-underlined-faces'.
623 ;; These variables contain lists of faces that ps-print should consider bold,
624 ;; italic or underline; to set them, put code like the following into your
627 ;; (setq ps-bold-faces '(my-blue-face))
628 ;; (setq ps-italic-faces '(my-red-face))
629 ;; (setq ps-underlined-faces '(my-green-face))
631 ;; Faces like bold-italic that are both bold and italic should go in
634 ;; Ps-print keeps internal lists of which fonts are bold and which are
635 ;; italic; these lists are built the first time you invoke ps-print.
636 ;; For the sake of efficiency, the lists are built only once; the same
637 ;; lists are referred in later invocations of ps-print.
639 ;; Because these lists are built only once, it's possible for them to
640 ;; get out of sync, if a face changes, or if new faces are added. To
641 ;; get the lists back in sync, you can set the variable
642 ;; `ps-build-face-reference' to t, and the lists will be rebuilt the
643 ;; next time ps-print is invoked. If you need that the lists always be
644 ;; rebuilt when ps-print is invoked, set the variable
645 ;; `ps-always-build-face-reference' to t.
648 ;; How Ps-Print Deals With Color
649 ;; -----------------------------
651 ;; Ps-print detects faces with foreground and background colors
652 ;; defined and embeds color information in the PostScript image.
653 ;; The default foreground and background colors are defined by the
654 ;; variables `ps-default-fg' and `ps-default-bg'.
655 ;; On black-and-white printers, colors are displayed in grayscale.
656 ;; To turn off color output, set `ps-print-color-p' to nil.
659 ;; How Ps-Print Maps Faces
660 ;; -----------------------
662 ;; As ps-print uses PostScript to print buffers, it is possible to have
663 ;; other attributes associated with faces. So the new attributes used
666 ;; strikeout - like underline, but the line is in middle of text.
667 ;; overline - like underline, but the line is over the text.
668 ;; shadow - text will have a shadow.
669 ;; box - text will be surrounded by a box.
670 ;; outline - print characters as hollow outlines.
672 ;; See the documentation for `ps-extend-face'.
674 ;; Let's, for example, remap font-lock-keyword-face to another foreground color
675 ;; and bold attribute:
677 ;; (ps-extend-face '(font-lock-keyword-face "RoyalBlue" nil bold) 'MERGE)
679 ;; If you want to use a new face, define it first with `defface',
680 ;; and then call `ps-extend-face' to specify how to print it.
683 ;; How Ps-Print Has A Text And/Or Image On Background
684 ;; --------------------------------------------------
686 ;; Ps-print can print texts and/or EPS PostScript images on background; it is
687 ;; possible to define the following text attributes: font name, font size,
688 ;; initial position, angle, gray scale and pages to print.
690 ;; It has the following EPS PostScript images attributes: file name containing
691 ;; the image, initial position, X and Y scales, angle and pages to print.
693 ;; See documentation for `ps-print-background-text' and
694 ;; `ps-print-background-image'.
696 ;; For example, if we wish to print text "preliminary" on all pages and text
697 ;; "special" on page 5 and from page 11 to page 17, we could specify:
699 ;; (setq ps-print-background-text
702 ;; "LeftMargin" "BottomMargin PrintHeight add" ; X and Y position
703 ;; ; (upper left corner)
705 ;; "PrintHeight neg PrintPageWidth atan" ; angle
706 ;; 5 (11 . 17)) ; page list
709 ;; Similarly, we could print image "~/images/EPS-image1.ps" on all pages and
710 ;; image "~/images/EPS-image2.ps" on page 5 and from page 11 to page 17, we
713 ;; (setq ps-print-background-image
714 ;; '(("~/images/EPS-image1.ps"
715 ;; "LeftMargin" "BottomMargin") ; X and Y position (lower left corner)
716 ;; ("~/images/EPS-image2.ps"
717 ;; "LeftMargin" "BottomMargin PrintHeight 2 div add" ; X and Y position
718 ;; ; (upper left corner)
720 ;; 5 (11 . 17)) ; page list
723 ;; If it is not possible to read (or does not exist) an image file, that file
726 ;; The printing order is:
728 ;; 1. Print zebra stripes
729 ;; 2. Print background texts that it should be on all pages
730 ;; 3. Print background images that it should be on all pages
731 ;; 4. Print background texts only for current page (if any)
732 ;; 5. Print background images only for current page (if any)
734 ;; 7. Print buffer text (with faces, if specified) and line number
740 ;; Some tools are provided to help you customize your font setup.
742 ;; `ps-setup' returns (some part of) the current setup.
744 ;; To avoid wrapping too many lines, you may want to adjust the
745 ;; left and right margins and the font size. On UN*X systems, do:
746 ;; pr -t file | awk '{printf "%3d %s\n", length($0), $0}' | sort -r | head
747 ;; to determine the longest lines of your file.
748 ;; Then, the command `ps-line-lengths' will give you the correspondence
749 ;; between a line length (number of characters) and the maximum font
750 ;; size which doesn't wrap such a line with the current ps-print setup.
752 ;; The commands `ps-nb-pages-buffer' and `ps-nb-pages-region' display
753 ;; the correspondence between a number of pages and the maximum font
754 ;; size which allow the number of lines of the current buffer or of
755 ;; its current region to fit in this number of pages.
757 ;; NOTE: line folding is not taken into account in this process and could
758 ;; change the results.
761 ;; New since version 1.5
762 ;; ---------------------
764 ;; Color output capability.
765 ;; Automatic detection of font attributes (bold, italic).
766 ;; Configurable headers with page numbers.
768 ;; Support for different paper sizes.
769 ;; Better conformance to PostScript Document Structure Conventions.
772 ;; New since version 2.8
773 ;; ---------------------
775 ;; [keinichi] 980819 Kein'ichi Handa <handa@etl.go.jp>
777 ;; Multi-byte buffer handling.
779 ;; [vinicius] 980306 Vinicius Jose Latorre <vinicius@cpqd.com.br>
781 ;; Skip invisible text.
783 ;; [vinicius] 971130 Vinicius Jose Latorre <vinicius@cpqd.com.br>
785 ;; Hooks: `ps-print-hook', `ps-print-begin-page-hook' and
786 ;; `ps-print-begin-column-hook'.
787 ;; Put one header per page over the columns.
788 ;; Better database font management.
789 ;; Better control characters handling.
791 ;; [vinicius] 971121 Vinicius Jose Latorre <vinicius@cpqd.com.br>
793 ;; Dynamic evaluation at print time of `ps-lpr-switches'.
794 ;; Handle control characters.
796 ;; New face attributes.
799 ;; Text and/or image on background.
801 ;; [jack] 960517 Jacques Duthen <duthen@cegelec-red.fr>
803 ;; Font family and float size for text and header.
806 ;; Tools for page setup.
809 ;; Known bugs and limitations of ps-print:
810 ;; --------------------------------------
812 ;; Although color printing will work in XEmacs 19.12, it doesn't work
813 ;; well; in particular, bold or italic fonts don't print in the right
816 ;; Invisible properties aren't correctly ignored in XEmacs 19.12.
818 ;; Automatic font-attribute detection doesn't work well, especially
819 ;; with hilit19 and older versions of get-create-face. Users having
820 ;; problems with auto-font detection should use the lists
821 ;; `ps-italic-faces', `ps-bold-faces' and `ps-underlined-faces' and/or
822 ;; turn off automatic detection by setting `ps-auto-font-detect' to nil.
824 ;; Automatic font-attribute detection doesn't work with XEmacs 19.12
825 ;; in tty mode; use the lists `ps-italic-faces', `ps-bold-faces' and
826 ;; `ps-underlined-faces' instead.
828 ;; Still too slow; could use some hand-optimization.
830 ;; Default background color isn't working.
832 ;; Faces are always treated as opaque.
834 ;; Epoch and Emacs 18 not supported. At all.
836 ;; Fixed-pitch fonts work better for line folding, but are not required.
838 ;; `ps-nb-pages-buffer' and `ps-nb-pages-region' don't take care
845 ;; Avoid page break inside a paragraph.
846 ;; Add `ps-non-bold-faces' and `ps-non-italic-faces' (should be easy).
847 ;; Improve the memory management for big files (hard?).
848 ;; `ps-nb-pages-buffer' and `ps-nb-pages-region' should take care
855 ;; Thanks to Kein'ichi Handa <handa@etl.go.jp> for multi-byte buffer handling.
857 ;; Thanks to Matthew O Persico <Matthew.Persico@lazard.com> for line number on
860 ;; Thanks to Theodore Jump <tjump@cais.com> for adjust PostScript code order on
863 ;; Thanks to Roland Ducournau <ducour@lirmm.fr> for
864 ;; `ps-print-control-characters' variable documentation.
866 ;; Thanks to Marcus G Daniels <marcus@cathcart.sysc.pdx.edu> for a better
867 ;; database font management.
869 ;; Thanks to Martin Boyer <gamin@videotron.ca> for some ideas on putting one
870 ;; header per page over the columns and correct line numbers when printing a
873 ;; Thanks to Steven L Baur <steve@miranova.com> for dynamic evaluation at
874 ;; print time of `ps-lpr-switches'.
876 ;; Thanks to Kevin Rodgers <kevinr@ihs.com> for handling control characters
877 ;; (his code was severely modified, but the main idea was kept).
879 ;; Thanks to some suggestions on:
880 ;; * Face color map: Marco Melgazzi <marco@techie.com>
881 ;; * XEmacs compatibility: William J. Henney <will@astrosmo.unam.mx>
882 ;; * Check `ps-paper-type': Sudhakar Frederick <sfrederi@asc.corp.mot.com>
884 ;; Thanks to Jacques Duthen <duthen@cegelec-red.fr> (Jack) for the 3.4 version
885 ;; I started from. [vinicius]
887 ;; Thanks to Jim Thompson <?@?> for the 2.8 version I started from.
890 ;; Thanks to Kevin Rodgers <kevinr@ihs.com> for adding support for
891 ;; color and the invisible property.
893 ;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing
894 ;; the initial port to Emacs 19. His code is no longer part of
895 ;; ps-print, but his work is still appreciated.
897 ;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org,
898 ;; for adding underline support. Their code also is no longer part of
899 ;; ps-print, but their efforts are not forgotten.
901 ;; Thanks also to all of you who mailed code to add features to
902 ;; ps-print; although I didn't use your code, I still appreciate your
903 ;; sharing it with me.
905 ;; Thanks to all who mailed comments, encouragement, and criticism.
906 ;; Thanks also to all who responded to my survey; I had too many
907 ;; responses to reply to them all, but I greatly appreciate your
911 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
915 (unless (featurep 'lisp-float-type
)
916 (error "`ps-print' requires floating point support"))
918 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
921 ;;; Interface to the command system
923 (defgroup ps-print nil
924 "PostScript generator for Emacs 19"
928 (defgroup ps-print-horizontal nil
929 "Horizontal page layout"
934 (defgroup ps-print-vertical nil
935 "Vertical page layout"
940 (defgroup ps-print-header nil
946 (defgroup ps-print-font nil
947 "Fonts customization"
952 (defgroup ps-print-color nil
953 "Color customization"
958 (defgroup ps-print-face nil
959 "Faces customization"
966 (defcustom ps-printer-name printer-name
967 "*The name of a local printer for printing PostScript files.
969 On Unix-like systems, a string value should be a name understood by
970 lpr's -P option; otherwise the value should be nil.
972 On MS-DOS and MS-Windows systems, if the value is a string, then it is
973 taken as the name of the device to which PostScript files are written.
974 By default it is the same as `printer-name'; typical non-default
975 settings would be \"LPT1\" to \"LPT3\" for parallel printers, or
976 \"COM1\" to \"COM4\" or \"AUX\" for serial printers, or
977 \"//hostname/printer\" for a shared network printer. You can also set
978 it to a name of a file, in which case the output gets appended to that
979 file. \(Note that `ps-print' package already has facilities for
980 printing to a file, so you might as well use them instead of changing
981 the setting of this variable.\) If you want to silently discard the
982 printed output, set this to \"NUL\".
984 On DOS/Windows, if the value is anything but a string, PostScript files
985 will be piped to the program given by `ps-lpr-command', with switches
986 given by `ps-lpr-switches', which see."
987 :type
'(choice file
(other :tag
"Pipe to ps-lpr-command" pipe
))
990 (defcustom ps-lpr-command lpr-command
991 "*The shell command for printing a PostScript file."
995 (defcustom ps-lpr-switches lpr-switches
996 "*A list of extra switches to pass to `ps-lpr-command'."
997 :type
'(repeat string
)
1002 ;; All page dimensions are in PostScript points.
1003 ;; 1 inch == 2.54 cm == 72 points
1004 ;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points
1006 ;; Letter 8.5 inch x 11.0 inch
1007 ;; Legal 8.5 inch x 14.0 inch
1008 ;; A4 8.26 inch x 11.69 inch = 21.0 cm x 29.7 cm
1010 ;; LetterSmall 7.68 inch x 10.16 inch
1011 ;; Tabloid 11.0 inch x 17.0 inch
1012 ;; Ledger 17.0 inch x 11.0 inch
1013 ;; Statement 5.5 inch x 8.5 inch
1014 ;; Executive 7.5 inch x 10.0 inch
1015 ;; A3 11.69 inch x 16.5 inch = 29.7 cm x 42.0 cm
1016 ;; A4Small 7.47 inch x 10.85 inch
1017 ;; B4 10.125 inch x 14.33 inch
1018 ;; B5 7.16 inch x 10.125 inch
1020 (defcustom ps-page-dimensions-database
1021 (list (list 'a4
(/ (* 72 21.0) 2.54) (/ (* 72 29.7) 2.54))
1022 (list 'a3
(/ (* 72 29.7) 2.54) (/ (* 72 42.0) 2.54))
1023 (list 'letter
(* 72 8.5) (* 72 11.0))
1024 (list 'legal
(* 72 8.5) (* 72 14.0))
1025 (list 'letter-small
(* 72 7.68) (* 72 10.16))
1026 (list 'tabloid
(* 72 11.0) (* 72 17.0))
1027 (list 'ledger
(* 72 17.0) (* 72 11.0))
1028 (list 'statement
(* 72 5.5) (* 72 8.5))
1029 (list 'executive
(* 72 7.5) (* 72 10.0))
1030 (list 'a4small
(* 72 7.47) (* 72 10.85))
1031 (list 'b4
(* 72 10.125) (* 72 14.33))
1032 (list 'b5
(* 72 7.16) (* 72 10.125)))
1033 "*List associating a symbolic paper type to its width and height.
1034 see `ps-paper-type'."
1035 :type
'(repeat (list :tag
"Paper Type"
1036 (symbol :tag
"Name")
1037 (number :tag
"Width")
1038 (number :tag
"Height")))
1042 (defcustom ps-paper-type
'letter
1043 "*Specifies the size of paper to format for.
1044 Should be one of the paper types defined in `ps-page-dimensions-database', for
1045 example `letter', `legal' or `a4'."
1046 :type
'(symbol :validate
(lambda (wid)
1047 (if (assq (widget-value wid
)
1048 ps-page-dimensions-database
)
1050 (widget-put wid
:error
"Unknown paper size")
1054 (defcustom ps-landscape-mode nil
1055 "*Non-nil means print in landscape mode."
1059 (defcustom ps-print-control-characters
'control-8-bit
1060 "*Specifies the printable form for control and 8-bit characters.
1061 That is, instead of sending, for example, a ^D (\004) to printer,
1062 it is sent the string \"^D\".
1066 `8-bit' This is the value to use when you want an ASCII encoding of
1067 any control or non-ASCII character. Control characters are
1068 encoded as \"^D\", and non-ASCII characters have an
1071 `control-8-bit' This is the value to use when you want an ASCII encoding of
1072 any control character, whether it is 7 or 8-bit.
1073 European 8-bits accented characters are printed according
1076 `control' Only ASCII control characters have an ASCII encoding.
1077 European 8-bits accented characters are printed according
1080 nil No ASCII encoding. Any character is printed according the
1083 Any other value is treated as nil."
1084 :type
'(choice (const 8-bit
) (const control-8-bit
)
1085 (const control
) (other :tag
"nil" nil
))
1088 (defcustom ps-number-of-columns
(if ps-landscape-mode
2 1)
1089 "*Specifies the number of columns"
1093 (defcustom ps-zebra-stripes nil
1094 "*Non-nil means print zebra stripes.
1095 See also documentation for `ps-zebra-stripe-height'."
1099 (defcustom ps-zebra-stripe-height
3
1100 "*Number of zebra stripe lines.
1101 See also documentation for `ps-zebra-stripes'."
1105 (defcustom ps-line-number nil
1106 "*Non-nil means print line number."
1110 (defcustom ps-print-background-image nil
1111 "*EPS image list to be printed on background.
1115 (FILENAME X Y XSCALE YSCALE ROTATION PAGES...)
1117 FILENAME is a file name which contains an EPS image or some PostScript
1118 programming like EPS.
1119 FILENAME is ignored, if it doesn't exist or is read protected.
1121 X and Y are relative positions on paper to put the image.
1122 If X and Y are nil, the image is centralized on paper.
1124 XSCALE and YSCALE are scale factor to be applied to image before printing.
1125 If XSCALE and YSCALE are nil, the original size is used.
1127 ROTATION is the image rotation angle; if nil, the default is 0.
1129 PAGES designates the page to print background image.
1130 PAGES may be a number or a cons cell (FROM . TO) designating FROM page
1132 If PAGES is nil, print background image on all pages.
1134 X, Y, XSCALE, YSCALE and ROTATION may be a floating point number,
1135 an integer number or a string. If it is a string, the string should contain
1136 PostScript programming that returns a float or integer value.
1138 For example, if you wish to print an EPS image on all pages do:
1140 '((\"~/images/EPS-image.ps\"))"
1141 :type
'(repeat (list file
1142 (choice :tag
"X" number string
(const nil
))
1143 (choice :tag
"Y" number string
(const nil
))
1144 (choice :tag
"X Scale" number string
(const nil
))
1145 (choice :tag
"Y Scale" number string
(const nil
))
1146 (choice :tag
"Rotation" number string
(const nil
))
1147 (repeat :tag
"Pages" :inline t
1150 (integer :tag
"From")
1151 (integer :tag
"To"))))))
1154 (defcustom ps-print-background-text nil
1155 "*Text list to be printed on background.
1159 (STRING X Y FONT FONTSIZE GRAY ROTATION PAGES...)
1161 STRING is the text to be printed on background.
1163 X and Y are positions on paper to put the text.
1164 If X and Y are nil, the text is positioned at lower left corner.
1166 FONT is a font name to be used on printing the text.
1167 If nil, \"Times-Roman\" is used.
1169 FONTSIZE is font size to be used, if nil, 200 is used.
1171 GRAY is the text gray factor (should be very light like 0.8).
1172 If nil, the default is 0.85.
1174 ROTATION is the text rotation angle; if nil, the angle is given by
1175 the diagonal from lower left corner to upper right corner.
1177 PAGES designates the page to print background text.
1178 PAGES may be a number or a cons cell (FROM . TO) designating FROM page
1180 If PAGES is nil, print background text on all pages.
1182 X, Y, FONTSIZE, GRAY and ROTATION may be a floating point number,
1183 an integer number or a string. If it is a string, the string should contain
1184 PostScript programming that returns a float or integer value.
1186 For example, if you wish to print text \"Preliminary\" on all pages do:
1188 '((\"Preliminary\"))"
1189 :type
'(repeat (list string
1190 (choice :tag
"X" number string
(const nil
))
1191 (choice :tag
"Y" number string
(const nil
))
1192 (choice :tag
"Font" string
(const nil
))
1193 (choice :tag
"Fontsize" number string
(const nil
))
1194 (choice :tag
"Gray" number string
(const nil
))
1195 (choice :tag
"Rotation" number string
(const nil
))
1196 (repeat :tag
"Pages" :inline t
1199 (integer :tag
"From")
1200 (integer :tag
"To"))))))
1203 ;;; Horizontal layout
1205 ;; ------------------------------------------
1207 ;; | lm | text | ic | text | ic | text | rm |
1209 ;; ------------------------------------------
1211 (defcustom ps-left-margin
(/ (* 72 2.0) 2.54) ; 2 cm
1212 "*Left margin in points (1/72 inch)."
1214 :group
'ps-print-horizontal
)
1216 (defcustom ps-right-margin
(/ (* 72 2.0) 2.54) ; 2 cm
1217 "*Right margin in points (1/72 inch)."
1219 :group
'ps-print-horizontal
)
1221 (defcustom ps-inter-column
(/ (* 72 2.0) 2.54) ; 2 cm
1222 "*Horizontal space between columns in points (1/72 inch)."
1224 :group
'ps-print-horizontal
)
1240 (defcustom ps-bottom-margin
(/ (* 72 1.5) 2.54) ; 1.5 cm
1241 "*Bottom margin in points (1/72 inch)."
1243 :group
'ps-print-vertical
)
1245 (defcustom ps-top-margin
(/ (* 72 1.5) 2.54) ; 1.5 cm
1246 "*Top margin in points (1/72 inch)."
1248 :group
'ps-print-vertical
)
1250 (defcustom ps-header-offset
(/ (* 72 1.0) 2.54) ; 1.0 cm
1251 "*Vertical space in points (1/72 inch) between the main text and the header."
1253 :group
'ps-print-vertical
)
1255 (defcustom ps-header-line-pad
0.15
1256 "*Portion of a header title line height to insert between the header frame
1257 and the text it contains, both in the vertical and horizontal directions."
1259 :group
'ps-print-vertical
)
1263 (defcustom ps-print-header t
1264 "*Non-nil means print a header at the top of each page.
1265 By default, the header displays the buffer name, page number, and, if
1266 the buffer is visiting a file, the file's directory. Headers are
1267 customizable by changing variables `ps-left-header' and
1270 :group
'ps-print-header
)
1272 (defcustom ps-print-only-one-header nil
1273 "*Non-nil means print only one header at the top of each page.
1274 This is useful when printing more than one column, so it is possible
1275 to have only one header over all columns or one header per column.
1276 See also `ps-print-header'."
1278 :group
'ps-print-header
)
1280 (defcustom ps-print-header-frame t
1281 "*Non-nil means draw a gaudy frame around the header."
1283 :group
'ps-print-header
)
1285 (defcustom ps-header-lines
2
1286 "*Number of lines to display in page header, when generating PostScript."
1288 :group
'ps-print-header
)
1289 (make-variable-buffer-local 'ps-header-lines
)
1291 (defcustom ps-show-n-of-n t
1292 "*Non-nil means show page numbers as N/M, meaning page N of M.
1293 NOTE: page numbers are displayed as part of headers,
1294 see variable `ps-print-headers'."
1296 :group
'ps-print-header
)
1298 (defcustom ps-spool-duplex nil
; Not many people have duplex
1299 ; printers, so default to nil.
1300 "*Non-nil indicates spooling is for a two-sided printer.
1301 For a duplex printer, the `ps-spool-*' commands will insert blank pages
1302 as needed between print jobs so that the next buffer printed will
1303 start on the right page. Also, if headers are turned on, the headers
1304 will be reversed on duplex printers so that the page numbers fall to
1305 the left on even-numbered pages."
1307 :group
'ps-print-header
)
1311 (defcustom ps-font-info-database
1312 '((Courier ; the family key
1313 (fonts (normal .
"Courier")
1314 (bold .
"Courier-Bold")
1315 (italic .
"Courier-Oblique")
1316 (bold-italic .
"Courier-BoldOblique"))
1318 (line-height .
10.55)
1320 (avg-char-width .
6.0))
1321 (Helvetica ; the family key
1322 (fonts (normal .
"Helvetica")
1323 (bold .
"Helvetica-Bold")
1324 (italic .
"Helvetica-Oblique")
1325 (bold-italic .
"Helvetica-BoldOblique"))
1327 (line-height .
11.56)
1328 (space-width .
2.78)
1329 (avg-char-width .
5.09243))
1331 (fonts (normal .
"Times-Roman")
1332 (bold .
"Times-Bold")
1333 (italic .
"Times-Italic")
1334 (bold-italic .
"Times-BoldItalic"))
1336 (line-height .
11.0)
1338 (avg-char-width .
4.71432))
1340 (fonts (normal .
"Palatino-Roman")
1341 (bold .
"Palatino-Bold")
1342 (italic .
"Palatino-Italic")
1343 (bold-italic .
"Palatino-BoldItalic"))
1345 (line-height .
12.1)
1347 (avg-char-width .
5.08676))
1349 (fonts (normal .
"Helvetica-Narrow")
1350 (bold .
"Helvetica-Narrow-Bold")
1351 (italic .
"Helvetica-Narrow-Oblique")
1352 (bold-italic .
"Helvetica-Narrow-BoldOblique"))
1354 (line-height .
11.56)
1355 (space-width .
2.2796)
1356 (avg-char-width .
4.17579))
1358 (fonts (normal .
"NewCenturySchlbk-Roman")
1359 (bold .
"NewCenturySchlbk-Bold")
1360 (italic .
"NewCenturySchlbk-Italic")
1361 (bold-italic .
"NewCenturySchlbk-BoldItalic"))
1363 (line-height .
12.15)
1364 (space-width .
2.78)
1365 (avg-char-width .
5.31162))
1366 ;; got no bold for the next ones
1368 (fonts (normal .
"AvantGarde-Book")
1369 (italic .
"AvantGarde-BookOblique"))
1371 (line-height .
11.77)
1372 (space-width .
2.77)
1373 (avg-char-width .
5.45189))
1375 (fonts (normal .
"AvantGarde-Demi")
1376 (italic .
"AvantGarde-DemiOblique"))
1378 (line-height .
12.72)
1380 (avg-char-width .
5.51351))
1382 (fonts (normal .
"Bookman-Demi")
1383 (italic .
"Bookman-DemiItalic"))
1385 (line-height .
11.77)
1387 (avg-char-width .
6.05946))
1389 (fonts (normal .
"Bookman-Light")
1390 (italic .
"Bookman-LightItalic"))
1392 (line-height .
11.79)
1394 (avg-char-width .
5.67027))
1395 ;; got no bold and no italic for the next ones
1397 (fonts (normal .
"Symbol"))
1399 (line-height .
13.03)
1401 (avg-char-width .
3.24324))
1403 (fonts (normal .
"Zapf-Dingbats"))
1405 (line-height .
9.63)
1406 (space-width .
2.78)
1407 (avg-char-width .
2.78))
1408 (Zapf-Chancery-MediumItalic
1409 (fonts (normal .
"Zapf-Chancery-MediumItalic"))
1411 (line-height .
11.45)
1413 (avg-char-width .
4.10811))
1415 "*Font info database: font family (the key), name, bold, italic, bold-italic,
1416 reference size, line height, space width, average character width.
1417 To get the info for another specific font (say Helvetica), do the following:
1418 - create a new buffer
1419 - generate the PostScript image to a file (C-u M-x ps-print-buffer)
1420 - open this file and delete the leading `%' (which is the PostScript
1421 comment character) from the line
1422 `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage'
1424 `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage'
1425 - add the values to `ps-font-info-database'.
1426 You can get all the fonts of YOUR printer using `ReportAllFontInfo'."
1427 :type
'(repeat (list :tag
"Font Definition"
1428 (symbol :tag
"Font Family")
1430 (const :format
"" fonts
)
1431 (repeat :tag
"Faces"
1432 (cons (choice (const normal
)
1436 (symbol :tag
"Face"))
1437 (string :tag
"Font Name"))))
1439 (const :format
"" size
)
1440 (number :tag
"Reference Size"))
1442 (const :format
"" line-height
)
1443 (number :tag
"Line Height"))
1445 (const :format
"" space-width
)
1446 (number :tag
"Space Width"))
1448 (const :format
"" avg-char-width
)
1449 (number :tag
"Average Character Width"))))
1450 :group
'ps-print-font
)
1452 (defcustom ps-font-family
'Courier
1453 "Font family name for ordinary text, when generating PostScript."
1455 :group
'ps-print-font
)
1457 (defcustom ps-font-size
(if ps-landscape-mode
7 8.5)
1458 "Font size, in points, for ordinary text, when generating PostScript."
1460 :group
'ps-print-font
)
1462 (defcustom ps-header-font-family
'Helvetica
1463 "Font family name for text in the header, when generating PostScript."
1465 :group
'ps-print-font
)
1467 (defcustom ps-header-font-size
(if ps-landscape-mode
10 12)
1468 "Font size, in points, for text in the header, when generating PostScript."
1470 :group
'ps-print-font
)
1472 (defcustom ps-header-title-font-size
(if ps-landscape-mode
12 14)
1473 "Font size, in points, for the top line of text in header, in PostScript."
1475 :group
'ps-print-font
)
1479 ;; Printing color requires x-color-values.
1480 (defcustom ps-print-color-p
(or (fboundp 'x-color-values
) ; Emacs
1481 (fboundp 'color-instance-rgb-components
))
1483 "*If non-nil, print the buffer's text in color."
1485 :group
'ps-print-color
)
1487 (defcustom ps-default-fg
'(0.0
0.0 0.0)
1488 "*RGB values of the default foreground color. Defaults to black."
1489 :type
'(list (number :tag
"Red") (number :tag
"Green") (number :tag
"Blue"))
1490 :group
'ps-print-color
)
1492 (defcustom ps-default-bg
'(1.0
1.0 1.0)
1493 "*RGB values of the default background color. Defaults to white."
1494 :type
'(list (number :tag
"Red") (number :tag
"Green") (number :tag
"Blue"))
1495 :group
'ps-print-color
)
1497 (defcustom ps-auto-font-detect t
1498 "*Non-nil means automatically detect bold/italic face attributes.
1499 If nil, we rely solely on the lists `ps-bold-faces', `ps-italic-faces',
1500 and `ps-underlined-faces'."
1502 :group
'ps-print-font
)
1504 (defcustom ps-bold-faces
1505 (unless ps-print-color-p
1506 '(font-lock-function-name-face
1507 font-lock-builtin-face
1508 font-lock-variable-name-face
1509 font-lock-keyword-face
1510 font-lock-warning-face
))
1511 "*A list of the \(non-bold\) faces that should be printed in bold font.
1512 This applies to generating PostScript."
1513 :type
'(repeat face
)
1514 :group
'ps-print-face
)
1516 (defcustom ps-italic-faces
1517 (unless ps-print-color-p
1518 '(font-lock-variable-name-face
1520 font-lock-string-face
1521 font-lock-comment-face
1522 font-lock-warning-face
))
1523 "*A list of the \(non-italic\) faces that should be printed in italic font.
1524 This applies to generating PostScript."
1525 :type
'(repeat face
)
1526 :group
'ps-print-face
)
1528 (defcustom ps-underlined-faces
1529 (unless ps-print-color-p
1530 '(font-lock-function-name-face
1531 font-lock-constant-face
1532 font-lock-warning-face
))
1533 "*A list of the \(non-underlined\) faces that should be printed underlined.
1534 This applies to generating PostScript."
1535 :type
'(repeat face
)
1536 :group
'ps-print-face
)
1538 (defcustom ps-left-header
1539 (list 'ps-get-buffer-name
'ps-header-dirpart
)
1540 "*The items to display (each on a line) on the left part of the page header.
1541 This applies to generating PostScript.
1543 The value should be a list of strings and symbols, each representing an
1544 entry in the PostScript array HeaderLinesLeft.
1546 Strings are inserted unchanged into the array; those representing
1547 PostScript string literals should be delimited with PostScript string
1548 delimiters '(' and ')'.
1550 For symbols with bound functions, the function is called and should
1551 return a string to be inserted into the array. For symbols with bound
1552 values, the value should be a string to be inserted into the array.
1553 In either case, function or variable, the string value has PostScript
1554 string delimiters added to it."
1555 :type
'(repeat (choice string symbol
))
1556 :group
'ps-print-header
)
1557 (make-variable-buffer-local 'ps-left-header
)
1559 (defcustom ps-right-header
1560 (list "/pagenumberstring load" 'time-stamp-mon-dd-yyyy
'time-stamp-hh
:mm
:ss
)
1561 "*The items to display (each on a line) on the right part of the page header.
1562 This applies to generating PostScript.
1564 See the variable `ps-left-header' for a description of the format of
1566 :type
'(repeat (choice string symbol
))
1567 :group
'ps-print-header
)
1568 (make-variable-buffer-local 'ps-right-header
)
1570 (defcustom ps-razzle-dazzle t
1571 "*Non-nil means report progress while formatting buffer."
1575 (defcustom ps-adobe-tag
"%!PS-Adobe-3.0\n"
1576 "*Contains the header line identifying the output as PostScript.
1577 By default, `ps-adobe-tag' contains the standard identifier. Some
1578 printers require slightly different versions of this line."
1582 (defcustom ps-build-face-reference t
1583 "*Non-nil means build the reference face lists.
1585 Ps-print sets this value to nil after it builds its internal reference
1586 lists of bold and italic faces. By settings its value back to t, you
1587 can force ps-print to rebuild the lists the next time you invoke one
1588 of the ...-with-faces commands.
1590 You should set this value back to t after you change the attributes of
1591 any face, or create new faces. Most users shouldn't have to worry
1592 about its setting, though."
1594 :group
'ps-print-face
)
1596 (defcustom ps-always-build-face-reference nil
1597 "*Non-nil means always rebuild the reference face lists.
1599 If this variable is non-nil, ps-print will rebuild its internal
1600 reference lists of bold and italic faces *every* time one of the
1601 ...-with-faces commands is called. Most users shouldn't need to set this
1604 :group
'ps-print-face
)
1606 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1610 (defun ps-print-buffer (&optional filename
)
1611 "Generate and print a PostScript image of the buffer.
1613 Interactively, when you use a prefix argument (C-u), the command
1614 prompts the user for a file name, and saves the PostScript image
1615 in that file instead of sending it to the printer.
1617 Noninteractively, the argument FILENAME is treated as follows: if it
1618 is nil, send the image to the printer. If FILENAME is a string, save
1619 the PostScript image in a file with that name."
1620 (interactive (list (ps-print-preprint current-prefix-arg
)))
1621 (ps-print-without-faces (point-min) (point-max) filename
))
1625 (defun ps-print-buffer-with-faces (&optional filename
)
1626 "Generate and print a PostScript image of the buffer.
1627 Like `ps-print-buffer', but includes font, color, and underline
1628 information in the generated image. This command works only if you
1629 are using a window system, so it has a way to determine color values."
1630 (interactive (list (ps-print-preprint current-prefix-arg
)))
1631 (ps-print-with-faces (point-min) (point-max) filename
))
1635 (defun ps-print-region (from to
&optional filename
)
1636 "Generate and print a PostScript image of the region.
1637 Like `ps-print-buffer', but prints just the current region."
1638 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg
)))
1639 (ps-print-without-faces from to filename t
))
1643 (defun ps-print-region-with-faces (from to
&optional filename
)
1644 "Generate and print a PostScript image of the region.
1645 Like `ps-print-region', but includes font, color, and underline
1646 information in the generated image. This command works only if you
1647 are using a window system, so it has a way to determine color values."
1648 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg
)))
1649 (ps-print-with-faces from to filename t
))
1653 (defun ps-spool-buffer ()
1654 "Generate and spool a PostScript image of the buffer.
1655 Like `ps-print-buffer' except that the PostScript image is saved in a
1656 local buffer to be sent to the printer later.
1658 Use the command `ps-despool' to send the spooled images to the printer."
1660 (ps-spool-without-faces (point-min) (point-max)))
1664 (defun ps-spool-buffer-with-faces ()
1665 "Generate and spool a PostScript image of the buffer.
1666 Like `ps-spool-buffer', but includes font, color, and underline
1667 information in the generated image. This command works only if you
1668 are using a window system, so it has a way to determine color values.
1670 Use the command `ps-despool' to send the spooled images to the printer."
1672 (ps-spool-with-faces (point-min) (point-max)))
1676 (defun ps-spool-region (from to
)
1677 "Generate a PostScript image of the region and spool locally.
1678 Like `ps-spool-buffer', but spools just the current region.
1680 Use the command `ps-despool' to send the spooled images to the printer."
1682 (ps-spool-without-faces from to t
))
1686 (defun ps-spool-region-with-faces (from to
)
1687 "Generate a PostScript image of the region and spool locally.
1688 Like `ps-spool-region', but includes font, color, and underline
1689 information in the generated image. This command works only if you
1690 are using a window system, so it has a way to determine color values.
1692 Use the command `ps-despool' to send the spooled images to the printer."
1694 (ps-spool-with-faces from to t
))
1697 (defun ps-despool (&optional filename
)
1698 "Send the spooled PostScript to the printer.
1700 Interactively, when you use a prefix argument (C-u), the command
1701 prompts the user for a file name, and saves the spooled PostScript
1702 image in that file instead of sending it to the printer.
1704 More specifically, the FILENAME argument is treated as follows: if it
1705 is nil, send the image to the printer. If FILENAME is a string, save
1706 the PostScript image in a file with that name."
1707 (interactive (list (ps-print-preprint current-prefix-arg
)))
1708 (ps-do-despool filename
))
1711 (defun ps-line-lengths ()
1712 "Display the correspondence between a line length and a font size,
1713 using the current ps-print setup.
1714 Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"
1716 (ps-line-lengths-internal))
1719 (defun ps-nb-pages-buffer (nb-lines)
1720 "Display number of pages to print this buffer, for various font heights.
1721 The table depends on the current ps-print setup."
1722 (interactive (list (count-lines (point-min) (point-max))))
1723 (ps-nb-pages nb-lines
))
1726 (defun ps-nb-pages-region (nb-lines)
1727 "Display number of pages to print the region, for various font heights.
1728 The table depends on the current ps-print setup."
1729 (interactive (list (count-lines (mark) (point))))
1730 (ps-nb-pages nb-lines
))
1734 "Return the current PostScript-generation setup."
1737 \(setq ps-print-color-p %s
1738 ps-lpr-command \"%s\"
1742 ps-landscape-mode %s
1743 ps-number-of-columns %s
1746 ps-zebra-stripe-height %s
1749 ps-print-control-characters %s
1751 ps-print-background-image %s
1753 ps-print-background-text %s
1761 ps-header-line-pad %s
1763 ps-print-header-frame %s
1770 ps-header-font-family '%s
1771 ps-header-font-size %s
1772 ps-header-title-font-size %s)
1779 ps-number-of-columns
1781 ps-zebra-stripe-height
1783 ps-print-control-characters
1784 ps-print-background-image
1785 ps-print-background-text
1794 ps-print-header-frame
1800 ps-header-font-family
1802 ps-header-title-font-size
))
1804 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1805 ;; Utility functions and variables:
1807 (defvar ps-print-emacs-type
1808 (cond ((string-match "XEmacs" emacs-version
) 'xemacs
)
1809 ((string-match "Lucid" emacs-version
) 'lucid
)
1810 ((string-match "Epoch" emacs-version
) 'epoch
)
1813 (if (or (eq ps-print-emacs-type
'lucid
)
1814 (eq ps-print-emacs-type
'xemacs
))
1815 (if (< emacs-minor-version
12)
1816 (setq ps-print-color-p nil
))
1817 (require 'faces
)) ; face-font, face-underline-p,
1820 ;; Return t if the device (which can be changed during an emacs session)
1821 ;; can handle colors.
1822 ;; This is function is not yet implemented for GNU emacs.
1823 (cond ((and (eq ps-print-emacs-type
'xemacs
)
1824 (>= emacs-minor-version
12)) ; xemacs
1825 (defun ps-color-device ()
1826 (eq (device-class) 'color
))
1830 (defun ps-color-device ()
1835 (require 'time-stamp
)
1837 (defvar ps-print-prologue-1
1838 "% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4:
1839 /ISOLatin1Encoding where { pop } {
1840 % -- The ISO Latin-1 encoding vector isn't known, so define it.
1841 % -- The first half is the same as the standard encoding,
1842 % -- except for minus instead of hyphen at code 055.
1844 StandardEncoding 0 45 getinterval aload pop
1846 StandardEncoding 46 82 getinterval aload pop
1847 %*** NOTE: the following are missing in the Adobe documentation,
1848 %*** but appear in the displayed table:
1849 %*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240.
1851 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
1852 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
1853 /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
1854 /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron
1856 /space /exclamdown /cent /sterling
1857 /currency /yen /brokenbar /section
1858 /dieresis /copyright /ordfeminine /guillemotleft
1859 /logicalnot /hyphen /registered /macron
1860 /degree /plusminus /twosuperior /threesuperior
1861 /acute /mu /paragraph /periodcentered
1862 /cedilla /onesuperior /ordmasculine /guillemotright
1863 /onequarter /onehalf /threequarters /questiondown
1865 /Agrave /Aacute /Acircumflex /Atilde
1866 /Adieresis /Aring /AE /Ccedilla
1867 /Egrave /Eacute /Ecircumflex /Edieresis
1868 /Igrave /Iacute /Icircumflex /Idieresis
1869 /Eth /Ntilde /Ograve /Oacute
1870 /Ocircumflex /Otilde /Odieresis /multiply
1871 /Oslash /Ugrave /Uacute /Ucircumflex
1872 /Udieresis /Yacute /Thorn /germandbls
1874 /agrave /aacute /acircumflex /atilde
1875 /adieresis /aring /ae /ccedilla
1876 /egrave /eacute /ecircumflex /edieresis
1877 /igrave /iacute /icircumflex /idieresis
1878 /eth /ntilde /ograve /oacute
1879 /ocircumflex /otilde /odieresis /divide
1880 /oslash /ugrave /uacute /ucircumflex
1881 /udieresis /yacute /thorn /ydieresis
1885 /reencodeFontISO { %def
1887 length 12 add dict % Make a new font (a new dict the same size
1888 % as the old one) with room for our new symbols.
1890 begin % Make the new font the current dictionary.
1894 { def } { pop pop } ifelse
1895 } forall % Copy each of the symbols from the old dictionary
1896 % to the new one except for the font ID.
1898 currentdict /FontType get 0 ne {
1899 /Encoding ISOLatin1Encoding def % Override the encoding with
1900 % the ISOLatin1 encoding.
1903 % Use the font's bounding box to determine the ascent, descent,
1904 % and overall height; don't forget that these values have to be
1905 % transformed using the font's matrix.
1912 % | | | | Ascent (usually > 0)
1914 % (0 0) -> +--+----+-------->
1916 % | | v Descent (usually < 0)
1917 % (x1 y1) --> +----+ - -
1919 currentdict /FontType get 0 ne {
1920 /FontBBox load aload pop % -- x1 y1 x2 y2
1921 FontMatrix transform /Ascent exch def pop
1922 FontMatrix transform /Descent exch def pop
1924 /PrimaryFont FDepVector 0 get def
1925 PrimaryFont /FontBBox get aload pop
1926 PrimaryFont /FontMatrix get transform /Ascent exch def pop
1927 PrimaryFont /FontMatrix get transform /Descent exch def pop
1930 /FontHeight Ascent Descent sub def % use `sub' because descent < 0
1932 % Define these in case they're not in the FontInfo
1933 % (also, here they're easier to get to).
1934 /UnderlinePosition Descent 0.70 mul def
1935 /OverlinePosition Descent UnderlinePosition sub Ascent add def
1936 /StrikeoutPosition Ascent 0.30 mul def
1937 /LineThickness FontHeight 0.05 mul def
1938 /Xshadow FontHeight 0.08 mul def
1939 /Yshadow FontHeight -0.09 mul def
1940 /SpaceBackground Descent neg UnderlinePosition add def
1941 /XBox Descent neg def
1942 /YBox LineThickness 0.7 mul def
1944 currentdict % Leave the new font on the stack
1945 end % Stop using the font as the current dictionary.
1946 definefont % Put the font into the font dictionary
1947 pop % Discard the returned font.
1950 /DefFont { % Font definition
1951 findfont exch scalefont reencodeFontISO
1954 /F { % Font selection
1956 dup /Ascent get /Ascent exch def
1957 dup /Descent get /Descent exch def
1958 dup /FontHeight get /FontHeight exch def
1959 dup /UnderlinePosition get /UnderlinePosition exch def
1960 dup /OverlinePosition get /OverlinePosition exch def
1961 dup /StrikeoutPosition get /StrikeoutPosition exch def
1962 dup /LineThickness get /LineThickness exch def
1963 dup /Xshadow get /Xshadow exch def
1964 dup /Yshadow get /Yshadow exch def
1965 dup /SpaceBackground get /SpaceBackground exch def
1966 dup /XBox get /XBox exch def
1967 dup /YBox get /YBox exch def
1971 /FG /setrgbcolor load def
1984 % | Ascent (usually > 0)
1986 % | Descent (usually < 0)
1990 /dobackground { % width --
1991 currentpoint % -- width x y
1995 0 Ascent rmoveto % B
1997 0 Descent Ascent sub rlineto % D
2000 bgcolor aload pop setrgbcolor
2005 /eolbg { % dobackground until right margin
2006 PrintWidth % -- x-eol
2007 currentpoint pop % -- cur-x
2008 sub % -- width until eol
2012 /PLN {PrintLineNumber {doLineNumber}if} def
2014 /SL { % Soft Linefeed
2016 0 currentpoint exch pop LineHeight sub moveto
2019 /HL {SL PLN} def % Hard Linefeed
2022 /dcp { currentpoint exch 40 string cvs print (, ) print = } def
2023 /dp { print 2 copy exch 40 string cvs print (, ) print = } def
2026 ( ) stringwidth % Get the width of a space in the current font.
2027 pop % Discard the Y component.
2028 mul % Multiply the width of a space
2029 % by the number of spaces to plot
2030 bg { dup dobackground } if
2035 /EF {/Effect exch def} def
2037 % stack: string |- --
2038 % effect: 1 - underline 2 - strikeout 4 - overline
2039 % 8 - shadow 16 - box 32 - outline
2041 /xx currentpoint dup Descent add /yy exch def
2042 Ascent add /YY exch def def
2043 dup stringwidth pop xx add /XX exch def
2045 /yy yy Yshadow add def
2046 /XX XX Xshadow add def
2051 {SpaceBackground doBox}
2052 {xx yy XX YY doRect}
2055 Effect 16 and 0 ne {false 0 doBox}if % box
2056 Effect 8 and 0 ne {dup doShadow}if % shadow
2058 {true doOutline} % outline
2059 {show} % normal text
2061 Effect 1 and 0 ne {UnderlinePosition Hline}if % underline
2062 Effect 2 and 0 ne {StrikeoutPosition Hline}if % strikeout
2063 Effect 4 and 0 ne {OverlinePosition Hline}if % overline
2066 % stack: position |- --
2068 currentpoint exch pop add dup
2074 LineThickness setlinewidth stroke
2078 % stack: fill-or-not delta |- --
2081 xx XBox sub dd sub yy YBox sub dd sub
2082 XX XBox add dd add YY YBox add dd add
2086 % stack: fill-or-not lower-x lower-y upper-x upper-y |- --
2099 % top of stack: fill-or-not
2101 {LineThickness setlinewidth stroke}
2106 % stack: string |- --
2109 Xshadow Yshadow rmoveto
2116 % stack: string fill-or-not |- --
2119 /-ox- currentpoint /-oy- exch def def
2121 LineThickness setlinewidth
2124 st dup true charpath
2125 -fillp- {gsave FillBgColor grestore}if
2127 -oy- add /-oy- exch def
2128 -ox- add /-ox- exch def
2136 /FillBgColor {bgcolor aload pop setrgbcolor fill} bind def
2138 /L0 6 /Times-Italic DefFont
2147 0.0 0.0 0.0 setrgbcolor
2148 /L0 findfont setfont
2151 {LineNumber 6 string cvs ( ) strcat}
2153 dup stringwidth pop neg 0 rmoveto
2157 /LineNumber LineNumber 1 add def
2165 /double-zebra ZebraHeight ZebraHeight add def
2166 /yiter double-zebra LineHeight mul neg def
2167 /xiter PrintWidth InterColumn add def
2168 NumberOfColumns {LinesPerColumn doColumnZebra xiter 0 rmoveto}repeat
2172 % stack: lines-per-column |- --
2175 dup double-zebra idiv {ZebraHeight doZebra 0 yiter rmoveto}repeat
2177 dup 0 le {pop}{dup ZebraHeight gt {pop ZebraHeight}if doZebra}ifelse
2181 % stack: zebra-height (in lines) |- --
2183 /zh exch 0.05 sub LineHeight mul def
2185 0 LineHeight 0.65 mul rmoveto
2186 PrintWidth 0 rlineto
2188 PrintWidth neg 0 rlineto
2194 % tx ty rotation xscale yscale xpos ypos BeginBackImage
2196 /-save-image- save def
2205 -save-image- restore
2208 % string fontsize fontname rotation gray xpos ypos ShowBackText
2214 findfont exch dup /-offset- exch -0.25 mul def scalefont setfont
2216 /-saveLineThickness- LineThickness def
2217 /LineThickness 1 def
2219 /LineThickness -saveLineThickness- def
2224 % ---- Remember space width of the normal text font `f0'.
2225 /SpaceWidth /f0 findfont setfont ( ) stringwidth pop def
2226 % ---- save the state of the document (useful for ghostscript!)
2228 % ---- [jack] Kludge: my ghostscript window is 21x27.7 instead of 21x29.7
2229 /JackGhostscript where {
2230 pop 1 27.7 29.7 div scale
2233 % ---- translate to bottom-right corner of Portrait page
2234 LandscapePageHeight 0 translate
2237 /ColumnWidth PrintWidth InterColumn add def
2238 % ---- translate to lower left corner of TEXT
2239 LeftMargin BottomMargin translate
2240 % ---- define where printing will start
2241 /f0 F % this installs Ascent
2242 /PrintStartY PrintHeight Ascent sub def
2247 % ---- on last page but not last column, spit out the page
2248 ColumnIndex 1 eq not { showpage } if
2249 % ---- restore the state of the document (useful for ghostscript!)
2254 % ---- when 1st column, save the state of the page
2255 ColumnIndex 1 eq { /pageState save def } if
2256 % ---- save the state of the column
2257 /columnState save def
2260 /PrintHeaderWidth PrintOnlyOneHeader{PrintPageWidth}{PrintWidth}ifelse def
2263 % ---- when 1st column, print all background effects
2265 0 PrintStartY moveto % move to where printing will start
2266 Zebra {printZebra}if
2267 printGlobalBackground
2268 printLocalBackground
2271 PrintOnlyOneHeader{ColumnIndex 1 eq}{true}ifelse {
2272 PrintHeaderFrame {HeaderFrame}if
2276 0 PrintStartY moveto % move to where printing will start
2285 ColumnIndex NumberOfColumns eq {
2286 % ---- on last column, spit out the page
2288 % ---- restore the state of the page
2292 % ---- restore the state of the current column
2294 % ---- and translate to the next column
2295 ColumnWidth 0 translate
2296 /ColumnIndex ColumnIndex 1 add def
2300 /SetHeaderLines { % nb-lines --
2301 /HeaderLines exch def
2304 HeaderLines 1 sub HeaderLineHeight mul add
2305 HeaderTitleLineHeight add
2307 /HeaderHeight exch def
2314 % |-+-------| <-- (x y)
2318 % |-+-------| <-- (0 0)
2322 /HeaderFrameStart { % -- x y
2323 0 PrintHeight HeaderOffset add
2327 PrintHeaderWidth 0 rlineto
2328 0 HeaderHeight rlineto
2329 PrintHeaderWidth neg 0 rlineto
2330 0 HeaderHeight neg rlineto
2336 % ---- fill a black rectangle (the shadow of the next one)
2337 HeaderFrameStart moveto
2341 % ---- do the next rectangle ...
2342 HeaderFrameStart moveto
2344 gsave 0.9 setgray fill grestore % filled with grey
2345 gsave 0 setgray stroke grestore % drawn with black
2351 exch HeaderPad add exch % horizontal pad
2353 HeaderPad add % vertical pad
2355 HeaderLineHeight HeaderLines 1 sub mul add
2359 dup length 3 -1 roll dup length dup 4 -1 roll add string dup
2360 0 5 -1 roll putinterval
2361 dup 4 2 roll exch putinterval
2365 PageNumber 32 string cvs
2368 PageCount 32 string cvs strcat
2375 HeaderLinesRight HeaderLinesLeft % -- rightLines leftLines
2377 % ---- hack: `PN 1 and' == `PN 2 modulo'
2379 % ---- if duplex and even page number, then exchange left and right
2380 Duplex PageNumber 1 and 0 eq and { exch } if
2382 { % ---- process the left lines
2386 dup xcheck { exec } if
2389 0 HeaderLineHeight neg rmoveto
2394 { % ---- process the right lines
2398 dup xcheck { exec } if
2400 PrintHeaderWidth exch sub HeaderPad 2 mul sub 0 rmoveto
2403 0 HeaderLineHeight neg rmoveto
2409 /t0 3 1 roll DefFont
2412 /sw ( ) stringwidth pop def
2413 /aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch
2414 stringwidth pop exch div def
2415 /t1 12 /Helvetica-Oblique DefFont
2422 ( point, the line height is ) show
2423 lh 32 string cvs show
2424 (, the space width is ) show
2425 sw 32 string cvs show
2428 0 FontHeight neg rmoveto
2430 (and a crude estimate of average character width is ) show
2431 aw 32 string cvs show
2434 0 FontHeight neg rmoveto
2441 /ReportAllFontInfo {
2443 { % key = font name value = font dictionary
2444 pop 10 exch ReportFontInfo
2448 % 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage
2449 % 3 cm 20 cm moveto ReportAllFontInfo showpage
2453 (defvar ps-print-prologue-2
2455 % ---- These lines must be kept together because...
2458 /HeaderTitleLineHeight FontHeight def
2461 /HeaderLineHeight FontHeight def
2462 /HeaderDescent Descent def
2464 % ---- ...because `F' has a side-effect on `FontHeight' and `Descent'
2468 ;; Start Editing Here:
2470 (defvar ps-source-buffer nil
)
2471 (defvar ps-spool-buffer-name
"*PostScript*")
2472 (defvar ps-spool-buffer nil
)
2474 (defvar ps-output-head nil
)
2475 (defvar ps-output-tail nil
)
2477 (defvar ps-page-postscript
0)
2478 (defvar ps-page-count
0)
2479 (defvar ps-showline-count
1)
2481 (defvar ps-control-or-escape-regexp nil
)
2483 (defvar ps-background-pages nil
)
2484 (defvar ps-background-all-pages nil
)
2485 (defvar ps-background-text-count
0)
2486 (defvar ps-background-image-count
0)
2488 (defvar ps-current-font
0)
2489 (defvar ps-default-color
(if ps-print-color-p ps-default-fg
)) ; black
2490 (defvar ps-current-color ps-default-color
)
2491 (defvar ps-current-bg nil
)
2493 (defvar ps-razchunk
0)
2495 (defvar ps-color-format
2496 (if (eq ps-print-emacs-type
'emacs
)
2498 ;; Emacs understands the %f format; we'll use it to limit color RGB
2499 ;; values to three decimals to cut down some on the size of the
2500 ;; PostScript output.
2503 ;; Lucid emacsen will have to make do with %s (princ) for floats.
2506 ;; These values determine how much print-height to deduct when headers
2507 ;; are turned on. This is a pretty clumsy way of handling it, but
2508 ;; it'll do for now.
2510 (defvar ps-header-pad
0
2511 "Vertical and horizontal space between the header frame and the text.
2512 This is in units of points (1/72 inch).")
2514 ;; Define accessors to the dimensions list.
2516 (defmacro ps-page-dimensions-get-width
(dims) `(nth 0 ,dims
))
2517 (defmacro ps-page-dimensions-get-height
(dims) `(nth 1 ,dims
))
2519 (defvar ps-landscape-page-height nil
)
2521 (defvar ps-print-width nil
)
2522 (defvar ps-print-height nil
)
2524 (defvar ps-height-remaining nil
)
2525 (defvar ps-width-remaining nil
)
2527 (defvar ps-print-color-scale nil
)
2530 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2531 ;; Internal Variables
2534 (defvar ps-print-face-extension-alist nil
2535 "Alist of symbolic faces *WITH* extension features (box, outline, etc).
2536 An element of this list has the following form:
2538 (FACE . [BITS FG BG])
2540 FACE is a symbol denoting a face name
2541 BITS is a bit vector, where each bit correspond
2542 to a feature (bold, underline, etc)
2543 (see documentation for `ps-print-face-map-alist')
2544 FG foreground color (string or nil)
2545 BG background color (string or nil)
2547 Don't change this list directly; instead,
2548 use `ps-extend-face' and `ps-extend-face-list'.
2549 See documentation for `ps-extend-face' for valid extension symbol.")
2552 (defvar ps-print-face-alist nil
2553 "Alist of symbolic faces *WITHOUT* extension features (box, outline, etc).
2555 An element of this list has the same form as an element of
2556 `ps-print-face-extension-alist'.
2558 Don't change this list directly; this list is used by `ps-face-attributes',
2559 `ps-map-face' and `ps-build-reference-face-lists'.")
2562 (defconst ps-print-face-map-alist
2571 "Alist of all features and the corresponding bit mask.
2572 Each symbol correspond to one bit in a bit vector.")
2575 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2580 (defun ps-extend-face-list (face-extension-list &optional merge-p
)
2581 "Extend face in `ps-print-face-extension-alist'.
2583 If optional MERGE-P is non-nil, extensions in FACE-EXTENSION-LIST are merged
2584 with face extension in `ps-print-face-extension-alist'; otherwise, overrides.
2586 The elements in FACE-EXTENSION-LIST is like those for `ps-extend-face'.
2588 See `ps-extend-face' for documentation."
2589 (while face-extension-list
2590 (ps-extend-face (car face-extension-list
) merge-p
)
2591 (setq face-extension-list
(cdr face-extension-list
))))
2595 (defun ps-extend-face (face-extension &optional merge-p
)
2596 "Extend face in `ps-print-face-extension-alist'.
2598 If optional MERGE-P is non-nil, extensions in FACE-EXTENSION list are merged
2599 with face extensions in `ps-print-face-extension-alist'; otherwise, overrides.
2601 The elements of FACE-EXTENSION list have the form:
2603 (FACE-NAME FOREGROUND BACKGROUND EXTENSION...)
2605 FACE-NAME is a face name symbol.
2607 FOREGROUND and BACKGROUND may be nil or a string that denotes the
2608 foreground and background colors respectively.
2610 EXTENSION is one of the following symbols:
2611 bold - use bold font.
2612 italic - use italic font.
2613 underline - put a line under text.
2614 strikeout - like underline, but the line is in middle of text.
2615 overline - like underline, but the line is over the text.
2616 shadow - text will have a shadow.
2617 box - text will be surrounded by a box.
2618 outline - print characters as hollow outlines.
2620 If EXTENSION is any other symbol, it is ignored."
2621 (let* ((face-name (nth 0 face-extension
))
2622 (foreground (nth 1 face-extension
))
2623 (background (nth 2 face-extension
))
2624 (ps-face (cdr (assq face-name ps-print-face-extension-alist
)))
2625 (face-vector (or ps-face
(vector 0 nil nil
)))
2626 (face-bit (ps-extension-bit face-extension
)))
2628 (aset face-vector
0 (if merge-p
2629 (logior (aref face-vector
0) face-bit
)
2631 (and foreground
(stringp foreground
) (aset face-vector
1 foreground
))
2632 (and background
(stringp background
) (aset face-vector
2 background
))
2633 ;; if face does not exist, insert it
2635 (setq ps-print-face-extension-alist
2636 (cons (cons face-name face-vector
)
2637 ps-print-face-extension-alist
)))))
2640 (defun ps-extension-bit (face-extension)
2642 ;; map valid symbol extension to bit vector
2643 (setq face-extension
(cdr (cdr face-extension
)))
2644 (while (setq face-extension
(cdr face-extension
))
2645 (setq face-bit
(logior face-bit
2646 (or (cdr (assq (car face-extension
)
2647 ps-print-face-map-alist
))
2652 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2653 ;; Adapted from font-lock:
2654 ;; Originally face attributes were specified via `font-lock-face-attributes'.
2655 ;; Users then changed the default face attributes by setting that variable.
2656 ;; However, we try and be back-compatible and respect its value if set except
2657 ;; for faces where M-x customize has been used to save changes for the face.
2659 (defun ps-font-lock-face-attributes ()
2660 (and (boundp 'font-lock-mode
) (symbol-value 'font-lock-mode
)
2661 (boundp 'font-lock-face-attributes
)
2662 (let ((face-attributes font-lock-face-attributes
))
2663 (while face-attributes
2664 (let* ((face-attribute
2665 (car (prog1 face-attributes
2666 (setq face-attributes
(cdr face-attributes
)))))
2667 (face (car face-attribute
)))
2668 ;; Rustle up a `defface' SPEC from a
2669 ;; `font-lock-face-attributes' entry.
2670 (unless (get face
'saved-face
)
2671 (let ((foreground (nth 1 face-attribute
))
2672 (background (nth 2 face-attribute
))
2673 (bold-p (nth 3 face-attribute
))
2674 (italic-p (nth 4 face-attribute
))
2675 (underline-p (nth 5 face-attribute
))
2678 (setq face-spec
(cons ':foreground
2679 (cons foreground face-spec
))))
2681 (setq face-spec
(cons ':background
2682 (cons background face-spec
))))
2684 (setq face-spec
(append '(:bold t
) face-spec
)))
2686 (setq face-spec
(append '(:italic t
) face-spec
)))
2688 (setq face-spec
(append '(:underline t
) face-spec
)))
2689 (custom-declare-face face
(list (list t face-spec
)) nil
)
2693 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2694 ;; Internal functions and variables
2697 (make-local-hook 'ps-print-hook
)
2698 (make-local-hook 'ps-print-begin-page-hook
)
2699 (make-local-hook 'ps-print-begin-column-hook
)
2702 (defun ps-print-without-faces (from to
&optional filename region-p
)
2703 (ps-spool-without-faces from to region-p
)
2704 (ps-do-despool filename
))
2707 (defun ps-spool-without-faces (from to
&optional region-p
)
2708 (run-hooks 'ps-print-hook
)
2709 (ps-printing-region region-p
)
2710 (ps-generate (current-buffer) from to
'ps-generate-postscript
))
2713 (defun ps-print-with-faces (from to
&optional filename region-p
)
2714 (ps-spool-with-faces from to region-p
)
2715 (ps-do-despool filename
))
2718 (defun ps-spool-with-faces (from to
&optional region-p
)
2719 (run-hooks 'ps-print-hook
)
2720 (ps-printing-region region-p
)
2721 (ps-generate (current-buffer) from to
'ps-generate-postscript-with-faces
))
2724 (defsubst ps-count-lines
(from to
)
2725 (+ (count-lines from to
)
2728 (if (= (current-column) 0) 1 0))))
2731 (defvar ps-printing-region nil
2732 "Variable used to indicate if ps-print is printing a region.
2733 If non-nil, it is a cons, the car of which is the line number
2734 where the region begins, and its cdr is the total number of lines
2735 in the buffer. Formatting functions can use this information
2736 to print the original line number (and not the number of lines printed),
2737 and to indicate in the header that the printout is of a partial file.")
2740 (defun ps-printing-region (region-p)
2741 (setq ps-printing-region
2743 (cons (ps-count-lines (point-min) (region-beginning))
2744 (ps-count-lines (point-min) (point-max))))))
2747 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2748 ;; Internal functions
2750 (defsubst ps-font-alist
(font-sym)
2751 (get font-sym
'fonts
))
2753 (defun ps-font (font-sym font-type
)
2754 "Font family name for text of `font-type', when generating PostScript."
2755 (let* ((font-list (ps-font-alist font-sym
))
2756 (normal-font (cdr (assq 'normal font-list
))))
2757 (while (and font-list
(not (eq font-type
(car (car font-list
)))))
2758 (setq font-list
(cdr font-list
)))
2759 (or (cdr (car font-list
)) normal-font
)))
2761 (defun ps-fonts (font-sym)
2762 (mapcar 'cdr
(ps-font-alist font-sym
)))
2764 (defun ps-font-number (font-sym font-type
)
2765 (or (ps-alist-position font-type
(ps-font-alist font-sym
))
2768 (defsubst ps-line-height
(font-sym)
2769 "The height of a line, for generating PostScript.
2770 This is the value that ps-print uses to determine the height,
2771 y-dimension, of the lines of text it has printed, and thus affects the
2772 point at which page-breaks are placed.
2773 The line-height is *not* the same as the point size of the font."
2774 (get font-sym
'line-height
))
2776 (defsubst ps-title-line-height
(font-sym)
2777 "The height of a `title' line, for generating PostScript.
2778 This is the value that ps-print uses to determine the height,
2779 y-dimension, of the lines of text it has printed, and thus affects the
2780 point at which page-breaks are placed.
2781 The title-line-height is *not* the same as the point size of the font."
2782 (get font-sym
'title-line-height
))
2784 (defsubst ps-space-width
(font-sym)
2785 "The width of a space character, for generating PostScript.
2786 This value is used in expanding tab characters."
2787 (get font-sym
'space-width
))
2789 (defsubst ps-avg-char-width
(font-sym)
2790 "The average width, in points, of a character, for generating PostScript.
2791 This is the value that ps-print uses to determine the length,
2792 x-dimension, of the text it has printed, and thus affects the point at
2793 which long lines wrap around."
2794 (get font-sym
'avg-char-width
))
2797 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2798 ;; For handling multibyte characters.
2800 ;; The following comments apply only to this part (through the next ^L).
2801 ;; Author: Kenichi Handa <handa@etl.go.jp>
2802 ;; Maintainer: Kenichi Handa <handa@etl.go.jp>
2805 (if (fboundp 'set-buffer-multibyte
)
2807 (defalias 'ps-mule-next-point
'1+)
2808 (defalias 'ps-mule-chars-in-string
'length
)
2809 (defalias 'ps-mule-string-char
'aref
)
2810 (defsubst ps-mule-next-index
(str i
) (1+ i
)))
2811 (defun set-buffer-multibyte (arg)
2812 (setq enable-multibyte-characters arg
))
2813 (defun string-as-unibyte (arg) arg
)
2814 (defun string-as-multibyte (arg) arg
)
2815 (defun charset-after (&optional arg
)
2816 (char-charset (char-after arg
)))
2817 (defun ps-mule-next-point (arg)
2818 (save-excursion (goto-char arg
) (forward-char 1) (point)))
2819 (defun ps-mule-chars-in-string (string)
2821 (defalias 'ps-mule-string-char
'aref
)
2822 (defun ps-mule-next-index (str i
)
2826 (defvar ps-mule-font-info-database
2828 (normal nil nil iso-latin-1
)))
2829 "Alist of charsets vs the corresponding font information.
2830 Each element has the form:
2831 (CHARSET (FONT-TYPE FONT-SRC FONT-NAME ENCODING BYTES) ...)
2834 CHARSET is a charset (symbol) for this font family,
2836 FONT-TYPE is a type of font: normal, bold, italic, or bold-italic.
2838 FONT-SRC is a source of font: builtin, bdf, vflib, or nil.
2840 If FONT-SRC is builtin, FONT-NAME is a buitin PostScript font name.
2842 If FONT-SRC is bdf, FONT-NAME is a BDF font file name. To use this
2843 font, the external library `bdf' is required.
2845 If FONT-SRC is vflib, FONT-NAME is name of font VFlib knows. To use
2846 this font, the external library `vflib' is required.
2848 If FONT-SRC is nil, a proper ASCII font in the variable
2849 `ps-font-info-database' is used. This is useful for Latin-1
2852 ENCODING is a coding system to encode a string of characters of
2853 CHARSET into a proper string matching an encoding of the specified
2854 font. ENCODING may be a function to call to do this encoding. In
2855 this case, the function is called with one arguemnt, the string to
2856 encode, and it should return an encoded string.
2858 BYTES specifies how many bytes in encoded byte sequence construct esch
2859 character, it should be 1 or 2.
2861 All multibyte characters are printed by fonts specified in this
2862 database regardless of a font family of ASCII characters. The
2863 exception is Latin-1 characters which are printed by the same font as
2864 ASCII characters, thus obey font family.
2866 See also the variable `ps-font-info-database'.")
2868 (defconst ps-mule-font-info-database-ps
2869 '((katakana-jisx0201
2870 (normal builtin
"Ryumin-Light.Katakana" ps-mule-encode-7bit
1)
2871 (bold builtin
"GothicBBB-Medium.Katakana" ps-mule-encode-7bit
1)
2872 (bold-italic builtin
"GothicBBB-Medium.Katakana" ps-mule-encode-7bit
1))
2874 (normat builtin
"Ryumin-Light.Hankaku" ps-mule-encode-7bit
1)
2875 (bold builtin
"GothicBBB-Medium.Hankaku" ps-mule-encode-7bit
1))
2877 (normal builtin
"Ryumin-Light-H" ps-mule-encode-7bit
2)
2878 (bold builtin
"GothicBBB-Medium-H" ps-mule-encode-7bit
2))
2880 (normal builtin
"Batang-Medium-KSC-H" ps-mule-encode-7bit
2)
2881 (bold builtin
" Gulim-Medium-KSC-H" ps-mule-encode-7bit
2))
2883 "Sample setting of the `ps-mule-font-info-database' to use builtin PS font.
2885 Currently, data for Japanese and Korean PostScript printers are listed.")
2887 (defconst ps-mule-font-info-database-bdf
2889 (normal bdf
"etl24-latin1.bdf" nil
1)
2890 (bold bdf
"etl16b-latin1.bdf" iso-latin-1
1)
2891 (italic bdf
"etl16i-latin1.bdf" iso-latin-1
1)
2892 (bold-italic bdf
"etl16bi-latin1.bdf" iso-latin-1
1))
2894 (normal bdf
"etl24-latin1.bdf" iso-latin-1
1)
2895 (bold bdf
"etl16b-latin1.bdf" iso-latin-1
1)
2896 (italic bdf
"etl16i-latin1.bdf" iso-latin-1
1)
2897 (bold-italic bdf
"etl16bi-latin1.bdf" iso-latin-1
1))
2899 (normal bdf
"etl24-latin2.bdf" iso-latin-2
1))
2901 (normal bdf
"etl24-latin3.bdf" iso-latin-3
1))
2903 (normal bdf
"etl24-latin4.bdf" iso-latin-4
1))
2905 (normal bdf
"thai-24.bdf" thai-tis620
1))
2907 (normal bdf
"etl24-greek.bdf" greek-iso-8bit
1))
2908 ;; (arabic-iso8859-6 nil) ; not yet available
2910 (normal bdf
"etl24-hebrew.bdf" hebrew-iso-8bit
1))
2912 (normal bdf
"12x24rk.bdf" ps-mule-encode-8bit
1))
2914 (normal bdf
"12x24rk.bdf" ps-mule-encode-7bit
1))
2916 (normal bdf
"etl24-cyrillic.bdf" cyrillic-iso-8bit
1))
2918 (normal bdf
"etl24-latin5.bdf" iso-latin-5
1))
2919 (japanese-jisx0208-1978
2920 (normal bdf
"jiskan24.bdf" ps-mule-encode-7bit
2))
2922 (normal bdf
"gb24st.bdf" ps-mule-encode-7bit
2))
2924 (normal bdf
"jiskan24.bdf" ps-mule-encode-7bit
2))
2926 (normal bdf
"hanglm24.bdf" ps-mule-encode-7bit
2))
2928 (normal bdf
"jisksp40.bdf" ps-mule-encode-7bit
2))
2930 (normal bdf
"cns-1-40.bdf" ps-mule-encode-7bit
2))
2932 (normal bdf
"cns-2-40.bdf" ps-mule-encode-7bit
2))
2934 (normal bdf
"taipei24.bdf" chinese-big5
2))
2936 (normal bdf
"taipei24.bdf" chinese-big5
2))
2938 (normal bdf
"etl24-sisheng.bdf" ps-mule-encode-8bit
1))
2940 (normal bdf
"etl24-ipa.bdf" ps-mule-encode-8bit
1))
2941 (vietnamese-viscii-lower
2942 (normal bdf
"etl24-viscii.bdf" vietnamese-viscii
1))
2943 (vietnamese-viscii-upper
2944 (normal bdf
"etl24-viscii.bdf" vietnamese-viscii
1))
2946 (normal bdf
"etl24-arabic0.bdf" ps-mule-encode-7bit
1))
2948 (normal bdf
"etl24-arabic1.bdf" ps-mule-encode-7bit
1))
2949 ;; (ascii-right-to-left nil) ; not yet available
2951 (normal bdf
"mule-lao-24.bdf" lao
1))
2953 (normal bdf
"etl24-arabic2.bdf" ps-mule-encode-7bit
1))
2955 (normal bdf
"mule-iscii-24.bdf" ps-mule-encode-7bit
1))
2957 (normal bdf
"mule-indian-1col-24.bdf" ps-mule-encode-7bit
2))
2959 (normal bdf
"mule-tibmdx-1col-24.bdf" ps-mule-encode-7bit
2))
2961 (normal bdf
"ethiomx24f-uni.bdf" ps-mule-encode-ethiopic
2))
2963 (normal bdf
"cns-3-40.bdf" ps-mule-encode-7bit
2))
2965 (normal bdf
"cns-4-40.bdf" ps-mule-encode-7bit
2))
2967 (normal bdf
"cns-5-40.bdf" ps-mule-encode-7bit
2))
2969 (normal bdf
"cns-6-40.bdf" ps-mule-encode-7bit
2))
2971 (normal bdf
"cns-7-40.bdf" ps-mule-encode-7bit
2))
2973 (normal bdf
"mule-indian-24.bdf" ps-mule-encode-7bit
2))
2975 (normal bdf
"mule-tibmdx-24.bdf" ps-mule-encode-7bit
2)))
2976 "Sample setting of the `ps-mule-font-info-database' to use BDF fonts.
2977 BDF (Bitmap Distribution Format) is a format used for distributing
2978 X's font source file.
2980 Current default value lists BDF fonts included in `intlfonts-1.1'
2981 which is a collection of X11 fonts for all characters supported by
2984 With the default value, all characters including ASCII and Latin-1 are
2985 printed by BDF fonts. See also `ps-mule-font-info-database-ps-bdf'.")
2987 (defconst ps-mule-font-info-database-ps-bdf
2988 (cons '(latin-iso8859-1
2989 (normal nil nil iso-latin-1
))
2990 (cdr (cdr ps-mule-font-info-database-bdf
)))
2991 "Sample setting of the `ps-mule-font-info-database to use BDF fonts.
2993 Current default value lists BDF fonts included in `intlfonts-1.1'
2994 which is a collection of X11 fonts for all characters supported by
2997 With the default value, all characters except for ASCII and Latin-1 are
2998 printed by BDF fonts. ASCII and Latin-1 charcaters are printed by
2999 PostScript font specified by `ps-font-family'.
3001 See also `ps-mule-font-info-database-bdf'.")
3003 ;; Two typical encoding functions for PostScript fonts.
3005 (defun ps-mule-encode-7bit (string)
3006 (let* ((dim (charset-dimension
3007 (char-charset (ps-mule-string-char string
0))))
3008 (len (* (ps-mule-chars-in-string string
) dim
))
3009 (str (make-string len
0))
3013 (aset str j
(nth 1 (split-char (ps-mule-string-char string i
))))
3014 (setq i
(ps-mule-next-index string i
)
3017 (let ((split (split-char (ps-mule-string-char string i
))))
3018 (aset str j
(nth 1 split
))
3019 (aset str
(1+ j
) (nth 2 split
))
3020 (setq i
(ps-mule-next-index string i
)
3024 (defun ps-mule-encode-8bit (string)
3025 (let* ((dim (charset-dimension
3026 (char-charset (ps-mule-string-char string
0))))
3027 (len (* (ps-mule-chars-in-string string
) dim
))
3028 (str (make-string len
0))
3033 (+ (nth 1 (split-char (ps-mule-string-char string i
))) 128))
3034 (setq i
(ps-mule-next-index string i
)
3037 (let ((split (split-char (ps-mule-string-char string i
))))
3038 (aset str j
(+ (nth 1 split
) 128))
3039 (aset str
(1+ j
) (+ (nth 2 split
) 128))
3040 (setq i
(ps-mule-next-index string i
)
3044 ;; Special encoding function for Ethiopic.
3045 (define-ccl-program ccl-encode-ethio-unicode
3049 (if (r2 == ,leading-code-private-22
)
3051 (if (r0 == ,(charset-id 'ethiopic
))
3053 (r1 &= 127) (r2 &= 127)
3054 (call ccl-encode-ethio-font
)
3056 (write-read-repeat r2
))
3059 (write-read-repeat r2
))))))
3061 (defun ps-mule-encode-ethiopic (string)
3062 (ccl-execute-on-string (symbol-value 'ccl-encode-ethio-unicode
)
3066 ;; A charset which we are now processing.
3067 (defvar ps-mule-current-charset nil
)
3069 (defun ps-mule-get-font-spec (charset font-type
)
3070 "Return FONT-SPEC for printing characters CHARSET with FONT-TYPE.
3071 FONT-SPEC is a list of FONT-SRC, FONT-NAME, ENCODING, and BYTES,
3072 this information is extracted from `ps-mule-font-info-database'
3073 See the documentation of `ps-mule-font-info-database' for the meaning
3074 of each element of the list."
3075 (let ((slot (cdr (assq charset ps-mule-font-info-database
))))
3077 (cdr (or (assq font-type slot
)
3078 (and (eq font-type
'bold-italic
)
3079 (or (assq 'bold slot
) (assq 'italic slot
)))
3080 (assq 'normal slot
))))))
3082 ;; Functions to access each element of FONT-SPEC.
3083 (defsubst ps-mule-font-spec-src
(font-spec) (car font-spec
))
3084 (defsubst ps-mule-font-spec-name
(font-spec) (nth 1 font-spec
))
3085 (defsubst ps-mule-font-spec-encoding
(font-spec) (nth 2 font-spec
))
3086 (defsubst ps-mule-font-spec-bytes
(font-spec) (nth 3 font-spec
))
3088 (defsubst ps-mule-printable-p
(charset)
3089 "Non-nil if characters in CHARSET is printable."
3090 (ps-mule-get-font-spec charset
'normal
))
3092 (defconst ps-mule-external-libraries
3096 bdf-generate-prologue bdf-generate-font bdf-generate-glyphs
)
3098 pcf-generate-prologue pcf-generate-font pcf-generate-glyphs
)
3100 vflib-generate-prologue vflib-generate-font vflib-generate-glyphs
))
3101 "Alist of information of external libraries to support PostScript printing.
3102 Each element has the form:
3103 (FONT-SRC INITIALIZED-P PROLOGUE-FUNC FONT-FUNC GLYPHS-FUNC)
3105 FONT-SRC is a source of font: builtin, bdf, pcf, or vflib. Except for
3106 builtin, libraries of the same names are necessary, but currently, we
3107 only have the library `bdf'.
3109 INITIALIZED-P is a flag to tell this library is initialized or not.
3111 PROLOGUE-FUNC is a function to call to get a PostScript codes which
3112 define procedures to use this library. It is called with no argument,
3113 and should return a list of strings.
3115 FONT-FUNC is a function to call to get a PostScript codes which define
3116 a new font. It is called with one argument FONT-SPEC, and should
3117 return a list of strings.
3119 GLYPHS-FUNC is a function to call to get a PostScript codes which
3120 define glyphs of characters. It is called with three arguments
3121 FONT-SPEC, CODE-LIST, and BYTES, and should return a list of strings.")
3123 (defun ps-mule-init-external-library (font-spec)
3124 "Initialize external librarie specified in FONT-SPEC for PostScript printing.
3125 See the documentation of `ps-mule-get-font-spec' for the meaning of
3126 each element of the list."
3127 (let* ((font-src (ps-mule-font-spec-src font-spec
))
3128 (slot (assq font-src ps-mule-external-libraries
)))
3131 (let ((func (nth 2 slot
)))
3134 (or (featurep font-src
) (require font-src
))
3135 (ps-output-prologue (funcall func
))))
3136 (setcar (cdr slot
) t
)))))
3138 ;; Cached glyph information of fonts, alist of:
3139 ;; (FONT-NAME ((FONT-TYPE-NUMBER . SCALED-FONT-NAME) ...)
3140 ;; cache CODE0 CODE1 ...)
3141 (defvar ps-mule-font-cache nil
)
3143 (defun ps-mule-generate-font (font-spec charset
)
3144 "Generate PostScript codes to define a new font in FONT-SPEC for CHARSET."
3145 (let* ((font-cache (assoc (ps-mule-font-spec-name font-spec
)
3146 ps-mule-font-cache
))
3147 (font-src (ps-mule-font-spec-src font-spec
))
3148 (font-name (ps-mule-font-spec-name font-spec
))
3149 (func (nth 3 (assq font-src ps-mule-external-libraries
)))
3151 (if (eq charset
'ascii
)
3152 (format "f%d" ps-current-font
)
3154 (charset-id charset
) ps-current-font
))))
3155 (if (and func
(not font-cache
))
3156 (ps-output-prologue (funcall func charset font-spec
)))
3158 (list (format "/%s %f /%s Def%sFontMule\n"
3159 scaled-font-name ps-font-size font-name
3160 (if (eq ps-mule-current-charset
'ascii
) "Ascii" ""))))
3162 (setcar (cdr font-cache
)
3163 (cons (cons ps-current-font scaled-font-name
)
3164 (nth 1 font-cache
)))
3165 (setq font-cache
(list font-name
3166 (list (cons ps-current-font scaled-font-name
))
3168 (setq ps-mule-font-cache
(cons font-cache ps-mule-font-cache
)))
3171 (defun ps-mule-generate-glyphs (font-spec code-list
)
3172 "Generate PostScript codes which generate glyphs for CODE-LIST of FONT-SPEC."
3173 (let* ((font-src (ps-mule-font-spec-src font-spec
))
3174 (func (nth 4 (assq font-src ps-mule-external-libraries
))))
3177 (funcall func font-spec code-list
3178 (ps-mule-font-spec-bytes font-spec
))))))
3180 (defvar ps-last-font nil
)
3182 (defun ps-mule-prepare-font (font-spec string charset
&optional no-setfont
)
3183 "Generate PostScript codes to print STRING of CHARSET by font in FONT-SPEC.
3184 The generated codes goes to prologue part except for a code for
3185 setting the current font (using PostScript procedure `FM').
3186 If optional arg NO-SETFONT is non-nil, don't generate the code for
3187 setting the current font."
3188 (let ((font-cache (assoc (ps-mule-font-spec-name font-spec
)
3189 ps-mule-font-cache
)))
3190 (or (and font-cache
(assq ps-current-font
(nth 1 font-cache
)))
3191 (setq font-cache
(ps-mule-generate-font font-spec charset
)))
3193 (let ((new-font (cdr (assq ps-current-font
(nth 1 font-cache
)))))
3194 (or (equal new-font ps-last-font
)
3196 (ps-output (format "/%s FM\n" new-font
))
3197 (setq ps-last-font new-font
)))))
3198 (if (nth 4 (assq (ps-mule-font-spec-src font-spec
)
3199 ps-mule-external-libraries
))
3200 ;; We have to generate PostScript codes which define glyphs.
3201 (let* ((cached-codes (nthcdr 2 font-cache
))
3203 (bytes (ps-mule-font-spec-bytes font-spec
))
3204 (len (length string
))
3209 (if (= bytes
1) (aref string i
)
3210 (+ (* (aref string i
) 256) (aref string
(1+ i
)))))
3211 (or (memq code cached-codes
)
3213 (setq newcodes
(cons code newcodes
))
3214 (setcdr cached-codes
(cons code
(cdr cached-codes
)))))
3215 (setq i
(+ i bytes
)))
3217 (ps-mule-generate-glyphs font-spec newcodes
))))))
3219 ;; List of charsets of multibyte characters in a text being printed.
3220 ;; If the text doesn't contain any multibyte characters (i.e. only
3221 ;; ASCII), the value is nil.
3222 (defvar ps-mule-charset-list nil
)
3224 ;; This constant string is a PostScript code embeded as is in the
3225 ;; header of generated PostScript.
3227 (defvar ps-mule-prologue-generated nil
)
3229 (defconst ps-mule-prologue
3230 "%%%% Start of Mule Section
3232 %% Working dictionaly for general use.
3233 /MuleDict 10 dict def
3235 %% Define already scaled font for non-ASCII character sets.
3236 /DefFontMule { % fontname size basefont |- --
3237 findfont exch scalefont definefont pop
3240 %% Define already scaled font for ASCII character sets.
3241 /DefAsciiFontMule { % fontname size basefont |-
3243 findfont dup /Encoding get /ISOLatin1Encoding exch def
3244 exch scalefont reencodeFontISO
3248 %% Set the specified non-ASCII font to use. It doesn't install
3250 /FM { % fontname |- --
3254 %% Show vacant box for characters which don't have appropriate font.
3255 /SB { % count column |- --
3256 SpaceWidth mul /w exch def
3257 1 exch 1 exch { %for
3261 0 Descent rmoveto w 0 rlineto
3262 0 LineHeight rlineto w neg 0 rlineto closepath stroke
3268 %% Flag to tell if we are now handling a composite character. This is
3269 %% defined here because both composite character handler and bitmap font
3270 %% handler require it.
3273 %%%% End of Mule Section
3276 "PostScript code for printing multibyte characters.")
3278 (defun ps-mule-skip-same-charset (charset)
3279 "Skip characters of CHARSET following the current point."
3280 (while (eq (charset-after) charset
) (forward-char 1)))
3282 (defun ps-mule-find-wrappoint (from to char-width
)
3283 "Find a longest sequence at FROM which is printable in the current line.
3285 TO limits the sequence. It is assumed that all characters between
3286 FROM and TO belong to a charset set in `ps-mule-current-charset'.
3288 CHAR-WIDTH is an average width of ASCII characters in the current font.
3290 The return value is a cons of ENDPOS and RUN-WIDTH, where
3291 ENDPOS is an end position of the sequence,
3292 RUN-WIDTH is the width of the sequence."
3294 (if (eq ps-mule-current-charset
'composition
)
3295 ;; We must draw one char by one.
3296 (let ((ch (char-after from
)))
3297 (setq run-width
(* (char-width ch
) char-width
))
3298 (if (> run-width ps-width-remaining
)
3299 (setq run-width ps-width-remaining
)
3300 (setq from
(ps-mule-next-point from
))))
3301 ;; We assume that all characters in this range have the same width.
3302 (let ((width (charset-width ps-mule-current-charset
)))
3303 (setq run-width
(* (- to from
) char-width width
))
3304 (if (> run-width ps-width-remaining
)
3306 (+ from
(truncate (/ ps-width-remaining char-width
)))
3308 run-width ps-width-remaining
)
3310 (cons from run-width
)))
3312 (defun ps-mule-plot-string (from to
&optional bg-color
)
3313 "Generate PostScript code for ploting characters in the region FROM and TO.
3314 It is assumed that all characters in this region belong to the
3315 charset `ps-mule-current-charset'.
3316 Optional arg BG-COLOR specifies background color.
3317 The return value is a cons of ENDPOS and WIDTH of the sequence
3318 actually plotted by this function."
3319 (let* ((wrappoint (ps-mule-find-wrappoint
3320 from to
(ps-avg-char-width 'ps-font-for-text
)))
3321 (to (car wrappoint
))
3322 (font-type (car (nth ps-current-font
3323 (ps-font-alist 'ps-font-for-text
))))
3324 (font-spec (ps-mule-get-font-spec ps-mule-current-charset font-type
))
3325 (encoding (ps-mule-font-spec-encoding font-spec
))
3326 (string (buffer-substring-no-properties from to
)))
3329 ;; We can't print any more characters in the current line.
3333 ;; We surely have a font for printing this character set.
3334 (if (coding-system-p encoding
)
3335 (setq string
(encode-coding-string string encoding
))
3336 (if (functionp encoding
)
3337 (setq string
(funcall encoding string
))
3339 (error "Invalid coding system or function: %s" encoding
))))
3340 (setq string
(string-as-unibyte string
))
3341 (if (ps-mule-font-spec-src font-spec
)
3342 (ps-mule-prepare-font font-spec string ps-mule-current-charset
)
3343 (ps-set-font ps-current-font
))
3344 (ps-output-string string
)
3347 ((eq ps-mule-current-charset
'latin-iso8859-1
)
3348 ;; Latin-1 can be printed by a normal ASCII font.
3349 (ps-set-font ps-current-font
)
3351 (string-as-unibyte (encode-coding-string string
'iso-latin-1
)))
3354 ((eq ps-mule-current-charset
'composition
)
3355 (let* ((ch (char-after from
))
3356 (width (char-width ch
))
3357 (ch-list (decompose-composite-char ch
'list t
)))
3358 (if (consp (nth 1 ch-list
))
3359 (ps-mule-plot-rule-cmpchar ch-list width font-type
)
3360 (ps-mule-plot-cmpchar ch-list width t font-type
))))
3363 ;; No way to print this charset. Just show a vacant box of an
3364 ;; appropriate width.
3365 (ps-output (format "%d %d SB\n"
3367 (if (eq ps-mule-current-charset
'composition
)
3368 (char-width (char-after from
))
3369 (charset-width ps-mule-current-charset
))))))
3372 ;; Composite font support
3374 (defvar ps-mule-cmpchar-prologue-generated nil
)
3376 (defconst ps-mule-cmpchar-prologue
3377 "%%%% Composite character handler
3379 /CmpcharRelativeCompose 0 def
3380 /CmpcharRelativeSkip 0.4 def
3382 %% Get a bounding box (relative to currentpoint) of STR.
3383 /GetPathBox { % str |- --
3385 currentfont /FontType get 3 eq { %ifelse
3388 currentpoint /y exch def pop
3389 false charpath flattenpath pathbbox
3390 y sub /URY exch def pop
3391 y sub /LLY exch def pop
3396 %% Beginning of composite char.
3397 /BC { % str xoff width |- --
3399 /CmpcharWidth exch def
3400 currentfont /RelativeCompose known {
3401 /CmpcharRelativeCompose currentfont /RelativeCompose get def
3403 /CmpcharRelativeCompose false def
3405 /bgsave bg def /bgcolorsave bgcolor def
3406 /Effectsave Effect def
3407 gsave % Reflect effect only at first
3408 /Effect Effect 1 2 add 4 add 16 add and def
3409 /f0 findfont setfont ( ) 0 CmpcharWidth getinterval S
3411 /Effect Effectsave 8 32 add and def % enable only shadow and outline
3413 gsave SpaceWidth mul 0 rmoveto dup GetPathBox S grestore
3414 /y currentpoint exch pop def
3415 /HIGH URY y add def /LOW LLY y add def
3418 %% End of composite char.
3420 /bg bgsave def /bgcolor bgcolorsave def
3421 /Effect Effectsave def
3423 CmpcharWidth SpaceWidth mul 0 rmoveto
3426 %% Rule base composition
3427 /RBC { % str xoff gref nref |- --
3428 /nref exch def /gref exch def
3430 SpaceWidth mul 0 rmoveto
3433 [ HIGH currentpoint exch pop LOW HIGH LOW add 2 div ] gref get
3434 [ URY LLY sub LLY neg 0 URY LLY sub 2 div ] nref get
3436 /top btm URY LLY sub add def
3437 top HIGH gt { /HIGH top def } if
3438 btm LOW lt { /LOW btm def } if
3439 currentpoint pop btm LLY sub moveto
3444 %% Relative composition
3448 CmpcharRelativeCompose type /integertype eq {
3449 LLY CmpcharRelativeCompose gt { % compose on top
3450 currentpoint pop HIGH LLY sub CmpcharRelativeSkip add moveto
3451 /HIGH HIGH URY LLY sub add CmpcharRelativeSkip add def
3452 } { URY 0 le { % compose under bottom
3453 currentpoint pop LOW LLY add CmpcharRelativeSkip sub moveto
3454 /LOW LOW URY LLY sub sub CmpcharRelativeSkip sub def
3459 %%%% End of composite character handler
3462 "PostScript code for printing composite characters.")
3464 (defun ps-mule-plot-rule-cmpchar (ch-rule-list total-width font-type
)
3465 (let* ((leftmost 0.0)
3466 (rightmost (float (char-width (car ch-rule-list
))))
3467 (l (cons '(3 .
3) ch-rule-list
))
3468 (cmpchar-elements nil
))
3470 (let* ((this (car l
))
3473 ;; X-axis info (0:left, 1:center, 2:right)
3476 ;; Y-axis info (0:top, 1:base, 2:bottom, 3:center)
3477 (gref-y (if (= gref
4) 3 (/ gref
3)))
3478 (nref-y (if (= nref
4) 3 (/ nref
3)))
3479 (width (float (char-width (car (cdr l
)))))
3481 (setq left
(+ leftmost
3482 (/ (* (- rightmost leftmost
) gref-x
) 2.0)
3483 (- (/ (* nref-x width
) 2.0))))
3484 (setq cmpchar-elements
3485 (cons (list (car (cdr l
)) left gref-y nref-y
) cmpchar-elements
))
3486 (if (< left leftmost
)
3487 (setq leftmost left
))
3488 (if (> (+ left width
) rightmost
)
3489 (setq rightmost
(+ left width
)))
3490 (setq l
(nthcdr 2 l
))))
3492 (let ((l cmpchar-elements
))
3494 (setcar (cdr (car l
))
3495 (- (nth 1 (car l
)) leftmost
))
3497 (ps-mule-plot-cmpchar (nreverse cmpchar-elements
)
3498 total-width nil font-type
)))
3500 (defun ps-mule-plot-cmpchar (elements total-width relativep font-type
)
3501 (let* ((ch (if relativep
(car elements
) (car (car elements
))))
3502 (str (ps-mule-prepare-cmpchar-font ch font-type
)))
3503 (ps-output-string str
)
3504 (ps-output (format " %d %d BC "
3505 (if relativep
0 (nth 1 (car elements
)))
3507 (setq elements
(cdr elements
))
3509 (let* ((elt (car elements
))
3510 (ch (if relativep elt
(car elt
)))
3511 (str (ps-mule-prepare-cmpchar-font ch font-type
)))
3514 (ps-output-string str
)
3515 (ps-output " RLC "))
3516 (ps-output-string str
)
3517 (ps-output (format " %d %d %d RBC "
3518 (nth 1 elt
) (nth 2 elt
) (nth 3 elt
)))))
3519 (setq elements
(cdr elements
)))
3522 (defun ps-mule-prepare-cmpchar-font (char font-type
)
3523 (let* ((ps-mule-current-charset (char-charset char
))
3524 (font-spec (ps-mule-get-font-spec ps-mule-current-charset font-type
))
3525 (encoding (ps-mule-font-spec-encoding font-spec
))
3526 (str (char-to-string char
)))
3528 (if (coding-system-p encoding
)
3529 (setq str
(encode-coding-string str encoding
))
3530 (if (functionp encoding
)
3531 (setq str
(funcall encoding str
))
3533 (error "Invalid coding system or function: %s" encoding
))))
3534 (setq str
(string-as-unibyte str
))
3535 (if (ps-mule-font-spec-src font-spec
)
3536 (ps-mule-prepare-font font-spec str ps-mule-current-charset
)
3537 (ps-set-font ps-current-font
)))
3539 ((eq ps-mule-current-charset
'latin-iso8859-1
)
3540 (ps-set-font ps-current-font
)
3542 (string-as-unibyte (encode-coding-string str
'iso-latin-1
))))
3545 ;; No font for CHAR.
3546 (ps-set-font ps-current-font
)
3550 ;; Bitmap font support
3552 (defvar ps-mule-bitmap-prologue-generated nil
)
3554 (defconst ps-mule-bitmap-prologue
3555 "%%%% Bitmap font handler
3557 /str7 7 string def % working area
3559 %% We grow the dictionary one bunch (1024 entries) by one.
3560 /BitmapDictArray 256 array def
3561 /BitmapDictLength 1024 def
3562 /BitmapDictIndex -1 def
3564 /NewBitmapDict { % -- |- --
3565 /BitmapDictIndex BitmapDictIndex 1 add def
3566 BitmapDictArray BitmapDictIndex BitmapDictLength dict put
3569 %% Make at least one dictionary.
3572 /AddBitmap { % gloval-charname bitmap-data |- --
3573 BitmapDictArray BitmapDictIndex get
3574 dup length BitmapDictLength ge {
3577 BitmapDictArray BitmapDictIndex get
3582 /GetBitmap { % gloval-charname |- bitmap-data
3583 0 1 BitmapDictIndex { BitmapDictArray exch get begin } for
3585 0 1 BitmapDictIndex { pop end } for
3588 %% Return a global character name which can be used as a key in the
3589 %% bitmap dictionary.
3590 /GlobalCharName { % fontidx code1 code2 |- gloval-charname
3591 exch 256 mul add exch 65536 mul add 16777216 add 16 str7 cvrs 0 66 put
3595 %% Character code holder for a 2-byte character.
3598 %% Glyph rendering procedure
3599 /BuildGlyphCommon { % fontdict charname |- --
3600 1 index /FontDimension get 1 eq { /FirstCode 0 store } if
3601 NameIndexDict exch get % STACK: fontdict charcode
3602 FirstCode 0 lt { %ifelse
3603 %% This is the first byte of a 2-byte character. Just
3604 %% remember it for the moment.
3605 /FirstCode exch store
3609 1 index /FontSize get /size exch def
3610 1 index /FontSpaceWidthRatio get /ratio exch def
3611 1 index /FontIndex get exch FirstCode exch
3612 GlobalCharName GetBitmap /bmp exch def
3613 %% bmp == [ DWIDTH BBX-WIDTH BBX-HEIGHT BBX-XOFF BBX-YOFF BITMAP ]
3615 /FontMatrix get [ exch { size div } forall ] /mtrx exch def
3616 bmp 3 get bmp 4 get mtrx transform
3618 bmp 1 get bmp 3 get add bmp 2 get bmp 4 get add mtrx transform
3625 bmp 0 get SpaceWidthRatio ratio div mul size div 0 % wx wy
3626 setcharwidth % We can't use setcachedevice here.
3628 bmp 1 get 0 gt bmp 2 get 0 gt and {
3629 bmp 1 get bmp 2 get % width height
3631 [ size 0 0 size neg bmp 3 get neg bmp 2 get bmp 4 get add ] % matrix
3632 bmp 5 1 getinterval cvx % datasrc
3639 1 index /Encoding get exch get
3640 1 index /BuildGlyph get exec
3643 %% Bitmap font creater
3645 %% Common Encoding shared by all bitmap fonts.
3646 /EncodingCommon 256 array def
3647 %% Mapping table from character name to character code.
3648 /NameIndexDict 256 dict def
3651 /idxname idx 256 add 16 (XXX) cvrs dup 0 67 put cvn def % `C' == 67
3652 EncodingCommon idx idxname put
3653 NameIndexDict idxname idx put
3656 /GlobalFontIndex 0 def
3658 %% fontname dim col fontsize relative-compose baseline-offset fbbx |- --
3662 /BaselineOffset exch def
3663 /RelativeCompose exch def
3665 /FontBBox [ FontBBox { FontSize div } forall ] def
3666 FontBBox 2 get FontBBox 0 get sub exch div
3667 /FontSpaceWidthRatio exch def
3668 /FontDimension exch def
3669 /FontIndex GlobalFontIndex def
3671 /FontMatrix matrix def
3672 /Encoding EncodingCommon def
3673 /BuildGlyph { BuildGlyphCommon } def
3674 /BuildChar { BuildCharCommon } def
3677 /GlobalFontIndex GlobalFontIndex 1 add def
3680 %% Define a new bitmap font.
3681 %% fontname dim col fontsize relative-compose baseline-offset fbbx |- --
3684 %% Convert BDF's FontBoundingBox to PostScript's FontBBox
3685 [ fbbx 2 get fbbx 3 get
3686 fbbx 2 get fbbx 0 get add fbbx 3 get fbbx 1 get add ]
3690 %% Define a glyph for the specified font and character.
3691 /NG { % fontname charcode bitmap-data |- --
3693 exch findfont dup /BaselineOffset get bmp 4 get add bmp exch 4 exch put
3695 dup 256 idiv exch 256 mod GlobalCharName
3698 %%%% End of bitmap font handler
3702 ;; External library support.
3704 ;; The following three functions are to be called from external
3705 ;; libraries which support bitmap fonts (e.g. `bdf') to get
3706 ;; appropriate PostScript code.
3708 (defun ps-mule-generate-bitmap-prologue ()
3709 (unless ps-mule-bitmap-prologue-generated
3710 (setq ps-mule-bitmap-prologue-generated t
)
3711 (list ps-mule-bitmap-prologue
)))
3713 (defun ps-mule-generate-bitmap-font (&rest args
)
3714 (list (apply 'format
"/%s %d %d %f %S %d %S NF\n" args
)))
3716 (defun ps-mule-generate-bitmap-glyph (font-name code dwidth bbx bitmap
)
3717 (format "/%s %d [ %d %d %d %d %d <%s> ] NG\n"
3719 dwidth
(aref bbx
0) (aref bbx
1) (aref bbx
2) (aref bbx
3)
3722 ;; Mule specific initializers.
3724 (defun ps-mule-initialize ()
3725 "Produce Poscript code in the prologue part for multibyte characters."
3726 (setq ps-mule-current-charset
'ascii
3727 ps-mule-font-cache nil
3728 ps-mule-prologue-generated nil
3729 ps-mule-cmpchar-prologue-generated nil
3730 ps-mule-bitmap-prologue-generated nil
)
3731 (mapcar (function (lambda (x) (setcar (cdr x
) nil
)))
3732 ps-mule-external-libraries
))
3734 (defun ps-mule-begin (from to
)
3735 (if (and (boundp 'enable-multibyte-characters
)
3736 enable-multibyte-characters
)
3737 ;; Initialize `ps-mule-charset-list'. If some characters aren't
3738 ;; printable, warn it.
3739 (let ((charsets (delete 'ascii
(find-charset-region from to
))))
3740 (setq ps-mule-charset-list charsets
)
3743 (if (search-forward "\200" to t
)
3744 (setq ps-mule-charset-list
3745 (cons 'composition ps-mule-charset-list
))))
3746 (if (and (catch 'tag
3748 (if (or (eq (car charsets
) 'composition
)
3749 (ps-mule-printable-p (car charsets
)))
3750 (setq charsets
(cdr charsets
))
3752 (not (y-or-n-p "Font for some characters not found, continue anyway? ")))
3753 (error "Printing cancelled"))))
3755 (if ps-mule-charset-list
3756 (let ((l ps-mule-charset-list
)
3758 (unless ps-mule-prologue-generated
3759 (ps-output-prologue ps-mule-prologue
)
3760 (setq ps-mule-prologue-generated t
))
3761 ;; If external functions are necessary, generate prologues for them.
3763 (if (and (eq (car l
) 'composition
)
3764 (not ps-mule-cmpchar-prologue-generated
))
3766 (ps-output-prologue ps-mule-cmpchar-prologue
)
3767 (setq ps-mule-cmpchar-prologue-generated t
))
3768 (if (setq font-spec
(ps-mule-get-font-spec (car l
) 'normal
))
3769 (ps-mule-init-external-library font-spec
)))
3772 ;; If ASCII font is also specified in ps-mule-font-info-database,
3773 ;; use it istead of what specified in ps-font-info-database.
3774 (let ((font-spec (ps-mule-get-font-spec 'ascii
'normal
)))
3777 (unless ps-mule-prologue-generated
3778 (ps-output-prologue ps-mule-prologue
)
3779 (setq ps-mule-prologue-generated t
))
3780 (ps-mule-init-external-library font-spec
)
3781 (let ((font (ps-font-alist 'ps-font-for-text
))
3784 (let ((ps-current-font i
))
3785 ;; Be sure to download a glyph for SPACE in advance.
3786 (ps-mule-prepare-font
3787 (ps-mule-get-font-spec 'ascii
(car font
))
3788 " " 'ascii
'no-setfont
))
3789 (setq font
(cdr font
) i
(1+ i
))))))))
3792 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3794 (defun ps-line-lengths-internal ()
3795 "Display the correspondence between a line length and a font size,
3796 using the current ps-print setup.
3797 Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"
3798 (let ((buf (get-buffer-create "*Line-lengths*"))
3799 (ifs ps-font-size
) ; initial font size
3800 (icw (ps-avg-char-width 'ps-font-for-text
)) ; initial character width
3801 (print-width (progn (ps-get-page-dimensions)
3803 (ps-setup (ps-setup)) ; setup for the current buffer
3804 (fs-min 5) ; minimum font size
3805 cw-min
; minimum character width
3806 nb-cpl-max
; maximum nb of characters per line
3807 (fs-max 14) ; maximum font size
3808 cw-max
; maximum character width
3809 nb-cpl-min
; minimum nb of characters per line
3810 fs
; current font size
3811 cw
; current character width
3812 nb-cpl
; current nb of characters per line
3814 (setq cw-min
(/ (* icw fs-min
) ifs
)
3815 nb-cpl-max
(floor (/ print-width cw-min
))
3816 cw-max
(/ (* icw fs-max
) ifs
)
3817 nb-cpl-min
(floor (/ print-width cw-max
))
3820 (goto-char (point-max))
3821 (or (bolp) (insert "\n"))
3823 "nb char per line / font size\n")
3824 (while (<= nb-cpl nb-cpl-max
)
3825 (setq cw
(/ print-width
(float nb-cpl
))
3826 fs
(/ (* ifs cw
) icw
))
3827 (insert (format "%3s %s\n" nb-cpl fs
))
3828 (setq nb-cpl
(1+ nb-cpl
)))
3830 (display-buffer buf
'not-this-window
)))
3832 (defun ps-nb-pages (nb-lines)
3833 "Display correspondence between font size and the number of pages.
3834 The correspondence is based on having NB-LINES lines of text,
3835 and on the current ps-print setup."
3836 (let ((buf (get-buffer-create "*Nb-Pages*"))
3837 (ifs ps-font-size
) ; initial font size
3838 (ilh (ps-line-height 'ps-font-for-text
)) ; initial line height
3839 (page-height (progn (ps-get-page-dimensions)
3841 (ps-setup (ps-setup)) ; setup for the current buffer
3842 (fs-min 4) ; minimum font size
3843 lh-min
; minimum line height
3844 nb-lpp-max
; maximum nb of lines per page
3845 nb-page-min
; minimum nb of pages
3846 (fs-max 14) ; maximum font size
3847 lh-max
; maximum line height
3848 nb-lpp-min
; minimum nb of lines per page
3849 nb-page-max
; maximum nb of pages
3850 fs
; current font size
3851 lh
; current line height
3852 nb-lpp
; current nb of lines per page
3853 nb-page
; current nb of pages
3855 (setq lh-min
(/ (* ilh fs-min
) ifs
)
3856 nb-lpp-max
(floor (/ page-height lh-min
))
3857 nb-page-min
(ceiling (/ (float nb-lines
) nb-lpp-max
))
3858 lh-max
(/ (* ilh fs-max
) ifs
)
3859 nb-lpp-min
(floor (/ page-height lh-max
))
3860 nb-page-max
(ceiling (/ (float nb-lines
) nb-lpp-min
))
3861 nb-page nb-page-min
)
3863 (goto-char (point-max))
3864 (or (bolp) (insert "\n"))
3866 (format "%d lines\n" nb-lines
)
3867 "nb page / font size\n")
3868 (while (<= nb-page nb-page-max
)
3869 (setq nb-lpp
(ceiling (/ nb-lines
(float nb-page
)))
3870 lh
(/ page-height nb-lpp
)
3871 fs
(/ (* ifs lh
) ilh
))
3872 (insert (format "%s %s\n" nb-page fs
))
3873 (setq nb-page
(1+ nb-page
)))
3875 (display-buffer buf
'not-this-window
)))
3877 ;; macros used in `ps-select-font'
3878 (defmacro ps-lookup
(key) `(cdr (assq ,key font-entry
)))
3879 (defmacro ps-size-scale
(key) `(/ (* (ps-lookup ,key
) font-size
) size
))
3881 (defun ps-select-font (font-family sym font-size title-font-size
)
3882 (let ((font-entry (cdr (assq font-family ps-font-info-database
))))
3884 (error "Don't have data to scale font %s. Known fonts families are %s"
3886 (mapcar 'car ps-font-info-database
)))
3887 (let ((size (ps-lookup 'size
)))
3888 (put sym
'fonts
(ps-lookup 'fonts
))
3889 (put sym
'space-width
(ps-size-scale 'space-width
))
3890 (put sym
'avg-char-width
(ps-size-scale 'avg-char-width
))
3891 (put sym
'line-height
(ps-size-scale 'line-height
))
3892 (put sym
'title-line-height
3893 (/ (* (ps-lookup 'line-height
) title-font-size
) size
)))))
3895 (defun ps-get-page-dimensions ()
3896 (let ((page-dimensions (cdr (assq ps-paper-type ps-page-dimensions-database
)))
3897 page-width page-height
)
3899 ((null page-dimensions
)
3900 (error "`ps-paper-type' must be one of:\n%s"
3901 (mapcar 'car ps-page-dimensions-database
)))
3902 ((< ps-number-of-columns
1)
3903 (error "The number of columns %d should be positive"
3904 ps-number-of-columns
)))
3906 (ps-select-font ps-font-family
'ps-font-for-text
3907 ps-font-size ps-font-size
)
3908 (ps-select-font ps-header-font-family
'ps-font-for-header
3909 ps-header-font-size ps-header-title-font-size
)
3911 (setq page-width
(ps-page-dimensions-get-width page-dimensions
)
3912 page-height
(ps-page-dimensions-get-height page-dimensions
))
3915 (if ps-landscape-mode
3916 ;; exchange width and height
3917 (setq page-width
(prog1 page-height
(setq page-height page-width
))))
3919 ;; It is used to get the lower right corner (only in landscape mode)
3920 (setq ps-landscape-page-height page-height
)
3922 ;; | lm | text | ic | text | ic | text | rm |
3923 ;; page-width == lm + n * pw + (n - 1) * ic + rm
3924 ;; => pw == (page-width - lm -rm - (n - 1) * ic) / n
3925 (setq ps-print-width
(/ (- page-width
3926 ps-left-margin ps-right-margin
3927 (* (1- ps-number-of-columns
) ps-inter-column
))
3928 ps-number-of-columns
))
3929 (if (<= ps-print-width
0)
3930 (error "Bad horizontal layout:
3932 ps-left-margin == %s
3933 ps-right-margin == %s
3934 ps-inter-column == %s
3935 ps-number-of-columns == %s
3936 | lm | text | ic | text | ic | text | rm |
3937 page-width == lm + n * print-width + (n - 1) * ic + rm
3938 => print-width == %d !"
3943 ps-number-of-columns
3946 (setq ps-print-height
3947 (- page-height ps-bottom-margin ps-top-margin
))
3948 (if (<= ps-print-height
0)
3949 (error "Bad vertical layout:
3951 ps-bottom-margin == %s
3952 page-height == bm + print-height + tm
3953 => print-height == %d !"
3957 ;; If headers are turned on, deduct the height of the header from
3958 ;; the print height.
3960 (setq ps-header-pad
(* ps-header-line-pad
3961 (ps-title-line-height 'ps-font-for-header
))
3962 ps-print-height
(- ps-print-height
3965 (ps-title-line-height 'ps-font-for-header
)
3966 (* (ps-line-height 'ps-font-for-header
)
3967 (1- ps-header-lines
))
3969 (if (<= ps-print-height
0)
3970 (error "Bad vertical layout:
3972 ps-bottom-margin == %s
3973 ps-header-offset == %s
3976 page-height == bm + print-height + tm - ho - hh
3977 => print-height == %d !"
3983 (ps-title-line-height 'ps-font-for-header
)
3984 (* (ps-line-height 'ps-font-for-header
)
3985 (1- ps-header-lines
))
3989 (defun ps-print-preprint (&optional filename
)
3991 (or (numberp filename
)
3993 (let* ((name (concat (buffer-name) ".ps"))
3994 (prompt (format "Save PostScript to file: (default %s) " name
))
3995 (res (read-file-name prompt default-directory name nil
)))
3996 (if (file-directory-p res
)
3997 (expand-file-name name
(file-name-as-directory res
))
4000 ;; The following functions implement a simple list-buffering scheme so
4001 ;; that ps-print doesn't have to repeatedly switch between buffers
4002 ;; while spooling. The functions `ps-output' and `ps-output-string' build
4003 ;; up the lists; the function `ps-flush-output' takes the lists and
4004 ;; insert its contents into the spool buffer (*PostScript*).
4006 (defvar ps-string-escape-codes
4007 (let ((table (make-vector 256 nil
))
4009 ;; control characters
4010 (while (<= char ?
\037)
4011 (aset table char
(format "\\%03o" char
))
4012 (setq char
(1+ char
)))
4013 ;; printable characters
4014 (while (< char ?
\177)
4015 (aset table char
(format "%c" char
))
4016 (setq char
(1+ char
)))
4017 ;; DEL and 8-bit characters
4018 (while (<= char ?
\377)
4019 (aset table char
(format "\\%o" char
))
4020 (setq char
(1+ char
)))
4021 ;; Override ASCII formatting characters with named escape code:
4022 (aset table ?
\n "\\n") ; [NL] linefeed
4023 (aset table ?
\r "\\r") ; [CR] carriage return
4024 (aset table ?
\t "\\t") ; [HT] horizontal tab
4025 (aset table ?
\b "\\b") ; [BS] backspace
4026 (aset table ?
\f "\\f") ; [NP] form feed
4027 ;; Escape PostScript escape and string delimiter characters:
4028 (aset table ?
\\ "\\\\")
4029 (aset table ?\
( "\\(")
4030 (aset table ?\
) "\\)")
4032 "Vector used to map characters to PostScript string escape codes.")
4034 (defun ps-output-string-prim (string)
4035 (insert "(") ;insert start-string delimiter
4036 (save-excursion ;insert string
4037 (insert (string-as-unibyte string
)))
4038 ;; Find and quote special characters as necessary for PS
4039 ;; This skips everything except control chars, non-ASCII chars, (, ) and \.
4040 (while (progn (skip-chars-forward " -'*-[]-~") (not (eobp)))
4041 (let ((special (following-char)))
4043 (insert (aref ps-string-escape-codes special
))))
4044 (goto-char (point-max))
4045 (insert ")")) ;insert end-string delimiter
4047 (defun ps-init-output-queue ()
4048 (setq ps-output-head
'("")
4049 ps-output-tail ps-output-head
))
4051 (defun ps-output (&rest args
)
4052 (setcdr ps-output-tail args
)
4053 (while (cdr ps-output-tail
)
4054 (setq ps-output-tail
(cdr ps-output-tail
))))
4056 (defun ps-output-string (string)
4057 (ps-output t string
))
4059 (defun ps-output-list (the-list)
4060 (mapcar 'ps-output the-list
))
4062 ;; Output strings in the list ARGS in the PostScript prologue part.
4063 (defun ps-output-prologue (args)
4064 (ps-output 'prologue
(if (stringp args
) (list args
) args
)))
4066 (defun ps-flush-output ()
4068 (set-buffer ps-spool-buffer
)
4069 (goto-char (point-max))
4070 (while ps-output-head
4071 (let ((it (car ps-output-head
)))
4074 (setq ps-output-head
(cdr ps-output-head
))
4075 (ps-output-string-prim (car ps-output-head
)))
4077 (setq ps-output-head
(cdr ps-output-head
))
4079 (search-backward "\nBeginDoc")
4081 (apply 'insert
(car ps-output-head
))))
4084 (setq ps-output-head
(cdr ps-output-head
))))
4085 (ps-init-output-queue))
4087 (defun ps-insert-file (fname)
4089 ;; Check to see that the file exists and is readable; if not, throw
4091 (or (file-readable-p fname
)
4092 (error "Could not read file `%s'" fname
))
4094 (set-buffer ps-spool-buffer
)
4095 (goto-char (point-max))
4096 (insert-file fname
)))
4098 ;; These functions insert the arrays that define the contents of the
4101 (defun ps-generate-header-line (fonttag &optional content
)
4102 (ps-output " [ " fonttag
" ")
4104 ;; Literal strings should be output as is -- the string must
4105 ;; contain its own PS string delimiters, '(' and ')', if necessary.
4107 (ps-output content
))
4109 ;; Functions are called -- they should return strings; they will be
4110 ;; inserted as strings and the PS string delimiters added.
4111 ((and (symbolp content
) (fboundp content
))
4112 (ps-output-string (funcall content
)))
4114 ;; Variables will have their contents inserted. They should
4115 ;; contain strings, and will be inserted as strings.
4116 ((and (symbolp content
) (boundp content
))
4117 (ps-output-string (symbol-value content
)))
4119 ;; Anything else will get turned into an empty string.
4121 (ps-output-string "")))
4124 (defun ps-generate-header (name contents
)
4125 (ps-output "/" name
" [\n")
4126 (if (> ps-header-lines
0)
4128 (ps-generate-header-line "/h0" (car contents
))
4129 (while (and (< count ps-header-lines
)
4130 (setq contents
(cdr contents
)))
4131 (ps-generate-header-line "/h1" (car contents
))
4132 (setq count
(1+ count
)))
4133 (ps-output "] def\n"))))
4135 (defun ps-output-boolean (name bool
)
4136 (ps-output (format "/%s %s def\n" name
(if bool
"true" "false"))))
4139 (defun ps-background-pages (page-list func
)
4143 (let ((start (if (consp pages
) (car pages
) pages
))
4144 (end (if (consp pages
) (cdr pages
) pages
)))
4145 (and (integerp start
) (integerp end
) (<= start end
)
4146 (add-to-list 'ps-background-pages
(vector start end func
)))))
4148 (setq ps-background-all-pages
(cons func ps-background-all-pages
))))
4151 (defun ps-get-boundingbox ()
4153 (set-buffer ps-spool-buffer
)
4155 (if (re-search-forward
4156 "^%%BoundingBox:\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)"
4158 (vector (string-to-number ; lower x
4159 (buffer-substring (match-beginning 1) (match-end 1)))
4160 (string-to-number ; lower y
4161 (buffer-substring (match-beginning 2) (match-end 2)))
4162 (string-to-number ; upper x
4163 (buffer-substring (match-beginning 3) (match-end 3)))
4164 (string-to-number ; upper y
4165 (buffer-substring (match-beginning 4) (match-end 4))))
4166 (vector 0 0 0 0)))))
4169 ;; Emacs understands the %f format; we'll use it to limit color RGB values
4170 ;; to three decimals to cut down some on the size of the PostScript output.
4171 ;; Lucid emacsen will have to make do with %s (princ) for floats.
4173 (defvar ps-float-format
(if (eq ps-print-emacs-type
'emacs
)
4175 "%s ")) ; Lucid emacsen
4178 (defun ps-float-format (value &optional default
)
4179 (let ((literal (or value default
)))
4181 (format (if (numberp literal
)
4188 (defun ps-background-text ()
4191 (setq ps-background-text-count
(1+ ps-background-text-count
))
4192 (ps-output (format "/ShowBackText-%d {\n" ps-background-text-count
))
4193 (ps-output-string (nth 0 text
)) ; text
4196 (ps-float-format (nth 4 text
) 200.0) ; font size
4197 (format "/%s " (or (nth 3 text
) "Times-Roman")) ; font name
4198 (ps-float-format (nth 6 text
)
4199 "PrintHeight PrintPageWidth atan") ; rotation
4200 (ps-float-format (nth 5 text
) 0.85) ; gray
4201 (ps-float-format (nth 1 text
) "0") ; x position
4202 (ps-float-format (nth 2 text
) "BottomMargin") ; y position
4203 "\nShowBackText} def\n")
4204 (ps-background-pages (nthcdr 7 text
) ; page list
4205 (format "ShowBackText-%d\n"
4206 ps-background-text-count
)))
4207 ps-print-background-text
))
4210 (defun ps-background-image ()
4213 (let ((image-file (expand-file-name (nth 0 image
))))
4214 (if (file-readable-p image-file
)
4216 (setq ps-background-image-count
(1+ ps-background-image-count
))
4218 (format "/ShowBackImage-%d {\n--back-- " ps-background-image-count
)
4219 (ps-float-format (nth 5 image
) 0.0) ; rotation
4220 (ps-float-format (nth 3 image
) 1.0) ; x scale
4221 (ps-float-format (nth 4 image
) 1.0) ; y scale
4222 (ps-float-format (nth 1 image
) ; x position
4223 "PrintPageWidth 2 div")
4224 (ps-float-format (nth 2 image
) ; y position
4225 "PrintHeight 2 div BottomMargin add")
4226 "\nBeginBackImage\n")
4227 (ps-insert-file image-file
)
4228 ;; coordinate adjustment to centralize image
4229 ;; around x and y position
4230 (let ((box (ps-get-boundingbox)))
4232 (set-buffer ps-spool-buffer
)
4234 (if (re-search-backward "^--back--" nil t
)
4238 (- (+ (/ (- (aref box
2) (aref box
0)) 2.0)
4241 (- (+ (/ (- (aref box
3) (aref box
1)) 2.0)
4244 (ps-output "\nEndBackImage} def\n")
4245 (ps-background-pages (nthcdr 6 image
) ; page list
4246 (format "ShowBackImage-%d\n"
4247 ps-background-image-count
))))))
4248 ps-print-background-image
))
4251 (defun ps-background (page-number)
4252 (let (has-local-background)
4253 (mapcar '(lambda (range)
4254 (and (<= (aref range
0) page-number
)
4255 (<= page-number
(aref range
1))
4256 (if has-local-background
4257 (ps-output (aref range
2))
4258 (setq has-local-background t
)
4259 (ps-output "/printLocalBackground {\n"
4261 ps-background-pages
)
4262 (and has-local-background
(ps-output "} def\n"))))
4265 ;; Return a list of the distinct elements of LIST.
4266 ;; Elements are compared with `equal'.
4267 (defun ps-remove-duplicates (list)
4268 (let (new (tail list
))
4270 (or (member (car tail
) new
)
4271 (setq new
(cons (car tail
) new
)))
4272 (setq tail
(cdr tail
)))
4276 ;; Find the first occurrence of ITEM in LIST.
4277 ;; Return the index of the matching item, or nil if not found.
4278 ;; Elements are compared with `eq'.
4279 (defun ps-alist-position (item list
)
4280 (let ((tail list
) (index 0) found
)
4282 (if (setq found
(eq (car (car tail
)) item
))
4284 (setq index
(1+ index
)
4289 (defun ps-begin-file ()
4290 (ps-get-page-dimensions)
4291 (setq ps-page-postscript
0
4292 ps-background-text-count
0
4293 ps-background-image-count
0
4294 ps-background-pages nil
4295 ps-background-all-pages nil
)
4297 (ps-output ps-adobe-tag
4298 "%%Title: " (buffer-name) ; Take job name from name of
4299 ; first buffer printed
4300 "\n%%Creator: " (user-full-name)
4301 " (using ps-print v" ps-print-version
4302 ")\n%%CreationDate: "
4303 (time-stamp-hh:mm
:ss
) " " (time-stamp-mon-dd-yyyy)
4305 (if ps-landscape-mode
"Landscape" "Portrait")
4306 "\n%% DocumentFonts: Times-Roman Times-Italic "
4307 (mapconcat 'identity
4308 (ps-remove-duplicates
4309 (append (ps-fonts 'ps-font-for-text
)
4310 (list (ps-font 'ps-font-for-header
'normal
)
4311 (ps-font 'ps-font-for-header
'bold
))))
4313 "\n%%Pages: (atend)\n"
4314 "%%EndComments\n\n")
4316 (ps-output-boolean "LandscapeMode" ps-landscape-mode
)
4317 (ps-output (format "/NumberOfColumns %d def\n" ps-number-of-columns
)
4319 (format "/LandscapePageHeight %s def\n" ps-landscape-page-height
)
4320 (format "/PrintPageWidth %s def\n"
4321 (- (* (+ ps-print-width ps-inter-column
)
4322 ps-number-of-columns
)
4324 (format "/PrintWidth %s def\n" ps-print-width
)
4325 (format "/PrintHeight %s def\n" ps-print-height
)
4327 (format "/LeftMargin %s def\n" ps-left-margin
)
4328 (format "/RightMargin %s def\n" ps-right-margin
) ; not used
4329 (format "/InterColumn %s def\n" ps-inter-column
)
4331 (format "/BottomMargin %s def\n" ps-bottom-margin
)
4332 (format "/TopMargin %s def\n" ps-top-margin
) ; not used
4333 (format "/HeaderOffset %s def\n" ps-header-offset
)
4334 (format "/HeaderPad %s def\n" ps-header-pad
))
4336 (ps-output-boolean "PrintHeader" ps-print-header
)
4337 (ps-output-boolean "PrintOnlyOneHeader" ps-print-only-one-header
)
4338 (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame
)
4339 (ps-output-boolean "ShowNofN" ps-show-n-of-n
)
4340 (ps-output-boolean "Duplex" ps-spool-duplex
)
4342 (let ((line-height (ps-line-height 'ps-font-for-text
)))
4343 (ps-output (format "/LineHeight %s def\n" line-height
)
4344 (format "/LinesPerColumn %d def\n"
4345 (round (/ (+ ps-print-height
4346 (* line-height
0.45))
4349 (ps-output-boolean "Zebra" ps-zebra-stripes
)
4350 (ps-output-boolean "PrintLineNumber" ps-line-number
)
4351 (ps-output (format "/ZebraHeight %d def\n" ps-zebra-stripe-height
))
4353 (ps-background-text)
4354 (ps-background-image)
4355 (setq ps-background-all-pages
(nreverse ps-background-all-pages
)
4356 ps-background-pages
(nreverse ps-background-pages
))
4358 (ps-output ps-print-prologue-1
)
4360 (ps-output "/printGlobalBackground {\n")
4361 (ps-output-list ps-background-all-pages
)
4362 (ps-output "} def\n/printLocalBackground {\n} def\n")
4365 (ps-output (format "/h0 %s /%s DefFont\n" ; /h0 14 /Helvetica-Bold DefFont
4366 ps-header-title-font-size
(ps-font 'ps-font-for-header
4368 (format "/h1 %s /%s DefFont\n" ; /h1 12 /Helvetica DefFont
4369 ps-header-font-size
(ps-font 'ps-font-for-header
4372 (ps-output ps-print-prologue-2
)
4375 (let ((font (ps-font-alist 'ps-font-for-text
))
4378 (ps-output (format "/f%d %s /%s DefFont\n"
4381 (ps-font 'ps-font-for-text
(car (car font
)))))
4382 (setq font
(cdr font
)
4385 (let ((font-entry (cdr (assq ps-font-family ps-font-info-database
))))
4386 (ps-output (format "/SpaceWidthRatio %f def\n"
4387 (/ (ps-lookup 'space-width
) (ps-lookup 'size
)))))
4389 (ps-mule-initialize)
4391 (ps-output "\nBeginDoc\n\n"
4394 (defun ps-header-dirpart ()
4395 (let ((fname (buffer-file-name)))
4397 (if (string-equal (buffer-name) (file-name-nondirectory fname
))
4398 (file-name-directory fname
)
4402 (defun ps-get-buffer-name ()
4404 ;; Indulge Jim this little easter egg:
4405 ((string= (buffer-name) "ps-print.el")
4406 "Hey, Cool! It's ps-print.el!!!")
4407 ;; Indulge Jack this other little easter egg:
4408 ((string= (buffer-name) "sokoban.el")
4409 "Super! C'est sokoban.el!")
4411 (and ps-printing-region
"Subset of: ")
4413 (and (buffer-modified-p) " (unsaved)")))))
4415 (defun ps-begin-job ()
4417 (set-buffer ps-spool-buffer
)
4418 (goto-char (point-max))
4419 (and (re-search-backward "^%%Trailer$" nil t
)
4420 (delete-region (match-beginning 0) (point-max))))
4421 (setq ps-showline-count
(if ps-printing-region
(car ps-printing-region
) 1)
4423 ps-control-or-escape-regexp
4424 (if ps-mule-charset-list
4425 (cond ((eq ps-print-control-characters
'8-bit
)
4427 ((eq ps-print-control-characters
'control-8-bit
)
4428 (string-as-multibyte "[^\040-\176\240-\377]"))
4429 ((eq ps-print-control-characters
'control
)
4430 (string-as-multibyte "[^\040-\176\200-\377]"))
4431 (t (string-as-multibyte "[^\000-\011\013\015-\377")))
4432 (cond ((eq ps-print-control-characters
'8-bit
)
4433 (string-as-unibyte "[\000-\037\177-\377]"))
4434 ((eq ps-print-control-characters
'control-8-bit
)
4435 (string-as-unibyte "[\000-\037\177-\237]"))
4436 ((eq ps-print-control-characters
'control
)
4440 (defmacro ps-page-number
()
4441 `(1+ (/ (1- ps-page-count
) ps-number-of-columns
)))
4443 (defun ps-end-file ()
4444 (ps-output "\n%%Trailer\n%%Pages: "
4445 (format "%d" ps-page-postscript
)
4446 "\n\nEndDoc\n\n%%EOF\n"))
4449 (defun ps-next-page ()
4454 (defun ps-header-page ()
4455 ;; set total line and page number when printing has finished
4456 ;; (see `ps-generate')
4458 (zerop (mod ps-page-count ps-number-of-columns
))
4459 (setq ps-page-count
(1+ ps-page-count
)))
4460 ;; Print only when a new real page begins.
4462 (setq ps-page-postscript
(1+ ps-page-postscript
))
4463 (ps-output (format "\n%%%%Page: %d %d\n"
4464 ps-page-postscript ps-page-postscript
))
4465 (ps-output "/Lines 0 def\n/PageCount 0 def\nBeginDSCPage\n")
4466 (ps-background ps-page-postscript
)
4467 (run-hooks 'ps-print-begin-page-hook
))
4468 ;; Print when any other page begins.
4469 (ps-output "/Lines 0 def\n/PageCount 0 def\nBeginDSCPage\n")
4470 (run-hooks 'ps-print-begin-column-hook
)))
4472 (defun ps-begin-page ()
4473 (ps-get-page-dimensions)
4474 (setq ps-width-remaining ps-print-width
4475 ps-height-remaining ps-print-height
4476 ps-mule-current-charset
'ascii
)
4480 (ps-output (format "/LineNumber %d def\n" ps-showline-count
)
4481 (format "/PageNumber %d def\n" (if ps-print-only-one-header
4485 (when ps-print-header
4486 (ps-generate-header "HeaderLinesLeft" ps-left-header
)
4487 (ps-generate-header "HeaderLinesRight" ps-right-header
)
4488 (ps-output (format "%d SetHeaderLines\n" ps-header-lines
)))
4490 (ps-output "BeginPage\n")
4491 (ps-set-font ps-current-font
)
4492 (ps-set-bg ps-current-bg
)
4493 (ps-set-color ps-current-color
))
4495 (defun ps-end-page ()
4496 (ps-output "EndPage\nEndDSCPage\n"))
4498 (defun ps-dummy-page ()
4500 (ps-output "/PrintHeader false def
4505 (defun ps-next-line ()
4506 (setq ps-showline-count
(1+ ps-showline-count
))
4507 (let ((lh (ps-line-height 'ps-font-for-text
)))
4508 (if (< ps-height-remaining lh
)
4510 (setq ps-width-remaining ps-print-width
4511 ps-height-remaining
(- ps-height-remaining lh
))
4512 (ps-output "HL\n"))))
4514 (defun ps-continue-line ()
4515 (let ((lh (ps-line-height 'ps-font-for-text
)))
4516 (if (< ps-height-remaining lh
)
4518 (setq ps-width-remaining ps-print-width
4519 ps-height-remaining
(- ps-height-remaining lh
))
4520 (ps-output "SL\n"))))
4522 (defun ps-find-wrappoint (from to char-width
)
4523 (let ((avail (truncate (/ ps-width-remaining char-width
)))
4526 (cons to
(* todo char-width
))
4527 (cons (+ from avail
) ps-width-remaining
))))
4529 (defun ps-basic-plot-string (from to
&optional bg-color
)
4530 (let* ((wrappoint (ps-find-wrappoint from to
4531 (ps-avg-char-width 'ps-font-for-text
)))
4532 (to (car wrappoint
))
4533 (string (buffer-substring-no-properties from to
))
4535 (ps-mule-get-font-spec
4537 (car (nth ps-current-font
(ps-font-alist 'ps-font-for-text
))))))
4539 (ps-mule-prepare-font font-spec string
'ascii
))
4540 (ps-output-string string
)
4544 (defun ps-basic-plot-whitespace (from to
&optional bg-color
)
4545 (let* ((wrappoint (ps-find-wrappoint from to
4546 (ps-space-width 'ps-font-for-text
)))
4547 (to (car wrappoint
)))
4548 (ps-output (format "%d W\n" (- to from
)))
4551 (defun ps-plot (plotfunc from to
&optional bg-color
)
4553 (let* ((wrappoint (funcall plotfunc from to bg-color
))
4554 (plotted-to (car wrappoint
))
4555 (plotted-width (cdr wrappoint
)))
4556 (setq from plotted-to
4557 ps-width-remaining
(- ps-width-remaining plotted-width
))
4559 (ps-continue-line))))
4560 (if ps-razzle-dazzle
4561 (let* ((q-todo (- (point-max) (point-min)))
4562 (q-done (- (point) (point-min)))
4563 (chunkfrac (/ q-todo
8))
4564 (chunksize (min chunkfrac
1000)))
4565 (if (> (- q-done ps-razchunk
) chunksize
)
4567 (setq ps-razchunk q-done
)
4568 (message "Formatting...%3d%%"
4570 (/ (* 100 q-done
) q-todo
)
4571 (/ q-done
(/ q-todo
100)))
4574 (defun ps-set-font (font)
4575 (setq ps-last-font
(format "f%d" (setq ps-current-font font
)))
4576 (ps-output (format "/%s F\n" ps-last-font
)))
4578 (defun ps-set-bg (color)
4579 (if (setq ps-current-bg color
)
4580 (ps-output (format ps-color-format
4581 (nth 0 color
) (nth 1 color
) (nth 2 color
))
4583 (ps-output "false BG\n")))
4585 (defun ps-set-color (color)
4586 (setq ps-current-color
(or color ps-default-fg
))
4587 (ps-output (format ps-color-format
4588 (nth 0 ps-current-color
)
4589 (nth 1 ps-current-color
) (nth 2 ps-current-color
))
4593 (defvar ps-current-effect
0)
4596 (defun ps-plot-region (from to font
&optional fg-color bg-color effects
)
4597 (if (not (equal font ps-current-font
))
4600 ;; Specify a foreground color only if one's specified and it's
4601 ;; different than the current.
4602 (if (not (equal fg-color ps-current-color
))
4603 (ps-set-color fg-color
))
4605 (if (not (equal bg-color ps-current-bg
))
4606 (ps-set-bg bg-color
))
4608 ;; Specify effects (underline, overline, box, etc)
4610 ((not (integerp effects
))
4611 (ps-output "0 EF\n")
4612 (setq ps-current-effect
0))
4613 ((/= effects ps-current-effect
)
4614 (ps-output (number-to-string effects
) " EF\n")
4615 (setq ps-current-effect effects
)))
4617 (setq ps-mule-current-charset
'ascii
)
4619 ;; Starting at the beginning of the specified region...
4623 ;; ...break the region up into chunks separated by tabs, linefeeds,
4624 ;; pagefeeds, control characters, and plot each chunk.
4626 (if (re-search-forward ps-control-or-escape-regexp to t
)
4627 ;; region with some control characters or some multibyte characters
4628 (let* ((match-point (match-beginning 0))
4629 (match (char-after match-point
)))
4630 (when (< from match-point
)
4631 (unless (eq ps-mule-current-charset
'ascii
)
4632 (ps-set-font ps-current-font
)
4633 (setq ps-mule-current-charset
'ascii
))
4634 (ps-plot 'ps-basic-plot-string from match-point bg-color
))
4636 ((= match ?
\t) ; tab
4637 (let ((linestart (line-beginning-position)))
4639 (setq from
(+ linestart
(current-column)))
4640 (when (re-search-forward "[ \t]+" to t
)
4641 (unless (eq ps-mule-current-charset
'ascii
)
4642 (ps-set-font ps-current-font
)
4643 (setq ps-mule-current-charset
'ascii
))
4644 (ps-plot 'ps-basic-plot-whitespace
4645 from
(+ linestart
(current-column))
4648 ((= match ?
\n) ; newline
4651 ((= match ?
\f) ; form feed
4652 ;; do not skip page if previous character is NEWLINE and
4653 ;; it is a beginning of page.
4654 (or (and (= (char-after (1- match-point
)) ?
\n)
4655 (= ps-height-remaining ps-print-height
))
4658 ((> match
255) ; a multibyte character
4659 (let ((charset (char-charset match
)))
4660 (or (eq charset
'composition
)
4661 (ps-mule-skip-same-charset charset
))
4662 (setq ps-mule-current-charset charset
)
4663 (ps-plot 'ps-mule-plot-string match-point
(point) bg-color
)))
4664 ; characters from ^@ to ^_ and
4665 (t ; characters from 127 to 255
4666 (ps-control-character match
)))
4667 (setq from
(point)))
4668 ;; region without control characters nor multibyte characters
4669 (when (not (eq ps-mule-current-charset
'ascii
))
4670 (ps-set-font ps-current-font
)
4671 (setq ps-mule-current-charset
'ascii
))
4672 (ps-plot 'ps-basic-plot-string from to bg-color
)
4675 (defvar ps-string-control-codes
4676 (let ((table (make-vector 256 nil
))
4678 ;; control character
4679 (while (<= char ?
\037)
4680 (aset table char
(format "^%c" (+ char ?
@)))
4681 (setq char
(1+ char
)))
4682 ;; printable character
4683 (while (< char ?
\177)
4684 (aset table char
(format "%c" char
))
4685 (setq char
(1+ char
)))
4687 (aset table char
"^?")
4689 (while (<= (setq char
(1+ char
)) ?
\377)
4690 (aset table char
(format "\\%o" char
)))
4692 "Vector used to map characters to a printable string.")
4694 (defun ps-control-character (char)
4695 (let* ((str (aref ps-string-control-codes char
))
4699 (char-width (ps-avg-char-width 'ps-font-for-text
))
4700 (wrappoint (ps-find-wrappoint from to char-width
)))
4701 (if (< (car wrappoint
) to
)
4703 (setq ps-width-remaining
(- ps-width-remaining
(* len char-width
)))
4704 (ps-output-string str
)
4705 (ps-output " S\n")))
4707 (defun ps-color-value (x-color-value)
4708 ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
4709 (/ x-color-value ps-print-color-scale
))
4711 (defun ps-color-values (x-color)
4712 (cond ((fboundp 'x-color-values
)
4713 (x-color-values x-color
))
4714 ((and (fboundp 'color-instance-rgb-components
)
4716 (color-instance-rgb-components
4717 (if (color-instance-p x-color
)
4719 (make-color-instance
4720 (if (color-specifier-p x-color
)
4721 (color-name x-color
)
4723 (t (error "No available function to determine X color values."))))
4726 (defun ps-face-attributes (face)
4727 "Return face attribute vector.
4729 If FACE is not in `ps-print-face-extension-alist' or in
4730 `ps-print-face-alist', insert it on `ps-print-face-alist' and
4731 return the attribute vector.
4733 If FACE is not a valid face name, it is used default face."
4734 (cdr (or (assq face ps-print-face-extension-alist
)
4735 (assq face ps-print-face-alist
)
4736 (let* ((the-face (if (facep face
) face
'default
))
4737 (new-face (ps-screen-to-bit-face the-face
)))
4738 (or (and (eq the-face
'default
)
4739 (assq the-face ps-print-face-alist
))
4740 (setq ps-print-face-alist
(cons new-face ps-print-face-alist
)))
4744 (defun ps-face-attribute-list (face-or-list)
4745 (if (listp face-or-list
)
4748 foreground background face-attr
)
4750 (setq face-attr
(ps-face-attributes (car face-or-list
))
4751 effects
(logior effects
(aref face-attr
0)))
4752 (or foreground
(setq foreground
(aref face-attr
1)))
4753 (or background
(setq background
(aref face-attr
2)))
4754 (setq face-or-list
(cdr face-or-list
)))
4755 (vector effects foreground background
))
4757 (ps-face-attributes face-or-list
)))
4760 (defconst ps-font-type
(vector nil
'bold
'italic
'bold-italic
))
4763 (defun ps-plot-with-face (from to face
)
4765 ((null face
) ; print text with null face
4766 (ps-plot-region from to
0))
4767 ((eq face
'emacs--invisible--face
)) ; skip invisible text!!!
4768 (t ; otherwise, text has a valid face
4769 (let* ((face-bit (ps-face-attribute-list face
))
4770 (effect (aref face-bit
0))
4771 (foreground (aref face-bit
1))
4772 (background (aref face-bit
2))
4773 (fg-color (if (and ps-print-color-p foreground
(ps-color-device))
4774 (mapcar 'ps-color-value
4775 (ps-color-values foreground
))
4777 (bg-color (and ps-print-color-p background
(ps-color-device)
4778 (mapcar 'ps-color-value
4779 (ps-color-values background
)))))
4782 (ps-font-number 'ps-font-for-text
4783 (or (aref ps-font-type
(logand effect
3))
4785 fg-color bg-color
(lsh effect -
2)))))
4789 (defun ps-xemacs-face-kind-p (face kind kind-regex kind-list
)
4790 (let* ((frame-font (or (face-font-instance face
)
4791 (face-font-instance 'default
)))
4792 (kind-cons (and frame-font
4793 (assq kind
(font-instance-properties frame-font
))))
4794 (kind-spec (cdr-safe kind-cons
))
4795 (case-fold-search t
))
4796 (or (and kind-spec
(string-match kind-regex kind-spec
))
4797 ;; Kludge-compatible:
4798 (memq face kind-list
))))
4801 (cond ((eq ps-print-emacs-type
'emacs
) ; emacs
4803 (defun ps-face-bold-p (face)
4804 (or (face-bold-p face
)
4805 (memq face ps-bold-faces
)))
4807 (defun ps-face-italic-p (face)
4808 (or (face-italic-p face
)
4809 (memq face ps-italic-faces
)))
4814 (defun ps-face-bold-p (face)
4815 (ps-xemacs-face-kind-p face
'WEIGHT_NAME
"bold\\|demibold" ps-bold-faces
))
4817 (defun ps-face-italic-p (face)
4818 (or (ps-xemacs-face-kind-p face
'ANGLE_NAME
"i\\|o" ps-italic-faces
)
4819 (ps-xemacs-face-kind-p face
'SLANT
"i\\|o" ps-italic-faces
)))
4823 (defun ps-face-underlined-p (face)
4824 (or (face-underline-p face
)
4825 (memq face ps-underlined-faces
)))
4828 ;; Ensure that face-list is fbound.
4829 (or (fboundp 'face-list
) (defalias 'face-list
'list-faces
))
4832 (defun ps-build-reference-face-lists ()
4833 ;; Ensure that face database is updated with faces on
4834 ;; `font-lock-face-attributes' (obsolete stuff)
4835 (ps-font-lock-face-attributes)
4836 ;; Now, rebuild reference face lists
4837 (setq ps-print-face-alist nil
)
4838 (if ps-auto-font-detect
4839 (mapcar 'ps-map-face
(face-list))
4840 (mapcar 'ps-set-face-bold ps-bold-faces
)
4841 (mapcar 'ps-set-face-italic ps-italic-faces
)
4842 (mapcar 'ps-set-face-underline ps-underlined-faces
))
4843 (setq ps-build-face-reference nil
))
4846 (defun ps-set-face-bold (face)
4847 (ps-set-face-attribute face
1))
4849 (defun ps-set-face-italic (face)
4850 (ps-set-face-attribute face
2))
4852 (defun ps-set-face-underline (face)
4853 (ps-set-face-attribute face
4))
4856 (defun ps-set-face-attribute (face effect
)
4857 (let ((face-bit (cdr (ps-map-face face
))))
4858 (aset face-bit
0 (logior (aref face-bit
0) effect
))))
4861 (defun ps-map-face (face)
4862 (let* ((face-map (ps-screen-to-bit-face face
))
4863 (ps-face-bit (cdr (assq (car face-map
) ps-print-face-alist
))))
4865 ;; if face exists, merge both
4866 (let ((face-bit (cdr face-map
)))
4867 (aset ps-face-bit
0 (logior (aref ps-face-bit
0) (aref face-bit
0)))
4868 (or (aref ps-face-bit
1) (aset ps-face-bit
1 (aref face-bit
1)))
4869 (or (aref ps-face-bit
2) (aset ps-face-bit
2 (aref face-bit
2))))
4870 ;; if face does not exist, insert it
4871 (setq ps-print-face-alist
(cons face-map ps-print-face-alist
)))
4875 (defun ps-screen-to-bit-face (face)
4877 (vector (logior (if (ps-face-bold-p face
) 1 0) ; bold
4878 (if (ps-face-italic-p face
) 2 0) ; italic
4879 (if (ps-face-underlined-p face
) 4 0)) ; underline
4880 (face-foreground face
)
4881 (face-background face
))))
4884 (defun ps-mapper (extent list
)
4885 (nconc list
(list (list (extent-start-position extent
) 'push extent
)
4886 (list (extent-end-position extent
) 'pull extent
)))
4889 (defun ps-extent-sorter (a b
)
4890 (< (extent-priority a
) (extent-priority b
)))
4892 (defun ps-print-ensure-fontified (start end
)
4893 (and (boundp 'lazy-lock-mode
) (symbol-value 'lazy-lock-mode
)
4894 (if (fboundp 'lazy-lock-fontify-region
)
4895 (lazy-lock-fontify-region start end
) ; the new
4896 (lazy-lock-fontify-buffer)))) ; the old
4898 (defun ps-generate-postscript-with-faces (from to
)
4899 ;; Some initialization...
4900 (setq ps-current-effect
0)
4902 ;; Build the reference lists of faces if necessary.
4903 (if (or ps-always-build-face-reference
4904 ps-build-face-reference
)
4906 (message "Collecting face information...")
4907 (ps-build-reference-face-lists)))
4908 ;; Set the color scale. We do it here instead of in the defvar so
4909 ;; that ps-print can be dumped into emacs. This expression can't be
4910 ;; evaluated at dump-time because X isn't initialized.
4911 (setq ps-print-color-scale
4912 (if (and ps-print-color-p
(ps-color-device))
4913 (float (car (ps-color-values "white")))
4915 ;; Generate some PostScript.
4917 (narrow-to-region from to
)
4918 (let ((face 'default
)
4920 (ps-print-ensure-fontified from to
)
4922 ((or (eq ps-print-emacs-type
'lucid
)
4923 (eq ps-print-emacs-type
'xemacs
))
4924 ;; Build the list of extents...
4925 (let ((a (cons 'dummy nil
))
4926 record type extent extent-list
)
4927 (map-extents 'ps-mapper nil from to a
)
4928 (setq a
(sort (cdr a
) 'car-less-than-car
)
4931 ;; Loop through the extents...
4933 (setq record
(car a
)
4935 position
(car record
)
4941 extent
(car record
))
4943 ;; Plot up to this record.
4944 ;; XEmacs 19.12: for some reason, we're getting into a
4945 ;; situation in which some of the records have
4946 ;; positions less than 'from'. Since we've narrowed
4947 ;; the buffer, this'll generate errors. This is a
4948 ;; hack, but don't call ps-plot-with-face unless from >
4950 (and (>= from
(point-min)) (<= position
(point-max))
4951 (ps-plot-with-face from position face
))
4955 (if (extent-face extent
)
4956 (setq extent-list
(sort (cons extent extent-list
)
4957 'ps-extent-sorter
))))
4960 (setq extent-list
(sort (delq extent extent-list
)
4961 'ps-extent-sorter
))))
4965 (extent-face (car extent-list
))
4971 ((eq ps-print-emacs-type
'emacs
)
4972 (let ((property-change from
)
4973 (overlay-change from
)
4974 (save-buffer-invisibility-spec buffer-invisibility-spec
)
4975 (buffer-invisibility-spec nil
))
4977 (if (< property-change to
) ; Don't search for property change
4978 ; unless previous search succeeded.
4979 (setq property-change
4980 (next-property-change from nil to
)))
4981 (if (< overlay-change to
) ; Don't search for overlay change
4982 ; unless previous search succeeded.
4983 (setq overlay-change
4984 (min (next-overlay-change from
) to
)))
4986 (min property-change overlay-change
))
4987 ;; The code below is not quite correct,
4988 ;; because a non-nil overlay invisible property
4989 ;; which is inactive according to the current value
4990 ;; of buffer-invisibility-spec nonetheless overrides
4991 ;; a face text property.
4993 (cond ((let ((prop (get-text-property from
'invisible
)))
4994 ;; Decide whether this invisible property
4995 ;; really makes the text invisible.
4996 (if (eq save-buffer-invisibility-spec t
)
4998 (or (memq prop save-buffer-invisibility-spec
)
4999 (assq prop save-buffer-invisibility-spec
))))
5000 'emacs--invisible--face
)
5001 ((get-text-property from
'face
))
5003 (let ((overlays (overlays-at from
))
5004 (face-priority -
1)) ; text-property
5006 (let* ((overlay (car overlays
))
5007 (overlay-face (overlay-get overlay
'face
))
5008 (overlay-invisible (overlay-get overlay
'invisible
))
5009 (overlay-priority (or (overlay-get overlay
5012 (and (or overlay-invisible overlay-face
)
5013 (> overlay-priority face-priority
)
5015 (cond ((if (eq save-buffer-invisibility-spec t
)
5016 (not (null overlay-invisible
))
5017 (or (memq overlay-invisible
5018 save-buffer-invisibility-spec
)
5019 (assq overlay-invisible
5020 save-buffer-invisibility-spec
)))
5021 'emacs--invisible--face
)
5022 (face overlay-face
))
5023 face-priority overlay-priority
)))
5024 (setq overlays
(cdr overlays
))))
5025 ;; Plot up to this record.
5026 (ps-plot-with-face from position face
)
5027 (setq from position
)))))
5028 (ps-plot-with-face from to face
))))
5030 (defun ps-generate-postscript (from to
)
5031 (ps-plot-region from to
0 nil
))
5033 (defun ps-generate (buffer from to genfunc
)
5035 (let ((from (min to from
))
5037 ;; This avoids trouble if chars with read-only properties
5038 ;; are copied into ps-spool-buffer.
5039 (inhibit-read-only t
))
5041 (narrow-to-region from to
)
5042 (and ps-razzle-dazzle
5043 (message "Formatting...%3d%%" (setq ps-razchunk
0)))
5044 (setq ps-source-buffer buffer
5045 ps-spool-buffer
(get-buffer-create ps-spool-buffer-name
))
5046 (ps-init-output-queue)
5047 (let (safe-marker completed-safely needs-begin-file
)
5050 (set-buffer ps-spool-buffer
)
5051 (set-buffer-multibyte nil
)
5053 ;; Get a marker and make it point to the current end of the
5054 ;; buffer, If an error occurs, we'll delete everything from
5055 ;; the end of this marker onwards.
5056 (setq safe-marker
(make-marker))
5057 (set-marker safe-marker
(point-max))
5059 (goto-char (point-min))
5060 (or (looking-at (regexp-quote ps-adobe-tag
))
5061 (setq needs-begin-file t
))
5063 (set-buffer ps-source-buffer
)
5064 (if needs-begin-file
(ps-begin-file))
5065 (ps-mule-begin from to
)
5068 (set-buffer ps-source-buffer
)
5069 (funcall genfunc from to
)
5072 (and ps-spool-duplex
(= (mod ps-page-count
2) 1)
5077 ;; Back to the PS output buffer to set the page count
5078 (let ((total-lines (if ps-printing-region
5079 (cdr ps-printing-region
)
5080 (ps-count-lines (point-min) (point-max))))
5081 (total-pages (if ps-print-only-one-header
5084 (set-buffer ps-spool-buffer
)
5085 (goto-char (point-min))
5086 (while (re-search-forward "^/Lines 0 def\n/PageCount 0 def$"
5088 (replace-match (format "/Lines %d def\n/PageCount %d def"
5089 total-lines total-pages
) t
)))
5091 ;; Setting this variable tells the unwind form that the
5092 ;; the PostScript was generated without error.
5093 (setq completed-safely t
))
5095 ;; Unwind form: If some bad mojo occurred while generating
5096 ;; PostScript, delete all the PostScript that was generated.
5097 ;; This protects the previously spooled files from getting
5099 (and (markerp safe-marker
) (not completed-safely
)
5101 (set-buffer ps-spool-buffer
)
5102 (delete-region (marker-position safe-marker
) (point-max))))))
5104 (and ps-razzle-dazzle
(message "Formatting...done"))))))
5106 ;; To avoid compilation gripes
5107 (defvar dos-ps-printer nil
)
5109 ;; Permit dynamic evaluation at print time of `ps-lpr-switches'.
5110 (defun ps-do-despool (filename)
5111 (if (or (not (boundp 'ps-spool-buffer
))
5112 (not (symbol-value 'ps-spool-buffer
)))
5113 (message "No spooled PostScript to print")
5116 (and ps-razzle-dazzle
(message "Saving..."))
5117 (set-buffer ps-spool-buffer
)
5118 (setq filename
(expand-file-name filename
))
5119 (let ((coding-system-for-write 'raw-text-unix
))
5120 (write-region (point-min) (point-max) filename
))
5121 (and ps-razzle-dazzle
(message "Wrote %s" filename
)))
5122 ;; Else, spool to the printer
5123 (and ps-razzle-dazzle
(message "Printing..."))
5125 (set-buffer ps-spool-buffer
)
5126 (let* ((coding-system-for-write 'raw-text-unix
)
5127 (ps-printer-name (or ps-printer-name printer-name
))
5129 (append (and (stringp ps-printer-name
)
5130 (list (concat "-P" ps-printer-name
)))
5132 (if (and (memq system-type
'(ms-dos windows-nt
))
5133 (or (stringp dos-ps-printer
)
5134 (stringp ps-printer-name
)))
5135 (write-region (point-min) (point-max)
5136 (if (stringp dos-ps-printer
)
5140 (apply 'call-process-region
5141 (point-min) (point-max) ps-lpr-command nil
5142 (and (fboundp 'start-process
) 0)
5144 (ps-flatten-list ; dynamic evaluation
5145 (mapcar 'ps-eval-switch ps-lpr-switches
))))))
5146 (and ps-razzle-dazzle
(message "Printing...done")))
5147 (kill-buffer ps-spool-buffer
)))
5149 ;; Dynamic evaluation
5150 (defun ps-eval-switch (arg)
5151 (cond ((stringp arg
) arg
)
5152 ((functionp arg
) (apply arg nil
))
5153 ((symbolp arg
) (symbol-value arg
))
5154 ((consp arg
) (apply (car arg
) (cdr arg
)))
5157 ;; `ps-flatten-list' is defined here (copied from "message.el" and
5158 ;; enhanced to handle dotted pairs as well) until we can get some
5159 ;; sensible autoloads, or `flatten-list' gets put somewhere decent.
5161 ;; (ps-flatten-list '((a . b) c (d . e) (f g h) i . j))
5162 ;; => (a b c d e f g h i j)
5164 (defun ps-flatten-list (&rest list
)
5165 (ps-flatten-list-1 list
))
5167 (defun ps-flatten-list-1 (list)
5168 (cond ((null list
) nil
)
5169 ((consp list
) (append (ps-flatten-list-1 (car list
))
5170 (ps-flatten-list-1 (cdr list
))))
5173 (defun ps-kill-emacs-check ()
5175 (and (setq ps-buffer
(get-buffer ps-spool-buffer-name
))
5176 (buffer-modified-p ps-buffer
)
5177 (y-or-n-p "Unprinted PostScript waiting; print now? ")
5179 (and (setq ps-buffer
(get-buffer ps-spool-buffer-name
))
5180 (buffer-modified-p ps-buffer
)
5181 (not (yes-or-no-p "Unprinted PostScript waiting; exit anyway? "))
5182 (error "Unprinted PostScript"))))
5184 (if (fboundp 'add-hook
)
5185 (funcall 'add-hook
'kill-emacs-hook
'ps-kill-emacs-check
)
5187 (message "Won't override existing kill-emacs-hook")
5188 (setq kill-emacs-hook
'ps-kill-emacs-check
)))
5190 ;;; Sample Setup Code:
5192 ;; This stuff is for anybody that's brave enough to look this far,
5193 ;; and able to figure out how to use it. It isn't really part of
5194 ;; ps-print, but I'll leave it here in hopes it might be useful:
5196 ;; WARNING!!! The following code is *sample* code only. Don't use it
5197 ;; unless you understand what it does!
5199 (defmacro ps-prsc
()
5200 `(if (eq ps-print-emacs-type
'emacs
) [f22] 'f22))
5201 (defmacro ps-c-prsc ()
5202 `(if (eq ps-print-emacs-type 'emacs) [C-f22] '(control f22)))
5203 (defmacro ps-s-prsc ()
5204 `(if (eq ps-print-emacs-type 'emacs) [S-f22] '(shift f22)))
5206 ;; A hook to bind to `rmail-mode-hook' to locally bind prsc and set the
5207 ;; `ps-left-headers' specially for mail messages.
5208 (defun ps-rmail-mode-hook ()
5209 (local-set-key (ps-prsc) 'ps-rmail-print-message-from-summary)
5210 (setq ps-header-lines 3
5212 ;; The left headers will display the message's subject, its
5213 ;; author, and the name of the folder it was in.
5214 '(ps-article-subject ps-article-author buffer-name)))
5216 ;; See `ps-gnus-print-article-from-summary'. This function does the
5217 ;; same thing for rmail.
5218 (defun ps-rmail-print-message-from-summary ()
5220 (ps-print-message-from-summary 'rmail-summary-buffer "RMAIL"))
5222 ;; Used in `ps-rmail-print-article-from-summary',
5223 ;; `ps-gnus-print-article-from-summary' and `ps-vm-print-message-from-summary'.
5224 (defun ps-print-message-from-summary (summary-buffer summary-default)
5225 (let ((ps-buf (or (and (boundp summary-buffer)
5226 (symbol-value summary-buffer))
5228 (and (get-buffer ps-buf)
5231 (ps-spool-buffer-with-faces)))))
5233 ;; Look in an article or mail message for the Subject: line. To be
5234 ;; placed in `ps-left-headers'.
5235 (defun ps-article-subject ()
5237 (goto-char (point-min))
5238 (if (re-search-forward "^Subject:[ \t]+\\(.*\\)$" nil t)
5239 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
5242 ;; Look in an article or mail message for the From: line. Sorta-kinda
5243 ;; understands RFC-822 addresses and can pull the real name out where
5244 ;; it's provided. To be placed in `ps-left-headers'.
5245 (defun ps-article-author ()
5247 (goto-char (point-min))
5248 (if (re-search-forward "^From:[ \t]+\\(.*\\)$" nil t)
5249 (let ((fromstring (buffer-substring-no-properties (match-beginning 1)
5253 ;; Try first to match addresses that look like
5254 ;; thompson@wg2.waii.com (Jim Thompson)
5255 ((string-match ".*[ \t]+(\\(.*\\))" fromstring)
5256 (substring fromstring (match-beginning 1) (match-end 1)))
5258 ;; Next try to match addresses that look like
5259 ;; Jim Thompson <thompson@wg2.waii.com>
5260 ((string-match "\\(.*\\)[ \t]+<.*>" fromstring)
5261 (substring fromstring (match-beginning 1) (match-end 1)))
5263 ;; Couldn't find a real name -- show the address instead.
5267 ;; A hook to bind to `gnus-article-prepare-hook'. This will set the
5268 ;; `ps-left-headers' specially for gnus articles. Unfortunately,
5269 ;; `gnus-article-mode-hook' is called only once, the first time the *Article*
5270 ;; buffer enters that mode, so it would only work for the first time
5271 ;; we ran gnus. The second time, this hook wouldn't get set up. The
5272 ;; only alternative is `gnus-article-prepare-hook'.
5273 (defun ps-gnus-article-prepare-hook ()
5274 (setq ps-header-lines 3
5276 ;; The left headers will display the article's subject, its
5277 ;; author, and the newsgroup it was in.
5278 '(ps-article-subject ps-article-author gnus-newsgroup-name)))
5280 ;; A hook to bind to `vm-mode-hook' to locally bind prsc and set the
5281 ;; `ps-left-headers' specially for mail messages.
5282 (defun ps-vm-mode-hook ()
5283 (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary)
5284 (setq ps-header-lines 3
5286 ;; The left headers will display the message's subject, its
5287 ;; author, and the name of the folder it was in.
5288 '(ps-article-subject ps-article-author buffer-name)))
5290 ;; Every now and then I forget to switch from the *Summary* buffer to
5291 ;; the *Article* before hitting prsc, and a nicely formatted list of
5292 ;; article subjects shows up at the printer. This function, bound to
5293 ;; prsc for the gnus *Summary* buffer means I don't have to switch
5295 ;; sb: Updated for Gnus 5.
5296 (defun ps-gnus-print-article-from-summary ()
5298 (ps-print-message-from-summary 'gnus-article-buffer "*Article*"))
5300 ;; See `ps-gnus-print-article-from-summary'. This function does the
5301 ;; same thing for vm.
5302 (defun ps-vm-print-message-from-summary ()
5304 (ps-print-message-from-summary 'vm-mail-buffer ""))
5306 ;; A hook to bind to bind to `gnus-summary-setup-buffer' to locally bind
5308 (defun ps-gnus-summary-setup ()
5309 (local-set-key (ps-prsc) 'ps-gnus-print-article-from-summary))
5311 ;; Look in an article or mail message for the Subject: line. To be
5312 ;; placed in `ps-left-headers'.
5313 (defun ps-info-file ()
5315 (goto-char (point-min))
5316 (if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)" nil t)
5317 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
5320 ;; Look in an article or mail message for the Subject: line. To be
5321 ;; placed in `ps-left-headers'.
5322 (defun ps-info-node ()
5324 (goto-char (point-min))
5325 (if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)" nil t)
5326 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
5329 (defun ps-info-mode-hook ()
5330 (setq ps-left-header
5331 ;; The left headers will display the node name and file name.
5332 '(ps-info-node ps-info-file)))
5334 ;; WARNING! The following function is a *sample* only, and is *not*
5335 ;; meant to be used as a whole unless you understand what the effects
5336 ;; will be! (In fact, this is a copy of Jim's setup for ps-print --
5337 ;; I'd be very surprised if it was useful to *anybody*, without
5340 (defun ps-jts-ps-setup ()
5341 (global-set-key (ps-prsc) 'ps-spool-buffer-with-faces) ;f22 is prsc
5342 (global-set-key (ps-s-prsc) 'ps-spool-region-with-faces)
5343 (global-set-key (ps-c-prsc) 'ps-despool)
5344 (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook)
5345 (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup)
5346 (add-hook 'vm-mode-hook 'ps-vm-mode-hook)
5347 (add-hook 'vm-mode-hooks 'ps-vm-mode-hook)
5348 (add-hook 'Info-mode-hook 'ps-info-mode-hook)
5349 (setq ps-spool-duplex t
5350 ps-print-color-p nil
5351 ps-lpr-command "lpr"
5352 ps-lpr-switches '("-Jjct,duplex_long"))
5355 ;; WARNING! The following function is a *sample* only, and is *not*
5356 ;; meant to be used as a whole unless it corresponds to your needs.
5357 ;; (In fact, this is a copy of Jack's setup for ps-print --
5358 ;; I would not be that surprised if it was useful to *anybody*,
5359 ;; without modification.)
5361 (defun ps-jack-setup ()
5362 (setq ps-print-color-p nil
5363 ps-lpr-command "lpr"
5368 ps-number-of-columns 2
5370 ps-left-margin (/ (* 72 1.0) 2.54) ; 1.0 cm
5371 ps-right-margin (/ (* 72 1.0) 2.54) ; 1.0 cm
5372 ps-inter-column (/ (* 72 1.0) 2.54) ; 1.0 cm
5373 ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
5374 ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
5375 ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm
5376 ps-header-line-pad .15
5378 ps-print-header-frame t
5383 ps-font-family 'Courier
5385 ps-header-font-family 'Helvetica
5386 ps-header-font-size 6
5387 ps-header-title-font-size 8)
5392 ;;; ps-print.el ends here