1 ;;; ps-print.el --- Print text from the buffer as PostScript
3 ;; Copyright (C) 1993, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc.
5 ;; Author: Jim Thompson (was <thompson@wg2.waii.com>)
6 ;; Author: Jacques Duthen (was <duthen@cegelec-red.fr>)
7 ;; Author: Vinicius Jose Latorre <vinicius@cpqd.com.br>
8 ;; Author: Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
9 ;; Maintainer: Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
10 ;; Maintainer: Vinicius Jose Latorre <vinicius@cpqd.com.br>
11 ;; Keywords: print, PostScript
12 ;; Time-stamp: <99/02/19 11:47:32 vinicius>
15 (defconst ps-print-version "4.1.4"
16 "ps-print.el, v 4.1.4 <99/02/19 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).
70 ;; ps-print provides eight commands for generating PostScript images
74 ;; ps-print-buffer-with-faces
76 ;; ps-print-region-with-faces
78 ;; ps-spool-buffer-with-faces
80 ;; ps-spool-region-with-faces
82 ;; These commands all perform essentially the same function: they
83 ;; generate PostScript images suitable for printing on a PostScript
84 ;; printer or displaying with GhostScript. These commands are
85 ;; collectively referred to as "ps-print- commands".
87 ;; The word "print" or "spool" in the command name determines when the
88 ;; PostScript image is sent to the printer:
90 ;; print - The PostScript image is immediately sent to the
93 ;; spool - The PostScript image is saved temporarily in an
94 ;; Emacs buffer. Many images may be spooled locally
95 ;; before printing them. To send the spooled images
96 ;; to the printer, use the command `ps-despool'.
98 ;; The spooling mechanism was designed for printing lots of small
99 ;; files (mail messages or netnews articles) to save paper that would
100 ;; otherwise be wasted on banner pages, and to make it easier to find
101 ;; your output at the printer (it's easier to pick up one 50-page
102 ;; printout than to find 50 single-page printouts).
104 ;; ps-print has a hook in the `kill-emacs-hook' so that you won't
105 ;; accidentally quit from Emacs while you have unprinted PostScript
106 ;; waiting in the spool buffer. If you do attempt to exit with
107 ;; spooled PostScript, you'll be asked if you want to print it, and if
108 ;; you decline, you'll be asked to confirm the exit; this is modeled
109 ;; on the confirmation that Emacs uses for modified buffers.
111 ;; The word "buffer" or "region" in the command name determines how
112 ;; much of the buffer is printed:
114 ;; buffer - Print the entire buffer.
116 ;; region - Print just the current region.
118 ;; The -with-faces suffix on the command name means that the command
119 ;; will include font, color, and underline information in the
120 ;; PostScript image, so the printed image can look as pretty as the
121 ;; buffer. The ps-print- commands without the -with-faces suffix
122 ;; don't include font, color, or underline information; images printed
123 ;; with these commands aren't as pretty, but are faster to generate.
125 ;; Two ps-print- command examples:
127 ;; ps-print-buffer - print the entire buffer,
128 ;; without font, color, or
129 ;; underline information, and
130 ;; send it immediately to the
133 ;; ps-spool-region-with-faces - print just the current region;
134 ;; include font, color, and
135 ;; underline information, and
136 ;; spool the image in Emacs to
137 ;; send to the printer later.
143 ;; To print your buffer, type
145 ;; M-x ps-print-buffer
147 ;; or substitute one of the other seven ps-print- commands. The
148 ;; command will generate the PostScript image and print or spool it as
149 ;; specified. By giving the command a prefix argument
151 ;; C-u M-x ps-print-buffer
153 ;; it will save the PostScript image to a file instead of sending it
154 ;; to the printer; you will be prompted for the name of the file to
155 ;; save the image to. The prefix argument is ignored by the commands
156 ;; that spool their images, but you may save the spooled images to a
157 ;; file by giving a prefix argument to `ps-despool':
159 ;; C-u M-x ps-despool
161 ;; When invoked this way, `ps-despool' will prompt you for the name of
162 ;; the file to save to.
164 ;; Any of the `ps-print-' commands can be bound to keys; I recommend
165 ;; binding `ps-spool-buffer-with-faces', `ps-spool-region-with-faces',
166 ;; and `ps-despool'. Here are the bindings I use on my Sun 4 keyboard:
168 ;; (global-set-key 'f22 'ps-spool-buffer-with-faces) ;f22 is prsc
169 ;; (global-set-key '(shift f22) 'ps-spool-region-with-faces)
170 ;; (global-set-key '(control f22) 'ps-despool)
173 ;; The Printer Interface
174 ;; ---------------------
176 ;; The variables `ps-lpr-command' and `ps-lpr-switches' determine what
177 ;; command is used to send the PostScript images to the printer, and
178 ;; what arguments to give the command. These are analogous to
179 ;; `lpr-command' and `lpr-switches'.
181 ;; Make sure that they contain appropriate values for your system;
182 ;; see the usage notes below and the documentation of these variables.
184 ;; The variable `ps-printer-name' determine the name of a local printer for
185 ;; printing PostScript files.
187 ;; NOTE: `ps-lpr-command' and `ps-lpr-switches' take their initial values
188 ;; from the variables `lpr-command' and `lpr-switches'. If you have
189 ;; `lpr-command' set to invoke a pretty-printer such as `enscript',
190 ;; then ps-print won't work properly. `ps-lpr-command' must name
191 ;; a program that does not format the files it prints.
192 ;; `ps-printer-name' takes its initial value from the variable
199 ;; All dimensions are floats in PostScript points.
200 ;; 1 inch == 2.54 cm == 72 points
201 ;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points
203 ;; The variable `ps-paper-type' determines the size of paper ps-print
204 ;; formats for; it should contain one of the symbols:
205 ;; `a4' `a3' `letter' `legal' `letter-small' `tabloid'
206 ;; `ledger' `statement' `executive' `a4small' `b4' `b5'
208 ;; The variable `ps-landscape-mode' determines the orientation
209 ;; of the printing on the page:
210 ;; nil means `portrait' mode, non-nil means `landscape' mode.
211 ;; There is no oblique mode yet, though this is easy to do in ps.
213 ;; In landscape mode, the text is NOT scaled: you may print 70 lines
214 ;; in portrait mode and only 50 lignes in landscape mode.
215 ;; The margins represent margins in the printed paper:
216 ;; the top margin is the margin between the top of the page
217 ;; and the printed header, whatever the orientation is.
219 ;; The variable `ps-number-of-columns' determines the number of columns
220 ;; both in landscape and portrait mode.
222 ;; - (the standard) one column portrait mode
223 ;; - (my favorite) two columns landscape mode (which spares trees)
225 ;; - one column landscape mode for files with very long lines.
226 ;; - multi-column portrait or landscape mode
232 ;; The horizontal layout is determined by the variables
233 ;; `ps-left-margin' `ps-inter-column' `ps-right-margin'
236 ;; ------------------------------------------
238 ;; | lm | text | ic | text | ic | text | rm |
240 ;; ------------------------------------------
242 ;; If `ps-number-of-columns' is 1, `ps-inter-column' is not relevant.
243 ;; Usually, lm = rm > 0 and ic = lm
244 ;; If (ic < 0), the text of adjacent columns can overlap.
250 ;; The vertical layout is determined by the variables
251 ;; `ps-bottom-margin' `ps-top-margin' `ps-header-offset'
254 ;; |--------| |--------|
256 ;; |--------| |--------|
260 ;; |--------| or | text |
264 ;; |--------| |--------|
266 ;; |--------| |--------|
268 ;; If `ps-print-header' is nil, `ps-header-offset' is not relevant.
269 ;; The margins represent margins in the printed paper:
270 ;; the top margin is the margin between the top of the page
271 ;; and the printed header, whatever the orientation is.
277 ;; ps-print can print headers at the top of each column or at the top
278 ;; of each page; the default headers contain the following four items:
279 ;; on the left, the name of the buffer and, if the buffer is visiting
280 ;; a file, the file's directory; on the right, the page number and
281 ;; date of printing. The default headers look something like this:
284 ;; /home/jct/emacs-lisp/ps/new 94/12/31
286 ;; When printing on duplex printers, left and right are reversed so
287 ;; that the page numbers are toward the outside (cf. `ps-spool-duplex').
289 ;; Headers are configurable:
290 ;; To turn them off completely, set `ps-print-header' to nil.
291 ;; To turn off the header's gaudy framing box,
292 ;; set `ps-print-header-frame' to nil.
294 ;; To print only one header at the top of each page,
295 ;; set `ps-print-only-one-header' to t.
297 ;; The font family and size of text in the header are determined
298 ;; by the variables `ps-header-font-family', `ps-header-font-size' and
299 ;; `ps-header-title-font-size' (see below).
301 ;; The variable `ps-header-line-pad' determines the portion of a header
302 ;; title line height to insert between the header frame and the text
303 ;; it contains, both in the vertical and horizontal directions:
304 ;; .5 means half a line.
306 ;; Page numbers are printed in `n/m' format, indicating page n of m pages;
307 ;; to omit the total page count and just print the page number,
308 ;; set `ps-show-n-of-n' to nil.
310 ;; The amount of information in the header can be changed by changing
311 ;; the number of lines. To show less, set `ps-header-lines' to 1, and
312 ;; the header will show only the buffer name and page number. To show
313 ;; more, set `ps-header-lines' to 3, and the header will show the time of
314 ;; printing below the date.
316 ;; To change the content of the headers, change the variables
317 ;; `ps-left-header' and `ps-right-header'.
318 ;; These variables are lists, specifying top-to-bottom the text
319 ;; to display on the left or right side of the header.
320 ;; Each element of the list should be a string or a symbol.
321 ;; Strings are inserted directly into the PostScript arrays,
322 ;; and should contain the PostScript string delimiters '(' and ')'.
324 ;; Symbols in the header format lists can either represent functions
325 ;; or variables. Functions are called, and should return a string to
326 ;; show in the header. Variables should contain strings to display in
327 ;; the header. In either case, function or variable, the PostScript
328 ;; string delimiters are added by ps-print, and should not be part of
329 ;; the returned value.
331 ;; Here's an example: say we want the left header to display the text
337 ;; where we have a function to return "Moe"
339 ;; (defun moe-func ()
342 ;; a variable specifying "Larry"
344 ;; (setq larry-var "Larry")
346 ;; and a literal for "Curly". Here's how `ps-left-header' should be
349 ;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)"))
351 ;; Note that Curly has the PostScript string delimiters inside his
352 ;; quotes -- those aren't misplaced lisp delimiters!
354 ;; Without them, PostScript would attempt to call the undefined
355 ;; function Curly, which would result in a PostScript error.
357 ;; Since most printers don't report PostScript errors except by
358 ;; aborting the print job, this kind of error can be hard to track down.
360 ;; Consider yourself warned!
363 ;; PostScript Prologue Header
364 ;; --------------------------
366 ;; It is possible to add PostScript prologue header comments besides that
367 ;; ps-print generates by setting the variable `ps-print-prologue-header'.
369 ;; `ps-print-prologue-header' may be a string or a symbol function which
370 ;; returns a string. Note that this string is inserted on PostScript prologue
371 ;; header section which is used to define some document characteristic through
372 ;; PostScript special comments, like "%%Requirements: jog\n".
374 ;; By default `ps-print-prologue-header' is nil.
376 ;; ps-print always inserts the %%Requirements: comment, so if you need to insert
377 ;; more requirements put them first in `ps-print-prologue-header' using the
378 ;; "%%+" comment. For example, if you need to set numcopies to 3 and jog on
379 ;; requirements and set %%LanguageLevel: to 2, do:
381 ;; (setq ps-print-prologue-header
382 ;; "%%+ numcopies(3) jog\n%%LanguageLevel: 2\n")
384 ;; The duplex requirement is inserted by ps-print (see section Duplex Printers).
386 ;; Do not forget to terminate the string with "\n".
388 ;; For more information about PostScript document comments, see:
389 ;; PostScript Language Reference Manual (2nd edition)
390 ;; Adobe Systems Incorporated
391 ;; Appendix G: Document Structuring Conventions -- Version 3.0
397 ;; If you have a duplex-capable printer (one that prints both sides of
398 ;; the paper), set `ps-spool-duplex' to t.
399 ;; ps-print will insert blank pages to make sure each buffer starts
400 ;; on the correct side of the paper.
401 ;; Don't forget to set `ps-lpr-switches' to select duplex printing
405 ;; Control And 8-bit Characters
406 ;; ----------------------------
408 ;; The variable `ps-print-control-characters' specifies whether you want to see
409 ;; a printable form for control and 8-bit characters, that is, instead of
410 ;; sending, for example, a ^D (\004) to printer, it is sent the string "^D".
412 ;; Valid values for `ps-print-control-characters' are:
414 ;; 8-bit This is the value to use when you want an ASCII encoding of
415 ;; any control or non-ASCII character. Control characters are
416 ;; encoded as "^D", and non-ASCII characters have an
419 ;; control-8-bit This is the value to use when you want an ASCII encoding of
420 ;; any control character, whether it is 7 or 8-bit.
421 ;; European 8-bits accented characters are printed according
424 ;; control Only ASCII control characters have an ASCII encoding.
425 ;; European 8-bits accented characters are printed according
428 ;; nil No ASCII encoding. Any character is printed according the
431 ;; Any other value is treated as nil.
433 ;; The default is `control-8-bit'.
435 ;; Characters TAB, NEWLINE and FORMFEED are always treated by ps-print engine.
438 ;; Printing Multi-byte Buffer
439 ;; --------------------------
441 ;; See ps-mule.el for documentation.
447 ;; The variable `ps-line-number' specifies whether to number each line;
448 ;; non-nil means do so. The default is nil (don't number each line).
454 ;; Zebra stripes are a kind of background that appear "underneath" the text
455 ;; and can make the text easier to read. They look like this:
457 ;; XXXXXXXXXXXXXXXXXXXXXXXX
458 ;; XXXXXXXXXXXXXXXXXXXXXXXX
459 ;; XXXXXXXXXXXXXXXXXXXXXXXX
463 ;; XXXXXXXXXXXXXXXXXXXXXXXX
464 ;; XXXXXXXXXXXXXXXXXXXXXXXX
465 ;; XXXXXXXXXXXXXXXXXXXXXXXX
467 ;; The blocks of X's represent rectangles filled with a light gray color.
468 ;; Each rectangle extends all the way across the page.
470 ;; The height, in lines, of each rectangle is controlled by
471 ;; the variable `ps-zebra-stripe-height', which is 3 by default.
472 ;; The distance between stripes equals the height of a stripe.
474 ;; The variable `ps-zebra-stripes' controls whether to print zebra stripes.
475 ;; Non-nil means yes, nil means no. The default is nil.
477 ;; See also section How Ps-Print Has A Text And/Or Image On Background.
483 ;; ps-print has the following hook variables:
486 ;; It is evaluated once before any printing process. This is the right
487 ;; place to initialize ps-print global data.
488 ;; For an example, see section Adding a New Font Family.
490 ;; `ps-print-begin-page-hook'
491 ;; It is evaluated on each real beginning of page, that is, ps-print
492 ;; considers each beginning of column as a beginning of page, and a real
493 ;; beginning of page is when the beginning of column coincides with a
494 ;; paper change on your printer.
496 ;; `ps-print-begin-column-hook'
497 ;; It is evaluated on each beginning of column, except in the beginning
498 ;; of column that `ps-print-begin-page-hook' is evaluated.
504 ;; ps-print now knows rather precisely some fonts: the variable
505 ;; `ps-font-info-database' contains information for a list of font families
506 ;; (currently mainly `Courier' `Helvetica' `Times' `Palatino' `Helvetica-Narrow'
507 ;; `NewCenturySchlbk'). Each font family contains the font names for standard,
508 ;; bold, italic and bold-italic characters, a reference size (usually 10) and
509 ;; the corresponding line height, width of a space and average character width.
511 ;; The variable `ps-font-family' determines which font family is to be used for
512 ;; ordinary text. If its value does not correspond to a known font family, an
513 ;; error message is printed into the `*Messages*' buffer, which lists the
514 ;; currently available font families.
516 ;; The variable `ps-font-size' determines the size (in points) of the font for
517 ;; ordinary text, when generating PostScript. Its value is a float or a cons of
518 ;; floats which has the following form:
520 ;; (LANDSCAPE-SIZE . PORTRAIT-SIZE)
522 ;; Similarly, the variable `ps-header-font-family' determines which font family
523 ;; is to be used for text in the header.
525 ;; The variable `ps-header-font-size' determines the font size, in points, for
526 ;; text in the header (similar to `ps-font-size').
528 ;; The variable `ps-header-title-font-size' determines the font size, in points,
529 ;; for the top line of text in the header (similar to `ps-font-size').
532 ;; Adding a New Font Family
533 ;; ------------------------
535 ;; To use a new font family, you MUST first teach ps-print
536 ;; this font, i.e., add its information to `ps-font-info-database',
537 ;; otherwise ps-print cannot correctly place line and page breaks.
539 ;; For example, assuming `Helvetica' is unknown,
540 ;; you first need to do the following ONLY ONCE:
542 ;; - create a new buffer
543 ;; - generate the PostScript image to a file (C-u M-x ps-print-buffer)
544 ;; - open this file and find the line:
545 ;; `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage'
546 ;; - delete the leading `%' (which is the PostScript comment character)
547 ;; - replace in this line `Courier' by the new font (say `Helvetica')
549 ;; `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage'
550 ;; - send this file to the printer (or to ghostscript).
551 ;; You should read the following on the output page:
553 ;; For Helvetica 10 point, the line height is 11.56, the space width is 2.78
554 ;; and a crude estimate of average character width is 5.09243
556 ;; - Add these values to the `ps-font-info-database':
557 ;; (setq ps-font-info-database
559 ;; '((Helvetica ; the family key
560 ;; (fonts (normal . "Helvetica")
561 ;; (bold . "Helvetica-Bold")
562 ;; (italic . "Helvetica-Oblique")
563 ;; (bold-italic . "Helvetica-BoldOblique"))
565 ;; (line-height . 11.56)
566 ;; (space-width . 2.78)
567 ;; (avg-char-width . 5.09243)))
568 ;; ps-font-info-database))
569 ;; - Now you can use this font family with any size:
570 ;; (setq ps-font-family 'Helvetica)
571 ;; - if you want to use this family in another emacs session, you must
572 ;; put into your `~/.emacs':
573 ;; (require 'ps-print)
574 ;; (setq ps-font-info-database (append ...)))
575 ;; if you don't want to load ps-print, you have to copy the whole value:
576 ;; (setq ps-font-info-database '(<your stuff> <the standard stuff>))
577 ;; or, use `ps-print-hook' (see section Hooks):
578 ;; (add-hook 'ps-print-hook
579 ;; '(lambda () (setq ps-font-info-database (append ...))))
581 ;; You can create new `mixed' font families like:
583 ;; (fonts (normal . "Courier-Bold")
584 ;; (bold . "Helvetica")
585 ;; (italic . "Zapf-Chancery-MediumItalic")
586 ;; (bold-italic . "NewCenturySchlbk-BoldItalic")
587 ;; (w3-table-hack-x-face . "LineDrawNormal"))
589 ;; (line-height . 10.55)
590 ;; (space-width . 6.0)
591 ;; (avg-char-width . 6.0))
593 ;; Now you can use your new font family with any size:
594 ;; (setq ps-font-family 'my-mixed-family)
596 ;; Note that on above example the `w3-table-hack-x-face' entry refers to
597 ;; a face symbol, so when printing this face it'll be used the font
598 ;; `LineDrawNormal'. If the face `w3-table-hack-x-face' is remapped to
599 ;; use bold and/or italic attribute, the corresponding entry (bold, italic
600 ;; or bold-italic) will be used instead of `w3-table-hack-x-face' entry.
602 ;; Note also that the font family entry order is irrelevant, so the above
603 ;; example could also be written:
606 ;; (fonts (w3-table-hack-x-face . "LineDrawNormal")
607 ;; (bold . "Helvetica")
608 ;; (bold-italic . "NewCenturySchlbk-BoldItalic")
609 ;; (italic . "Zapf-Chancery-MediumItalic")
610 ;; (normal . "Courier-Bold"))
611 ;; (avg-char-width . 6.0)
612 ;; (space-width . 6.0)
613 ;; (line-height . 10.55))
615 ;; Despite the note above, it is recommended that some convention about
616 ;; entry order be used.
618 ;; You can get information on all the fonts resident in YOUR printer
619 ;; by uncommenting the line:
620 ;; % 3 cm 20 cm moveto ReportAllFontInfo showpage
622 ;; The PostScript file should be sent to YOUR PostScript printer.
623 ;; If you send it to ghostscript or to another PostScript printer,
624 ;; you may get slightly different results.
625 ;; Anyway, as ghostscript fonts are autoload, you won't get
629 ;; How Ps-Print Deals With Faces
630 ;; -----------------------------
632 ;; The ps-print-*-with-faces commands attempt to determine which faces
633 ;; should be printed in bold or italic, but their guesses aren't
634 ;; always right. For example, you might want to map colors into faces
635 ;; so that blue faces print in bold, and red faces in italic.
637 ;; It is possible to force ps-print to consider specific faces bold,
638 ;; italic or underline, no matter what font they are displayed in, by setting
639 ;; the variables `ps-bold-faces', `ps-italic-faces' and `ps-underlined-faces'.
640 ;; These variables contain lists of faces that ps-print should consider bold,
641 ;; italic or underline; to set them, put code like the following into your
644 ;; (setq ps-bold-faces '(my-blue-face))
645 ;; (setq ps-italic-faces '(my-red-face))
646 ;; (setq ps-underlined-faces '(my-green-face))
648 ;; Faces like bold-italic that are both bold and italic should go in
651 ;; ps-print keeps internal lists of which fonts are bold and which are
652 ;; italic; these lists are built the first time you invoke ps-print.
653 ;; For the sake of efficiency, the lists are built only once; the same
654 ;; lists are referred in later invocations of ps-print.
656 ;; Because these lists are built only once, it's possible for them to
657 ;; get out of sync, if a face changes, or if new faces are added. To
658 ;; get the lists back in sync, you can set the variable
659 ;; `ps-build-face-reference' to t, and the lists will be rebuilt the
660 ;; next time ps-print is invoked. If you need that the lists always be
661 ;; rebuilt when ps-print is invoked, set the variable
662 ;; `ps-always-build-face-reference' to t.
665 ;; How Ps-Print Deals With Color
666 ;; -----------------------------
668 ;; ps-print detects faces with foreground and background colors
669 ;; defined and embeds color information in the PostScript image.
670 ;; The default foreground and background colors are defined by the
671 ;; variables `ps-default-fg' and `ps-default-bg'.
672 ;; On black-and-white printers, colors are displayed in grayscale.
673 ;; To turn off color output, set `ps-print-color-p' to nil.
676 ;; How Ps-Print Maps Faces
677 ;; -----------------------
679 ;; As ps-print uses PostScript to print buffers, it is possible to have
680 ;; other attributes associated with faces. So the new attributes used
683 ;; strikeout - like underline, but the line is in middle of text.
684 ;; overline - like underline, but the line is over the text.
685 ;; shadow - text will have a shadow.
686 ;; box - text will be surrounded by a box.
687 ;; outline - print characters as hollow outlines.
689 ;; See the documentation for `ps-extend-face'.
691 ;; Let's, for example, remap font-lock-keyword-face to another foreground color
692 ;; and bold attribute:
694 ;; (ps-extend-face '(font-lock-keyword-face "RoyalBlue" nil bold) 'MERGE)
696 ;; If you want to use a new face, define it first with `defface',
697 ;; and then call `ps-extend-face' to specify how to print it.
700 ;; How Ps-Print Has A Text And/Or Image On Background
701 ;; --------------------------------------------------
703 ;; ps-print can print texts and/or EPS PostScript images on background; it is
704 ;; possible to define the following text attributes: font name, font size,
705 ;; initial position, angle, gray scale and pages to print.
707 ;; It has the following EPS PostScript images attributes: file name containing
708 ;; the image, initial position, X and Y scales, angle and pages to print.
710 ;; See documentation for `ps-print-background-text' and
711 ;; `ps-print-background-image'.
713 ;; For example, if we wish to print text "preliminary" on all pages and text
714 ;; "special" on page 5 and from page 11 to page 17, we could specify:
716 ;; (setq ps-print-background-text
719 ;; "LeftMargin" "BottomMargin PrintHeight add" ; X and Y position
720 ;; ; (upper left corner)
722 ;; "PrintHeight neg PrintPageWidth atan" ; angle
723 ;; 5 (11 . 17)) ; page list
726 ;; Similarly, we could print image "~/images/EPS-image1.ps" on all pages and
727 ;; image "~/images/EPS-image2.ps" on page 5 and from page 11 to page 17, we
730 ;; (setq ps-print-background-image
731 ;; '(("~/images/EPS-image1.ps"
732 ;; "LeftMargin" "BottomMargin") ; X and Y position (lower left corner)
733 ;; ("~/images/EPS-image2.ps"
734 ;; "LeftMargin" "BottomMargin PrintHeight 2 div add" ; X and Y position
735 ;; ; (upper left corner)
737 ;; 5 (11 . 17)) ; page list
740 ;; If it is not possible to read (or does not exist) an image file, that file
743 ;; The printing order is:
745 ;; 1. Print zebra stripes
746 ;; 2. Print background texts that it should be on all pages
747 ;; 3. Print background images that it should be on all pages
748 ;; 4. Print background texts only for current page (if any)
749 ;; 5. Print background images only for current page (if any)
751 ;; 7. Print buffer text (with faces, if specified) and line number
757 ;; Some tools are provided to help you customize your font setup.
759 ;; `ps-setup' returns (some part of) the current setup.
761 ;; To avoid wrapping too many lines, you may want to adjust the
762 ;; left and right margins and the font size. On UN*X systems, do:
763 ;; pr -t file | awk '{printf "%3d %s\n", length($0), $0}' | sort -r | head
764 ;; to determine the longest lines of your file.
765 ;; Then, the command `ps-line-lengths' will give you the correspondence
766 ;; between a line length (number of characters) and the maximum font
767 ;; size which doesn't wrap such a line with the current ps-print setup.
769 ;; The commands `ps-nb-pages-buffer' and `ps-nb-pages-region' display
770 ;; the correspondence between a number of pages and the maximum font
771 ;; size which allow the number of lines of the current buffer or of
772 ;; its current region to fit in this number of pages.
774 ;; NOTE: line folding is not taken into account in this process and could
775 ;; change the results.
778 ;; New since version 1.5
779 ;; ---------------------
781 ;; Color output capability.
782 ;; Automatic detection of font attributes (bold, italic).
783 ;; Configurable headers with page numbers.
785 ;; Support for different paper sizes.
786 ;; Better conformance to PostScript Document Structure Conventions.
789 ;; New since version 2.8
790 ;; ---------------------
792 ;; [vinicius] 980922 Vinicius Jose Latorre <vinicius@cpqd.com.br>
794 ;; PostScript prologue header comment insertion.
795 ;; Skip invisible text better.
797 ;; [keinichi] 980819 Kein'ichi Handa <handa@etl.go.jp>
799 ;; Multi-byte buffer handling.
801 ;; [vinicius] 980306 Vinicius Jose Latorre <vinicius@cpqd.com.br>
803 ;; Skip invisible text.
805 ;; [vinicius] 971130 Vinicius Jose Latorre <vinicius@cpqd.com.br>
807 ;; Hooks: `ps-print-hook', `ps-print-begin-page-hook' and
808 ;; `ps-print-begin-column-hook'.
809 ;; Put one header per page over the columns.
810 ;; Better database font management.
811 ;; Better control characters handling.
813 ;; [vinicius] 971121 Vinicius Jose Latorre <vinicius@cpqd.com.br>
815 ;; Dynamic evaluation at print time of `ps-lpr-switches'.
816 ;; Handle control characters.
818 ;; New face attributes.
821 ;; Text and/or image on background.
823 ;; [jack] 960517 Jacques Duthen <duthen@cegelec-red.fr>
825 ;; Font family and float size for text and header.
828 ;; Tools for page setup.
831 ;; Known bugs and limitations of ps-print
832 ;; --------------------------------------
834 ;; Although color printing will work in XEmacs 19.12, it doesn't work
835 ;; well; in particular, bold or italic fonts don't print in the right
838 ;; Invisible properties aren't correctly ignored in XEmacs 19.12.
840 ;; Automatic font-attribute detection doesn't work well, especially
841 ;; with hilit19 and older versions of get-create-face. Users having
842 ;; problems with auto-font detection should use the lists
843 ;; `ps-italic-faces', `ps-bold-faces' and `ps-underlined-faces' and/or
844 ;; turn off automatic detection by setting `ps-auto-font-detect' to nil.
846 ;; Automatic font-attribute detection doesn't work with XEmacs 19.12
847 ;; in tty mode; use the lists `ps-italic-faces', `ps-bold-faces' and
848 ;; `ps-underlined-faces' instead.
850 ;; Still too slow; could use some hand-optimization.
852 ;; Default background color isn't working.
854 ;; Faces are always treated as opaque.
856 ;; Epoch and Emacs 18 not supported. At all.
858 ;; Fixed-pitch fonts work better for line folding, but are not required.
860 ;; `ps-nb-pages-buffer' and `ps-nb-pages-region' don't take care
867 ;; 2-up and 4-up capabilities.
868 ;; Avoid page break inside a paragraph.
869 ;; Add `ps-non-bold-faces' and `ps-non-italic-faces' (should be easy).
870 ;; Improve the memory management for big files (hard?).
871 ;; `ps-nb-pages-buffer' and `ps-nb-pages-region' should take care
878 ;; Thanks to Kein'ichi Handa <handa@etl.go.jp> for multi-byte buffer handling.
880 ;; Thanks to Matthew O Persico <Matthew.Persico@lazard.com> for line number on
883 ;; Thanks to Theodore Jump <tjump@cais.com> for adjust PostScript code order on
886 ;; Thanks to Roland Ducournau <ducour@lirmm.fr> for
887 ;; `ps-print-control-characters' variable documentation.
889 ;; Thanks to Marcus G Daniels <marcus@cathcart.sysc.pdx.edu> for a better
890 ;; database font management.
892 ;; Thanks to Martin Boyer <gamin@videotron.ca> for some ideas on putting one
893 ;; header per page over the columns and correct line numbers when printing a
896 ;; Thanks to Steven L Baur <steve@miranova.com> for dynamic evaluation at
897 ;; print time of `ps-lpr-switches'.
899 ;; Thanks to Kevin Rodgers <kevinr@ihs.com> for handling control characters
900 ;; (his code was severely modified, but the main idea was kept).
902 ;; Thanks to some suggestions on:
903 ;; * Face color map: Marco Melgazzi <marco@techie.com>
904 ;; * XEmacs compatibility: William J. Henney <will@astrosmo.unam.mx>
905 ;; * Check `ps-paper-type': Sudhakar Frederick <sfrederi@asc.corp.mot.com>
907 ;; Thanks to Jacques Duthen <duthen@cegelec-red.fr> (Jack) for the 3.4 version
908 ;; I started from. [vinicius]
910 ;; Thanks to Jim Thompson <?@?> for the 2.8 version I started from.
913 ;; Thanks to Kevin Rodgers <kevinr@ihs.com> for adding support for
914 ;; color and the invisible property.
916 ;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing
917 ;; the initial port to Emacs 19. His code is no longer part of
918 ;; ps-print, but his work is still appreciated.
920 ;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org,
921 ;; for adding underline support. Their code also is no longer part of
922 ;; ps-print, but their efforts are not forgotten.
924 ;; Thanks also to all of you who mailed code to add features to
925 ;; ps-print; although I didn't use your code, I still appreciate your
926 ;; sharing it with me.
928 ;; Thanks to all who mailed comments, encouragement, and criticism.
929 ;; Thanks also to all who responded to my survey; I had too many
930 ;; responses to reply to them all, but I greatly appreciate your
934 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
938 (unless (featurep 'lisp-float-type)
939 (error "`ps-print' requires floating point support"))
941 ;; For Emacs 20.2 and the earlier version.
943 (and (string< mule-version "4.0")
945 (defun set-buffer-multibyte (arg)
946 (setq enable-multibyte-characters arg))
947 (defun string-as-unibyte (arg) arg)
948 (defun string-as-multibyte (arg) arg)
949 (defun charset-after (&optional arg)
950 (char-charset (char-after arg))))))
952 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
955 ;;; Interface to the command system
957 (defgroup ps-print nil
958 "PostScript generator for Emacs 19"
962 (defgroup ps-print-horizontal nil
963 "Horizontal page layout"
968 (defgroup ps-print-vertical nil
969 "Vertical page layout"
974 (defgroup ps-print-header nil
980 (defgroup ps-print-font nil
981 "Fonts customization"
986 (defgroup ps-print-color nil
987 "Color customization"
992 (defgroup ps-print-face nil
993 "Faces customization"
1000 (defcustom ps-print-prologue-header nil
1001 "*PostScript prologue header comments besides that ps-print generates.
1003 `ps-print-prologue-header' may be a string or a symbol function which
1004 returns a string. Note that this string is inserted on PostScript prologue
1005 header section which is used to define some document characteristic through
1006 PostScript special comments, like \"%%Requirements: jog\\n\".
1008 ps-print always inserts the %%Requirements: comment, so if you need to insert
1009 more requirements put them first in `ps-print-prologue-header' using the
1010 \"%%+\" comment. For example, if you need to set numcopies to 3 and jog on
1011 requirements and set %%LanguageLevel: to 2, do:
1013 (setq ps-print-prologue-header
1014 \"%%+ numcopies(3) jog\\n%%LanguageLevel: 2\\n\")
1016 The duplex requirement is inserted by ps-print (see `ps-spool-duplex').
1018 Do not forget to terminate the string with \"\\n\".
1020 For more information about PostScript document comments, see:
1021 PostScript Language Reference Manual (2nd edition)
1022 Adobe Systems Incorporated
1023 Appendix G: Document Structuring Conventions -- Version 3.0"
1024 :type '(choice string symbol (other :tag "nil" nil))
1027 (defcustom ps-printer-name (and (boundp 'printer-name)
1029 "*The name of a local printer for printing PostScript files.
1031 On Unix-like systems, a string value should be a name understood by
1032 lpr's -P option; a value of nil means use the value of `printer-name'
1033 instead. Any other value will be ignored.
1035 On MS-DOS and MS-Windows systems, a string value is taken as the name of
1036 the printer device or port to which PostScript files are written,
1037 provided `ps-lpr-command' is \"\". By default it is the same as
1038 `printer-name'; typical non-default settings would be \"LPT1\" to
1039 \"LPT3\" for parallel printers, or \"COM1\" to \"COM4\" or \"AUX\" for
1040 serial printers, or \"//hostname/printer\" for a shared network printer.
1041 You can also set it to a name of a file, in which case the output gets
1042 appended to that file. \(Note that `ps-print' package already has
1043 facilities for printing to a file, so you might as well use them instead
1044 of changing the setting of this variable.\) If you want to silently
1045 discard the printed output, set this to \"NUL\"."
1046 :type '(choice file)
1049 (defcustom ps-lpr-command lpr-command
1050 "*Name of program for printing a PostScript file.
1052 On MS-DOS and MS-Windows systems, if the value is an empty string then
1053 Emacs will write directly to the printer port named by `ps-printer-name'.
1054 The programs `print' and `nprint' (the standard print programs on Windows
1055 NT and Novell Netware respectively) are handled specially, using
1056 `ps-printer-name' as the destination for output; any other program is
1057 treated like `lpr' except that an explicit filename is given as the last
1062 (defcustom ps-lpr-switches lpr-switches
1063 "*A list of extra switches to pass to `ps-lpr-command'."
1064 :type '(repeat string)
1067 (defcustom ps-print-region-function nil
1068 "Function to call to print the region on a PostScript printer.
1069 See definition of `ps-do-despool' for calling conventions."
1075 ;; All page dimensions are in PostScript points.
1076 ;; 1 inch == 2.54 cm == 72 points
1077 ;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points
1079 ;; Letter 8.5 inch x 11.0 inch
1080 ;; Legal 8.5 inch x 14.0 inch
1081 ;; A4 8.26 inch x 11.69 inch = 21.0 cm x 29.7 cm
1083 ;; LetterSmall 7.68 inch x 10.16 inch
1084 ;; Tabloid 11.0 inch x 17.0 inch
1085 ;; Ledger 17.0 inch x 11.0 inch
1086 ;; Statement 5.5 inch x 8.5 inch
1087 ;; Executive 7.5 inch x 10.0 inch
1088 ;; A3 11.69 inch x 16.5 inch = 29.7 cm x 42.0 cm
1089 ;; A4Small 7.47 inch x 10.85 inch
1090 ;; B4 10.125 inch x 14.33 inch
1091 ;; B5 7.16 inch x 10.125 inch
1093 (defcustom ps-page-dimensions-database
1094 (list (list 'a4 (/ (* 72 21.0) 2.54) (/ (* 72 29.7) 2.54))
1095 (list 'a3 (/ (* 72 29.7) 2.54) (/ (* 72 42.0) 2.54))
1096 (list 'letter (* 72 8.5) (* 72 11.0))
1097 (list 'legal (* 72 8.5) (* 72 14.0))
1098 (list 'letter-small (* 72 7.68) (* 72 10.16))
1099 (list 'tabloid (* 72 11.0) (* 72 17.0))
1100 (list 'ledger (* 72 17.0) (* 72 11.0))
1101 (list 'statement (* 72 5.5) (* 72 8.5))
1102 (list 'executive (* 72 7.5) (* 72 10.0))
1103 (list 'a4small (* 72 7.47) (* 72 10.85))
1104 (list 'b4 (* 72 10.125) (* 72 14.33))
1105 (list 'b5 (* 72 7.16) (* 72 10.125)))
1106 "*List associating a symbolic paper type to its width and height.
1107 see `ps-paper-type'."
1108 :type '(repeat (list :tag "Paper Type"
1109 (symbol :tag "Name")
1110 (number :tag "Width")
1111 (number :tag "Height")))
1115 (defcustom ps-paper-type 'letter
1116 "*Specifies the size of paper to format for.
1117 Should be one of the paper types defined in `ps-page-dimensions-database', for
1118 example `letter', `legal' or `a4'."
1119 :type '(symbol :validate (lambda (wid)
1120 (if (assq (widget-value wid)
1121 ps-page-dimensions-database)
1123 (widget-put wid :error "Unknown paper size")
1127 (defcustom ps-landscape-mode nil
1128 "*Non-nil means print in landscape mode."
1132 (defcustom ps-print-control-characters 'control-8-bit
1133 "*Specifies the printable form for control and 8-bit characters.
1134 That is, instead of sending, for example, a ^D (\004) to printer,
1135 it is sent the string \"^D\".
1139 `8-bit' This is the value to use when you want an ASCII encoding of
1140 any control or non-ASCII character. Control characters are
1141 encoded as \"^D\", and non-ASCII characters have an
1144 `control-8-bit' This is the value to use when you want an ASCII encoding of
1145 any control character, whether it is 7 or 8-bit.
1146 European 8-bits accented characters are printed according
1149 `control' Only ASCII control characters have an ASCII encoding.
1150 European 8-bits accented characters are printed according
1153 nil No ASCII encoding. Any character is printed according the
1156 Any other value is treated as nil."
1157 :type '(choice (const 8-bit) (const control-8-bit)
1158 (const control) (other :tag "nil" nil))
1161 (defcustom ps-number-of-columns (if ps-landscape-mode 2 1)
1162 "*Specifies the number of columns"
1166 (defcustom ps-zebra-stripes nil
1167 "*Non-nil means print zebra stripes.
1168 See also documentation for `ps-zebra-stripe-height'."
1172 (defcustom ps-zebra-stripe-height 3
1173 "*Number of zebra stripe lines.
1174 See also documentation for `ps-zebra-stripes'."
1178 (defcustom ps-line-number nil
1179 "*Non-nil means print line number."
1183 (defcustom ps-print-background-image nil
1184 "*EPS image list to be printed on background.
1188 (FILENAME X Y XSCALE YSCALE ROTATION PAGES...)
1190 FILENAME is a file name which contains an EPS image or some PostScript
1191 programming like EPS.
1192 FILENAME is ignored, if it doesn't exist or is read protected.
1194 X and Y are relative positions on paper to put the image.
1195 If X and Y are nil, the image is centralized on paper.
1197 XSCALE and YSCALE are scale factor to be applied to image before printing.
1198 If XSCALE and YSCALE are nil, the original size is used.
1200 ROTATION is the image rotation angle; if nil, the default is 0.
1202 PAGES designates the page to print background image.
1203 PAGES may be a number or a cons cell (FROM . TO) designating FROM page
1205 If PAGES is nil, print background image on all pages.
1207 X, Y, XSCALE, YSCALE and ROTATION may be a floating point number,
1208 an integer number or a string. If it is a string, the string should contain
1209 PostScript programming that returns a float or integer value.
1211 For example, if you wish to print an EPS image on all pages do:
1213 '((\"~/images/EPS-image.ps\"))"
1214 :type '(repeat (list file
1215 (choice :tag "X" number string (const nil))
1216 (choice :tag "Y" number string (const nil))
1217 (choice :tag "X Scale" number string (const nil))
1218 (choice :tag "Y Scale" number string (const nil))
1219 (choice :tag "Rotation" number string (const nil))
1220 (repeat :tag "Pages" :inline t
1223 (integer :tag "From")
1224 (integer :tag "To"))))))
1227 (defcustom ps-print-background-text nil
1228 "*Text list to be printed on background.
1232 (STRING X Y FONT FONTSIZE GRAY ROTATION PAGES...)
1234 STRING is the text to be printed on background.
1236 X and Y are positions on paper to put the text.
1237 If X and Y are nil, the text is positioned at lower left corner.
1239 FONT is a font name to be used on printing the text.
1240 If nil, \"Times-Roman\" is used.
1242 FONTSIZE is font size to be used, if nil, 200 is used.
1244 GRAY is the text gray factor (should be very light like 0.8).
1245 If nil, the default is 0.85.
1247 ROTATION is the text rotation angle; if nil, the angle is given by
1248 the diagonal from lower left corner to upper right corner.
1250 PAGES designates the page to print background text.
1251 PAGES may be a number or a cons cell (FROM . TO) designating FROM page
1253 If PAGES is nil, print background text on all pages.
1255 X, Y, FONTSIZE, GRAY and ROTATION may be a floating point number,
1256 an integer number or a string. If it is a string, the string should contain
1257 PostScript programming that returns a float or integer value.
1259 For example, if you wish to print text \"Preliminary\" on all pages do:
1261 '((\"Preliminary\"))"
1262 :type '(repeat (list string
1263 (choice :tag "X" number string (const nil))
1264 (choice :tag "Y" number string (const nil))
1265 (choice :tag "Font" string (const nil))
1266 (choice :tag "Fontsize" number string (const nil))
1267 (choice :tag "Gray" number string (const nil))
1268 (choice :tag "Rotation" number string (const nil))
1269 (repeat :tag "Pages" :inline t
1272 (integer :tag "From")
1273 (integer :tag "To"))))))
1276 ;;; Horizontal layout
1278 ;; ------------------------------------------
1280 ;; | lm | text | ic | text | ic | text | rm |
1282 ;; ------------------------------------------
1284 (defcustom ps-left-margin (/ (* 72 2.0) 2.54) ; 2 cm
1285 "*Left margin in points (1/72 inch)."
1287 :group 'ps-print-horizontal)
1289 (defcustom ps-right-margin (/ (* 72 2.0) 2.54) ; 2 cm
1290 "*Right margin in points (1/72 inch)."
1292 :group 'ps-print-horizontal)
1294 (defcustom ps-inter-column (/ (* 72 2.0) 2.54) ; 2 cm
1295 "*Horizontal space between columns in points (1/72 inch)."
1297 :group 'ps-print-horizontal)
1313 (defcustom ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
1314 "*Bottom margin in points (1/72 inch)."
1316 :group 'ps-print-vertical)
1318 (defcustom ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
1319 "*Top margin in points (1/72 inch)."
1321 :group 'ps-print-vertical)
1323 (defcustom ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm
1324 "*Vertical space in points (1/72 inch) between the main text and the header."
1326 :group 'ps-print-vertical)
1328 (defcustom ps-header-line-pad 0.15
1329 "*Portion of a header title line height to insert between the header frame
1330 and the text it contains, both in the vertical and horizontal directions."
1332 :group 'ps-print-vertical)
1336 (defcustom ps-print-header t
1337 "*Non-nil means print a header at the top of each page.
1338 By default, the header displays the buffer name, page number, and, if
1339 the buffer is visiting a file, the file's directory. Headers are
1340 customizable by changing variables `ps-left-header' and
1343 :group 'ps-print-header)
1345 (defcustom ps-print-only-one-header nil
1346 "*Non-nil means print only one header at the top of each page.
1347 This is useful when printing more than one column, so it is possible
1348 to have only one header over all columns or one header per column.
1349 See also `ps-print-header'."
1351 :group 'ps-print-header)
1353 (defcustom ps-print-header-frame t
1354 "*Non-nil means draw a gaudy frame around the header."
1356 :group 'ps-print-header)
1358 (defcustom ps-header-lines 2
1359 "*Number of lines to display in page header, when generating PostScript."
1361 :group 'ps-print-header)
1362 (make-variable-buffer-local 'ps-header-lines)
1364 (defcustom ps-show-n-of-n t
1365 "*Non-nil means show page numbers as N/M, meaning page N of M.
1366 NOTE: page numbers are displayed as part of headers,
1367 see variable `ps-print-headers'."
1369 :group 'ps-print-header)
1371 (defcustom ps-spool-duplex nil ; Not many people have duplex
1372 ; printers, so default to nil.
1373 "*Non-nil indicates spooling is for a two-sided printer.
1374 For a duplex printer, the `ps-spool-*' commands will insert blank pages
1375 as needed between print jobs so that the next buffer printed will
1376 start on the right page. Also, if headers are turned on, the headers
1377 will be reversed on duplex printers so that the page numbers fall to
1378 the left on even-numbered pages."
1380 :group 'ps-print-header)
1384 (defcustom ps-font-info-database
1385 '((Courier ; the family key
1386 (fonts (normal . "Courier")
1387 (bold . "Courier-Bold")
1388 (italic . "Courier-Oblique")
1389 (bold-italic . "Courier-BoldOblique"))
1391 (line-height . 10.55)
1393 (avg-char-width . 6.0))
1394 (Helvetica ; the family key
1395 (fonts (normal . "Helvetica")
1396 (bold . "Helvetica-Bold")
1397 (italic . "Helvetica-Oblique")
1398 (bold-italic . "Helvetica-BoldOblique"))
1400 (line-height . 11.56)
1401 (space-width . 2.78)
1402 (avg-char-width . 5.09243))
1404 (fonts (normal . "Times-Roman")
1405 (bold . "Times-Bold")
1406 (italic . "Times-Italic")
1407 (bold-italic . "Times-BoldItalic"))
1409 (line-height . 11.0)
1411 (avg-char-width . 4.71432))
1413 (fonts (normal . "Palatino-Roman")
1414 (bold . "Palatino-Bold")
1415 (italic . "Palatino-Italic")
1416 (bold-italic . "Palatino-BoldItalic"))
1418 (line-height . 12.1)
1420 (avg-char-width . 5.08676))
1422 (fonts (normal . "Helvetica-Narrow")
1423 (bold . "Helvetica-Narrow-Bold")
1424 (italic . "Helvetica-Narrow-Oblique")
1425 (bold-italic . "Helvetica-Narrow-BoldOblique"))
1427 (line-height . 11.56)
1428 (space-width . 2.2796)
1429 (avg-char-width . 4.17579))
1431 (fonts (normal . "NewCenturySchlbk-Roman")
1432 (bold . "NewCenturySchlbk-Bold")
1433 (italic . "NewCenturySchlbk-Italic")
1434 (bold-italic . "NewCenturySchlbk-BoldItalic"))
1436 (line-height . 12.15)
1437 (space-width . 2.78)
1438 (avg-char-width . 5.31162))
1439 ;; got no bold for the next ones
1441 (fonts (normal . "AvantGarde-Book")
1442 (italic . "AvantGarde-BookOblique"))
1444 (line-height . 11.77)
1445 (space-width . 2.77)
1446 (avg-char-width . 5.45189))
1448 (fonts (normal . "AvantGarde-Demi")
1449 (italic . "AvantGarde-DemiOblique"))
1451 (line-height . 12.72)
1453 (avg-char-width . 5.51351))
1455 (fonts (normal . "Bookman-Demi")
1456 (italic . "Bookman-DemiItalic"))
1458 (line-height . 11.77)
1460 (avg-char-width . 6.05946))
1462 (fonts (normal . "Bookman-Light")
1463 (italic . "Bookman-LightItalic"))
1465 (line-height . 11.79)
1467 (avg-char-width . 5.67027))
1468 ;; got no bold and no italic for the next ones
1470 (fonts (normal . "Symbol"))
1472 (line-height . 13.03)
1474 (avg-char-width . 3.24324))
1476 (fonts (normal . "Zapf-Dingbats"))
1478 (line-height . 9.63)
1479 (space-width . 2.78)
1480 (avg-char-width . 2.78))
1481 (Zapf-Chancery-MediumItalic
1482 (fonts (normal . "Zapf-Chancery-MediumItalic"))
1484 (line-height . 11.45)
1486 (avg-char-width . 4.10811))
1488 "*Font info database: font family (the key), name, bold, italic, bold-italic,
1489 reference size, line height, space width, average character width.
1490 To get the info for another specific font (say Helvetica), do the following:
1491 - create a new buffer
1492 - generate the PostScript image to a file (C-u M-x ps-print-buffer)
1493 - open this file and delete the leading `%' (which is the PostScript
1494 comment character) from the line
1495 `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage'
1497 `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage'
1498 - add the values to `ps-font-info-database'.
1499 You can get all the fonts of YOUR printer using `ReportAllFontInfo'."
1500 :type '(repeat (list :tag "Font Definition"
1501 (symbol :tag "Font Family")
1503 (const :format "" fonts)
1504 (repeat :tag "Faces"
1505 (cons (choice (const normal)
1509 (symbol :tag "Face"))
1510 (string :tag "Font Name"))))
1512 (const :format "" size)
1513 (number :tag "Reference Size"))
1515 (const :format "" line-height)
1516 (number :tag "Line Height"))
1518 (const :format "" space-width)
1519 (number :tag "Space Width"))
1521 (const :format "" avg-char-width)
1522 (number :tag "Average Character Width"))))
1523 :group 'ps-print-font)
1525 (defcustom ps-font-family 'Courier
1526 "*Font family name for ordinary text, when generating PostScript."
1528 :group 'ps-print-font)
1530 (defcustom ps-font-size '(7 . 8.5)
1531 "*Font size, in points, for ordinary text, when generating PostScript."
1532 :type '(choice (number :tag "Text Size")
1533 (cons :tag "Landscape/Portrait"
1534 (number :tag "Landscape Text Size")
1535 (number :tag "Portrait Text Size")))
1536 :group 'ps-print-font)
1538 (defcustom ps-header-font-family 'Helvetica
1539 "*Font family name for text in the header, when generating PostScript."
1541 :group 'ps-print-font)
1543 (defcustom ps-header-font-size '(10 . 12)
1544 "*Font size, in points, for text in the header, when generating PostScript."
1545 :type '(choice (number :tag "Header Size")
1546 (cons :tag "Landscape/Portrait"
1547 (number :tag "Landscape Header Size")
1548 (number :tag "Portrait Header Size")))
1549 :group 'ps-print-font)
1551 (defcustom ps-header-title-font-size '(12 . 14)
1552 "*Font size, in points, for the top line of text in header, in PostScript."
1553 :type '(choice (number :tag "Header Title Size")
1554 (cons :tag "Landscape/Portrait"
1555 (number :tag "Landscape Header Title Size")
1556 (number :tag "Portrait Header Title Size")))
1557 :group 'ps-print-font)
1561 ;; Printing color requires x-color-values.
1562 (defcustom ps-print-color-p (or (fboundp 'x-color-values) ; Emacs
1563 (fboundp 'color-instance-rgb-components))
1565 "*If non-nil, print the buffer's text in color."
1567 :group 'ps-print-color)
1569 (defcustom ps-default-fg '(0.0 0.0 0.0)
1570 "*RGB values of the default foreground color. Defaults to black."
1571 :type '(list (number :tag "Red") (number :tag "Green") (number :tag "Blue"))
1572 :group 'ps-print-color)
1574 (defcustom ps-default-bg '(1.0 1.0 1.0)
1575 "*RGB values of the default background color. Defaults to white."
1576 :type '(list (number :tag "Red") (number :tag "Green") (number :tag "Blue"))
1577 :group 'ps-print-color)
1579 (defcustom ps-auto-font-detect t
1580 "*Non-nil means automatically detect bold/italic face attributes.
1581 If nil, we rely solely on the lists `ps-bold-faces', `ps-italic-faces',
1582 and `ps-underlined-faces'."
1584 :group 'ps-print-font)
1586 (defcustom ps-bold-faces
1587 (unless ps-print-color-p
1588 '(font-lock-function-name-face
1589 font-lock-builtin-face
1590 font-lock-variable-name-face
1591 font-lock-keyword-face
1592 font-lock-warning-face))
1593 "*A list of the \(non-bold\) faces that should be printed in bold font.
1594 This applies to generating PostScript."
1595 :type '(repeat face)
1596 :group 'ps-print-face)
1598 (defcustom ps-italic-faces
1599 (unless ps-print-color-p
1600 '(font-lock-variable-name-face
1602 font-lock-string-face
1603 font-lock-comment-face
1604 font-lock-warning-face))
1605 "*A list of the \(non-italic\) faces that should be printed in italic font.
1606 This applies to generating PostScript."
1607 :type '(repeat face)
1608 :group 'ps-print-face)
1610 (defcustom ps-underlined-faces
1611 (unless ps-print-color-p
1612 '(font-lock-function-name-face
1613 font-lock-constant-face
1614 font-lock-warning-face))
1615 "*A list of the \(non-underlined\) faces that should be printed underlined.
1616 This applies to generating PostScript."
1617 :type '(repeat face)
1618 :group 'ps-print-face)
1620 (defcustom ps-left-header
1621 (list 'ps-get-buffer-name 'ps-header-dirpart)
1622 "*The items to display (each on a line) on the left part of the page header.
1623 This applies to generating PostScript.
1625 The value should be a list of strings and symbols, each representing an
1626 entry in the PostScript array HeaderLinesLeft.
1628 Strings are inserted unchanged into the array; those representing
1629 PostScript string literals should be delimited with PostScript string
1630 delimiters '(' and ')'.
1632 For symbols with bound functions, the function is called and should
1633 return a string to be inserted into the array. For symbols with bound
1634 values, the value should be a string to be inserted into the array.
1635 In either case, function or variable, the string value has PostScript
1636 string delimiters added to it."
1637 :type '(repeat (choice string symbol))
1638 :group 'ps-print-header)
1639 (make-variable-buffer-local 'ps-left-header)
1641 (defcustom ps-right-header
1642 (list "/pagenumberstring load" 'time-stamp-mon-dd-yyyy 'time-stamp-hh:mm:ss)
1643 "*The items to display (each on a line) on the right part of the page header.
1644 This applies to generating PostScript.
1646 See the variable `ps-left-header' for a description of the format of
1648 :type '(repeat (choice string symbol))
1649 :group 'ps-print-header)
1650 (make-variable-buffer-local 'ps-right-header)
1652 (defcustom ps-razzle-dazzle t
1653 "*Non-nil means report progress while formatting buffer."
1657 (defcustom ps-adobe-tag "%!PS-Adobe-3.0\n"
1658 "*Contains the header line identifying the output as PostScript.
1659 By default, `ps-adobe-tag' contains the standard identifier. Some
1660 printers require slightly different versions of this line."
1664 (defcustom ps-build-face-reference t
1665 "*Non-nil means build the reference face lists.
1667 ps-print sets this value to nil after it builds its internal reference
1668 lists of bold and italic faces. By settings its value back to t, you
1669 can force ps-print to rebuild the lists the next time you invoke one
1670 of the ...-with-faces commands.
1672 You should set this value back to t after you change the attributes of
1673 any face, or create new faces. Most users shouldn't have to worry
1674 about its setting, though."
1676 :group 'ps-print-face)
1678 (defcustom ps-always-build-face-reference nil
1679 "*Non-nil means always rebuild the reference face lists.
1681 If this variable is non-nil, ps-print will rebuild its internal
1682 reference lists of bold and italic faces *every* time one of the
1683 ...-with-faces commands is called. Most users shouldn't need to set this
1686 :group 'ps-print-face)
1688 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1692 (defun ps-print-buffer (&optional filename)
1693 "Generate and print a PostScript image of the buffer.
1695 Interactively, when you use a prefix argument (C-u), the command
1696 prompts the user for a file name, and saves the PostScript image
1697 in that file instead of sending it to the printer.
1699 Noninteractively, the argument FILENAME is treated as follows: if it
1700 is nil, send the image to the printer. If FILENAME is a string, save
1701 the PostScript image in a file with that name."
1702 (interactive (list (ps-print-preprint current-prefix-arg)))
1703 (ps-print-without-faces (point-min) (point-max) filename))
1707 (defun ps-print-buffer-with-faces (&optional filename)
1708 "Generate and print a PostScript image of the buffer.
1709 Like `ps-print-buffer', but includes font, color, and underline
1710 information in the generated image. This command works only if you
1711 are using a window system, so it has a way to determine color values."
1712 (interactive (list (ps-print-preprint current-prefix-arg)))
1713 (ps-print-with-faces (point-min) (point-max) filename))
1717 (defun ps-print-region (from to &optional filename)
1718 "Generate and print a PostScript image of the region.
1719 Like `ps-print-buffer', but prints just the current region."
1720 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg)))
1721 (ps-print-without-faces from to filename t))
1725 (defun ps-print-region-with-faces (from to &optional filename)
1726 "Generate and print a PostScript image of the region.
1727 Like `ps-print-region', but includes font, color, and underline
1728 information in the generated image. This command works only if you
1729 are using a window system, so it has a way to determine color values."
1730 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg)))
1731 (ps-print-with-faces from to filename t))
1735 (defun ps-spool-buffer ()
1736 "Generate and spool a PostScript image of the buffer.
1737 Like `ps-print-buffer' except that the PostScript image is saved in a
1738 local buffer to be sent to the printer later.
1740 Use the command `ps-despool' to send the spooled images to the printer."
1742 (ps-spool-without-faces (point-min) (point-max)))
1746 (defun ps-spool-buffer-with-faces ()
1747 "Generate and spool a PostScript image of the buffer.
1748 Like `ps-spool-buffer', but includes font, color, and underline
1749 information in the generated image. This command works only if you
1750 are using a window system, so it has a way to determine color values.
1752 Use the command `ps-despool' to send the spooled images to the printer."
1754 (ps-spool-with-faces (point-min) (point-max)))
1758 (defun ps-spool-region (from to)
1759 "Generate a PostScript image of the region and spool locally.
1760 Like `ps-spool-buffer', but spools just the current region.
1762 Use the command `ps-despool' to send the spooled images to the printer."
1764 (ps-spool-without-faces from to t))
1768 (defun ps-spool-region-with-faces (from to)
1769 "Generate a PostScript image of the region and spool locally.
1770 Like `ps-spool-region', but includes font, color, and underline
1771 information in the generated image. This command works only if you
1772 are using a window system, so it has a way to determine color values.
1774 Use the command `ps-despool' to send the spooled images to the printer."
1776 (ps-spool-with-faces from to t))
1779 (defun ps-despool (&optional filename)
1780 "Send the spooled PostScript to the printer.
1782 Interactively, when you use a prefix argument (C-u), the command
1783 prompts the user for a file name, and saves the spooled PostScript
1784 image in that file instead of sending it to the printer.
1786 Noninteractively, the argument FILENAME is treated as follows: if it
1787 is nil, send the image to the printer. If FILENAME is a string, save
1788 the PostScript image in a file with that name."
1789 (interactive (list (ps-print-preprint current-prefix-arg)))
1790 (ps-do-despool filename))
1793 (defun ps-line-lengths ()
1794 "Display the correspondence between a line length and a font size,
1795 using the current ps-print setup.
1796 Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"
1798 (ps-line-lengths-internal))
1801 (defun ps-nb-pages-buffer (nb-lines)
1802 "Display number of pages to print this buffer, for various font heights.
1803 The table depends on the current ps-print setup."
1804 (interactive (list (count-lines (point-min) (point-max))))
1805 (ps-nb-pages nb-lines))
1808 (defun ps-nb-pages-region (nb-lines)
1809 "Display number of pages to print the region, for various font heights.
1810 The table depends on the current ps-print setup."
1811 (interactive (list (count-lines (mark) (point))))
1812 (ps-nb-pages nb-lines))
1816 "Return the current PostScript-generation setup."
1819 \(setq ps-print-color-p %s
1825 ps-landscape-mode %s
1826 ps-number-of-columns %s
1829 ps-zebra-stripe-height %s
1832 ps-print-control-characters %s
1834 ps-print-background-image %s
1836 ps-print-background-text %s
1838 ps-print-prologue-header %s
1846 ps-header-line-pad %s
1848 ps-print-only-one-header %s
1849 ps-print-header-frame %s
1854 ps-multibyte-buffer %s
1857 ps-header-font-family %s
1858 ps-header-font-size %s
1859 ps-header-title-font-size %s)
1863 (ps-print-quote ps-lpr-switches)
1865 (ps-print-quote ps-paper-type)
1867 ps-number-of-columns
1869 ps-zebra-stripe-height
1871 (ps-print-quote ps-print-control-characters)
1872 (ps-print-quote ps-print-background-image)
1873 (ps-print-quote ps-print-background-text)
1874 (ps-print-quote ps-print-prologue-header)
1883 ps-print-only-one-header
1884 ps-print-header-frame
1888 (ps-print-quote ps-multibyte-buffer) ; see `ps-mule.el'
1889 (ps-print-quote ps-font-family)
1890 (ps-print-quote ps-font-size)
1891 (ps-print-quote ps-header-font-family)
1892 (ps-print-quote ps-header-font-size)
1893 (ps-print-quote ps-header-title-font-size)))
1895 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1896 ;; Utility functions and variables:
1898 (defun ps-print-quote (sym)
1901 ((or (symbolp sym) (listp sym))
1908 (defvar ps-print-emacs-type
1909 (cond ((string-match "XEmacs" emacs-version) 'xemacs)
1910 ((string-match "Lucid" emacs-version) 'lucid)
1911 ((string-match "Epoch" emacs-version) 'epoch)
1914 (if (or (eq ps-print-emacs-type 'lucid)
1915 (eq ps-print-emacs-type 'xemacs))
1916 (if (< emacs-minor-version 12)
1917 (setq ps-print-color-p nil))
1918 (require 'faces)) ; face-font, face-underline-p,
1921 ;; Return t if the device (which can be changed during an emacs session)
1922 ;; can handle colors.
1923 ;; This is function is not yet implemented for GNU emacs.
1924 (cond ((and (eq ps-print-emacs-type 'xemacs)
1925 (>= emacs-minor-version 12)) ; xemacs
1926 (defun ps-color-device ()
1927 (eq (device-class) 'color))
1931 (defun ps-color-device ()
1936 (require 'time-stamp)
1938 (defvar ps-print-prologue-1
1939 "% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4:
1940 /ISOLatin1Encoding where { pop } {
1941 % -- The ISO Latin-1 encoding vector isn't known, so define it.
1942 % -- The first half is the same as the standard encoding,
1943 % -- except for minus instead of hyphen at code 055.
1945 StandardEncoding 0 45 getinterval aload pop
1947 StandardEncoding 46 82 getinterval aload pop
1948 %*** NOTE: the following are missing in the Adobe documentation,
1949 %*** but appear in the displayed table:
1950 %*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240.
1952 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
1953 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
1954 /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
1955 /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron
1957 /space /exclamdown /cent /sterling
1958 /currency /yen /brokenbar /section
1959 /dieresis /copyright /ordfeminine /guillemotleft
1960 /logicalnot /hyphen /registered /macron
1961 /degree /plusminus /twosuperior /threesuperior
1962 /acute /mu /paragraph /periodcentered
1963 /cedilla /onesuperior /ordmasculine /guillemotright
1964 /onequarter /onehalf /threequarters /questiondown
1966 /Agrave /Aacute /Acircumflex /Atilde
1967 /Adieresis /Aring /AE /Ccedilla
1968 /Egrave /Eacute /Ecircumflex /Edieresis
1969 /Igrave /Iacute /Icircumflex /Idieresis
1970 /Eth /Ntilde /Ograve /Oacute
1971 /Ocircumflex /Otilde /Odieresis /multiply
1972 /Oslash /Ugrave /Uacute /Ucircumflex
1973 /Udieresis /Yacute /Thorn /germandbls
1975 /agrave /aacute /acircumflex /atilde
1976 /adieresis /aring /ae /ccedilla
1977 /egrave /eacute /ecircumflex /edieresis
1978 /igrave /iacute /icircumflex /idieresis
1979 /eth /ntilde /ograve /oacute
1980 /ocircumflex /otilde /odieresis /divide
1981 /oslash /ugrave /uacute /ucircumflex
1982 /udieresis /yacute /thorn /ydieresis
1986 /reencodeFontISO { %def
1988 length 12 add dict % Make a new font (a new dict the same size
1989 % as the old one) with room for our new symbols.
1991 begin % Make the new font the current dictionary.
1995 { def } { pop pop } ifelse
1996 } forall % Copy each of the symbols from the old dictionary
1997 % to the new one except for the font ID.
1999 currentdict /FontType get 0 ne {
2000 /Encoding ISOLatin1Encoding def % Override the encoding with
2001 % the ISOLatin1 encoding.
2004 % Use the font's bounding box to determine the ascent, descent,
2005 % and overall height; don't forget that these values have to be
2006 % transformed using the font's matrix.
2013 % | | | | Ascent (usually > 0)
2015 % (0 0) -> +--+----+-------->
2017 % | | v Descent (usually < 0)
2018 % (x1 y1) --> +----+ - -
2020 currentdict /FontType get 0 ne {
2021 /FontBBox load aload pop % -- x1 y1 x2 y2
2022 FontMatrix transform /Ascent exch def pop
2023 FontMatrix transform /Descent exch def pop
2025 /PrimaryFont FDepVector 0 get def
2026 PrimaryFont /FontBBox get aload pop
2027 PrimaryFont /FontMatrix get transform /Ascent exch def pop
2028 PrimaryFont /FontMatrix get transform /Descent exch def pop
2031 /FontHeight Ascent Descent sub def % use `sub' because descent < 0
2033 % Define these in case they're not in the FontInfo
2034 % (also, here they're easier to get to).
2035 /UnderlinePosition Descent 0.70 mul def
2036 /OverlinePosition Descent UnderlinePosition sub Ascent add def
2037 /StrikeoutPosition Ascent 0.30 mul def
2038 /LineThickness FontHeight 0.05 mul def
2039 /Xshadow FontHeight 0.08 mul def
2040 /Yshadow FontHeight -0.09 mul def
2041 /SpaceBackground Descent neg UnderlinePosition add def
2042 /XBox Descent neg def
2043 /YBox LineThickness 0.7 mul def
2045 currentdict % Leave the new font on the stack
2046 end % Stop using the font as the current dictionary.
2047 definefont % Put the font into the font dictionary
2048 pop % Discard the returned font.
2051 /DefFont { % Font definition
2052 findfont exch scalefont reencodeFontISO
2055 /F { % Font selection
2057 dup /Ascent get /Ascent exch def
2058 dup /Descent get /Descent exch def
2059 dup /FontHeight get /FontHeight exch def
2060 dup /UnderlinePosition get /UnderlinePosition exch def
2061 dup /OverlinePosition get /OverlinePosition exch def
2062 dup /StrikeoutPosition get /StrikeoutPosition exch def
2063 dup /LineThickness get /LineThickness exch def
2064 dup /Xshadow get /Xshadow exch def
2065 dup /Yshadow get /Yshadow exch def
2066 dup /SpaceBackground get /SpaceBackground exch def
2067 dup /XBox get /XBox exch def
2068 dup /YBox get /YBox exch def
2072 /FG /setrgbcolor load def
2085 % | Ascent (usually > 0)
2087 % | Descent (usually < 0)
2091 /dobackground { % width --
2092 currentpoint % -- width x y
2096 0 Ascent rmoveto % B
2098 0 Descent Ascent sub rlineto % D
2101 bgcolor aload pop setrgbcolor
2106 /eolbg { % dobackground until right margin
2107 PrintWidth % -- x-eol
2108 currentpoint pop % -- cur-x
2109 sub % -- width until eol
2113 /PLN {PrintLineNumber {doLineNumber}if} def
2115 /SL { % Soft Linefeed
2117 0 currentpoint exch pop LineHeight sub moveto
2120 /HL {SL PLN} def % Hard Linefeed
2123 /dcp { currentpoint exch 40 string cvs print (, ) print = } def
2124 /dp { print 2 copy exch 40 string cvs print (, ) print = } def
2127 ( ) stringwidth % Get the width of a space in the current font.
2128 pop % Discard the Y component.
2129 mul % Multiply the width of a space
2130 % by the number of spaces to plot
2131 bg { dup dobackground } if
2136 /EF {/Effect exch def} def
2138 % stack: string |- --
2139 % effect: 1 - underline 2 - strikeout 4 - overline
2140 % 8 - shadow 16 - box 32 - outline
2142 /xx currentpoint dup Descent add /yy exch def
2143 Ascent add /YY exch def def
2144 dup stringwidth pop xx add /XX exch def
2146 /yy yy Yshadow add def
2147 /XX XX Xshadow add def
2152 {SpaceBackground doBox}
2153 {xx yy XX YY doRect}
2156 Effect 16 and 0 ne {false 0 doBox}if % box
2157 Effect 8 and 0 ne {dup doShadow}if % shadow
2159 {true doOutline} % outline
2160 {show} % normal text
2162 Effect 1 and 0 ne {UnderlinePosition Hline}if % underline
2163 Effect 2 and 0 ne {StrikeoutPosition Hline}if % strikeout
2164 Effect 4 and 0 ne {OverlinePosition Hline}if % overline
2167 % stack: position |- --
2169 currentpoint exch pop add dup
2175 LineThickness setlinewidth stroke
2179 % stack: fill-or-not delta |- --
2182 xx XBox sub dd sub yy YBox sub dd sub
2183 XX XBox add dd add YY YBox add dd add
2187 % stack: fill-or-not lower-x lower-y upper-x upper-y |- --
2200 % top of stack: fill-or-not
2202 {LineThickness setlinewidth stroke}
2207 % stack: string |- --
2210 Xshadow Yshadow rmoveto
2217 % stack: string fill-or-not |- --
2220 /-ox- currentpoint /-oy- exch def def
2222 LineThickness setlinewidth
2225 st dup true charpath
2226 -fillp- {gsave FillBgColor grestore}if
2228 -oy- add /-oy- exch def
2229 -ox- add /-ox- exch def
2237 /FillBgColor {bgcolor aload pop setrgbcolor fill} bind def
2239 /L0 6 /Times-Italic DefFont
2248 0.0 0.0 0.0 setrgbcolor
2249 /L0 findfont setfont
2252 {LineNumber 6 string cvs ( ) strcat}
2254 dup stringwidth pop neg 0 rmoveto
2258 /LineNumber LineNumber 1 add def
2266 /double-zebra ZebraHeight ZebraHeight add def
2267 /yiter double-zebra LineHeight mul neg def
2268 /xiter PrintWidth InterColumn add def
2269 NumberOfColumns {LinesPerColumn doColumnZebra xiter 0 rmoveto}repeat
2273 % stack: lines-per-column |- --
2276 dup double-zebra idiv {ZebraHeight doZebra 0 yiter rmoveto}repeat
2278 dup 0 le {pop}{dup ZebraHeight gt {pop ZebraHeight}if doZebra}ifelse
2282 % stack: zebra-height (in lines) |- --
2284 /zh exch 0.05 sub LineHeight mul def
2286 0 LineHeight 0.65 mul rmoveto
2287 PrintWidth 0 rlineto
2289 PrintWidth neg 0 rlineto
2295 % tx ty rotation xscale yscale xpos ypos BeginBackImage
2297 /-save-image- save def
2306 -save-image- restore
2309 % string fontsize fontname rotation gray xpos ypos ShowBackText
2315 findfont exch dup /-offset- exch -0.25 mul def scalefont setfont
2317 /-saveLineThickness- LineThickness def
2318 /LineThickness 1 def
2320 /LineThickness -saveLineThickness- def
2325 % ---- Remember space width of the normal text font `f0'.
2326 /SpaceWidth /f0 findfont setfont ( ) stringwidth pop def
2327 % ---- save the state of the document (useful for ghostscript!)
2329 % ---- [jack] Kludge: my ghostscript window is 21x27.7 instead of 21x29.7
2330 /JackGhostscript where {pop 1 27.7 29.7 div scale}if
2331 % ---- [andrewi] set PageSize based on chosen dimensions
2332 % /setpagedevice where {
2335 % /PageSize [ PrintPageWidth LeftMargin add RightMargin add
2336 % LandscapePageHeight ] put
2340 % ---- translate to bottom-right corner of Portrait page
2341 LandscapePageHeight 0 translate
2345 /ColumnWidth PrintWidth InterColumn add def
2346 % ---- translate to lower left corner of TEXT
2347 LeftMargin BottomMargin translate
2348 % ---- define where printing will start
2349 /f0 F % this installs Ascent
2350 /PrintStartY PrintHeight Ascent sub def
2355 % ---- on last page but not last column, spit out the page
2356 ColumnIndex 1 eq not { showpage } if
2357 % ---- restore the state of the document (useful for ghostscript!)
2362 % ---- when 1st column, save the state of the page
2363 ColumnIndex 1 eq { /pageState save def } if
2364 % ---- save the state of the column
2365 /columnState save def
2368 /PrintHeaderWidth PrintOnlyOneHeader{PrintPageWidth}{PrintWidth}ifelse def
2371 % ---- when 1st column, print all background effects
2373 0 PrintStartY moveto % move to where printing will start
2374 Zebra {printZebra}if
2375 printGlobalBackground
2376 printLocalBackground
2379 PrintOnlyOneHeader{ColumnIndex 1 eq}{true}ifelse {
2380 PrintHeaderFrame {HeaderFrame}if
2384 0 PrintStartY moveto % move to where printing will start
2393 ColumnIndex NumberOfColumns eq {
2394 % ---- on last column, spit out the page
2396 % ---- restore the state of the page
2400 % ---- restore the state of the current column
2402 % ---- and translate to the next column
2403 ColumnWidth 0 translate
2404 /ColumnIndex ColumnIndex 1 add def
2408 /SetHeaderLines { % nb-lines --
2409 /HeaderLines exch def
2412 HeaderLines 1 sub HeaderLineHeight mul add
2413 HeaderTitleLineHeight add
2415 /HeaderHeight exch def
2422 % |-+-------| <-- (x y)
2426 % |-+-------| <-- (0 0)
2430 /HeaderFrameStart { % -- x y
2431 0 PrintHeight HeaderOffset add
2435 PrintHeaderWidth 0 rlineto
2436 0 HeaderHeight rlineto
2437 PrintHeaderWidth neg 0 rlineto
2438 0 HeaderHeight neg rlineto
2444 % ---- fill a black rectangle (the shadow of the next one)
2445 HeaderFrameStart moveto
2449 % ---- do the next rectangle ...
2450 HeaderFrameStart moveto
2452 gsave 0.9 setgray fill grestore % filled with grey
2453 gsave 0 setgray stroke grestore % drawn with black
2459 exch HeaderPad add exch % horizontal pad
2461 HeaderPad add % vertical pad
2463 HeaderLineHeight HeaderLines 1 sub mul add
2467 dup length 3 -1 roll dup length dup 4 -1 roll add string dup
2468 0 5 -1 roll putinterval
2469 dup 4 2 roll exch putinterval
2473 PageNumber 32 string cvs
2476 PageCount 32 string cvs strcat
2483 HeaderLinesRight HeaderLinesLeft % -- rightLines leftLines
2485 % ---- hack: `PN 1 and' == `PN 2 modulo'
2487 % ---- if duplex and even page number, then exchange left and right
2488 Duplex PageNumber 1 and 0 eq and { exch } if
2490 { % ---- process the left lines
2494 dup xcheck { exec } if
2497 0 HeaderLineHeight neg rmoveto
2502 { % ---- process the right lines
2506 dup xcheck { exec } if
2508 PrintHeaderWidth exch sub HeaderPad 2 mul sub 0 rmoveto
2511 0 HeaderLineHeight neg rmoveto
2517 /t0 3 1 roll DefFont
2520 /sw ( ) stringwidth pop def
2521 /aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch
2522 stringwidth pop exch div def
2523 /t1 12 /Helvetica-Oblique DefFont
2530 ( point, the line height is ) show
2531 lh 32 string cvs show
2532 (, the space width is ) show
2533 sw 32 string cvs show
2536 0 FontHeight neg rmoveto
2538 (and a crude estimate of average character width is ) show
2539 aw 32 string cvs show
2542 0 FontHeight neg rmoveto
2549 /ReportAllFontInfo {
2551 { % key = font name value = font dictionary
2552 pop 10 exch ReportFontInfo
2556 % 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage
2557 % 3 cm 20 cm moveto ReportAllFontInfo showpage
2561 (defvar ps-print-prologue-2
2563 % ---- These lines must be kept together because...
2566 /HeaderTitleLineHeight FontHeight def
2569 /HeaderLineHeight FontHeight def
2570 /HeaderDescent Descent def
2572 % ---- ...because `F' has a side-effect on `FontHeight' and `Descent'
2576 ;; Start Editing Here:
2578 (defvar ps-source-buffer nil)
2579 (defvar ps-spool-buffer-name "*PostScript*")
2580 (defvar ps-spool-buffer nil)
2582 (defvar ps-output-head nil)
2583 (defvar ps-output-tail nil)
2585 (defvar ps-page-postscript 0)
2586 (defvar ps-page-count 0)
2587 (defvar ps-showline-count 1)
2589 (defvar ps-control-or-escape-regexp nil)
2591 (defvar ps-background-pages nil)
2592 (defvar ps-background-all-pages nil)
2593 (defvar ps-background-text-count 0)
2594 (defvar ps-background-image-count 0)
2596 (defvar ps-current-font 0)
2597 (defvar ps-default-color (and ps-print-color-p ps-default-fg)) ; black
2598 (defvar ps-current-color ps-default-color)
2599 (defvar ps-current-bg nil)
2601 (defvar ps-razchunk 0)
2603 (defvar ps-color-p nil)
2604 (defvar ps-color-format
2605 (if (eq ps-print-emacs-type 'emacs)
2607 ;; Emacs understands the %f format; we'll use it to limit color RGB
2608 ;; values to three decimals to cut down some on the size of the
2609 ;; PostScript output.
2612 ;; Lucid emacsen will have to make do with %s (princ) for floats.
2615 ;; These values determine how much print-height to deduct when headers
2616 ;; are turned on. This is a pretty clumsy way of handling it, but
2617 ;; it'll do for now.
2619 (defvar ps-header-pad 0
2620 "Vertical and horizontal space between the header frame and the text.
2621 This is in units of points (1/72 inch).")
2623 ;; Define accessors to the dimensions list.
2625 (defmacro ps-page-dimensions-get-width (dims) `(nth 0 ,dims))
2626 (defmacro ps-page-dimensions-get-height (dims) `(nth 1 ,dims))
2628 (defvar ps-landscape-page-height nil)
2630 (defvar ps-print-width nil)
2631 (defvar ps-print-height nil)
2633 (defvar ps-height-remaining nil)
2634 (defvar ps-width-remaining nil)
2636 (defvar ps-print-color-scale nil)
2638 (defvar ps-font-size-internal nil)
2639 (defvar ps-header-font-size-internal nil)
2640 (defvar ps-header-title-font-size-internal nil)
2643 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2644 ;; Internal Variables
2647 (defvar ps-print-face-extension-alist nil
2648 "Alist of symbolic faces *WITH* extension features (box, outline, etc).
2649 An element of this list has the following form:
2651 (FACE . [BITS FG BG])
2653 FACE is a symbol denoting a face name
2654 BITS is a bit vector, where each bit correspond
2655 to a feature (bold, underline, etc)
2656 (see documentation for `ps-print-face-map-alist')
2657 FG foreground color (string or nil)
2658 BG background color (string or nil)
2660 Don't change this list directly; instead,
2661 use `ps-extend-face' and `ps-extend-face-list'.
2662 See documentation for `ps-extend-face' for valid extension symbol.")
2665 (defvar ps-print-face-alist nil
2666 "Alist of symbolic faces *WITHOUT* extension features (box, outline, etc).
2668 An element of this list has the same form as an element of
2669 `ps-print-face-extension-alist'.
2671 Don't change this list directly; this list is used by `ps-face-attributes',
2672 `ps-map-face' and `ps-build-reference-face-lists'.")
2675 (defconst ps-print-face-map-alist
2684 "Alist of all features and the corresponding bit mask.
2685 Each symbol correspond to one bit in a bit vector.")
2688 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2693 (defun ps-extend-face-list (face-extension-list &optional merge-p)
2694 "Extend face in `ps-print-face-extension-alist'.
2696 If optional MERGE-P is non-nil, extensions in FACE-EXTENSION-LIST are merged
2697 with face extension in `ps-print-face-extension-alist'; otherwise, overrides.
2699 The elements in FACE-EXTENSION-LIST is like those for `ps-extend-face'.
2701 See `ps-extend-face' for documentation."
2702 (while face-extension-list
2703 (ps-extend-face (car face-extension-list) merge-p)
2704 (setq face-extension-list (cdr face-extension-list))))
2708 (defun ps-extend-face (face-extension &optional merge-p)
2709 "Extend face in `ps-print-face-extension-alist'.
2711 If optional MERGE-P is non-nil, extensions in FACE-EXTENSION list are merged
2712 with face extensions in `ps-print-face-extension-alist'; otherwise, overrides.
2714 The elements of FACE-EXTENSION list have the form:
2716 (FACE-NAME FOREGROUND BACKGROUND EXTENSION...)
2718 FACE-NAME is a face name symbol.
2720 FOREGROUND and BACKGROUND may be nil or a string that denotes the
2721 foreground and background colors respectively.
2723 EXTENSION is one of the following symbols:
2724 bold - use bold font.
2725 italic - use italic font.
2726 underline - put a line under text.
2727 strikeout - like underline, but the line is in middle of text.
2728 overline - like underline, but the line is over the text.
2729 shadow - text will have a shadow.
2730 box - text will be surrounded by a box.
2731 outline - print characters as hollow outlines.
2733 If EXTENSION is any other symbol, it is ignored."
2734 (let* ((face-name (nth 0 face-extension))
2735 (foreground (nth 1 face-extension))
2736 (background (nth 2 face-extension))
2737 (ps-face (cdr (assq face-name ps-print-face-extension-alist)))
2738 (face-vector (or ps-face (vector 0 nil nil)))
2739 (face-bit (ps-extension-bit face-extension)))
2741 (aset face-vector 0 (if merge-p
2742 (logior (aref face-vector 0) face-bit)
2744 (and foreground (stringp foreground) (aset face-vector 1 foreground))
2745 (and background (stringp background) (aset face-vector 2 background))
2746 ;; if face does not exist, insert it
2748 (setq ps-print-face-extension-alist
2749 (cons (cons face-name face-vector)
2750 ps-print-face-extension-alist)))))
2753 (defun ps-extension-bit (face-extension)
2755 ;; map valid symbol extension to bit vector
2756 (setq face-extension (cdr (cdr face-extension)))
2757 (while (setq face-extension (cdr face-extension))
2758 (setq face-bit (logior face-bit
2759 (or (cdr (assq (car face-extension)
2760 ps-print-face-map-alist))
2765 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2766 ;; Adapted from font-lock:
2767 ;; Originally face attributes were specified via `font-lock-face-attributes'.
2768 ;; Users then changed the default face attributes by setting that variable.
2769 ;; However, we try and be back-compatible and respect its value if set except
2770 ;; for faces where M-x customize has been used to save changes for the face.
2772 (defun ps-font-lock-face-attributes ()
2773 (and (boundp 'font-lock-mode) (symbol-value 'font-lock-mode)
2774 (boundp 'font-lock-face-attributes)
2775 (let ((face-attributes font-lock-face-attributes))
2776 (while face-attributes
2777 (let* ((face-attribute
2778 (car (prog1 face-attributes
2779 (setq face-attributes (cdr face-attributes)))))
2780 (face (car face-attribute)))
2781 ;; Rustle up a `defface' SPEC from a
2782 ;; `font-lock-face-attributes' entry.
2783 (unless (get face 'saved-face)
2784 (let ((foreground (nth 1 face-attribute))
2785 (background (nth 2 face-attribute))
2786 (bold-p (nth 3 face-attribute))
2787 (italic-p (nth 4 face-attribute))
2788 (underline-p (nth 5 face-attribute))
2791 (setq face-spec (cons ':foreground
2792 (cons foreground face-spec))))
2794 (setq face-spec (cons ':background
2795 (cons background face-spec))))
2797 (setq face-spec (append '(:bold t) face-spec)))
2799 (setq face-spec (append '(:italic t) face-spec)))
2801 (setq face-spec (append '(:underline t) face-spec)))
2802 (custom-declare-face face (list (list t face-spec)) nil)
2806 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2807 ;; Internal functions and variables
2810 (make-local-hook 'ps-print-hook)
2811 (make-local-hook 'ps-print-begin-page-hook)
2812 (make-local-hook 'ps-print-begin-column-hook)
2815 (defun ps-print-without-faces (from to &optional filename region-p)
2816 (ps-spool-without-faces from to region-p)
2817 (ps-do-despool filename))
2820 (defun ps-spool-without-faces (from to &optional region-p)
2821 (run-hooks 'ps-print-hook)
2822 (ps-printing-region region-p)
2823 (ps-generate (current-buffer) from to 'ps-generate-postscript))
2826 (defun ps-print-with-faces (from to &optional filename region-p)
2827 (ps-spool-with-faces from to region-p)
2828 (ps-do-despool filename))
2831 (defun ps-spool-with-faces (from to &optional region-p)
2832 (run-hooks 'ps-print-hook)
2833 (ps-printing-region region-p)
2834 (ps-generate (current-buffer) from to 'ps-generate-postscript-with-faces))
2837 (defsubst ps-count-lines (from to)
2838 (+ (count-lines from to)
2841 (if (= (current-column) 0) 1 0))))
2844 (defvar ps-printing-region nil
2845 "Variable used to indicate if ps-print is printing a region.
2846 If non-nil, it is a cons, the car of which is the line number
2847 where the region begins, and its cdr is the total number of lines
2848 in the buffer. Formatting functions can use this information
2849 to print the original line number (and not the number of lines printed),
2850 and to indicate in the header that the printout is of a partial file.")
2853 (defun ps-printing-region (region-p)
2854 (setq ps-printing-region
2856 (cons (ps-count-lines (point-min) (region-beginning))
2857 (ps-count-lines (point-min) (point-max))))))
2860 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2861 ;; Internal functions
2863 (defsubst ps-font-alist (font-sym)
2864 (get font-sym 'fonts))
2866 (defun ps-font (font-sym font-type)
2867 "Font family name for text of `font-type', when generating PostScript."
2868 (let* ((font-list (ps-font-alist font-sym))
2869 (normal-font (cdr (assq 'normal font-list))))
2870 (while (and font-list (not (eq font-type (car (car font-list)))))
2871 (setq font-list (cdr font-list)))
2872 (or (cdr (car font-list)) normal-font)))
2874 (defun ps-fonts (font-sym)
2875 (mapcar 'cdr (ps-font-alist font-sym)))
2877 (defun ps-font-number (font-sym font-type)
2878 (or (ps-alist-position font-type (ps-font-alist font-sym))
2881 (defsubst ps-line-height (font-sym)
2882 "The height of a line, for generating PostScript.
2883 This is the value that ps-print uses to determine the height,
2884 y-dimension, of the lines of text it has printed, and thus affects the
2885 point at which page-breaks are placed.
2886 The line-height is *not* the same as the point size of the font."
2887 (get font-sym 'line-height))
2889 (defsubst ps-title-line-height (font-sym)
2890 "The height of a `title' line, for generating PostScript.
2891 This is the value that ps-print uses to determine the height,
2892 y-dimension, of the lines of text it has printed, and thus affects the
2893 point at which page-breaks are placed.
2894 The title-line-height is *not* the same as the point size of the font."
2895 (get font-sym 'title-line-height))
2897 (defsubst ps-space-width (font-sym)
2898 "The width of a space character, for generating PostScript.
2899 This value is used in expanding tab characters."
2900 (get font-sym 'space-width))
2902 (defsubst ps-avg-char-width (font-sym)
2903 "The average width, in points, of a character, for generating PostScript.
2904 This is the value that ps-print uses to determine the length,
2905 x-dimension, of the text it has printed, and thus affects the point at
2906 which long lines wrap around."
2907 (get font-sym 'avg-char-width))
2909 (defun ps-line-lengths-internal ()
2910 "Display the correspondence between a line length and a font size,
2911 using the current ps-print setup.
2912 Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"
2913 (let ((buf (get-buffer-create "*Line-lengths*"))
2914 (ifs ps-font-size-internal) ; initial font size
2915 (icw (ps-avg-char-width 'ps-font-for-text)) ; initial character width
2916 (print-width (progn (ps-get-page-dimensions)
2918 (ps-setup (ps-setup)) ; setup for the current buffer
2919 (fs-min 5) ; minimum font size
2920 cw-min ; minimum character width
2921 nb-cpl-max ; maximum nb of characters per line
2922 (fs-max 14) ; maximum font size
2923 cw-max ; maximum character width
2924 nb-cpl-min ; minimum nb of characters per line
2925 fs ; current font size
2926 cw ; current character width
2927 nb-cpl ; current nb of characters per line
2929 (setq cw-min (/ (* icw fs-min) ifs)
2930 nb-cpl-max (floor (/ print-width cw-min))
2931 cw-max (/ (* icw fs-max) ifs)
2932 nb-cpl-min (floor (/ print-width cw-max))
2935 (goto-char (point-max))
2936 (or (bolp) (insert "\n"))
2938 "nb char per line / font size\n")
2939 (while (<= nb-cpl nb-cpl-max)
2940 (setq cw (/ print-width (float nb-cpl))
2941 fs (/ (* ifs cw) icw))
2942 (insert (format "%3s %s\n" nb-cpl fs))
2943 (setq nb-cpl (1+ nb-cpl)))
2945 (display-buffer buf 'not-this-window)))
2947 (defun ps-nb-pages (nb-lines)
2948 "Display correspondence between font size and the number of pages.
2949 The correspondence is based on having NB-LINES lines of text,
2950 and on the current ps-print setup."
2951 (let ((buf (get-buffer-create "*Nb-Pages*"))
2952 (ifs ps-font-size-internal) ; initial font size
2953 (ilh (ps-line-height 'ps-font-for-text)) ; initial line height
2954 (page-height (progn (ps-get-page-dimensions)
2956 (ps-setup (ps-setup)) ; setup for the current buffer
2957 (fs-min 4) ; minimum font size
2958 lh-min ; minimum line height
2959 nb-lpp-max ; maximum nb of lines per page
2960 nb-page-min ; minimum nb of pages
2961 (fs-max 14) ; maximum font size
2962 lh-max ; maximum line height
2963 nb-lpp-min ; minimum nb of lines per page
2964 nb-page-max ; maximum nb of pages
2965 fs ; current font size
2966 lh ; current line height
2967 nb-lpp ; current nb of lines per page
2968 nb-page ; current nb of pages
2970 (setq lh-min (/ (* ilh fs-min) ifs)
2971 nb-lpp-max (floor (/ page-height lh-min))
2972 nb-page-min (ceiling (/ (float nb-lines) nb-lpp-max))
2973 lh-max (/ (* ilh fs-max) ifs)
2974 nb-lpp-min (floor (/ page-height lh-max))
2975 nb-page-max (ceiling (/ (float nb-lines) nb-lpp-min))
2976 nb-page nb-page-min)
2978 (goto-char (point-max))
2979 (or (bolp) (insert "\n"))
2981 (format "%d lines\n" nb-lines)
2982 "nb page / font size\n")
2983 (while (<= nb-page nb-page-max)
2984 (setq nb-lpp (ceiling (/ nb-lines (float nb-page)))
2985 lh (/ page-height nb-lpp)
2986 fs (/ (* ifs lh) ilh))
2987 (insert (format "%s %s\n" nb-page fs))
2988 (setq nb-page (1+ nb-page)))
2990 (display-buffer buf 'not-this-window)))
2992 ;; macros used in `ps-select-font'
2993 (defmacro ps-lookup (key) `(cdr (assq ,key font-entry)))
2994 (defmacro ps-size-scale (key) `(/ (* (ps-lookup ,key) font-size) size))
2996 (defun ps-select-font (font-family sym font-size title-font-size)
2997 (let ((font-entry (cdr (assq font-family ps-font-info-database))))
2999 (error "Don't have data to scale font %s. Known fonts families are %s"
3001 (mapcar 'car ps-font-info-database)))
3002 (let ((size (ps-lookup 'size)))
3003 (put sym 'fonts (ps-lookup 'fonts))
3004 (put sym 'space-width (ps-size-scale 'space-width))
3005 (put sym 'avg-char-width (ps-size-scale 'avg-char-width))
3006 (put sym 'line-height (ps-size-scale 'line-height))
3007 (put sym 'title-line-height
3008 (/ (* (ps-lookup 'line-height) title-font-size) size)))))
3010 (defun ps-get-page-dimensions ()
3011 (let ((page-dimensions (cdr (assq ps-paper-type ps-page-dimensions-database)))
3012 page-width page-height)
3014 ((null page-dimensions)
3015 (error "`ps-paper-type' must be one of:\n%s"
3016 (mapcar 'car ps-page-dimensions-database)))
3017 ((< ps-number-of-columns 1)
3018 (error "The number of columns %d should be positive"
3019 ps-number-of-columns)))
3021 (ps-select-font ps-font-family 'ps-font-for-text
3022 ps-font-size-internal ps-font-size-internal)
3023 (ps-select-font ps-header-font-family 'ps-font-for-header
3024 ps-header-font-size-internal
3025 ps-header-title-font-size-internal)
3027 (setq page-width (ps-page-dimensions-get-width page-dimensions)
3028 page-height (ps-page-dimensions-get-height page-dimensions))
3031 (if ps-landscape-mode
3032 ;; exchange width and height
3033 (setq page-width (prog1 page-height (setq page-height page-width))))
3035 ;; It is used to get the lower right corner (only in landscape mode)
3036 (setq ps-landscape-page-height page-height)
3038 ;; | lm | text | ic | text | ic | text | rm |
3039 ;; page-width == lm + n * pw + (n - 1) * ic + rm
3040 ;; => pw == (page-width - lm -rm - (n - 1) * ic) / n
3041 (setq ps-print-width (/ (- page-width
3042 ps-left-margin ps-right-margin
3043 (* (1- ps-number-of-columns) ps-inter-column))
3044 ps-number-of-columns))
3045 (if (<= ps-print-width 0)
3046 (error "Bad horizontal layout:
3048 ps-left-margin == %s
3049 ps-right-margin == %s
3050 ps-inter-column == %s
3051 ps-number-of-columns == %s
3052 | lm | text | ic | text | ic | text | rm |
3053 page-width == lm + n * print-width + (n - 1) * ic + rm
3054 => print-width == %d !"
3059 ps-number-of-columns
3062 (setq ps-print-height
3063 (- page-height ps-bottom-margin ps-top-margin))
3064 (if (<= ps-print-height 0)
3065 (error "Bad vertical layout:
3067 ps-bottom-margin == %s
3068 page-height == bm + print-height + tm
3069 => print-height == %d !"
3073 ;; If headers are turned on, deduct the height of the header from
3074 ;; the print height.
3076 (setq ps-header-pad (* ps-header-line-pad
3077 (ps-title-line-height 'ps-font-for-header))
3078 ps-print-height (- ps-print-height
3081 (ps-title-line-height 'ps-font-for-header)
3082 (* (ps-line-height 'ps-font-for-header)
3083 (1- ps-header-lines))
3085 (if (<= ps-print-height 0)
3086 (error "Bad vertical layout:
3088 ps-bottom-margin == %s
3089 ps-header-offset == %s
3092 page-height == bm + print-height + tm - ho - hh
3093 => print-height == %d !"
3099 (ps-title-line-height 'ps-font-for-header)
3100 (* (ps-line-height 'ps-font-for-header)
3101 (1- ps-header-lines))
3105 (defun ps-print-preprint (&optional filename)
3107 (or (numberp filename)
3109 (let* ((name (concat (file-name-nondirectory (or (buffer-file-name)
3112 (prompt (format "Save PostScript to file: (default %s) " name))
3113 (res (read-file-name prompt default-directory name nil)))
3114 (while (cond ((not (file-writable-p res))
3116 (setq prompt "is unwritable"))
3117 ((file-exists-p res)
3118 (setq prompt "exists")
3119 (not (y-or-n-p (format "File `%s' exists; overwrite? "
3122 (setq res (read-file-name
3123 (format "File %s; save PostScript to file: " prompt)
3124 (file-name-directory res) nil nil
3125 (file-name-nondirectory res))))
3126 (if (file-directory-p res)
3127 (expand-file-name name (file-name-as-directory res))
3130 ;; The following functions implement a simple list-buffering scheme so
3131 ;; that ps-print doesn't have to repeatedly switch between buffers
3132 ;; while spooling. The functions `ps-output' and `ps-output-string' build
3133 ;; up the lists; the function `ps-flush-output' takes the lists and
3134 ;; insert its contents into the spool buffer (*PostScript*).
3136 (defvar ps-string-escape-codes
3137 (let ((table (make-vector 256 nil))
3139 ;; control characters
3140 (while (<= char ?\037)
3141 (aset table char (format "\\%03o" char))
3142 (setq char (1+ char)))
3143 ;; printable characters
3144 (while (< char ?\177)
3145 (aset table char (format "%c" char))
3146 (setq char (1+ char)))
3147 ;; DEL and 8-bit characters
3148 (while (<= char ?\377)
3149 (aset table char (format "\\%o" char))
3150 (setq char (1+ char)))
3151 ;; Override ASCII formatting characters with named escape code:
3152 (aset table ?\n "\\n") ; [NL] linefeed
3153 (aset table ?\r "\\r") ; [CR] carriage return
3154 (aset table ?\t "\\t") ; [HT] horizontal tab
3155 (aset table ?\b "\\b") ; [BS] backspace
3156 (aset table ?\f "\\f") ; [NP] form feed
3157 ;; Escape PostScript escape and string delimiter characters:
3158 (aset table ?\\ "\\\\")
3159 (aset table ?\( "\\(")
3160 (aset table ?\) "\\)")
3162 "Vector used to map characters to PostScript string escape codes.")
3164 (defun ps-output-string-prim (string)
3165 (insert "(") ;insert start-string delimiter
3166 (save-excursion ;insert string
3167 (insert (string-as-unibyte string)))
3168 ;; Find and quote special characters as necessary for PS
3169 ;; This skips everything except control chars, non-ASCII chars, (, ) and \.
3170 (while (progn (skip-chars-forward " -'*-[]-~") (not (eobp)))
3171 (let ((special (following-char)))
3173 (insert (aref ps-string-escape-codes special))))
3174 (goto-char (point-max))
3175 (insert ")")) ;insert end-string delimiter
3177 (defun ps-init-output-queue ()
3178 (setq ps-output-head '("")
3179 ps-output-tail ps-output-head))
3181 (defun ps-output (&rest args)
3182 (setcdr ps-output-tail args)
3183 (while (cdr ps-output-tail)
3184 (setq ps-output-tail (cdr ps-output-tail))))
3186 (defun ps-output-string (string)
3187 (ps-output t string))
3189 (defun ps-output-list (the-list)
3190 (mapcar 'ps-output the-list))
3192 ;; Output strings in the list ARGS in the PostScript prologue part.
3193 (defun ps-output-prologue (args)
3194 (ps-output 'prologue (if (stringp args) (list args) args)))
3196 (defun ps-flush-output ()
3198 (set-buffer ps-spool-buffer)
3199 (goto-char (point-max))
3200 (while ps-output-head
3201 (let ((it (car ps-output-head)))
3204 (setq ps-output-head (cdr ps-output-head))
3205 (ps-output-string-prim (car ps-output-head)))
3207 (setq ps-output-head (cdr ps-output-head))
3209 (search-backward "\nBeginDoc")
3211 (apply 'insert (car ps-output-head))))
3214 (setq ps-output-head (cdr ps-output-head))))
3215 (ps-init-output-queue))
3217 (defun ps-insert-file (fname)
3219 ;; Check to see that the file exists and is readable; if not, throw
3221 (or (file-readable-p fname)
3222 (error "Could not read file `%s'" fname))
3224 (set-buffer ps-spool-buffer)
3225 (goto-char (point-max))
3226 (insert-file fname)))
3228 ;; These functions insert the arrays that define the contents of the
3231 (defun ps-generate-header-line (fonttag &optional content)
3232 (ps-output " [ " fonttag " ")
3234 ;; Literal strings should be output as is -- the string must
3235 ;; contain its own PS string delimiters, '(' and ')', if necessary.
3237 (ps-output content))
3239 ;; Functions are called -- they should return strings; they will be
3240 ;; inserted as strings and the PS string delimiters added.
3241 ((and (symbolp content) (fboundp content))
3242 (ps-output-string (funcall content)))
3244 ;; Variables will have their contents inserted. They should
3245 ;; contain strings, and will be inserted as strings.
3246 ((and (symbolp content) (boundp content))
3247 (ps-output-string (symbol-value content)))
3249 ;; Anything else will get turned into an empty string.
3251 (ps-output-string "")))
3254 (defun ps-generate-header (name contents)
3255 (ps-output "/" name " [\n")
3256 (if (> ps-header-lines 0)
3258 (ps-generate-header-line "/h0" (car contents))
3259 (while (and (< count ps-header-lines)
3260 (setq contents (cdr contents)))
3261 (ps-generate-header-line "/h1" (car contents))
3262 (setq count (1+ count)))
3263 (ps-output "] def\n"))))
3265 (defun ps-output-boolean (name bool)
3266 (ps-output (format "/%s %s def\n" name (if bool "true" "false"))))
3269 (defun ps-background-pages (page-list func)
3273 (let ((start (if (consp pages) (car pages) pages))
3274 (end (if (consp pages) (cdr pages) pages)))
3275 (and (integerp start) (integerp end) (<= start end)
3276 (add-to-list 'ps-background-pages (vector start end func)))))
3278 (setq ps-background-all-pages (cons func ps-background-all-pages))))
3281 (defun ps-get-boundingbox ()
3283 (set-buffer ps-spool-buffer)
3285 (if (re-search-forward
3286 "^%%BoundingBox:\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)"
3288 (vector (string-to-number ; lower x
3289 (buffer-substring (match-beginning 1) (match-end 1)))
3290 (string-to-number ; lower y
3291 (buffer-substring (match-beginning 2) (match-end 2)))
3292 (string-to-number ; upper x
3293 (buffer-substring (match-beginning 3) (match-end 3)))
3294 (string-to-number ; upper y
3295 (buffer-substring (match-beginning 4) (match-end 4))))
3296 (vector 0 0 0 0)))))
3299 ;; Emacs understands the %f format; we'll use it to limit color RGB values
3300 ;; to three decimals to cut down some on the size of the PostScript output.
3301 ;; Lucid emacsen will have to make do with %s (princ) for floats.
3303 (defvar ps-float-format (if (eq ps-print-emacs-type 'emacs)
3305 "%s ")) ; Lucid emacsen
3308 (defun ps-float-format (value &optional default)
3309 (let ((literal (or value default)))
3311 (format (if (numberp literal)
3318 (defun ps-background-text ()
3321 (setq ps-background-text-count (1+ ps-background-text-count))
3322 (ps-output (format "/ShowBackText-%d {\n" ps-background-text-count))
3323 (ps-output-string (nth 0 text)) ; text
3326 (ps-float-format (nth 4 text) 200.0) ; font size
3327 (format "/%s " (or (nth 3 text) "Times-Roman")) ; font name
3328 (ps-float-format (nth 6 text)
3329 "PrintHeight PrintPageWidth atan") ; rotation
3330 (ps-float-format (nth 5 text) 0.85) ; gray
3331 (ps-float-format (nth 1 text) "0") ; x position
3332 (ps-float-format (nth 2 text) "BottomMargin") ; y position
3333 "\nShowBackText} def\n")
3334 (ps-background-pages (nthcdr 7 text) ; page list
3335 (format "ShowBackText-%d\n"
3336 ps-background-text-count)))
3337 ps-print-background-text))
3340 (defun ps-background-image ()
3343 (let ((image-file (expand-file-name (nth 0 image))))
3344 (if (file-readable-p image-file)
3346 (setq ps-background-image-count (1+ ps-background-image-count))
3348 (format "/ShowBackImage-%d {\n--back-- " ps-background-image-count)
3349 (ps-float-format (nth 5 image) 0.0) ; rotation
3350 (ps-float-format (nth 3 image) 1.0) ; x scale
3351 (ps-float-format (nth 4 image) 1.0) ; y scale
3352 (ps-float-format (nth 1 image) ; x position
3353 "PrintPageWidth 2 div")
3354 (ps-float-format (nth 2 image) ; y position
3355 "PrintHeight 2 div BottomMargin add")
3356 "\nBeginBackImage\n")
3357 (ps-insert-file image-file)
3358 ;; coordinate adjustment to centralize image
3359 ;; around x and y position
3360 (let ((box (ps-get-boundingbox)))
3362 (set-buffer ps-spool-buffer)
3364 (if (re-search-backward "^--back--" nil t)
3368 (- (+ (/ (- (aref box 2) (aref box 0)) 2.0)
3371 (- (+ (/ (- (aref box 3) (aref box 1)) 2.0)
3374 (ps-output "\nEndBackImage} def\n")
3375 (ps-background-pages (nthcdr 6 image) ; page list
3376 (format "ShowBackImage-%d\n"
3377 ps-background-image-count))))))
3378 ps-print-background-image))
3381 (defun ps-background (page-number)
3382 (let (has-local-background)
3383 (mapcar '(lambda (range)
3384 (and (<= (aref range 0) page-number)
3385 (<= page-number (aref range 1))
3386 (if has-local-background
3387 (ps-output (aref range 2))
3388 (setq has-local-background t)
3389 (ps-output "/printLocalBackground {\n"
3391 ps-background-pages)
3392 (and has-local-background (ps-output "} def\n"))))
3395 ;; Return a list of the distinct elements of LIST.
3396 ;; Elements are compared with `equal'.
3397 (defun ps-remove-duplicates (list)
3398 (let (new (tail list))
3400 (or (member (car tail) new)
3401 (setq new (cons (car tail) new)))
3402 (setq tail (cdr tail)))
3406 ;; Find the first occurrence of ITEM in LIST.
3407 ;; Return the index of the matching item, or nil if not found.
3408 ;; Elements are compared with `eq'.
3409 (defun ps-alist-position (item list)
3410 (let ((tail list) (index 0) found)
3412 (if (setq found (eq (car (car tail)) item))
3414 (setq index (1+ index)
3419 (defun ps-begin-file ()
3420 (ps-get-page-dimensions)
3421 (setq ps-page-postscript 0
3422 ps-background-text-count 0
3423 ps-background-image-count 0
3424 ps-background-pages nil
3425 ps-background-all-pages nil)
3427 (ps-output ps-adobe-tag
3428 "%%Title: " (buffer-name) ; Take job name from name of
3429 ; first buffer printed
3430 "\n%%Creator: " (user-full-name)
3431 " (using ps-print v" ps-print-version
3432 ")\n%%CreationDate: "
3433 (time-stamp-hh:mm:ss) " " (time-stamp-mon-dd-yyyy)
3435 (if ps-landscape-mode "Landscape" "Portrait")
3436 "\n%%DocumentNeededResources: font Times-Roman Times-Italic\n%%+ font "
3437 (mapconcat 'identity
3438 (ps-remove-duplicates
3439 (append (ps-fonts 'ps-font-for-text)
3440 (list (ps-font 'ps-font-for-header 'normal)
3441 (ps-font 'ps-font-for-header 'bold))))
3443 "\n%%Pages: (atend)\n%%Requirements:"
3444 (if ps-spool-duplex " duplex\n" "\n"))
3446 (let ((comments (if (functionp ps-print-prologue-header)
3447 (funcall ps-print-prologue-header)
3448 ps-print-prologue-header)))
3449 (and (stringp comments)
3450 (ps-output comments)))
3452 (ps-output "%%EndComments\n\n%%BeginPrologue\n\n")
3454 (ps-output-boolean "LandscapeMode" ps-landscape-mode)
3455 (ps-output (format "/NumberOfColumns %d def\n" ps-number-of-columns)
3457 (format "/LandscapePageHeight %s def\n" ps-landscape-page-height)
3458 (format "/PrintPageWidth %s def\n"
3459 (- (* (+ ps-print-width ps-inter-column)
3460 ps-number-of-columns)
3462 (format "/PrintWidth %s def\n" ps-print-width)
3463 (format "/PrintHeight %s def\n" ps-print-height)
3465 (format "/LeftMargin %s def\n" ps-left-margin)
3466 (format "/RightMargin %s def\n" ps-right-margin) ; not used
3467 (format "/InterColumn %s def\n" ps-inter-column)
3469 (format "/BottomMargin %s def\n" ps-bottom-margin)
3470 (format "/TopMargin %s def\n" ps-top-margin) ; not used
3471 (format "/HeaderOffset %s def\n" ps-header-offset)
3472 (format "/HeaderPad %s def\n" ps-header-pad))
3474 (ps-output-boolean "PrintHeader" ps-print-header)
3475 (ps-output-boolean "PrintOnlyOneHeader" ps-print-only-one-header)
3476 (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame)
3477 (ps-output-boolean "ShowNofN" ps-show-n-of-n)
3478 (ps-output-boolean "Duplex" ps-spool-duplex)
3480 (let ((line-height (ps-line-height 'ps-font-for-text)))
3481 (ps-output (format "/LineHeight %s def\n" line-height)
3482 (format "/LinesPerColumn %d def\n"
3483 (round (/ (+ ps-print-height
3484 (* line-height 0.45))
3487 (ps-output-boolean "Zebra" ps-zebra-stripes)
3488 (ps-output-boolean "PrintLineNumber" ps-line-number)
3489 (ps-output (format "/ZebraHeight %d def\n" ps-zebra-stripe-height))
3491 (ps-background-text)
3492 (ps-background-image)
3493 (setq ps-background-all-pages (nreverse ps-background-all-pages)
3494 ps-background-pages (nreverse ps-background-pages))
3496 (ps-output ps-print-prologue-1)
3498 (ps-output "/printGlobalBackground {\n")
3499 (ps-output-list ps-background-all-pages)
3500 (ps-output "} def\n/printLocalBackground {\n} def\n")
3503 (ps-output (format "/h0 %s (%s) cvn DefFont\n" ; /h0 14 /Helvetica-Bold DefFont
3504 ps-header-title-font-size-internal
3505 (ps-font 'ps-font-for-header 'bold))
3506 (format "/h1 %s (%s) cvn DefFont\n" ; /h1 12 /Helvetica DefFont
3507 ps-header-font-size-internal
3508 (ps-font 'ps-font-for-header 'normal)))
3510 (ps-output ps-print-prologue-2)
3513 (let ((font (ps-font-alist 'ps-font-for-text))
3516 (ps-output (format "/f%d %s (%s) cvn DefFont\n"
3518 ps-font-size-internal
3519 (ps-font 'ps-font-for-text (car (car font)))))
3520 (setq font (cdr font)
3523 (let ((font-entry (cdr (assq ps-font-family ps-font-info-database))))
3524 (ps-output (format "/SpaceWidthRatio %f def\n"
3525 (/ (ps-lookup 'space-width) (ps-lookup 'size)))))
3527 (ps-output "\n%%EndPrologue\n\n%%BeginSetup\nBeginDoc\n%%EndSetup\n"))
3529 (defun ps-header-dirpart ()
3530 (let ((fname (buffer-file-name)))
3532 (if (string-equal (buffer-name) (file-name-nondirectory fname))
3533 (file-name-directory fname)
3537 (defun ps-get-buffer-name ()
3539 ;; Indulge Jim this little easter egg:
3540 ((string= (buffer-name) "ps-print.el")
3541 "Hey, Cool! It's ps-print.el!!!")
3542 ;; Indulge Jack this other little easter egg:
3543 ((string= (buffer-name) "sokoban.el")
3544 "Super! C'est sokoban.el!")
3546 (and ps-printing-region "Subset of: ")
3548 (and (buffer-modified-p) " (unsaved)")))))
3551 (defun ps-get-font-size (font-sym)
3552 (let ((font-size (symbol-value font-sym)))
3553 (cond ((numberp font-size)
3555 ((and (consp font-size)
3556 (numberp (car font-size))
3557 (numberp (cdr font-size)))
3558 (if ps-landscape-mode
3562 (error "Invalid font size `%S' for `%S'" font-size font-sym)))))
3565 (defun ps-begin-job ()
3567 (set-buffer ps-spool-buffer)
3568 (goto-char (point-max))
3569 (and (re-search-backward "^%%Trailer$" nil t)
3570 (delete-region (match-beginning 0) (point-max))))
3571 (setq ps-showline-count (if ps-printing-region (car ps-printing-region) 1)
3573 ps-font-size-internal (ps-get-font-size 'ps-font-size)
3574 ps-header-font-size-internal (ps-get-font-size 'ps-header-font-size)
3575 ps-header-title-font-size-internal
3576 (ps-get-font-size 'ps-header-title-font-size)
3577 ps-control-or-escape-regexp
3578 (cond ((eq ps-print-control-characters '8-bit)
3579 (string-as-unibyte "[\000-\037\177-\377]"))
3580 ((eq ps-print-control-characters 'control-8-bit)
3581 (string-as-unibyte "[\000-\037\177-\237]"))
3582 ((eq ps-print-control-characters 'control)
3586 (defmacro ps-page-number ()
3587 `(1+ (/ (1- ps-page-count) ps-number-of-columns)))
3589 (defun ps-end-file ()
3590 (ps-output "\n%%Trailer\n%%Pages: "
3591 (format "%d" ps-page-postscript)
3592 "\n\nEndDoc\n\n%%EOF\n"))
3595 (defun ps-next-page ()
3600 (defun ps-header-page ()
3601 ;; set total line and page number when printing has finished
3602 ;; (see `ps-generate')
3604 (zerop (mod ps-page-count ps-number-of-columns))
3605 (setq ps-page-count (1+ ps-page-count)))
3606 ;; Print only when a new real page begins.
3608 (setq ps-page-postscript (1+ ps-page-postscript))
3609 (ps-output (format "\n%%%%Page: %d %d\n"
3610 ps-page-postscript ps-page-postscript))
3611 (ps-output "/Lines 0 def\n/PageCount 0 def\nBeginDSCPage\n")
3612 (ps-background ps-page-postscript)
3613 (run-hooks 'ps-print-begin-page-hook))
3614 ;; Print when any other page begins.
3615 (ps-output "/Lines 0 def\n/PageCount 0 def\nBeginDSCPage\n")
3616 (run-hooks 'ps-print-begin-column-hook)))
3618 (defun ps-begin-page ()
3619 (ps-get-page-dimensions)
3620 (setq ps-width-remaining ps-print-width
3621 ps-height-remaining ps-print-height)
3625 (ps-output (format "/LineNumber %d def\n" ps-showline-count)
3626 (format "/PageNumber %d def\n" (if ps-print-only-one-header
3630 (when ps-print-header
3631 (ps-generate-header "HeaderLinesLeft" ps-left-header)
3632 (ps-generate-header "HeaderLinesRight" ps-right-header)
3633 (ps-output (format "%d SetHeaderLines\n" ps-header-lines)))
3635 (ps-output "BeginPage\n")
3636 (ps-set-font ps-current-font)
3637 (ps-set-bg ps-current-bg)
3638 (ps-set-color ps-current-color)
3639 (ps-mule-begin-page))
3641 (defun ps-end-page ()
3642 (ps-output "EndPage\nEndDSCPage\n"))
3644 (defun ps-dummy-page ()
3646 (ps-output "/PrintHeader false def
3651 (defun ps-next-line ()
3652 (setq ps-showline-count (1+ ps-showline-count))
3653 (let ((lh (ps-line-height 'ps-font-for-text)))
3654 (if (< ps-height-remaining lh)
3656 (setq ps-width-remaining ps-print-width
3657 ps-height-remaining (- ps-height-remaining lh))
3658 (ps-output "HL\n"))))
3660 (defun ps-continue-line ()
3661 (let ((lh (ps-line-height 'ps-font-for-text)))
3662 (if (< ps-height-remaining lh)
3664 (setq ps-width-remaining ps-print-width
3665 ps-height-remaining (- ps-height-remaining lh))
3666 (ps-output "SL\n"))))
3668 (defun ps-find-wrappoint (from to char-width)
3669 (let ((avail (truncate (/ ps-width-remaining char-width)))
3672 (cons to (* todo char-width))
3673 (cons (+ from avail) ps-width-remaining))))
3675 (defun ps-basic-plot-string (from to &optional bg-color)
3676 (let* ((wrappoint (ps-find-wrappoint from to
3677 (ps-avg-char-width 'ps-font-for-text)))
3678 (to (car wrappoint))
3679 (string (buffer-substring-no-properties from to)))
3680 (ps-mule-prepare-ascii-font string)
3681 (ps-output-string string)
3685 (defun ps-basic-plot-whitespace (from to &optional bg-color)
3686 (let* ((wrappoint (ps-find-wrappoint from to
3687 (ps-space-width 'ps-font-for-text)))
3688 (to (car wrappoint)))
3689 (ps-output (format "%d W\n" (- to from)))
3692 (defun ps-plot (plotfunc from to &optional bg-color)
3694 (let* ((wrappoint (funcall plotfunc from to bg-color))
3695 (plotted-to (car wrappoint))
3696 (plotted-width (cdr wrappoint)))
3697 (setq from plotted-to
3698 ps-width-remaining (- ps-width-remaining plotted-width))
3700 (ps-continue-line))))
3701 (if ps-razzle-dazzle
3702 (let* ((q-todo (- (point-max) (point-min)))
3703 (q-done (- (point) (point-min)))
3704 (chunkfrac (/ q-todo 8))
3705 (chunksize (min chunkfrac 1000)))
3706 (if (> (- q-done ps-razchunk) chunksize)
3708 (setq ps-razchunk q-done)
3709 (message "Formatting...%3d%%"
3711 (/ (* 100 q-done) q-todo)
3712 (/ q-done (/ q-todo 100)))
3715 (defvar ps-last-font nil)
3717 (defun ps-set-font (font)
3718 (setq ps-last-font (format "f%d" (setq ps-current-font font)))
3719 (ps-output (format "/%s F\n" ps-last-font)))
3721 (defun ps-set-bg (color)
3722 (if (setq ps-current-bg color)
3723 (ps-output (format ps-color-format
3724 (nth 0 color) (nth 1 color) (nth 2 color))
3726 (ps-output "false BG\n")))
3728 (defun ps-set-color (color)
3729 (setq ps-current-color (or color ps-default-fg))
3730 (ps-output (format ps-color-format
3731 (nth 0 ps-current-color)
3732 (nth 1 ps-current-color) (nth 2 ps-current-color))
3736 (defvar ps-current-effect 0)
3739 (defun ps-plot-region (from to font &optional fg-color bg-color effects)
3740 (if (not (equal font ps-current-font))
3743 ;; Specify a foreground color only if one's specified and it's
3744 ;; different than the current.
3745 (if (not (equal fg-color ps-current-color))
3746 (ps-set-color fg-color))
3748 (if (not (equal bg-color ps-current-bg))
3749 (ps-set-bg bg-color))
3751 ;; Specify effects (underline, overline, box, etc)
3753 ((not (integerp effects))
3754 (ps-output "0 EF\n")
3755 (setq ps-current-effect 0))
3756 ((/= effects ps-current-effect)
3757 (ps-output (number-to-string effects) " EF\n")
3758 (setq ps-current-effect effects)))
3760 ;; Starting at the beginning of the specified region...
3764 ;; ...break the region up into chunks separated by tabs, linefeeds,
3765 ;; pagefeeds, control characters, and plot each chunk.
3767 (if (re-search-forward ps-control-or-escape-regexp to t)
3768 ;; region with some control characters or some multi-byte characters
3769 (let* ((match-point (match-beginning 0))
3770 (match (char-after match-point)))
3771 (when (< from match-point)
3772 (ps-mule-set-ascii-font)
3773 (ps-plot 'ps-basic-plot-string from match-point bg-color))
3775 ((= match ?\t) ; tab
3776 (let ((linestart (line-beginning-position)))
3778 (setq from (+ linestart (current-column)))
3779 (when (re-search-forward "[ \t]+" to t)
3780 (ps-mule-set-ascii-font)
3781 (ps-plot 'ps-basic-plot-whitespace
3782 from (+ linestart (current-column))
3785 ((= match ?\n) ; newline
3788 ((= match ?\f) ; form feed
3789 ;; do not skip page if previous character is NEWLINE and
3790 ;; it is a beginning of page.
3791 (or (and (= (char-after (1- match-point)) ?\n)
3792 (= ps-height-remaining ps-print-height))
3795 ((> match 255) ; a multi-byte character
3796 (let ((charset (char-charset match)))
3797 (or (eq charset 'composition)
3798 (while (eq (charset-after) charset)
3800 (ps-plot 'ps-mule-plot-string match-point (point) bg-color)))
3801 ; characters from ^@ to ^_ and
3802 (t ; characters from 127 to 255
3803 (ps-control-character match)))
3804 (setq from (point)))
3805 ;; region without control characters nor multi-byte characters
3806 (ps-mule-set-ascii-font)
3807 (ps-plot 'ps-basic-plot-string from to bg-color)
3810 (defvar ps-string-control-codes
3811 (let ((table (make-vector 256 nil))
3813 ;; control character
3814 (while (<= char ?\037)
3815 (aset table char (format "^%c" (+ char ?@)))
3816 (setq char (1+ char)))
3817 ;; printable character
3818 (while (< char ?\177)
3819 (aset table char (format "%c" char))
3820 (setq char (1+ char)))
3822 (aset table char "^?")
3824 (while (<= (setq char (1+ char)) ?\377)
3825 (aset table char (format "\\%o" char)))
3827 "Vector used to map characters to a printable string.")
3829 (defun ps-control-character (char)
3830 (let* ((str (aref ps-string-control-codes char))
3834 (char-width (ps-avg-char-width 'ps-font-for-text))
3835 (wrappoint (ps-find-wrappoint from to char-width)))
3836 (if (< (car wrappoint) to)
3838 (setq ps-width-remaining (- ps-width-remaining (* len char-width)))
3839 (ps-output-string str)
3840 (ps-output " S\n")))
3842 (defun ps-color-value (x-color-value)
3843 ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
3844 (/ x-color-value ps-print-color-scale))
3847 (cond ((eq ps-print-emacs-type 'emacs) ; emacs
3849 (defun ps-color-values (x-color)
3850 (if (fboundp 'x-color-values)
3851 (x-color-values x-color)
3852 (error "No available function to determine X color values.")))
3857 (defun ps-color-values (x-color)
3858 (cond ((fboundp 'x-color-values)
3859 (x-color-values x-color))
3860 ((and (fboundp 'color-instance-rgb-components)
3862 (color-instance-rgb-components
3863 (if (color-instance-p x-color)
3865 (make-color-instance
3866 (if (color-specifier-p x-color)
3867 (color-name x-color)
3869 (t (error "No available function to determine X color values."))))
3873 (defun ps-face-attributes (face)
3874 "Return face attribute vector.
3876 If FACE is not in `ps-print-face-extension-alist' or in
3877 `ps-print-face-alist', insert it on `ps-print-face-alist' and
3878 return the attribute vector.
3880 If FACE is not a valid face name, it is used default face."
3881 (cdr (or (assq face ps-print-face-extension-alist)
3882 (assq face ps-print-face-alist)
3883 (let* ((the-face (if (facep face) face 'default))
3884 (new-face (ps-screen-to-bit-face the-face)))
3885 (or (and (eq the-face 'default)
3886 (assq the-face ps-print-face-alist))
3887 (setq ps-print-face-alist (cons new-face ps-print-face-alist)))
3891 (defun ps-face-attribute-list (face-or-list)
3892 (if (listp face-or-list)
3895 foreground background face-attr)
3897 (setq face-attr (ps-face-attributes (car face-or-list))
3898 effects (logior effects (aref face-attr 0)))
3899 (or foreground (setq foreground (aref face-attr 1)))
3900 (or background (setq background (aref face-attr 2)))
3901 (setq face-or-list (cdr face-or-list)))
3902 (vector effects foreground background))
3904 (ps-face-attributes face-or-list)))
3907 (defconst ps-font-type (vector nil 'bold 'italic 'bold-italic))
3910 (defun ps-plot-with-face (from to face)
3912 ((null face) ; print text with null face
3913 (ps-plot-region from to 0))
3914 ((eq face 'emacs--invisible--face)) ; skip invisible text!!!
3915 (t ; otherwise, text has a valid face
3916 (let* ((face-bit (ps-face-attribute-list face))
3917 (effect (aref face-bit 0))
3918 (foreground (aref face-bit 1))
3919 (background (aref face-bit 2))
3920 (fg-color (if (and ps-color-p foreground)
3921 (mapcar 'ps-color-value
3922 (ps-color-values foreground))
3924 (bg-color (and ps-color-p background
3925 (mapcar 'ps-color-value
3926 (ps-color-values background)))))
3929 (ps-font-number 'ps-font-for-text
3930 (or (aref ps-font-type (logand effect 3))
3932 fg-color bg-color (lsh effect -2)))))
3936 (defun ps-xemacs-face-kind-p (face kind kind-regex kind-list)
3937 (let* ((frame-font (or (face-font-instance face)
3938 (face-font-instance 'default)))
3939 (kind-cons (and frame-font
3941 (font-instance-properties frame-font))))
3942 (kind-spec (cdr-safe kind-cons))
3943 (case-fold-search t))
3944 (or (and kind-spec (string-match kind-regex kind-spec))
3945 ;; Kludge-compatible:
3946 (memq face kind-list))))
3949 (cond ((eq ps-print-emacs-type 'emacs) ; emacs
3951 (defun ps-face-bold-p (face)
3952 (or (face-bold-p face)
3953 (memq face ps-bold-faces)))
3955 (defun ps-face-italic-p (face)
3956 (or (face-italic-p face)
3957 (memq face ps-italic-faces)))
3962 (defun ps-face-bold-p (face)
3963 (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold"
3966 (defun ps-face-italic-p (face)
3967 (or (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o" ps-italic-faces)
3968 (ps-xemacs-face-kind-p face 'SLANT "i\\|o" ps-italic-faces)))
3972 (defun ps-face-underlined-p (face)
3973 (or (face-underline-p face)
3974 (memq face ps-underlined-faces)))
3977 ;; Ensure that face-list is fbound.
3978 (or (fboundp 'face-list) (defalias 'face-list 'list-faces))
3981 (defun ps-build-reference-face-lists ()
3982 ;; Ensure that face database is updated with faces on
3983 ;; `font-lock-face-attributes' (obsolete stuff)
3984 (ps-font-lock-face-attributes)
3985 ;; Now, rebuild reference face lists
3986 (setq ps-print-face-alist nil)
3987 (if ps-auto-font-detect
3988 (mapcar 'ps-map-face (face-list))
3989 (mapcar 'ps-set-face-bold ps-bold-faces)
3990 (mapcar 'ps-set-face-italic ps-italic-faces)
3991 (mapcar 'ps-set-face-underline ps-underlined-faces))
3992 (setq ps-build-face-reference nil))
3995 (defun ps-set-face-bold (face)
3996 (ps-set-face-attribute face 1))
3998 (defun ps-set-face-italic (face)
3999 (ps-set-face-attribute face 2))
4001 (defun ps-set-face-underline (face)
4002 (ps-set-face-attribute face 4))
4005 (defun ps-set-face-attribute (face effect)
4006 (let ((face-bit (cdr (ps-map-face face))))
4007 (aset face-bit 0 (logior (aref face-bit 0) effect))))
4010 (defun ps-map-face (face)
4011 (let* ((face-map (ps-screen-to-bit-face face))
4012 (ps-face-bit (cdr (assq (car face-map) ps-print-face-alist))))
4014 ;; if face exists, merge both
4015 (let ((face-bit (cdr face-map)))
4016 (aset ps-face-bit 0 (logior (aref ps-face-bit 0) (aref face-bit 0)))
4017 (or (aref ps-face-bit 1) (aset ps-face-bit 1 (aref face-bit 1)))
4018 (or (aref ps-face-bit 2) (aset ps-face-bit 2 (aref face-bit 2))))
4019 ;; if face does not exist, insert it
4020 (setq ps-print-face-alist (cons face-map ps-print-face-alist)))
4024 (defun ps-screen-to-bit-face (face)
4026 (vector (logior (if (ps-face-bold-p face) 1 0) ; bold
4027 (if (ps-face-italic-p face) 2 0) ; italic
4028 (if (ps-face-underlined-p face) 4 0)) ; underline
4029 (face-foreground face)
4030 (face-background face))))
4033 (cond ((not (eq ps-print-emacs-type 'emacs))
4037 (defun ps-mapper (extent list)
4038 (nconc list (list (list (extent-start-position extent) 'push extent)
4039 (list (extent-end-position extent) 'pull extent)))
4042 (defun ps-extent-sorter (a b)
4043 (< (extent-priority a) (extent-priority b)))
4047 (defun ps-print-ensure-fontified (start end)
4048 (and (boundp 'lazy-lock-mode) (symbol-value 'lazy-lock-mode)
4049 (lazy-lock-fontify-region start end)))
4051 (defun ps-generate-postscript-with-faces (from to)
4052 ;; Some initialization...
4053 (setq ps-current-effect 0)
4055 ;; Build the reference lists of faces if necessary.
4056 (if (or ps-always-build-face-reference
4057 ps-build-face-reference)
4059 (message "Collecting face information...")
4060 (ps-build-reference-face-lists)))
4061 ;; Set the color scale. We do it here instead of in the defvar so
4062 ;; that ps-print can be dumped into emacs. This expression can't be
4063 ;; evaluated at dump-time because X isn't initialized.
4064 (setq ps-color-p (and ps-print-color-p (ps-color-device))
4065 ps-print-color-scale (if ps-color-p
4066 (float (car (ps-color-values "white")))
4068 ;; Generate some PostScript.
4070 (narrow-to-region from to)
4071 (ps-print-ensure-fontified from to)
4072 (let ((face 'default)
4075 ((or (eq ps-print-emacs-type 'lucid)
4076 (eq ps-print-emacs-type 'xemacs))
4077 ;; Build the list of extents...
4078 (let ((a (cons 'dummy nil))
4079 record type extent extent-list)
4080 (map-extents 'ps-mapper nil from to a)
4081 (setq a (sort (cdr a) 'car-less-than-car)
4084 ;; Loop through the extents...
4086 (setq record (car a)
4088 position (car record)
4094 extent (car record))
4096 ;; Plot up to this record.
4097 ;; XEmacs 19.12: for some reason, we're getting into a
4098 ;; situation in which some of the records have
4099 ;; positions less than 'from'. Since we've narrowed
4100 ;; the buffer, this'll generate errors. This is a
4101 ;; hack, but don't call ps-plot-with-face unless from >
4103 (and (>= from (point-min)) (<= position (point-max))
4104 (ps-plot-with-face from position face))
4108 (and (extent-face extent)
4109 (setq extent-list (sort (cons extent extent-list)
4110 'ps-extent-sorter))))
4113 (setq extent-list (sort (delq extent extent-list)
4114 'ps-extent-sorter))))
4116 (setq face (if extent-list
4117 (extent-face (car extent-list))
4122 ((eq ps-print-emacs-type 'emacs)
4123 (let ((property-change from)
4124 (overlay-change from)
4125 (save-buffer-invisibility-spec buffer-invisibility-spec)
4126 (buffer-invisibility-spec nil))
4128 (and (< property-change to) ; Don't search for property change
4129 ; unless previous search succeeded.
4130 (setq property-change (next-property-change from nil to)))
4131 (and (< overlay-change to) ; Don't search for overlay change
4132 ; unless previous search succeeded.
4133 (setq overlay-change (min (next-overlay-change from) to)))
4134 (setq position (min property-change overlay-change))
4135 ;; The code below is not quite correct,
4136 ;; because a non-nil overlay invisible property
4137 ;; which is inactive according to the current value
4138 ;; of buffer-invisibility-spec nonetheless overrides
4139 ;; a face text property.
4141 (cond ((let ((prop (get-text-property from 'invisible)))
4142 ;; Decide whether this invisible property
4143 ;; really makes the text invisible.
4144 (if (eq save-buffer-invisibility-spec t)
4146 (or (memq prop save-buffer-invisibility-spec)
4147 (assq prop save-buffer-invisibility-spec))))
4148 'emacs--invisible--face)
4149 ((get-text-property from 'face))
4151 (let ((overlays (overlays-at from))
4152 (face-priority -1)) ; text-property
4153 (while (and overlays
4154 (not (eq face 'emacs--invisible--face)))
4155 (let* ((overlay (car overlays))
4156 (overlay-invisible (overlay-get overlay 'invisible))
4157 (overlay-priority (or (overlay-get overlay 'priority)
4159 (and (> overlay-priority face-priority)
4161 (cond ((if (eq save-buffer-invisibility-spec t)
4162 (not (null overlay-invisible))
4163 (or (memq overlay-invisible
4164 save-buffer-invisibility-spec)
4165 (assq overlay-invisible
4166 save-buffer-invisibility-spec)))
4167 'emacs--invisible--face)
4168 ((overlay-get overlay 'face))
4170 face-priority overlay-priority)))
4171 (setq overlays (cdr overlays))))
4172 ;; Plot up to this record.
4173 (ps-plot-with-face from position face)
4174 (setq from position)))))
4175 (ps-plot-with-face from to face))))
4177 (defun ps-generate-postscript (from to)
4178 (ps-plot-region from to 0 nil))
4180 (defun ps-generate (buffer from to genfunc)
4182 (let ((from (min to from))
4184 ;; This avoids trouble if chars with read-only properties
4185 ;; are copied into ps-spool-buffer.
4186 (inhibit-read-only t))
4188 (narrow-to-region from to)
4189 (and ps-razzle-dazzle
4190 (message "Formatting...%3d%%" (setq ps-razchunk 0)))
4191 (setq ps-source-buffer buffer
4192 ps-spool-buffer (get-buffer-create ps-spool-buffer-name))
4193 (ps-init-output-queue)
4194 (let (safe-marker completed-safely needs-begin-file)
4197 (set-buffer ps-spool-buffer)
4198 (set-buffer-multibyte nil)
4200 ;; Get a marker and make it point to the current end of the
4201 ;; buffer, If an error occurs, we'll delete everything from
4202 ;; the end of this marker onwards.
4203 (setq safe-marker (make-marker))
4204 (set-marker safe-marker (point-max))
4206 (goto-char (point-min))
4207 (or (looking-at (regexp-quote ps-adobe-tag))
4208 (setq needs-begin-file t))
4210 (set-buffer ps-source-buffer)
4212 (when needs-begin-file
4214 (ps-mule-initialize))
4215 (ps-mule-begin-job from to)
4217 (set-buffer ps-source-buffer)
4218 (funcall genfunc from to)
4221 (and ps-spool-duplex (= (mod ps-page-count 2) 1)
4226 ;; Back to the PS output buffer to set the page count
4227 (let ((total-lines (if ps-printing-region
4228 (cdr ps-printing-region)
4229 (ps-count-lines (point-min) (point-max))))
4230 (total-pages (if ps-print-only-one-header
4233 (set-buffer ps-spool-buffer)
4234 (goto-char (point-min))
4235 (while (re-search-forward "^/Lines 0 def\n/PageCount 0 def$"
4237 (replace-match (format "/Lines %d def\n/PageCount %d def"
4238 total-lines total-pages) t)))
4240 ;; Setting this variable tells the unwind form that the
4241 ;; the PostScript was generated without error.
4242 (setq completed-safely t))
4244 ;; Unwind form: If some bad mojo occurred while generating
4245 ;; PostScript, delete all the PostScript that was generated.
4246 ;; This protects the previously spooled files from getting
4248 (and (markerp safe-marker) (not completed-safely)
4250 (set-buffer ps-spool-buffer)
4251 (delete-region (marker-position safe-marker) (point-max))))))
4253 (and ps-razzle-dazzle (message "Formatting...done"))))))
4256 ;; to avoid compilation gripes.
4257 (defvar dos-ps-printer nil)
4260 ;; Permit dynamic evaluation at print time of `ps-lpr-switches'.
4261 (defun ps-do-despool (filename)
4262 (if (or (not (boundp 'ps-spool-buffer))
4263 (not (symbol-value 'ps-spool-buffer)))
4264 (message "No spooled PostScript to print")
4267 (and ps-razzle-dazzle (message "Saving..."))
4268 (set-buffer ps-spool-buffer)
4269 (setq filename (expand-file-name filename))
4270 (let ((coding-system-for-write 'raw-text-unix))
4271 (write-region (point-min) (point-max) filename))
4272 (and ps-razzle-dazzle (message "Wrote %s" filename)))
4273 ;; Else, spool to the printer
4274 (and ps-razzle-dazzle (message "Printing..."))
4276 (set-buffer ps-spool-buffer)
4277 (let* ((coding-system-for-write 'raw-text-unix)
4278 (ps-printer-name (or ps-printer-name
4279 (and (boundp 'printer-name)
4283 (and (stringp ps-printer-name)
4284 (list (concat "-P" ps-printer-name)))
4286 (apply (or ps-print-region-function 'call-process-region)
4287 (point-min) (point-max) ps-lpr-command nil
4288 (and (fboundp 'start-process) 0)
4290 (ps-flatten-list ; dynamic evaluation
4291 (mapcar 'ps-eval-switch ps-lpr-switches)))))
4292 (and ps-razzle-dazzle (message "Printing...done")))
4293 (kill-buffer ps-spool-buffer)))
4295 ;; Dynamic evaluation
4296 (defun ps-eval-switch (arg)
4297 (cond ((stringp arg) arg)
4298 ((functionp arg) (apply arg nil))
4299 ((symbolp arg) (symbol-value arg))
4300 ((consp arg) (apply (car arg) (cdr arg)))
4303 ;; `ps-flatten-list' is defined here (copied from "message.el" and
4304 ;; enhanced to handle dotted pairs as well) until we can get some
4305 ;; sensible autoloads, or `flatten-list' gets put somewhere decent.
4307 ;; (ps-flatten-list '((a . b) c (d . e) (f g h) i . j))
4308 ;; => (a b c d e f g h i j)
4310 (defun ps-flatten-list (&rest list)
4311 (ps-flatten-list-1 list))
4313 (defun ps-flatten-list-1 (list)
4314 (cond ((null list) nil)
4315 ((consp list) (append (ps-flatten-list-1 (car list))
4316 (ps-flatten-list-1 (cdr list))))
4319 (defun ps-kill-emacs-check ()
4321 (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
4322 (buffer-modified-p ps-buffer)
4323 (y-or-n-p "Unprinted PostScript waiting; print now? ")
4325 (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
4326 (buffer-modified-p ps-buffer)
4327 (not (yes-or-no-p "Unprinted PostScript waiting; exit anyway? "))
4328 (error "Unprinted PostScript"))))
4330 (cond ((fboundp 'add-hook)
4331 (funcall 'add-hook 'kill-emacs-hook 'ps-kill-emacs-check))
4333 (message "Won't override existing `kill-emacs-hook'"))
4335 (setq kill-emacs-hook 'ps-kill-emacs-check)))
4338 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4339 ;;; Sample Setup Code:
4341 ;; This stuff is for anybody that's brave enough to look this far,
4342 ;; and able to figure out how to use it. It isn't really part of
4343 ;; ps-print, but I'll leave it here in hopes it might be useful:
4345 ;; WARNING!!! The following code is *sample* code only.
4346 ;; Don't use it unless you understand what it does!
4348 (defmacro ps-prsc ()
4349 `(if (eq ps-print-emacs-type 'emacs) [f22] 'f22))
4350 (defmacro ps-c-prsc ()
4351 `(if (eq ps-print-emacs-type 'emacs) [C-f22] '(control f22)))
4352 (defmacro ps-s-prsc ()
4353 `(if (eq ps-print-emacs-type 'emacs) [S-f22] '(shift f22)))
4355 ;; A hook to bind to `rmail-mode-hook' to locally bind prsc and set the
4356 ;; `ps-left-headers' specially for mail messages.
4357 (defun ps-rmail-mode-hook ()
4358 (local-set-key (ps-prsc) 'ps-rmail-print-message-from-summary)
4359 (setq ps-header-lines 3
4361 ;; The left headers will display the message's subject, its
4362 ;; author, and the name of the folder it was in.
4363 '(ps-article-subject ps-article-author buffer-name)))
4365 ;; See `ps-gnus-print-article-from-summary'. This function does the
4366 ;; same thing for rmail.
4367 (defun ps-rmail-print-message-from-summary ()
4369 (ps-print-message-from-summary 'rmail-summary-buffer "RMAIL"))
4371 ;; Used in `ps-rmail-print-article-from-summary',
4372 ;; `ps-gnus-print-article-from-summary' and `ps-vm-print-message-from-summary'.
4373 (defun ps-print-message-from-summary (summary-buffer summary-default)
4374 (let ((ps-buf (or (and (boundp summary-buffer)
4375 (symbol-value summary-buffer))
4377 (and (get-buffer ps-buf)
4380 (ps-spool-buffer-with-faces)))))
4382 ;; Look in an article or mail message for the Subject: line. To be
4383 ;; placed in `ps-left-headers'.
4384 (defun ps-article-subject ()
4386 (goto-char (point-min))
4387 (if (re-search-forward "^Subject:[ \t]+\\(.*\\)$" nil t)
4388 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
4391 ;; Look in an article or mail message for the From: line. Sorta-kinda
4392 ;; understands RFC-822 addresses and can pull the real name out where
4393 ;; it's provided. To be placed in `ps-left-headers'.
4394 (defun ps-article-author ()
4396 (goto-char (point-min))
4397 (if (re-search-forward "^From:[ \t]+\\(.*\\)$" nil t)
4398 (let ((fromstring (buffer-substring-no-properties (match-beginning 1)
4402 ;; Try first to match addresses that look like
4403 ;; thompson@wg2.waii.com (Jim Thompson)
4404 ((string-match ".*[ \t]+(\\(.*\\))" fromstring)
4405 (substring fromstring (match-beginning 1) (match-end 1)))
4407 ;; Next try to match addresses that look like
4408 ;; Jim Thompson <thompson@wg2.waii.com>
4409 ((string-match "\\(.*\\)[ \t]+<.*>" fromstring)
4410 (substring fromstring (match-beginning 1) (match-end 1)))
4412 ;; Couldn't find a real name -- show the address instead.
4416 ;; A hook to bind to `gnus-article-prepare-hook'. This will set the
4417 ;; `ps-left-headers' specially for gnus articles. Unfortunately,
4418 ;; `gnus-article-mode-hook' is called only once, the first time the *Article*
4419 ;; buffer enters that mode, so it would only work for the first time
4420 ;; we ran gnus. The second time, this hook wouldn't get set up. The
4421 ;; only alternative is `gnus-article-prepare-hook'.
4422 (defun ps-gnus-article-prepare-hook ()
4423 (setq ps-header-lines 3
4425 ;; The left headers will display the article's subject, its
4426 ;; author, and the newsgroup it was in.
4427 '(ps-article-subject ps-article-author gnus-newsgroup-name)))
4429 ;; A hook to bind to `vm-mode-hook' to locally bind prsc and set the
4430 ;; `ps-left-headers' specially for mail messages.
4431 (defun ps-vm-mode-hook ()
4432 (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary)
4433 (setq ps-header-lines 3
4435 ;; The left headers will display the message's subject, its
4436 ;; author, and the name of the folder it was in.
4437 '(ps-article-subject ps-article-author buffer-name)))
4439 ;; Every now and then I forget to switch from the *Summary* buffer to
4440 ;; the *Article* before hitting prsc, and a nicely formatted list of
4441 ;; article subjects shows up at the printer. This function, bound to
4442 ;; prsc for the gnus *Summary* buffer means I don't have to switch
4444 ;; sb: Updated for Gnus 5.
4445 (defun ps-gnus-print-article-from-summary ()
4447 (ps-print-message-from-summary 'gnus-article-buffer "*Article*"))
4449 ;; See `ps-gnus-print-article-from-summary'. This function does the
4450 ;; same thing for vm.
4451 (defun ps-vm-print-message-from-summary ()
4453 (ps-print-message-from-summary 'vm-mail-buffer ""))
4455 ;; A hook to bind to bind to `gnus-summary-setup-buffer' to locally bind
4457 (defun ps-gnus-summary-setup ()
4458 (local-set-key (ps-prsc) 'ps-gnus-print-article-from-summary))
4460 ;; Look in an article or mail message for the Subject: line. To be
4461 ;; placed in `ps-left-headers'.
4462 (defun ps-info-file ()
4464 (goto-char (point-min))
4465 (if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)" nil t)
4466 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
4469 ;; Look in an article or mail message for the Subject: line. To be
4470 ;; placed in `ps-left-headers'.
4471 (defun ps-info-node ()
4473 (goto-char (point-min))
4474 (if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)" nil t)
4475 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
4478 (defun ps-info-mode-hook ()
4479 (setq ps-left-header
4480 ;; The left headers will display the node name and file name.
4481 '(ps-info-node ps-info-file)))
4483 ;; WARNING! The following function is a *sample* only, and is *not*
4484 ;; meant to be used as a whole unless you understand what the effects
4485 ;; will be! (In fact, this is a copy of Jim's setup for ps-print --
4486 ;; I'd be very surprised if it was useful to *anybody*, without
4489 (defun ps-jts-ps-setup ()
4490 (global-set-key (ps-prsc) 'ps-spool-buffer-with-faces) ;f22 is prsc
4491 (global-set-key (ps-s-prsc) 'ps-spool-region-with-faces)
4492 (global-set-key (ps-c-prsc) 'ps-despool)
4493 (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook)
4494 (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup)
4495 (add-hook 'vm-mode-hook 'ps-vm-mode-hook)
4496 (add-hook 'vm-mode-hooks 'ps-vm-mode-hook)
4497 (add-hook 'Info-mode-hook 'ps-info-mode-hook)
4498 (setq ps-spool-duplex t
4499 ps-print-color-p nil
4500 ps-lpr-command "lpr"
4501 ps-lpr-switches '("-Jjct,duplex_long"))
4504 ;; WARNING! The following function is a *sample* only, and is *not*
4505 ;; meant to be used as a whole unless it corresponds to your needs.
4506 ;; (In fact, this is a copy of Jack's setup for ps-print --
4507 ;; I would not be that surprised if it was useful to *anybody*,
4508 ;; without modification.)
4510 (defun ps-jack-setup ()
4511 (setq ps-print-color-p nil
4512 ps-lpr-command "lpr"
4517 ps-number-of-columns 2
4519 ps-left-margin (/ (* 72 1.0) 2.54) ; 1.0 cm
4520 ps-right-margin (/ (* 72 1.0) 2.54) ; 1.0 cm
4521 ps-inter-column (/ (* 72 1.0) 2.54) ; 1.0 cm
4522 ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
4523 ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
4524 ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm
4525 ps-header-line-pad .15
4527 ps-print-header-frame t
4532 ps-font-family 'Courier
4534 ps-header-font-family 'Helvetica
4535 ps-header-font-size 6
4536 ps-header-title-font-size 8)
4540 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4541 ;; To make this file smaller, some commands go in a separate file.
4542 ;; But autoload them here to make the separation invisible.
4544 (autoload 'ps-mule-prepare-ascii-font "ps-mule"
4545 "Setup special ASCII font for STRING.
4546 STRING should contain only ASCII characters.")
4548 (autoload 'ps-mule-set-ascii-font "ps-mule"
4549 "Adjust current font if current charset is not ASCII.")
4551 (autoload 'ps-mule-plot-string "ps-mule"
4552 "Generate PostScript code for ploting characters in the region FROM and TO.
4554 It is assumed that all characters in this region belong to the same charset.
4556 Optional argument BG-COLOR specifies background color.
4560 (ENDPOS . RUN-WIDTH)
4562 Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
4565 (autoload 'ps-mule-initialize "ps-mule"
4566 "Initialize global data for printing multi-byte characters.")
4568 (autoload 'ps-mule-begin-job "ps-mule"
4569 "Start printing job for multi-byte chars between FROM and TO.
4570 This checks if all multi-byte characters in the region are printable or not.")
4572 (autoload 'ps-mule-begin-page "ps-mule"
4573 "Initialize multi-byte charset for printing current page.")
4576 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4580 ;;; ps-print.el ends here