1 ;;; ps-print.el --- Print text from the buffer as PostScript
3 ;; Copyright (C) 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
5 ;; Author: Jim Thompson (was <thompson@wg2.waii.com>)
6 ;; Author: Jacques Duthen <duthen@cegelec-red.fr>
7 ;; Maintainer: Vinicius Jose Latorre <vinicius@cpqd.br>
8 ;; Keywords: print, PostScript
9 ;; Time-stamp: <97/08/09 1:30:17 vinicius>
12 (defconst ps-print-version
"3.05"
13 "ps-print.el, v 3.05 <97/08/09 vinicius>
15 Vinicius's last change version -- this file may have been edited as part of
16 Emacs without changes to the version number. When reporting bugs,
17 please also report the version of Emacs, if any, that ps-print was
20 Please send all bug fixes and enhancements to
21 Jacques Duthen <duthen@cegelec-red.fr>.
24 ;; This file is part of GNU Emacs.
26 ;; GNU Emacs is free software; you can redistribute it and/or modify
27 ;; it under the terms of the GNU General Public License as published by
28 ;; the Free Software Foundation; either version 2, or (at your option)
31 ;; GNU Emacs is distributed in the hope that it will be useful,
32 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
33 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
34 ;; GNU General Public License for more details.
36 ;; You should have received a copy of the GNU General Public License
37 ;; along with GNU Emacs; see the file COPYING. If not, write to the
38 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
39 ;; Boston, MA 02111-1307, USA.
43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
48 ;; This package provides printing of Emacs buffers on PostScript
49 ;; printers; the buffer's bold and italic text attributes are
50 ;; preserved in the printer output. Ps-print is intended for use with
51 ;; Emacs 19 or Lucid Emacs, together with a fontifying package such as
52 ;; font-lock or hilit.
54 ;; ps-print uses the same face attributes defined through font-lock or hilit
55 ;; to print a PostScript file, but some faces are better seeing on the screen
56 ;; than on paper, specially when you have a black/white PostScript printer.
58 ;; ps-print allows a remap of face to another one that it is better to print,
59 ;; for example, the face font-lock-comment-face (if you are using font-lock)
60 ;; could have bold or italic attribute when printing, besides foreground color.
61 ;; This remap improves printing look (see How Ps-Print Maps Faces).
69 ;; Ps-print provides eight commands for generating PostScript images
73 ;; ps-print-buffer-with-faces
75 ;; ps-print-region-with-faces
77 ;; ps-spool-buffer-with-faces
79 ;; ps-spool-region-with-faces
81 ;; These commands all perform essentially the same function: they
82 ;; generate PostScript images suitable for printing on a PostScript
83 ;; printer or displaying with GhostScript. These commands are
84 ;; collectively referred to as "ps-print- commands".
86 ;; The word "print" or "spool" in the command name determines when the
87 ;; PostScript image is sent to the printer:
89 ;; print - The PostScript image is immediately sent to the
92 ;; spool - The PostScript image is saved temporarily in an
93 ;; Emacs buffer. Many images may be spooled locally
94 ;; before printing them. To send the spooled images
95 ;; to the printer, use the command `ps-despool'.
97 ;; The spooling mechanism was designed for printing lots of small
98 ;; files (mail messages or netnews articles) to save paper that would
99 ;; otherwise be wasted on banner pages, and to make it easier to find
100 ;; your output at the printer (it's easier to pick up one 50-page
101 ;; printout than to find 50 single-page printouts).
103 ;; Ps-print has a hook in the `kill-emacs-hooks' so that you won't
104 ;; accidentally quit from Emacs while you have unprinted PostScript
105 ;; waiting in the spool buffer. If you do attempt to exit with
106 ;; spooled PostScript, you'll be asked if you want to print it, and if
107 ;; you decline, you'll be asked to confirm the exit; this is modeled
108 ;; on the confirmation that Emacs uses for modified buffers.
110 ;; The word "buffer" or "region" in the command name determines how
111 ;; much of the buffer is printed:
113 ;; buffer - Print the entire buffer.
115 ;; region - Print just the current region.
117 ;; The -with-faces suffix on the command name means that the command
118 ;; will include font, color, and underline information in the
119 ;; PostScript image, so the printed image can look as pretty as the
120 ;; buffer. The ps-print- commands without the -with-faces suffix
121 ;; don't include font, color, or underline information; images printed
122 ;; with these commands aren't as pretty, but are faster to generate.
124 ;; Two ps-print- command examples:
126 ;; ps-print-buffer - print the entire buffer,
127 ;; without font, color, or
128 ;; underline information, and
129 ;; send it immediately to the
132 ;; ps-spool-region-with-faces - print just the current region;
133 ;; include font, color, and
134 ;; underline information, and
135 ;; spool the image in Emacs to
136 ;; send to the printer later.
142 ;; To print your buffer, type
144 ;; M-x ps-print-buffer
146 ;; or substitute one of the other seven ps-print- commands. The
147 ;; command will generate the PostScript image and print or spool it as
148 ;; specified. By giving the command a prefix argument
150 ;; C-u M-x ps-print-buffer
152 ;; it will save the PostScript image to a file instead of sending it
153 ;; to the printer; you will be prompted for the name of the file to
154 ;; save the image to. The prefix argument is ignored by the commands
155 ;; that spool their images, but you may save the spooled images to a
156 ;; file by giving a prefix argument to `ps-despool':
158 ;; C-u M-x ps-despool
160 ;; When invoked this way, `ps-despool' will prompt you for the name of
161 ;; the file to save to.
163 ;; Any of the `ps-print-' commands can be bound to keys; I recommend
164 ;; binding `ps-spool-buffer-with-faces', `ps-spool-region-with-faces',
165 ;; and `ps-despool'. Here are the bindings I use on my Sun 4 keyboard:
167 ;; (global-set-key 'f22 'ps-spool-buffer-with-faces) ;f22 is prsc
168 ;; (global-set-key '(shift f22) 'ps-spool-region-with-faces)
169 ;; (global-set-key '(control f22) 'ps-despool)
172 ;; The Printer Interface
173 ;; ---------------------
175 ;; The variables `ps-lpr-command' and `ps-lpr-switches' determine what
176 ;; command is used to send the PostScript images to the printer, and
177 ;; what arguments to give the command. These are analogous to
178 ;; `lpr-command' and `lpr-switches'.
180 ;; Make sure that they contain appropriate values for your system;
181 ;; see the usage notes below and the documentation of these variables.
183 ;; NOTE: `ps-lpr-command' and `ps-lpr-switches' take their initial values
184 ;; from the variables `lpr-command' and `lpr-switches'. If you have
185 ;; `lpr-command' set to invoke a pretty-printer such as `enscript',
186 ;; then ps-print won't work properly. `ps-lpr-command' must name
187 ;; a program that does not format the files it prints.
193 ;; All dimensions are floats in PostScript points.
194 ;; 1 inch == 2.54 cm == 72 points
195 ;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points
197 ;; The variable `ps-paper-type' determines the size of paper ps-print
198 ;; formats for; it should contain one of the symbols:
199 ;; `a4' `a3' `letter' `legal' `letter-small' `tabloid'
200 ;; `ledger' `statement' `executive' `a4small' `b4' `b5'
202 ;; The variable `ps-landscape-mode' determines the orientation
203 ;; of the printing on the page:
204 ;; nil means `portrait' mode, non-nil means `landscape' mode.
205 ;; There is no oblique mode yet, though this is easy to do in ps.
207 ;; In landscape mode, the text is NOT scaled: you may print 70 lines
208 ;; in portrait mode and only 50 lignes in landscape mode.
209 ;; The margins represent margins in the printed paper:
210 ;; the top margin is the margin between the top of the page
211 ;; and the printed header, whatever the orientation is.
213 ;; The variable `ps-number-of-columns' determines the number of columns
214 ;; both in landscape and portrait mode.
216 ;; - (the standard) one column portrait mode
217 ;; - (my favorite) two columns landscape mode (which spares trees)
219 ;; - one column landscape mode for files with very long lines.
220 ;; - multi-column portrait or landscape mode
226 ;; The horizontal layout is determined by the variables
227 ;; `ps-left-margin' `ps-inter-column' `ps-right-margin'
230 ;; ------------------------------------------
232 ;; | lm | text | ic | text | ic | text | rm |
234 ;; ------------------------------------------
236 ;; If `ps-number-of-columns' is 1, `ps-inter-column' is not relevant.
237 ;; Usually, lm = rm > 0 and ic = lm
238 ;; If (ic < 0), the text of adjacent columns can overlap.
244 ;; The vertical layout is determined by the variables
245 ;; `ps-bottom-margin' `ps-top-margin' `ps-header-offset'
248 ;; |--------| |--------|
250 ;; |--------| |--------|
254 ;; |--------| or | text |
258 ;; |--------| |--------|
260 ;; |--------| |--------|
262 ;; If `ps-print-header' is nil, `ps-header-offset' is not relevant.
263 ;; The margins represent margins in the printed paper:
264 ;; the top margin is the margin between the top of the page
265 ;; and the printed header, whatever the orientation is.
271 ;; Ps-print can print headers at the top of each column; the default
272 ;; headers contain the following four items: on the left, the name of
273 ;; the buffer and, if the buffer is visiting a file, the file's
274 ;; directory; on the right, the page number and date of printing.
275 ;; The default headers look something like this:
278 ;; /home/jct/emacs-lisp/ps/new 94/12/31
280 ;; When printing on duplex printers, left and right are reversed so
281 ;; that the page numbers are toward the outside (cf. `ps-spool-duplex').
283 ;; Headers are configurable:
284 ;; To turn them off completely, set `ps-print-header' to nil.
285 ;; To turn off the header's gaudy framing box,
286 ;; set `ps-print-header-frame' to nil.
288 ;; The font family and size of text in the header are determined
289 ;; by the variables `ps-header-font-family', `ps-header-font-size' and
290 ;; `ps-header-title-font-size' (see below).
292 ;; The variable `ps-header-line-pad' determines the portion of a header
293 ;; title line height to insert between the header frame and the text
294 ;; it contains, both in the vertical and horizontal directions:
295 ;; .5 means half a line.
297 ;; Page numbers are printed in `n/m' format, indicating page n of m pages;
298 ;; to omit the total page count and just print the page number,
299 ;; set `ps-show-n-of-n' to nil.
301 ;; The amount of information in the header can be changed by changing
302 ;; the number of lines. To show less, set `ps-header-lines' to 1, and
303 ;; the header will show only the buffer name and page number. To show
304 ;; more, set `ps-header-lines' to 3, and the header will show the time of
305 ;; printing below the date.
307 ;; To change the content of the headers, change the variables
308 ;; `ps-left-header' and `ps-right-header'.
309 ;; These variables are lists, specifying top-to-bottom the text
310 ;; to display on the left or right side of the header.
311 ;; Each element of the list should be a string or a symbol.
312 ;; Strings are inserted directly into the PostScript arrays,
313 ;; and should contain the PostScript string delimiters '(' and ')'.
315 ;; Symbols in the header format lists can either represent functions
316 ;; or variables. Functions are called, and should return a string to
317 ;; show in the header. Variables should contain strings to display in
318 ;; the header. In either case, function or variable, the PostScript
319 ;; string delimiters are added by ps-print, and should not be part of
320 ;; the returned value.
322 ;; Here's an example: say we want the left header to display the text
328 ;; where we have a function to return "Moe"
330 ;; (defun moe-func ()
333 ;; a variable specifying "Larry"
335 ;; (setq larry-var "Larry")
337 ;; and a literal for "Curly". Here's how `ps-left-header' should be
340 ;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)"))
342 ;; Note that Curly has the PostScript string delimiters inside his
343 ;; quotes -- those aren't misplaced lisp delimiters!
345 ;; Without them, PostScript would attempt to call the undefined
346 ;; function Curly, which would result in a PostScript error.
348 ;; Since most printers don't report PostScript errors except by
349 ;; aborting the print job, this kind of error can be hard to track down.
351 ;; Consider yourself warned!
357 ;; If you have a duplex-capable printer (one that prints both sides of
358 ;; the paper), set `ps-spool-duplex' to t.
359 ;; Ps-print will insert blank pages to make sure each buffer starts
360 ;; on the correct side of the paper.
361 ;; Don't forget to set `ps-lpr-switches' to select duplex printing
368 ;; The variable `ps-line-number' determines if lines will be
369 ;; numerated (non-nil value) or not (nil value).
370 ;; The default is not numerated (nil value).
376 ;; Zebra stripes are a kind of background which you can request
377 ;; to appear "underneath" the text. They look like this:
379 ;; XXXXXXXXXXXXXXXXXXXXXXXX
380 ;; XXXXXXXXXXXXXXXXXXXXXXXX
381 ;; XXXXXXXXXXXXXXXXXXXXXXXX
385 ;; XXXXXXXXXXXXXXXXXXXXXXXX
386 ;; XXXXXXXXXXXXXXXXXXXXXXXX
387 ;; XXXXXXXXXXXXXXXXXXXXXXXX
389 ;; The X's here represent a rectangle area filled with a light gray color.
390 ;; The height, in lines, of the gray area pis controlled by
391 ;; the variable `ps-zebra-stripe-height', which is 3 by default.
392 ;; The distance between stripes equals the height of a stripe.
394 ;; The variable `ps-zebra-stripe' determines if zebra stripe lines will be
395 ;; printed (non-nil value) or not (nil value).
396 ;; The default is not print zebra stripes (nil value).
402 ;; Ps-print now knows rather precisely some fonts:
403 ;; the variable `ps-font-info-database' contains information
404 ;; for a list of font families (currently mainly `Courier' `Helvetica'
405 ;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk').
406 ;; Each font family contains the font names for standard, bold, italic
407 ;; and bold-italic characters, a reference size (usually 10) and the
408 ;; corresponding line height, width of a space and average character width.
410 ;; The variable `ps-font-family' determines which font family
411 ;; is to be used for ordinary text.
412 ;; If its value does not correspond to a known font family,
413 ;; an error message is printed into the `*Messages*' buffer,
414 ;; which lists the currently available font families.
416 ;; The variable `ps-font-size' determines the size (in points)
417 ;; of the font for ordinary text, when generating Postscript.
418 ;; Its value is a float.
420 ;; Similarly, the variable `ps-header-font-family' determines
421 ;; which font family is to be used for text in the header.
422 ;; The variable `ps-header-font-size' determines the font size,
423 ;; in points, for text in the header.
424 ;; The variable `ps-header-title-font-size' determines the font size,
425 ;; in points, for the top line of text in the header.
428 ;; Adding a new font family
429 ;; ------------------------
431 ;; To use a new font family, you MUST first teach ps-print
432 ;; this font, i.e., add its information to `ps-font-info-database',
433 ;; otherwise ps-print cannot correctly place line and page breaks.
435 ;; For example, assuming `Helvetica' is unknown,
436 ;; you first need to do the following ONLY ONCE:
438 ;; - create a new buffer
439 ;; - generate the PostScript image to a file (C-u M-x ps-print-buffer)
440 ;; - open this file and find the line:
441 ;; `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage'
442 ;; - delete the leading `%' (which is the Postscript comment character)
443 ;; - replace in this line `Courier' by the new font (say `Helvetica')
445 ;; `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage'
446 ;; - send this file to the printer (or to ghostscript).
447 ;; You should read the following on the output page:
449 ;; For Helvetica 10 point, the line height is 11.56, the space width is 2.78
450 ;; and a crude estimate of average character width is 5.09243
452 ;; - Add these values to the `ps-font-info-database':
453 ;; (setq ps-font-info-database
455 ;; '((Helvetica ; the family name
456 ;; "Helvetica" "Helvetica-Bold" "Helvetica-Oblique" "Helvetica-BoldOblique"
457 ;; 10.0 11.56 2.78 5.09243))
458 ;; ps-font-info-database))
459 ;; - Now you can use this font family with any size:
460 ;; (setq ps-font-family 'Helvetica)
461 ;; - if you want to use this family in another emacs session, you must
462 ;; put into your `~/.emacs':
463 ;; (require 'ps-print)
464 ;; (setq ps-font-info-database (append ...)))
465 ;; if you don't want to load ps-print, you have to copy the whole value:
466 ;; (setq ps-font-info-database '(<your stuff> <the standard stuff>))
467 ;; or, if you can wait until the `ps-print-hook' is implemented, do:
468 ;; (add-hook 'ps-print-hook '(setq ps-font-info-database (append ...)))
469 ;; This does not work yet, since there is no `ps-print-hook' yet.
471 ;; You can create new `mixed' font families like:
473 ;; "Courier-Bold" "Helvetica"
474 ;; "Zapf-Chancery-MediumItalic" "NewCenturySchlbk-BoldItalic"
475 ;; 10.0 10.55 6.0 6.0)
476 ;; Now you can use your new font family with any size:
477 ;; (setq ps-font-family 'my-mixed-family)
479 ;; You can get information on all the fonts resident in YOUR printer
480 ;; by uncommenting the line:
481 ;; % 3 cm 20 cm moveto ReportAllFontInfo showpage
483 ;; The postscript file should be sent to YOUR postscript printer.
484 ;; If you send it to ghostscript or to another postscript printer,
485 ;; you may get slightly different results.
486 ;; Anyway, as ghostscript fonts are autoload, you won't get
490 ;; How Ps-Print Deals With Faces
491 ;; -----------------------------
493 ;; The ps-print-*-with-faces commands attempt to determine which faces
494 ;; should be printed in bold or italic, but their guesses aren't
495 ;; always right. For example, you might want to map colors into faces
496 ;; so that blue faces print in bold, and red faces in italic.
498 ;; It is possible to force ps-print to consider specific faces bold or
499 ;; italic, no matter what font they are displayed in, by setting the
500 ;; variables `ps-bold-faces' and `ps-italic-faces'. These variables
501 ;; contain lists of faces that ps-print should consider bold or
502 ;; italic; to set them, put code like the following into your .emacs
505 ;; (setq ps-bold-faces '(my-blue-face))
506 ;; (setq ps-italic-faces '(my-red-face))
508 ;; Faces like bold-italic that are both bold and italic should go in
511 ;; Ps-print keeps internal lists of which fonts are bold and which are
512 ;; italic; these lists are built the first time you invoke ps-print.
513 ;; For the sake of efficiency, the lists are built only once; the same
514 ;; lists are referred in later invocations of ps-print.
516 ;; Because these lists are built only once, it's possible for them to
517 ;; get out of sync, if a face changes, or if new faces are added. To
518 ;; get the lists back in sync, you can set the variable
519 ;; `ps-build-face-reference' to t, and the lists will be rebuilt the
520 ;; next time ps-print is invoked.
523 ;; How Ps-Print Deals With Color
524 ;; -----------------------------
526 ;; Ps-print detects faces with foreground and background colors
527 ;; defined and embeds color information in the PostScript image.
528 ;; The default foreground and background colors are defined by the
529 ;; variables `ps-default-fg' and `ps-default-bg'.
530 ;; On black-and-white printers, colors are displayed in grayscale.
531 ;; To turn off color output, set `ps-print-color-p' to nil.
534 ;; How Ps-Print Maps Faces
535 ;; -----------------------
537 ;; As ps-print uses PostScript to print buffers, it is possible to have
538 ;; other attributes associated with faces. So the new attributes used
541 ;; strikeout - like underline, but the line is in middle of text.
542 ;; overline - like underline, but the line is over the text.
543 ;; shadow - text will have a shadow.
544 ;; box - text will be surrounded by a box.
545 ;; outline - only the contour of the characters will be printed.
547 ;; See the documentation for `ps-extend-face' and `ps-extend-face-list'.
549 ;; Let's, for example, remap font-lock-keyword-face to another foreground color
550 ;; and bold attribute:
552 ;; (ps-extend-face '(font-lock-keyword-face "RoyalBlue" nil bold))
554 ;; Note: the only attributes that have effect on screen are: bold, italic and
555 ;; underline. All other screen effect is ignored.
557 ;; If you want to use a new face, define it first with `defface',
558 ;; and then call `ps-extend-face' to specify how to print it.
561 ;; How Ps-Print Has A Text And/Or Image On Background
562 ;; --------------------------------------------------
564 ;; Ps-print can print texts and/or EPS PostScript images on background; it is
565 ;; possible to define the following text attributes: font name, font size,
566 ;; initial position, angle, gray scale and pages to print.
568 ;; It has the following EPS PostScript images attributes: file name containing
569 ;; the image, initial position, X and Y scales, angle and pages to print.
571 ;; See documentation for `ps-print-background-text' and
572 ;; `ps-print-background-image'.
574 ;; For example, if we wish to print text "preliminary" on all pages and text
575 ;; "special" on page 5 and from page 11 to page 17, we could specify:
577 ;; (setq ps-print-background-text
580 ;; "LeftMargin" "BottomMargin PrintHeight add" ; X and Y position
581 ;; ; (upper left corner)
583 ;; "PrintHeight neg PrintWidth atan" ; angle
584 ;; 5 (11 . 17)) ; page list
587 ;; Similarly, we could print image "~/images/EPS-image1.ps" on all pages and
588 ;; image "~/images/EPS-image2.ps" on page 5 and from page 11 to page 17, we
591 ;; (setq ps-print-background-image
592 ;; '(("~/images/EPS-image1.ps"
593 ;; "LeftMargin" "BottomMargin") ; X and Y position (lower left corner)
594 ;; ("~/images/EPS-image2.ps"
595 ;; "LeftMargin" "BottomMargin PrintHeight 2 div add" ; X and Y position
596 ;; ; (upper left corner)
598 ;; 5 (11 . 17)) ; page list
601 ;; If it is not possible to read (or does not exist) an image file, that file
604 ;; The printing order is:
606 ;; 1. Print zebra stripes
607 ;; 2. Print background texts that it should be on all pages
608 ;; 3. Print background images that it should be on all pages
609 ;; 4. Print background texts only for current page (if any)
610 ;; 5. Print background images only for current page (if any)
612 ;; 7. Print buffer text (with faces, if specified) with line number
618 ;; Some tools are provided to help you customize your font setup.
620 ;; `ps-setup' returns (some part of) the current setup.
622 ;; To avoid wrapping too many lines, you may want to adjust the
623 ;; left and right margins and the font size. On UN*X systems, do:
624 ;; pr -t file | awk '{printf "%3d %s\n", length($0), $0}' | sort -r | head
625 ;; to determine the longest lines of your file.
626 ;; Then, the command `ps-line-lengths' will give you the correspondence
627 ;; between a line length (number of characters) and the maximum font
628 ;; size which doesn't wrap such a line with the current ps-print setup.
630 ;; The commands `ps-nb-pages-buffer' and `ps-nb-pages-region' display
631 ;; the correspondence between a number of pages and the maximum font
632 ;; size which allow the number of lines of the current buffer or of
633 ;; its current region to fit in this number of pages.
634 ;; Note: line folding is not taken into account in this process
635 ;; and could change the results.
638 ;; New since version 1.5
639 ;; ---------------------
641 ;; Color output capability.
642 ;; Automatic detection of font attributes (bold, italic).
643 ;; Configurable headers with page numbers.
645 ;; Support for different paper sizes.
646 ;; Better conformance to PostScript Document Structure Conventions.
649 ;; New since version 2.8
650 ;; ---------------------
652 ;; [vinicius] 970809 Vinicius Jose Latorre <vinicius@cpqd.br>
654 ;; Handle control characters.
656 ;; New face attributes.
659 ;; Text and/or image on background.
661 ;; [jack] 960517 Jacques Duthen <duthen@cegelec-red.fr>
663 ;; Font familiy and float size for text and header.
666 ;; Tools for page setup.
669 ;; Known bugs and limitations of ps-print:
670 ;; --------------------------------------
672 ;; Although color printing will work in XEmacs 19.12, it doesn't work
673 ;; well; in particular, bold or italic fonts don't print in the right
676 ;; Invisible properties aren't correctly ignored in XEmacs 19.12.
678 ;; Automatic font-attribute detection doesn't work well, especially
679 ;; with hilit19 and older versions of get-create-face. Users having
680 ;; problems with auto-font detection should use the lists
681 ;; `ps-italic-faces' and `ps-bold-faces' and/or turn off automatic
682 ;; detection by setting `ps-auto-font-detect' to nil.
684 ;; Automatic font-attribute detection doesn't work with XEmacs 19.12
685 ;; in tty mode; use the lists `ps-italic-faces' and `ps-bold-faces'
688 ;; Still too slow; could use some hand-optimization.
690 ;; Default background color isn't working.
692 ;; Faces are always treated as opaque.
694 ;; Epoch and Emacs 18 not supported. At all.
696 ;; Fixed-pitch fonts work better for line folding, but are not required.
698 ;; `ps-nb-pages-buffer' and `ps-nb-pages-region' don't take care
705 ;; Add `ps-print-hook' (I don't know how to do that (yet!)).
706 ;; Add 4-up capability (really needed?).
707 ;; Add line numbers (should not be too hard).
708 ;; Add `ps-non-bold-faces' and `ps-non-italic-faces' (should be easy).
709 ;; Put one header per page over the columns (easy but needed?).
710 ;; Improve the memory management for big files (hard?).
711 ;; `ps-nb-pages-buffer' and `ps-nb-pages-region' should take care
717 ;; Thanks to Jim Thompson <?@?> for the 2.8 version I started from.
720 ;; Thanks to Kevin Rodgers <kevinr@ihs.com> for adding support for
721 ;; color and the invisible property.
723 ;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing
724 ;; the initial port to Emacs 19. His code is no longer part of
725 ;; ps-print, but his work is still appreciated.
727 ;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org,
728 ;; for adding underline support. Their code also is no longer part of
729 ;; ps-print, but their efforts are not forgotten.
731 ;; Thanks also to all of you who mailed code to add features to
732 ;; ps-print; although I didn't use your code, I still appreciate your
733 ;; sharing it with me.
735 ;; Thanks to all who mailed comments, encouragement, and criticism.
736 ;; Thanks also to all who responded to my survey; I had too many
737 ;; responses to reply to them all, but I greatly appreciate your
741 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
748 (unless (featurep 'lisp-float-type
)
749 (error "`ps-print' requires floating point support"))
751 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
754 ;;; Interface to the command system
756 (defgroup ps-print nil
757 "Postscript generator for Emacs 19"
761 (defgroup ps-print-horizontal nil
762 "Horizontal page layout"
767 (defgroup ps-print-vertical nil
768 "Vertical page layout"
773 (defgroup ps-print-header nil
779 (defgroup ps-print-font nil
780 "Fonts customization"
785 (defgroup ps-print-color nil
786 "Color customization"
791 (defgroup ps-print-face nil
792 "Faces customization"
799 (defcustom ps-lpr-command lpr-command
800 "*The shell command for printing a PostScript file."
804 (defcustom ps-lpr-switches lpr-switches
805 "*A list of extra switches to pass to `ps-lpr-command'."
806 :type
'(repeat string
)
811 ;; All page dimensions are in PostScript points.
812 ;; 1 inch == 2.54 cm == 72 points
813 ;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points
815 ;; Letter 8.5 inch x 11.0 inch
816 ;; Legal 8.5 inch x 14.0 inch
817 ;; A4 8.26 inch x 11.69 inch = 21.0 cm x 29.7 cm
819 ;; LetterSmall 7.68 inch x 10.16 inch
820 ;; Tabloid 11.0 inch x 17.0 inch
821 ;; Ledger 17.0 inch x 11.0 inch
822 ;; Statement 5.5 inch x 8.5 inch
823 ;; Executive 7.5 inch x 10.0 inch
824 ;; A3 11.69 inch x 16.5 inch = 29.7 cm x 42.0 cm
825 ;; A4Small 7.47 inch x 10.85 inch
826 ;; B4 10.125 inch x 14.33 inch
827 ;; B5 7.16 inch x 10.125 inch
829 (defcustom ps-page-dimensions-database
830 (list (list 'a4
(/ (* 72 21.0) 2.54) (/ (* 72 29.7) 2.54))
831 (list 'a3
(/ (* 72 29.7) 2.54) (/ (* 72 42.0) 2.54))
832 (list 'letter
(* 72 8.5) (* 72 11.0))
833 (list 'legal
(* 72 8.5) (* 72 14.0))
834 (list 'letter-small
(* 72 7.68) (* 72 10.16))
835 (list 'tabloid
(* 72 11.0) (* 72 17.0))
836 (list 'ledger
(* 72 17.0) (* 72 11.0))
837 (list 'statement
(* 72 5.5) (* 72 8.5))
838 (list 'executive
(* 72 7.5) (* 72 10.0))
839 (list 'a4small
(* 72 7.47) (* 72 10.85))
840 (list 'b4
(* 72 10.125) (* 72 14.33))
841 (list 'b5
(* 72 7.16) (* 72 10.125)))
842 "*List associating a symbolic paper type to its width and height.
843 see `ps-paper-type'."
844 :type
'(repeat (list :tag
"Paper Type"
846 (number :tag
"Width")
847 (number :tag
"Height")))
850 (defcustom ps-paper-type
'letter
851 "*Specifies the size of paper to format for.
852 Should be one of the paper types defined in `ps-page-dimensions-database', for
853 example `letter', `legal' or `a4'."
854 :type
'(symbol :validate
(lambda (wid)
855 (if (assq (widget-value wid
)
856 ps-page-dimensions-database
)
858 (widget-put wid
:error
"Unknown paper size")
862 (defcustom ps-landscape-mode nil
863 "*Non-nil means print in landscape mode."
867 (defcustom ps-number-of-columns
(if ps-landscape-mode
2 1)
868 "*Specifies the number of columns"
872 (defcustom ps-zebra-stripes nil
873 "*Non-nil means print zebra stripes.
874 See also documentation for `ps-print-n-zebra'."
878 (defcustom ps-zebra-stripe-height
3
879 "*Number of zebra stripe lines.
880 See also documentation for `ps-print-zebra'."
884 (defcustom ps-line-number nil
885 "*Non-nil means print line number."
889 (defcustom ps-print-background-image nil
890 "*EPS image list to be printed on background.
894 (FILENAME X Y XSCALE YSCALE ROTATION PAGES...)
896 FILENAME is a file name which contains an EPS image or some PostScript
897 programming like EPS.
898 FILENAME is ignored, if it doesn't exist or is read protected.
900 X and Y are relative positions on paper to put the image.
901 If X and Y are nil, the image is centralized on paper.
903 XSCALE and YSCALE are scale factor to be applied to image before printing.
904 If XSCALE and YSCALE are nil, the original size is used.
906 ROTATION is the image rotation angle; if nil, the default is 0.
908 PAGES designates the page to print background image.
909 PAGES may be a number or a cons cell (FROM . TO) designating FROM page
911 If PAGES is nil, print background image on all pages.
913 X, Y, XSCALE, YSCALE and ROTATION may be a floating point number,
914 an integer number or a string. If it is a string, the string should contain
915 PostScript programming that returns a float or integer value.
917 For example, if you wish to print an EPS image on all pages do:
919 '((\"~/images/EPS-image.ps\"))"
923 (defcustom ps-print-background-text nil
924 "*Text list to be printed on background.
928 (STRING X Y FONT FONTSIZE GRAY ROTATION PAGES...)
930 STRING is the text to be printed on background.
932 X and Y are positions on paper to put the text.
933 If X and Y are nil, the text is positioned at lower left corner.
935 FONT is a font name to be used on printing the text.
936 If nil, \"Times-Roman\" is used.
938 FONTSIZE is font size to be used, if nil, 200 is used.
940 GRAY is the text gray factor (should be very light like 0.8).
941 If nil, the default is 0.85.
943 ROTATION is the text rotation angle; if nil, the angle is given by
944 the diagonal from lower left corner to upper right corner.
946 PAGES designates the page to print background text.
947 PAGES may be a number or a cons cell (FROM . TO) designating FROM page
949 If PAGES is nil, print background text on all pages.
951 X, Y, FONTSIZE, GRAY and ROTATION may be a floating point number,
952 an integer number or a string. If it is a string, the string should contain
953 PostScript programming that returns a float or integer value.
955 For example, if you wish to print text \"Preliminary\" on all pages do:
957 '((\"Preliminary\"))"
961 ;;; Horizontal layout
963 ;; ------------------------------------------
965 ;; | lm | text | ic | text | ic | text | rm |
967 ;; ------------------------------------------
969 (defcustom ps-left-margin
(/ (* 72 2.0) 2.54) ; 2 cm
970 "*Left margin in points (1/72 inch)."
972 :group
'ps-print-horizontal
)
974 (defcustom ps-right-margin
(/ (* 72 2.0) 2.54) ; 2 cm
975 "*Right margin in points (1/72 inch)."
977 :group
'ps-print-horizontal
)
979 (defcustom ps-inter-column
(/ (* 72 2.0) 2.54) ; 2 cm
980 "*Horizontal space between columns in points (1/72 inch)."
982 :group
'ps-print-horizontal
)
998 (defcustom ps-bottom-margin
(/ (* 72 1.5) 2.54) ; 1.5 cm
999 "*Bottom margin in points (1/72 inch)."
1001 :group
'ps-print-vertical
)
1003 (defcustom ps-top-margin
(/ (* 72 1.5) 2.54) ; 1.5 cm
1004 "*Top margin in points (1/72 inch)."
1006 :group
'ps-print-vertical
)
1008 (defcustom ps-header-offset
(/ (* 72 1.0) 2.54) ; 1.0 cm
1009 "*Vertical space in points (1/72 inch) between the main text and the header."
1011 :group
'ps-print-vertical
)
1013 (defcustom ps-header-line-pad
0.15
1014 "*Portion of a header title line height to insert between the header frame
1015 and the text it contains, both in the vertical and horizontal directions."
1017 :group
'ps-print-vertical
)
1021 (defcustom ps-print-header t
1022 "*Non-nil means print a header at the top of each page.
1023 By default, the header displays the buffer name, page number, and, if
1024 the buffer is visiting a file, the file's directory. Headers are
1025 customizable by changing variables `ps-left-header' and
1028 :group
'ps-print-header
)
1030 (defcustom ps-print-header-frame t
1031 "*Non-nil means draw a gaudy frame around the header."
1033 :group
'ps-print-header
)
1035 (defcustom ps-header-lines
2
1036 "*Number of lines to display in page header, when generating Postscript."
1038 :group
'ps-print-header
)
1039 (make-variable-buffer-local 'ps-header-lines
)
1041 (defcustom ps-show-n-of-n t
1042 "*Non-nil means show page numbers as N/M, meaning page N of M.
1043 Note: page numbers are displayed as part of headers, see variable
1044 `ps-print-headers'."
1046 :group
'ps-print-header
)
1048 (defcustom ps-spool-duplex nil
; Not many people have duplex
1049 ; printers, so default to nil.
1050 "*Non-nil indicates spooling is for a two-sided printer.
1051 For a duplex printer, the `ps-spool-*' commands will insert blank pages
1052 as needed between print jobs so that the next buffer printed will
1053 start on the right page. Also, if headers are turned on, the headers
1054 will be reversed on duplex printers so that the page numbers fall to
1055 the left on even-numbered pages."
1057 :group
'ps-print-header
)
1061 (defcustom ps-font-info-database
1062 '((Courier ; the family key
1063 "Courier" "Courier-Bold" "Courier-Oblique" "Courier-BoldOblique"
1065 (Helvetica ; the family key
1066 "Helvetica" "Helvetica-Bold" "Helvetica-Oblique" "Helvetica-BoldOblique"
1067 10.0 11.56 2.78 5.09243)
1069 "Times-Roman" "Times-Bold" "Times-Italic" "Times-BoldItalic"
1070 10.0 11.0 2.5 4.71432)
1072 "Palatino-Roman" "Palatino-Bold" "Palatino-Italic" "Palatino-BoldItalic"
1073 10.0 12.1 2.5 5.08676)
1075 "Helvetica-Narrow" "Helvetica-Narrow-Bold"
1076 "Helvetica-Narrow-Oblique" "Helvetica-Narrow-BoldOblique"
1077 10.0 11.56 2.2796 4.17579)
1079 "NewCenturySchlbk-Roman" "NewCenturySchlbk-Bold"
1080 "NewCenturySchlbk-Italic" "NewCenturySchlbk-BoldItalic"
1081 10.0 12.15 2.78 5.31162)
1082 ;; got no bold for the next ones
1084 "AvantGarde-Book" "AvantGarde-Book"
1085 "AvantGarde-BookOblique" "AvantGarde-BookOblique"
1086 10.0 11.77 2.77 5.45189)
1088 "AvantGarde-Demi" "AvantGarde-Demi"
1089 "AvantGarde-DemiOblique" "AvantGarde-DemiOblique"
1090 10.0 12.72 2.8 5.51351)
1092 "Bookman-Demi" "Bookman-Demi"
1093 "Bookman-DemiItalic" "Bookman-DemiItalic"
1094 10.0 11.77 3.4 6.05946)
1096 "Bookman-Light" "Bookman-Light"
1097 "Bookman-LightItalic" "Bookman-LightItalic"
1098 10.0 11.79 3.2 5.67027)
1099 ;; got no bold and no italic for the next ones
1101 "Symbol" "Symbol" "Symbol" "Symbol"
1102 10.0 13.03 2.5 3.24324)
1104 "Zapf-Dingbats" "Zapf-Dingbats" "Zapf-Dingbats" "Zapf-Dingbats"
1105 10.0 9.63 2.78 2.78)
1106 (Zapf-Chancery-MediumItalic
1107 "Zapf-Chancery-MediumItalic" "Zapf-Chancery-MediumItalic"
1108 "Zapf-Chancery-MediumItalic" "Zapf-Chancery-MediumItalic"
1109 10.0 11.45 2.2 4.10811)
1111 "*Font info database: font family (the key), name, bold, italic, bold-italic,
1112 reference size, line height, space width, average character width.
1113 To get the info for another specific font (say Helvetica), do the following:
1114 - create a new buffer
1115 - generate the PostScript image to a file (C-u M-x ps-print-buffer)
1116 - open this file and delete the leading `%' (which is the Postscript
1117 comment character) from the line
1118 `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage'
1120 `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage'
1121 - add the values to `ps-font-info-database'.
1122 You can get all the fonts of YOUR printer using `ReportAllFontInfo'."
1123 :type
'(repeat (list :tag
"Font Definition"
1124 (symbol :tag
"Font")
1125 (string :tag
"Name")
1126 (string :tag
"Bold")
1127 (string :tag
"Italic")
1128 (string :tag
"Bold-Italic")
1129 (number :tag
"Reference Size")
1130 (number :tag
"Line Height")
1131 (number :tag
"Space Width")
1132 (number :tag
"Average Character Width")))
1133 :group
'ps-print-font
)
1135 (defcustom ps-font-family
'Courier
1136 "Font family name for ordinary text, when generating Postscript."
1138 :group
'ps-print-font
)
1140 (defcustom ps-font-size
(if ps-landscape-mode
7 8.5)
1141 "Font size, in points, for ordinary text, when generating Postscript."
1143 :group
'ps-print-font
)
1145 (defcustom ps-header-font-family
'Helvetica
1146 "Font family name for text in the header, when generating Postscript."
1148 :group
'ps-print-font
)
1150 (defcustom ps-header-font-size
(if ps-landscape-mode
10 12)
1151 "Font size, in points, for text in the header, when generating Postscript."
1153 :group
'ps-print-font
)
1155 (defcustom ps-header-title-font-size
(if ps-landscape-mode
12 14)
1156 "Font size, in points, for the top line of text in the header,
1157 when generating Postscript."
1159 :group
'ps-print-font
)
1163 ;; Printing color requires x-color-values.
1164 (defcustom ps-print-color-p
(or (fboundp 'x-color-values
) ; Emacs
1165 (fboundp 'pixel-components
)) ; XEmacs
1166 "*If non-nil, print the buffer's text in color."
1168 :group
'ps-print-color
)
1170 (defcustom ps-default-fg
'(0.0
0.0 0.0)
1171 "*RGB values of the default foreground color. Defaults to black."
1172 :type
'(list (number :tag
"Red") (number :tag
"Green") (number :tag
"Blue"))
1173 :group
'ps-print-color
)
1175 (defcustom ps-default-bg
'(1.0
1.0 1.0)
1176 "*RGB values of the default background color. Defaults to white."
1177 :type
'(list (number :tag
"Red") (number :tag
"Green") (number :tag
"Blue"))
1178 :group
'ps-print-color
)
1180 (defcustom ps-auto-font-detect t
1181 "*Non-nil means automatically detect bold/italic face attributes.
1182 nil means rely solely on the lists `ps-bold-faces', `ps-italic-faces',
1183 and `ps-underlined-faces'."
1185 :group
'ps-print-font
)
1187 (defcustom ps-bold-faces
1188 (unless ps-print-color-p
1189 '(font-lock-function-name-face
1190 font-lock-builtin-face
1191 font-lock-variable-name-face
1192 font-lock-keyword-face
1193 font-lock-warning-face
))
1194 "*A list of the \(non-bold\) faces that should be printed in bold font.
1195 This applies to generating Postscript."
1196 :type
'(repeat face
)
1197 :group
'ps-print-face
)
1199 (defcustom ps-italic-faces
1200 (unless ps-print-color-p
1201 '(font-lock-variable-name-face
1202 font-lock-string-face
1203 font-lock-comment-face
1204 font-lock-warning-face
))
1205 "*A list of the \(non-italic\) faces that should be printed in italic font.
1206 This applies to generating Postscript."
1207 :type
'(repeat face
)
1208 :group
'ps-print-face
)
1210 (defcustom ps-underlined-faces
1211 (unless ps-print-color-p
1212 '(font-lock-function-name-face
1214 font-lock-reference-face
1215 font-lock-warning-face
))
1216 "*A list of the \(non-underlined\) faces that should be printed underlined.
1217 This applies to generating Postscript."
1218 :type
'(repeat face
)
1219 :group
'ps-print-face
)
1221 (defcustom ps-left-header
1222 (list 'ps-get-buffer-name
'ps-header-dirpart
)
1223 "*The items to display (each on a line) on the left part of the page header.
1224 This applies to generating Postscript.
1226 The value should be a list of strings and symbols, each representing an
1227 entry in the PostScript array HeaderLinesLeft.
1229 Strings are inserted unchanged into the array; those representing
1230 PostScript string literals should be delimited with PostScript string
1231 delimiters '(' and ')'.
1233 For symbols with bound functions, the function is called and should
1234 return a string to be inserted into the array. For symbols with bound
1235 values, the value should be a string to be inserted into the array.
1236 In either case, function or variable, the string value has PostScript
1237 string delimiters added to it."
1238 :type
'(repeat (choice string symbol
))
1239 :group
'ps-print-header
)
1240 (make-variable-buffer-local 'ps-left-header
)
1242 (defcustom ps-right-header
1243 (list "/pagenumberstring load" 'time-stamp-mon-dd-yyyy
'time-stamp-hh
:mm
:ss
)
1244 "*The items to display (each on a line) on the right part of the page header.
1245 This applies to generating Postscript.
1247 See the variable `ps-left-header' for a description of the format of
1249 :type
'(repeat (choice string symbol
))
1250 :group
'ps-print-header
)
1251 (make-variable-buffer-local 'ps-right-header
)
1253 (defcustom ps-razzle-dazzle t
1254 "*Non-nil means report progress while formatting buffer."
1258 (defvar ps-adobe-tag
"%!PS-Adobe-3.0\n"
1259 "*Contains the header line identifying the output as PostScript.
1260 By default, `ps-adobe-tag' contains the standard identifier. Some
1261 printers require slightly different versions of this line.")
1263 (defcustom ps-build-face-reference t
1264 "*Non-nil means build the reference face lists.
1266 Ps-print sets this value to nil after it builds its internal reference
1267 lists of bold and italic faces. By settings its value back to t, you
1268 can force ps-print to rebuild the lists the next time you invoke one
1269 of the ...-with-faces commands.
1271 You should set this value back to t after you change the attributes of
1272 any face, or create new faces. Most users shouldn't have to worry
1273 about its setting, though."
1275 :group
'ps-print-face
)
1277 (defcustom ps-always-build-face-reference nil
1278 "*Non-nil means always rebuild the reference face lists.
1280 If this variable is non-nil, ps-print will rebuild its internal
1281 reference lists of bold and italic faces *every* time one of the
1282 -with-faces commands is called. Most users shouldn't need to set this
1285 :group
'ps-print-face
)
1287 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1291 (defun ps-print-buffer (&optional filename
)
1292 "Generate and print a PostScript image of the buffer.
1294 When called with a numeric prefix argument (C-u), prompts the user for
1295 the name of a file to save the PostScript image in, instead of sending
1298 More specifically, the FILENAME argument is treated as follows: if it
1299 is nil, send the image to the printer. If FILENAME is a string, save
1300 the PostScript image in a file with that name. If FILENAME is a
1301 number, prompt the user for the name of the file to save in."
1302 (interactive (list (ps-print-preprint current-prefix-arg
)))
1303 (ps-print-without-faces (point-min) (point-max) filename
))
1307 (defun ps-print-buffer-with-faces (&optional filename
)
1308 "Generate and print a PostScript image of the buffer.
1309 Like `ps-print-buffer', but includes font, color, and underline
1310 information in the generated image. This command works only if you
1311 are using a window system, so it has a way to determine color values."
1312 (interactive (list (ps-print-preprint current-prefix-arg
)))
1313 (ps-print-with-faces (point-min) (point-max) filename
))
1317 (defun ps-print-region (from to
&optional filename
)
1318 "Generate and print a PostScript image of the region.
1319 Like `ps-print-buffer', but prints just the current region."
1320 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg
)))
1321 (ps-print-without-faces from to filename
))
1325 (defun ps-print-region-with-faces (from to
&optional filename
)
1326 "Generate and print a PostScript image of the region.
1327 Like `ps-print-region', but includes font, color, and underline
1328 information in the generated image. This command works only if you
1329 are using a window system, so it has a way to determine color values."
1330 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg
)))
1331 (ps-generate (current-buffer) from to
1332 'ps-generate-postscript-with-faces
)
1333 (ps-print-with-faces from to filename
))
1337 (defun ps-spool-buffer ()
1338 "Generate and spool a PostScript image of the buffer.
1339 Like `ps-print-buffer' except that the PostScript image is saved in a
1340 local buffer to be sent to the printer later.
1342 Use the command `ps-despool' to send the spooled images to the printer."
1344 (ps-spool-without-faces (point-min) (point-max)))
1348 (defun ps-spool-buffer-with-faces ()
1349 "Generate and spool a PostScript image of the buffer.
1350 Like `ps-spool-buffer', but includes font, color, and underline
1351 information in the generated image. This command works only if you
1352 are using a window system, so it has a way to determine color values.
1354 Use the command `ps-despool' to send the spooled images to the printer."
1356 (ps-spool-with-faces (point-min) (point-max)))
1360 (defun ps-spool-region (from to
)
1361 "Generate a PostScript image of the region and spool locally.
1362 Like `ps-spool-buffer', but spools just the current region.
1364 Use the command `ps-despool' to send the spooled images to the printer."
1366 (ps-spool-without-faces from to
))
1370 (defun ps-spool-region-with-faces (from to
)
1371 "Generate a PostScript image of the region and spool locally.
1372 Like `ps-spool-region', but includes font, color, and underline
1373 information in the generated image. This command works only if you
1374 are using a window system, so it has a way to determine color values.
1376 Use the command `ps-despool' to send the spooled images to the printer."
1378 (ps-spool-with-faces from to
))
1381 (defun ps-despool (&optional filename
)
1382 "Send the spooled PostScript to the printer.
1384 When called with a numeric prefix argument (C-u), prompt the user for
1385 the name of a file to save the spooled PostScript in, instead of sending
1388 More specifically, the FILENAME argument is treated as follows: if it
1389 is nil, send the image to the printer. If FILENAME is a string, save
1390 the PostScript image in a file with that name. If FILENAME is a
1391 number, prompt the user for the name of the file to save in."
1392 (interactive (list (ps-print-preprint current-prefix-arg
)))
1393 (ps-do-despool filename
))
1396 (defun ps-line-lengths ()
1397 "*Display the correspondence between a line length and a font size,
1398 using the current ps-print setup.
1399 Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"
1401 (ps-line-lengths-internal))
1404 (defun ps-nb-pages-buffer (nb-lines)
1405 "*Display an approximate correspondence between a font size and the number
1406 of pages the current buffer would require to print
1407 using the current ps-print setup."
1408 (interactive (list (count-lines (point-min) (point-max))))
1409 (ps-nb-pages nb-lines
))
1412 (defun ps-nb-pages-region (nb-lines)
1413 "*Display an approximate correspondence between a font size and the number
1414 of pages the current region would require to print
1415 using the current ps-print setup."
1416 (interactive (list (count-lines (mark) (point))))
1417 (ps-nb-pages nb-lines
))
1421 "*Return the current setup"
1423 (setq ps-print-color-p %s
1424 ps-lpr-command \"%s\"
1428 ps-landscape-mode %s
1429 ps-number-of-columns %s
1437 ps-header-line-pad %s
1439 ps-print-header-frame %s
1446 ps-header-font-family '%s
1447 ps-header-font-size %s
1448 ps-header-title-font-size %s)
1455 ps-number-of-columns
1464 ps-print-header-frame
1470 ps-header-font-family
1472 ps-header-title-font-size
))
1474 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1475 ;; Utility functions and variables:
1477 (defvar ps-print-emacs-type
1478 (cond ((string-match "XEmacs" emacs-version
) 'xemacs
)
1479 ((string-match "Lucid" emacs-version
) 'lucid
)
1480 ((string-match "Epoch" emacs-version
) 'epoch
)
1483 (if (or (eq ps-print-emacs-type
'lucid
)
1484 (eq ps-print-emacs-type
'xemacs
))
1485 (if (< emacs-minor-version
12)
1486 (setq ps-print-color-p nil
))
1487 (require 'faces
)) ; face-font, face-underline-p,
1490 (require 'time-stamp
)
1493 "Font family name for ordinary text, when generating Postscript.")
1495 (defvar ps-font-bold nil
1496 "Font family name for bold text, when generating Postscript.")
1498 (defvar ps-font-italic nil
1499 "Font family name for italic text, when generating Postscript.")
1501 (defvar ps-font-bold-italic nil
1502 "Font family name for bold italic text, when generating Postscript.")
1504 (defvar ps-avg-char-width nil
1505 "The average width, in points, of a character, for generating Postscript.
1506 This is the value that ps-print uses to determine the length,
1507 x-dimension, of the text it has printed, and thus affects the point at
1508 which long lines wrap around.")
1510 (defvar ps-space-width nil
1511 "The width of a space character, for generating Postscript.
1512 This value is used in expanding tab characters.")
1514 (defvar ps-line-height nil
1515 "The height of a line, for generating Postscript.
1516 This is the value that ps-print uses to determine the height,
1517 y-dimension, of the lines of text it has printed, and thus affects the
1518 point at which page-breaks are placed.
1519 The line-height is *not* the same as the point size of the font.")
1521 (defvar ps-print-prologue-1
1522 "% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4:
1523 /ISOLatin1Encoding where { pop } {
1524 % -- The ISO Latin-1 encoding vector isn't known, so define it.
1525 % -- The first half is the same as the standard encoding,
1526 % -- except for minus instead of hyphen at code 055.
1528 StandardEncoding 0 45 getinterval aload pop
1530 StandardEncoding 46 82 getinterval aload pop
1531 %*** NOTE: the following are missing in the Adobe documentation,
1532 %*** but appear in the displayed table:
1533 %*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240.
1535 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
1536 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
1537 /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
1538 /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron
1540 /space /exclamdown /cent /sterling
1541 /currency /yen /brokenbar /section
1542 /dieresis /copyright /ordfeminine /guillemotleft
1543 /logicalnot /hyphen /registered /macron
1544 /degree /plusminus /twosuperior /threesuperior
1545 /acute /mu /paragraph /periodcentered
1546 /cedilla /onesuperior /ordmasculine /guillemotright
1547 /onequarter /onehalf /threequarters /questiondown
1549 /Agrave /Aacute /Acircumflex /Atilde
1550 /Adieresis /Aring /AE /Ccedilla
1551 /Egrave /Eacute /Ecircumflex /Edieresis
1552 /Igrave /Iacute /Icircumflex /Idieresis
1553 /Eth /Ntilde /Ograve /Oacute
1554 /Ocircumflex /Otilde /Odieresis /multiply
1555 /Oslash /Ugrave /Uacute /Ucircumflex
1556 /Udieresis /Yacute /Thorn /germandbls
1558 /agrave /aacute /acircumflex /atilde
1559 /adieresis /aring /ae /ccedilla
1560 /egrave /eacute /ecircumflex /edieresis
1561 /igrave /iacute /icircumflex /idieresis
1562 /eth /ntilde /ograve /oacute
1563 /ocircumflex /otilde /odieresis /divide
1564 /oslash /ugrave /uacute /ucircumflex
1565 /udieresis /yacute /thorn /ydieresis
1569 /reencodeFontISO { %def
1571 length 12 add dict % Make a new font (a new dict the same size
1572 % as the old one) with room for our new symbols.
1574 begin % Make the new font the current dictionary.
1578 { def } { pop pop } ifelse
1579 } forall % Copy each of the symbols from the old dictionary
1580 % to the new one except for the font ID.
1582 /Encoding ISOLatin1Encoding def % Override the encoding with
1583 % the ISOLatin1 encoding.
1585 % Use the font's bounding box to determine the ascent, descent,
1586 % and overall height; don't forget that these values have to be
1587 % transformed using the font's matrix.
1594 % | | | | Ascent (usually > 0)
1596 % (0 0) -> +--+----+-------->
1598 % | | v Descent (usually < 0)
1599 % (x1 y1) --> +----+ - -
1601 FontBBox % -- x1 y1 x2 y2
1602 FontMatrix transform /Ascent exch def pop
1603 FontMatrix transform /Descent exch def pop
1604 /FontHeight Ascent Descent sub def % use `sub' because descent < 0
1606 % Define these in case they're not in the FontInfo
1607 % (also, here they're easier to get to).
1608 /UnderlinePosition Descent 0.70 mul def
1609 /OverlinePosition Descent UnderlinePosition sub Ascent add def
1610 /StrikeoutPosition Ascent 0.30 mul def
1611 /LineThickness 0 50 FontMatrix transform exch pop def
1612 /Xshadow 0 80 FontMatrix transform exch pop def
1613 /Yshadow 0 -90 FontMatrix transform exch pop def
1614 /SpaceBackground Descent neg UnderlinePosition add def
1615 /XBox Descent neg def
1616 /YBox LineThickness 0.7 mul def
1618 currentdict % Leave the new font on the stack
1619 end % Stop using the font as the current dictionary.
1620 definefont % Put the font into the font dictionary
1621 pop % Discard the returned font.
1624 /DefFont { % Font definition
1625 findfont exch scalefont reencodeFontISO
1628 /F { % Font selection
1630 dup /Ascent get /Ascent exch def
1631 dup /Descent get /Descent exch def
1632 dup /FontHeight get /FontHeight exch def
1633 dup /UnderlinePosition get /UnderlinePosition exch def
1634 dup /OverlinePosition get /OverlinePosition exch def
1635 dup /StrikeoutPosition get /StrikeoutPosition exch def
1636 dup /LineThickness get /LineThickness exch def
1637 dup /Xshadow get /Xshadow exch def
1638 dup /Yshadow get /Yshadow exch def
1639 dup /SpaceBackground get /SpaceBackground exch def
1640 dup /XBox get /XBox exch def
1641 dup /YBox get /YBox exch def
1645 /FG /setrgbcolor load def
1658 % | Ascent (usually > 0)
1660 % | Descent (usually < 0)
1664 /dobackground { % width --
1665 currentpoint % -- width x y
1669 0 Ascent rmoveto % B
1671 0 Descent Ascent sub rlineto % D
1674 bgcolor aload pop setrgbcolor
1679 /eolbg { % dobackground until right margin
1680 PrintWidth % -- x-eol
1681 currentpoint pop % -- cur-x
1682 sub % -- width until eol
1686 /PLN {PrintLineNumber {doLineNumber}if} def
1688 /SL { % Soft Linefeed
1690 0 currentpoint exch pop LineHeight sub moveto
1693 /HL {SL PLN} def % Hard Linefeed
1696 /dcp { currentpoint exch 40 string cvs print (, ) print = } def
1697 /dp { print 2 copy exch 40 string cvs print (, ) print = } def
1700 ( ) stringwidth % Get the width of a space in the current font.
1701 pop % Discard the Y component.
1702 mul % Multiply the width of a space
1703 % by the number of spaces to plot
1704 bg { dup dobackground } if
1709 /EF {/Effect exch def} def
1711 % stack: string |- --
1712 % effect: 1 - underline 2 - strikeout 4 - overline
1713 % 8 - shadow 16 - box 32 - outline
1715 /xx currentpoint dup Descent add /yy exch def
1716 Ascent add /YY exch def def
1717 dup stringwidth pop xx add /XX exch def
1719 /yy yy Yshadow add def
1720 /XX XX Xshadow add def
1725 {SpaceBackground doBox}
1726 {xx yy XX YY doRect}
1729 Effect 16 and 0 ne {false 0 doBox}if % box
1730 Effect 8 and 0 ne {dup doShadow}if % shadow
1732 {true doOutline} % outline
1733 {show} % normal text
1735 Effect 1 and 0 ne {UnderlinePosition Hline}if % underline
1736 Effect 2 and 0 ne {StrikeoutPosition Hline}if % strikeout
1737 Effect 4 and 0 ne {OverlinePosition Hline}if % overline
1740 % stack: position |- --
1742 currentpoint exch pop add dup
1748 LineThickness setlinewidth stroke
1752 % stack: fill-or-not delta |- --
1755 xx XBox sub dd sub yy YBox sub dd sub
1756 XX XBox add dd add YY YBox add dd add
1760 % stack: fill-or-not lower-x lower-y upper-x upper-y |- --
1773 % top of stack: fill-or-not
1775 {LineThickness setlinewidth stroke}
1780 % stack: string |- --
1783 Xshadow Yshadow rmoveto
1790 % stack: string fill-or-not |- --
1793 /-ox- currentpoint /-oy- exch def def
1795 LineThickness setlinewidth
1798 st dup true charpath
1799 -fillp- {gsave FillBgColor grestore}if
1801 -oy- add /-oy- exch def
1802 -ox- add /-ox- exch def
1810 /FillBgColor {bgcolor aload pop setrgbcolor fill} bind def
1812 /L0 6 /Times-Italic DefFont
1818 0.0 0.0 0.0 setrgbcolor
1819 /L0 findfont setfont
1822 {LineNumber 6 string cvs ( ) strcat}
1824 dup stringwidth pop neg 0 rmoveto
1828 /LineNumber LineNumber 1 add def
1835 /double-zebra NumberOfZebra NumberOfZebra add def
1836 /yiter double-zebra LineHeight mul neg def
1837 /xiter PrintWidth InterColumn add def
1838 NumberOfColumns {LinesPerColumn doColumnZebra xiter 0 rmoveto}repeat
1842 % stack: lines-per-column |- --
1845 dup double-zebra idiv {NumberOfZebra doZebra 0 yiter rmoveto}repeat
1847 dup 0 le {pop}{dup NumberOfZebra gt {pop NumberOfZebra}if doZebra}ifelse
1851 % stack: zebra-height (in lines) |- --
1853 /zh exch 0.05 sub LineHeight mul def
1855 0 LineHeight 0.65 mul rmoveto
1856 PrintWidth 0 rlineto
1858 PrintWidth neg 0 rlineto
1864 % tx ty rotation xscale yscale xpos ypos BeginBackImage
1866 /-save-image- save def
1875 -save-image- restore
1878 % string fontsize fontname rotation gray xpos ypos ShowBackText
1884 findfont exch dup /-offset- exch -0.25 mul def scalefont setfont
1886 /-saveLineThickness- LineThickness def
1887 /LineThickness 1 def
1889 /LineThickness -saveLineThickness- def
1894 % ---- save the state of the document (useful for ghostscript!)
1896 % ---- [jack] Kludge: my ghostscript window is 21x27.7 instead of 21x29.7
1897 /JackGhostscript where {
1898 pop 1 27.7 29.7 div scale
1901 % ---- translate to bottom-right corner of Portrait page
1902 LandscapePageHeight 0 translate
1905 /ColumnWidth PrintWidth InterColumn add def
1906 % ---- translate to lower left corner of TEXT
1907 LeftMargin BottomMargin translate
1908 % ---- define where printing will start
1909 /f0 F % this installs Ascent
1910 /PrintStartY PrintHeight Ascent sub def
1915 % ---- on last page but not last column, spit out the page
1916 ColumnIndex 1 eq not { showpage } if
1917 % ---- restore the state of the document (useful for ghostscript!)
1922 % ---- when 1st column, save the state of the page
1923 ColumnIndex 1 eq { /pageState save def
1924 0 PrintStartY moveto % move to where printing will start
1925 Zebra {printZebra}if
1926 printGlobalBackground
1927 printLocalBackground
1929 % ---- save the state of the column
1930 /columnState save def
1935 PrintHeaderFrame { HeaderFrame } if
1938 0 PrintStartY moveto % move to where printing will start
1947 ColumnIndex NumberOfColumns eq {
1948 % ---- on last column, spit out the page
1950 % ---- restore the state of the page
1954 % ---- restore the state of the current column
1956 % ---- and translate to the next column
1957 ColumnWidth 0 translate
1958 /ColumnIndex ColumnIndex 1 add def
1962 /SetHeaderLines { % nb-lines --
1963 /HeaderLines exch def
1966 HeaderLines 1 sub HeaderLineHeight mul add
1967 HeaderTitleLineHeight add
1969 /HeaderHeight exch def
1976 % |-+-------| <-- (x y)
1980 % |-+-------| <-- (0 0)
1984 /HeaderFrameStart { % -- x y
1985 0 PrintHeight HeaderOffset add
1989 PrintWidth 0 rlineto
1990 0 HeaderHeight rlineto
1991 PrintWidth neg 0 rlineto
1992 0 HeaderHeight neg rlineto
1998 % ---- fill a black rectangle (the shadow of the next one)
1999 HeaderFrameStart moveto
2003 % ---- do the next rectangle ...
2004 HeaderFrameStart moveto
2006 gsave 0.9 setgray fill grestore % filled with grey
2007 gsave 0 setgray stroke grestore % drawn with black
2013 exch HeaderPad add exch % horizontal pad
2015 HeaderPad add % vertical pad
2017 HeaderLineHeight HeaderLines 1 sub mul add
2021 dup length 3 -1 roll dup length dup 4 -1 roll add string dup
2022 0 5 -1 roll putinterval
2023 dup 4 2 roll exch putinterval
2027 PageNumber 32 string cvs
2030 PageCount 32 string cvs strcat
2037 HeaderLinesRight HeaderLinesLeft % -- rightLines leftLines
2039 % ---- hack: `PN 1 and' == `PN 2 modulo'
2041 % ---- if duplex and even page number, then exchange left and right
2042 Duplex PageNumber 1 and 0 eq and { exch } if
2044 { % ---- process the left lines
2048 dup xcheck { exec } if
2051 0 HeaderLineHeight neg rmoveto
2056 { % ---- process the right lines
2060 dup xcheck { exec } if
2062 PrintWidth exch sub HeaderPad 2 mul sub 0 rmoveto
2065 0 HeaderLineHeight neg rmoveto
2071 /t0 3 1 roll DefFont
2074 /sw ( ) stringwidth pop def
2075 /aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch
2076 stringwidth pop exch div def
2077 /t1 12 /Helvetica-Oblique DefFont
2084 ( point, the line height is ) show
2085 lh 32 string cvs show
2086 (, the space width is ) show
2087 sw 32 string cvs show
2090 0 FontHeight neg rmoveto
2092 (and a crude estimate of average character width is ) show
2093 aw 32 string cvs show
2096 0 FontHeight neg rmoveto
2103 /ReportAllFontInfo {
2105 { % key = font name value = font dictionary
2106 pop 10 exch ReportFontInfo
2110 % 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage
2111 % 3 cm 20 cm moveto ReportAllFontInfo showpage
2115 (defvar ps-print-prologue-2
2117 % ---- These lines must be kept together because...
2120 /HeaderTitleLineHeight FontHeight def
2123 /HeaderLineHeight FontHeight def
2124 /HeaderDescent Descent def
2126 % ---- ...because `F' has a side-effect on `FontHeight' and `Descent'
2130 ;; Start Editing Here:
2132 (defvar ps-source-buffer nil
)
2133 (defvar ps-spool-buffer-name
"*PostScript*")
2134 (defvar ps-spool-buffer nil
)
2136 (defvar ps-output-head nil
)
2137 (defvar ps-output-tail nil
)
2139 (defvar ps-page-count
0)
2140 (defvar ps-showpage-count
0)
2141 (defvar ps-showline-count
1)
2143 (defvar ps-background-pages nil
)
2144 (defvar ps-background-all-pages nil
)
2145 (defvar ps-background-text-count
0)
2146 (defvar ps-background-image-count
0)
2148 (defvar ps-current-font
0)
2149 (defvar ps-default-color
(if ps-print-color-p ps-default-fg
)) ; black
2150 (defvar ps-current-color ps-default-color
)
2151 (defvar ps-current-bg nil
)
2153 (defvar ps-razchunk
0)
2155 (defvar ps-color-format
2156 (if (eq ps-print-emacs-type
'emacs
)
2158 ;;Emacs understands the %f format; we'll
2159 ;;use it to limit color RGB values to
2160 ;;three decimals to cut down some on the
2161 ;;size of the PostScript output.
2164 ;; Lucid emacsen will have to make do with
2165 ;; %s (princ) for floats.
2168 ;; These values determine how much print-height to deduct when headers
2169 ;; are turned on. This is a pretty clumsy way of handling it, but
2170 ;; it'll do for now.
2172 (defvar ps-header-font nil
)
2173 (defvar ps-header-title-font nil
)
2175 (defvar ps-header-line-height nil
)
2176 (defvar ps-header-title-line-height nil
)
2177 (defvar ps-header-pad
0
2178 "Vertical and horizontal space in points (1/72 inch) between the header frame
2179 and the text it contains.")
2181 ;; Define accessors to the dimensions list.
2183 (defmacro ps-page-dimensions-get-width
(dims) `(nth 0 ,dims
))
2184 (defmacro ps-page-dimensions-get-height
(dims) `(nth 1 ,dims
))
2186 (defvar ps-landscape-page-height nil
)
2188 (defvar ps-print-width nil
)
2189 (defvar ps-print-height nil
)
2191 (defvar ps-height-remaining
)
2192 (defvar ps-width-remaining
)
2194 (defvar ps-ref-bold-faces nil
)
2195 (defvar ps-ref-italic-faces nil
)
2196 (defvar ps-ref-underlined-faces nil
)
2198 (defvar ps-print-color-scale nil
)
2201 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2202 ;; Internal Variables
2205 (defvar ps-print-face-extension-alist nil
2206 "Alist of symbolic faces with extension features (box, outline, etc).
2207 An element of this list has the following form:
2209 (FACE . [BITS FG BG])
2211 FACE is a symbol denoting a face name
2212 BITS is a bit vector, where each bit correspond
2213 to a feature (bold, underline, etc)
2214 (see documentation for `ps-print-face-map-alist')
2215 FG foreground color (string or nil)
2216 BG background color (string or nil)
2218 Don't change this list directly; instead, use
2219 `ps-extend-face' and `ps-extend-face-list' to change it.
2220 See documentation for `ps-extend-face' for valid extension symbol.
2221 See also `font-lock-face-attributes'.")
2224 (defconst ps-print-face-map-alist
2233 "Alist of all features and the corresponding bit mask.
2234 Each symbol correspond to one bit in a bit vector.")
2237 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2238 ;; Creating and Remapping Faces
2241 (require 'font-lock
)
2244 ;; The definition below is necessary because some emacs variant does not
2245 ;; define it on font-lock package.
2247 (defvar font-lock-face-attributes nil
)
2251 (defun ps-override-list (sym-list element
)
2252 (let ((maplist (assq (car element
) (symbol-value sym-list
))))
2254 (setcdr maplist
(cdr element
))
2255 (set sym-list
(cons element
(symbol-value sym-list
)))
2259 (defun ps-extension-to-bit-face (face-extension)
2260 (cons (nth 0 face-extension
)
2261 (vector (ps-extension-bit face-extension
)
2262 (nth 1 face-extension
)
2263 (nth 2 face-extension
))))
2266 (defun ps-extension-to-screen-face (face)
2267 (let ((face-name (nth 0 face
))
2268 (face-foreground (nth 1 face
))
2269 (face-background (nth 2 face
))
2270 (face-attributes (nthcdr 3 face
)))
2271 (list face-name face-foreground face-background
2272 (and (memq 'bold face-attributes
) t
)
2273 (and (memq 'italic face-attributes
) t
)
2274 (and (memq 'underline face-attributes
) t
))))
2278 (defun ps-extend-face-list (face-extension-list &optional merge-p
)
2279 "Extend face in `ps-print-face-extension-alist'.
2281 If optional MERGE-P is non-nil, extensions in FACE-EXTENSION are merged with
2282 face extension in `ps-print-face-extension-alist'; otherwise, overrides.
2284 The elements in FACE-EXTENSION-LIST is like those for `ps-extend-face'.
2286 See `ps-extend-face' for documentation."
2287 (while face-extension-list
2288 (ps-extend-face (car face-extension-list
) merge-p
)
2289 (setq face-extension-list
(cdr face-extension-list
))))
2293 (defun ps-extend-face (face-extension &optional merge-p
)
2294 "Extend face in `ps-print-face-extension-alist'.
2296 If optional MERGE-p is non-nil, extensions in FACE-EXTENSION are merged with
2297 face extensions in `ps-print-face-extension-alist'; otherwise, overrides.
2299 The elements of FACE-EXTENSION list have the form:
2301 (FACE-NAME FOREGROUND BACKGROUND EXTENSION...)
2303 FACE-NAME is a face name symbol.
2305 FOREGROUND and BACKGROUND may be nil or a string that denotes the
2306 foreground and background colors respectively.
2308 EXTENSION is one of the following symbols:
2309 bold - use bold font.
2310 italic - use italic font.
2311 underline - put a line under text.
2312 strikeout - like underline, but the line is in middle of text.
2313 overline - like underline, but the line is over the text.
2314 shadow - text will have a shadow.
2315 box - text will be surrounded by a box.
2316 outline - only the text border font will be printed.
2318 If EXTENSION is any other symbol, it is ignored."
2319 (let* ((face-name (nth 0 face-extension
))
2320 (foreground (nth 1 face-extension
))
2321 (background (nth 2 face-extension
))
2322 (ps-face (cdr (assq face-name ps-print-face-extension-alist
)))
2323 (face-vector (or ps-face
(vector 0 nil nil
)))
2324 (face-bit (ps-extension-bit face-extension
)))
2326 (aset face-vector
0 (if merge-p
2327 (logior (aref face-vector
0) face-bit
)
2329 (and foreground
(stringp foreground
) (aset face-vector
1 foreground
))
2330 (and background
(stringp background
) (aset face-vector
2 background
))
2331 ;; if face does not exist, insert it
2333 (setq ps-print-face-extension-alist
2334 (cons (cons face-name face-vector
)
2335 ps-print-face-extension-alist
)))))
2338 (defun ps-extension-bit (face-extension)
2340 ;; map valid symbol extension to bit vector
2341 (setq face-extension
(cdr (cdr face-extension
)))
2342 (while (setq face-extension
(cdr face-extension
))
2343 (setq face-bit
(logior face-bit
2344 (or (cdr (assq (car face-extension
)
2345 ps-print-face-map-alist
))
2350 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2351 ;; Internal functions and variables
2354 (defun ps-print-without-faces (from to
&optional filename
)
2355 (ps-generate (current-buffer) from to
'ps-generate-postscript
)
2356 (ps-do-despool filename
))
2359 (defun ps-spool-without-faces (from to
)
2360 (ps-generate (current-buffer) from to
'ps-generate-postscript
))
2363 (defun ps-print-with-faces (from to
&optional filename
)
2364 (ps-initialize-faces)
2365 (ps-generate (current-buffer) from to
'ps-generate-postscript-with-faces
)
2366 (ps-do-despool filename
))
2369 (defun ps-spool-with-faces (from to
)
2370 (ps-initialize-faces)
2371 (ps-generate (current-buffer) from to
'ps-generate-postscript-with-faces
))
2374 (defvar ps-initialize-faces nil
)
2377 (defun ps-initialize-faces ()
2378 (or ps-initialize-faces
2380 (setq ps-initialize-faces t
)
2381 (mapcar 'ps-map-font-lock font-lock-face-attributes
))))
2384 (defun ps-map-font-lock (face)
2385 (let* ((face-map (ps-screen-to-bit-face face
))
2386 (ps-face-bit (cdr (assq (car face-map
)
2387 ps-print-face-extension-alist
))))
2389 ;; if face exists, merge both
2390 (let ((face-bit (cdr face-map
)))
2391 (aset ps-face-bit
0 (logior (aref ps-face-bit
0) (aref face-bit
0)))
2392 (or (aref ps-face-bit
1) (aset ps-face-bit
1 (aref face-bit
1)))
2393 (or (aref ps-face-bit
2) (aset ps-face-bit
2 (aref face-bit
2))))
2394 ;; if face does not exist, insert it
2395 (setq ps-print-face-extension-alist
2396 (cons face-map ps-print-face-extension-alist
))
2400 (defun ps-screen-to-bit-face (face)
2401 (let ((face-name (car face
))
2402 (face-foreground (nth 1 face
))
2403 (face-background (nth 2 face
))
2404 (face-bit (logior (if (nth 3 face
) 1 0) ; bold
2405 (if (nth 4 face
) 2 0) ; italic
2406 (if (nth 5 face
) 4 0)))) ; underline
2407 (cons face-name
(vector face-bit face-foreground face-background
))))
2410 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2411 ;; Internal functions
2413 (defun ps-line-lengths-internal ()
2414 "Display the correspondence between a line length and a font size,
2415 using the current ps-print setup.
2416 Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"
2417 (let ((buf (get-buffer-create "*Line-lengths*"))
2418 (ifs ps-font-size
) ; initial font size
2419 (icw ps-avg-char-width
) ; initial character width
2420 (print-width (progn (ps-get-page-dimensions)
2422 (ps-setup (ps-setup)) ; setup for the current buffer
2423 (fs-min 5) ; minimum font size
2424 cw-min
; minimum character width
2425 nb-cpl-max
; maximum nb of characters per line
2426 (fs-max 14) ; maximum font size
2427 cw-max
; maximum character width
2428 nb-cpl-min
; minimum nb of characters per line
2429 fs
; current font size
2430 cw
; current character width
2431 nb-cpl
; current nb of characters per line
2433 (setq cw-min
(/ (* icw fs-min
) ifs
)
2434 nb-cpl-max
(floor (/ print-width cw-min
))
2435 cw-max
(/ (* icw fs-max
) ifs
)
2436 nb-cpl-min
(floor (/ print-width cw-max
)))
2437 (setq nb-cpl nb-cpl-min
)
2439 (goto-char (point-max))
2440 (if (not (bolp)) (insert "\n"))
2442 (insert "nb char per line / font size\n")
2443 (while (<= nb-cpl nb-cpl-max
)
2444 (setq cw
(/ print-width
(float nb-cpl
))
2445 fs
(/ (* ifs cw
) icw
))
2446 (insert (format "%3s %s\n" nb-cpl fs
))
2447 (setq nb-cpl
(1+ nb-cpl
)))
2449 (display-buffer buf
'not-this-window
)))
2451 (defun ps-nb-pages (nb-lines)
2452 "Display an approximate correspondence between a font size and the number
2453 of pages the number of lines would require to print
2454 using the current ps-print setup."
2455 (let ((buf (get-buffer-create "*Nb-Pages*"))
2456 (ifs ps-font-size
) ; initial font size
2457 (ilh ps-line-height
) ; initial line height
2458 (page-height (progn (ps-get-page-dimensions)
2460 (ps-setup (ps-setup)) ; setup for the current buffer
2461 (fs-min 4) ; minimum font size
2462 lh-min
; minimum line height
2463 nb-lpp-max
; maximum nb of lines per page
2464 nb-page-min
; minimum nb of pages
2465 (fs-max 14) ; maximum font size
2466 lh-max
; maximum line height
2467 nb-lpp-min
; minimum nb of lines per page
2468 nb-page-max
; maximum nb of pages
2469 fs
; current font size
2470 lh
; current line height
2471 nb-lpp
; current nb of lines per page
2472 nb-page
; current nb of pages
2474 (setq lh-min
(/ (* ilh fs-min
) ifs
)
2475 nb-lpp-max
(floor (/ page-height lh-min
))
2476 nb-page-min
(ceiling (/ (float nb-lines
) nb-lpp-max
))
2477 lh-max
(/ (* ilh fs-max
) ifs
)
2478 nb-lpp-min
(floor (/ page-height lh-max
))
2479 nb-page-max
(ceiling (/ (float nb-lines
) nb-lpp-min
)))
2480 (setq nb-page nb-page-min
)
2482 (goto-char (point-max))
2483 (if (not (bolp)) (insert "\n"))
2485 (insert (format "%d lines\n" nb-lines
))
2486 (insert "nb page / font size\n")
2487 (while (<= nb-page nb-page-max
)
2488 (setq nb-lpp
(ceiling (/ nb-lines
(float nb-page
)))
2489 lh
(/ page-height nb-lpp
)
2490 fs
(/ (* ifs lh
) ilh
))
2491 (insert (format "%s %s\n" nb-page fs
))
2492 (setq nb-page
(1+ nb-page
)))
2494 (display-buffer buf
'not-this-window
)))
2496 (defun ps-select-font ()
2497 "Choose the font name and size (scaling data)."
2498 (let ((assoc (assq ps-font-family ps-font-info-database
))
2499 l fn fb fi bi sz lh sw aw
)
2501 (error "Don't have data to scale font %s. Known fonts families are %s"
2503 (mapcar 'car ps-font-info-database
)))
2505 fn
(prog1 (car l
) (setq l
(cdr l
))) ; need `pop'
2506 fb
(prog1 (car l
) (setq l
(cdr l
)))
2507 fi
(prog1 (car l
) (setq l
(cdr l
)))
2508 bi
(prog1 (car l
) (setq l
(cdr l
)))
2509 sz
(prog1 (car l
) (setq l
(cdr l
)))
2510 lh
(prog1 (car l
) (setq l
(cdr l
)))
2511 sw
(prog1 (car l
) (setq l
(cdr l
)))
2512 aw
(prog1 (car l
) (setq l
(cdr l
))))
2515 (setq ps-font-bold fb
)
2516 (setq ps-font-italic fi
)
2517 (setq ps-font-bold-italic bi
)
2518 ;; These data just need to be rescaled:
2519 (setq ps-line-height
(/ (* lh ps-font-size
) sz
))
2520 (setq ps-space-width
(/ (* sw ps-font-size
) sz
))
2521 (setq ps-avg-char-width
(/ (* aw ps-font-size
) sz
))
2524 (defun ps-select-header-font ()
2525 "Choose the font name and size (scaling data) for the header."
2526 (let ((assoc (assq ps-header-font-family ps-font-info-database
))
2527 l fn fb fi bi sz lh sw aw
)
2529 (error "Don't have data to scale font %s. Known fonts families are %s"
2531 (mapcar 'car ps-font-info-database
)))
2533 fn
(prog1 (car l
) (setq l
(cdr l
))) ; need `pop'
2534 fb
(prog1 (car l
) (setq l
(cdr l
)))
2535 fi
(prog1 (car l
) (setq l
(cdr l
)))
2536 bi
(prog1 (car l
) (setq l
(cdr l
)))
2537 sz
(prog1 (car l
) (setq l
(cdr l
)))
2538 lh
(prog1 (car l
) (setq l
(cdr l
)))
2539 sw
(prog1 (car l
) (setq l
(cdr l
)))
2540 aw
(prog1 (car l
) (setq l
(cdr l
))))
2543 (setq ps-header-font fn
)
2544 (setq ps-header-title-font fb
)
2545 ;; Line height: These data just need to be rescaled:
2546 (setq ps-header-title-line-height
(/ (* lh ps-header-title-font-size
) sz
))
2547 (setq ps-header-line-height
(/ (* lh ps-header-font-size
) sz
))
2548 ps-header-font-family
))
2550 (defun ps-get-page-dimensions ()
2551 (let ((page-dimensions (cdr (assq ps-paper-type ps-page-dimensions-database
)))
2552 page-width page-height
)
2554 ((null page-dimensions
)
2555 (error "`ps-paper-type' must be one of:\n%s"
2556 (mapcar 'car ps-page-dimensions-database
)))
2557 ((< ps-number-of-columns
1)
2558 (error "The number of columns %d should not be negative" ps-number-of-columns
)))
2561 (ps-select-header-font)
2563 (setq page-width
(ps-page-dimensions-get-width page-dimensions
)
2564 page-height
(ps-page-dimensions-get-height page-dimensions
))
2567 (if ps-landscape-mode
2568 ;; exchange width and height
2569 (setq page-width
(prog1 page-height
(setq page-height page-width
))))
2571 ;; It is used to get the lower right corner (only in landscape mode)
2572 (setq ps-landscape-page-height page-height
)
2574 ;; | lm | text | ic | text | ic | text | rm |
2575 ;; page-width == lm + n * pw + (n - 1) * ic + rm
2576 ;; => pw == (page-width - lm -rm - (n - 1) * ic) / n
2577 (setq ps-print-width
2579 ps-left-margin ps-right-margin
2580 (* (1- ps-number-of-columns
) ps-inter-column
))
2581 ps-number-of-columns
))
2582 (if (<= ps-print-width
0)
2583 (error "Bad horizontal layout:
2585 ps-left-margin == %s
2586 ps-right-margin == %s
2587 ps-inter-column == %s
2588 ps-number-of-columns == %s
2589 | lm | text | ic | text | ic | text | rm |
2590 page-width == lm + n * print-width + (n - 1) * ic + rm
2591 => print-width == %d !"
2596 ps-number-of-columns
2599 (setq ps-print-height
2600 (- page-height ps-bottom-margin ps-top-margin
))
2601 (if (<= ps-print-height
0)
2602 (error "Bad vertical layout:
2604 ps-bottom-margin == %s
2605 page-height == bm + print-height + tm
2606 => print-height == %d !"
2610 ;; If headers are turned on, deduct the height of the header from
2611 ;; the print height.
2615 (* ps-header-line-pad ps-header-title-line-height
))
2616 (setq ps-print-height
2620 ps-header-title-line-height
2621 (* ps-header-line-height
(- ps-header-lines
1))
2623 (if (<= ps-print-height
0)
2624 (error "Bad vertical layout:
2626 ps-bottom-margin == %s
2627 ps-header-offset == %s
2630 page-height == bm + print-height + tm - ho - hh
2631 => print-height == %d !"
2637 ps-header-title-line-height
2638 (* ps-header-line-height
(- ps-header-lines
1))
2642 (defun ps-print-preprint (&optional filename
)
2644 (or (numberp filename
)
2646 (let* ((name (concat (buffer-name) ".ps"))
2647 (prompt (format "Save PostScript to file: (default %s) "
2649 (res (read-file-name prompt default-directory name nil
)))
2650 (if (file-directory-p res
)
2651 (expand-file-name name
(file-name-as-directory res
))
2654 ;; The following functions implement a simple list-buffering scheme so
2655 ;; that ps-print doesn't have to repeatedly switch between buffers
2656 ;; while spooling. The functions ps-output and ps-output-string build
2657 ;; up the lists; the function ps-flush-output takes the lists and
2658 ;; insert its contents into the spool buffer (*PostScript*).
2660 (defun ps-output-string-prim (string)
2661 (insert "(") ;insert start-string delimiter
2662 (save-excursion ;insert string
2665 ;; Find and quote special characters as necessary for PS
2666 (while (re-search-forward "[()\\]" nil t
)
2671 (goto-char (point-max))
2672 (insert ")")) ;insert end-string delimiter
2674 (defun ps-init-output-queue ()
2675 (setq ps-output-head
(list ""))
2676 (setq ps-output-tail ps-output-head
))
2678 (defun ps-output (&rest args
)
2679 (setcdr ps-output-tail args
)
2680 (while (cdr ps-output-tail
)
2681 (setq ps-output-tail
(cdr ps-output-tail
))))
2683 (defun ps-output-string (string)
2684 (ps-output t string
))
2686 (defun ps-output-list (the-list)
2687 (mapcar 'ps-output the-list
))
2689 (defun ps-flush-output ()
2691 (set-buffer ps-spool-buffer
)
2692 (goto-char (point-max))
2693 (while ps-output-head
2694 (let ((it (car ps-output-head
)))
2697 (setq ps-output-head
(cdr ps-output-head
))
2698 (ps-output-string-prim (car ps-output-head
))))
2699 (setq ps-output-head
(cdr ps-output-head
))))
2700 (ps-init-output-queue))
2702 (defun ps-insert-file (fname)
2704 ;; Check to see that the file exists and is readable; if not, throw
2706 (or (file-readable-p fname
)
2707 (error "Could not read file `%s'" fname
))
2709 (set-buffer ps-spool-buffer
)
2710 (goto-char (point-max))
2711 (insert-file fname
)))
2713 ;; These functions insert the arrays that define the contents of the
2716 (defun ps-generate-header-line (fonttag &optional content
)
2717 (ps-output " [ " fonttag
" ")
2719 ;; Literal strings should be output as is -- the string must
2720 ;; contain its own PS string delimiters, '(' and ')', if necessary.
2722 (ps-output content
))
2724 ;; Functions are called -- they should return strings; they will be
2725 ;; inserted as strings and the PS string delimiters added.
2726 ((and (symbolp content
) (fboundp content
))
2727 (ps-output-string (funcall content
)))
2729 ;; Variables will have their contents inserted. They should
2730 ;; contain strings, and will be inserted as strings.
2731 ((and (symbolp content
) (boundp content
))
2732 (ps-output-string (symbol-value content
)))
2734 ;; Anything else will get turned into an empty string.
2736 (ps-output-string "")))
2739 (defun ps-generate-header (name contents
)
2740 (ps-output "/" name
" [\n")
2741 (if (> ps-header-lines
0)
2743 (ps-generate-header-line "/h0" (car contents
))
2744 (while (and (< count ps-header-lines
)
2745 (setq contents
(cdr contents
)))
2746 (ps-generate-header-line "/h1" (car contents
))
2747 (setq count
(+ count
1)))
2748 (ps-output "] def\n"))))
2750 (defun ps-output-boolean (name bool
)
2751 (ps-output (format "/%s %s def\n" name
(if bool
"true" "false"))))
2753 (defsubst ps-count-lines
(from to
)
2754 (+ (count-lines from to
)
2755 (save-excursion (goto-char to
)
2756 (if (= (current-column) 0) 1 0))))
2759 (defun ps-background-pages (page-list func
)
2763 (let ((start (if (consp pages
) (car pages
) pages
))
2764 (end (if (consp pages
) (cdr pages
) pages
)))
2765 (and (integerp start
) (integerp end
) (<= start end
)
2766 (add-to-list 'ps-background-pages
(vector start end func
)))))
2768 (setq ps-background-all-pages
(cons func ps-background-all-pages
))))
2771 (defun ps-get-boundingbox ()
2773 (set-buffer ps-spool-buffer
)
2775 (if (re-search-forward
2776 "^%%BoundingBox:\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)"
2778 (vector (string-to-number ; lower x
2779 (buffer-substring (match-beginning 1) (match-end 1)))
2780 (string-to-number ; lower y
2781 (buffer-substring (match-beginning 2) (match-end 2)))
2782 (string-to-number ; upper x
2783 (buffer-substring (match-beginning 3) (match-end 3)))
2784 (string-to-number ; upper y
2785 (buffer-substring (match-beginning 4) (match-end 4))))
2786 (vector 0 0 0 0)))))
2789 ;; Emacs understands the %f format; we'll use it to limit color RGB values
2790 ;; to three decimals to cut down some on the size of the PostScript output.
2791 ;; Lucid emacsen will have to make do with %s (princ) for floats.
2793 (defvar ps-float-format
(if (eq ps-print-emacs-type
'emacs
)
2795 "%s ")) ; Lucid emacsen
2798 (defun ps-float-format (value &optional default
)
2799 (let ((literal (or value default
)))
2801 (format (if (numberp literal
)
2808 (defun ps-background-text ()
2811 (setq ps-background-text-count
(1+ ps-background-text-count
))
2812 (ps-output (format "/ShowBackText-%d {\n" ps-background-text-count
))
2813 (ps-output-string (nth 0 text
)) ; text
2816 (ps-float-format (nth 4 text
) 200.0) ; font size
2817 (format "/%s " (or (nth 3 text
) "Times-Roman")) ; font name
2818 (ps-float-format (nth 6 text
)
2819 "PrintHeight PrintPageWidth atan") ; rotation
2820 (ps-float-format (nth 5 text
) 0.85) ; gray
2821 (ps-float-format (nth 1 text
) "0") ; x position
2822 (ps-float-format (nth 2 text
) "BottomMargin") ; y position
2823 "\nShowBackText} def\n")
2824 (ps-background-pages (nthcdr 7 text
) ; page list
2825 (format "ShowBackText-%d\n"
2826 ps-background-text-count
)))
2827 ps-print-background-text
))
2830 (defun ps-background-image ()
2833 (let ((image-file (expand-file-name (nth 0 image
))))
2834 (if (file-readable-p image-file
)
2836 (setq ps-background-image-count
(1+ ps-background-image-count
))
2838 (format "/ShowBackImage-%d {\n--back-- " ps-background-image-count
)
2839 (ps-float-format (nth 5 image
) 0.0) ; rotation
2840 (ps-float-format (nth 3 image
) 1.0) ; x scale
2841 (ps-float-format (nth 4 image
) 1.0) ; y scale
2842 (ps-float-format (nth 1 image
) ; x position
2843 "PrintPageWidth 2 div")
2844 (ps-float-format (nth 2 image
) ; y position
2845 "PrintHeight 2 div BottomMargin add")
2846 "\nBeginBackImage\n")
2847 (ps-insert-file image-file
)
2848 ;; coordinate adjustment to centralize image
2849 ;; around x and y position
2850 (let ((box (ps-get-boundingbox)))
2852 (set-buffer ps-spool-buffer
)
2854 (if (re-search-backward "^--back--" nil t
)
2858 (- (+ (/ (- (aref box
2) (aref box
0)) 2.0)
2861 (- (+ (/ (- (aref box
3) (aref box
1)) 2.0)
2864 (ps-output "\nEndBackImage} def\n")
2865 (ps-background-pages (nthcdr 6 image
) ; page list
2866 (format "ShowBackImage-%d\n"
2867 ps-background-image-count
))))))
2868 ps-print-background-image
))
2871 (defun ps-background ()
2872 (let (has-local-background)
2873 (mapcar '(lambda (range)
2874 (and (<= (aref range
0) ps-page-count
)
2875 (<= ps-page-count
(aref range
1))
2876 (if has-local-background
2877 (ps-output (aref range
2))
2878 (setq has-local-background t
)
2879 (ps-output "/printLocalBackground {\n"
2881 ps-background-pages
)
2882 (and has-local-background
(ps-output "} def\n"))))
2885 (defun ps-begin-file ()
2886 (ps-get-page-dimensions)
2887 (setq ps-showpage-count
0
2889 ps-background-text-count
0
2890 ps-background-image-count
0
2891 ps-background-pages nil
2892 ps-background-all-pages nil
)
2894 (ps-output ps-adobe-tag
)
2895 (ps-output "%%Title: " (buffer-name)) ;Take job name from name of
2896 ;first buffer printed
2897 (ps-output "\n%%Creator: " (user-full-name))
2898 (ps-output "\n%%CreationDate: "
2899 (time-stamp-hh:mm
:ss
) " " (time-stamp-mon-dd-yyyy)
2901 (if ps-landscape-mode
"Landscape" "Portrait"))
2902 (ps-output "\n%% DocumentFonts: Times-Roman Times-Italic "
2903 ps-font
" " ps-font-bold
" " ps-font-italic
" "
2904 ps-font-bold-italic
" "
2905 ps-header-font
" " ps-header-title-font
)
2906 (ps-output "\n%%Pages: (atend)\n")
2907 (ps-output "%%EndComments\n\n")
2909 (ps-output-boolean "LandscapeMode" ps-landscape-mode
)
2910 (ps-output (format "/NumberOfColumns %d def\n" ps-number-of-columns
))
2912 (ps-output (format "/LandscapePageHeight %s def\n" ps-landscape-page-height
))
2913 (ps-output (format "/PrintPageWidth %s def\n"
2914 (- (* (+ ps-print-width ps-inter-column
)
2915 ps-number-of-columns
)
2917 (ps-output (format "/PrintWidth %s def\n" ps-print-width
))
2918 (ps-output (format "/PrintHeight %s def\n" ps-print-height
))
2920 (ps-output (format "/LeftMargin %s def\n" ps-left-margin
))
2921 (ps-output (format "/RightMargin %s def\n" ps-right-margin
)) ; not used
2922 (ps-output (format "/InterColumn %s def\n" ps-inter-column
))
2924 (ps-output (format "/BottomMargin %s def\n" ps-bottom-margin
))
2925 (ps-output (format "/TopMargin %s def\n" ps-top-margin
)) ; not used
2926 (ps-output (format "/HeaderOffset %s def\n" ps-header-offset
))
2927 (ps-output (format "/HeaderPad %s def\n" ps-header-pad
))
2929 (ps-output-boolean "PrintHeader" ps-print-header
)
2930 (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame
)
2931 (ps-output-boolean "ShowNofN" ps-show-n-of-n
)
2932 (ps-output-boolean "Duplex" ps-spool-duplex
)
2934 (ps-output (format "/LineHeight %s def\n" ps-line-height
)
2935 (format "/LinesPerColumn %d def\n"
2936 (round (/ (+ (if ps-print-header
2937 (- ps-print-height
(ps-header-height))
2939 (* ps-line-height
0.45))
2942 (ps-output-boolean "Zebra" ps-zebra-stripes
)
2943 (ps-output (format "/NumberOfZebra %d def\n" ps-zebra-stripe-height
))
2945 (ps-output-boolean "PrintLineNumber" ps-line-number
)
2946 (ps-output (format "/Lines %d def\n" (ps-count-lines (point-min) (point-max))))
2948 (ps-background-text)
2949 (ps-background-image)
2950 (setq ps-background-all-pages
(nreverse ps-background-all-pages
)
2951 ps-background-pages
(nreverse ps-background-pages
))
2953 (ps-output ps-print-prologue-1
)
2955 (ps-output "/printGlobalBackground {\n")
2956 (ps-output-list ps-background-all-pages
)
2957 (ps-output "} def\n/printLocalBackground {\n} def\n")
2960 (ps-output ; /h0 14 /Helvetica-Bold Font
2961 (format "/h0 %s /%s DefFont\n" ps-header-title-font-size ps-header-title-font
))
2962 (ps-output ; /h1 12 /Helvetica Font
2963 (format "/h1 %s /%s DefFont\n" ps-header-font-size ps-header-font
))
2965 (ps-output ps-print-prologue-2
)
2968 (ps-output (format "/f0 %s /%s DefFont\n" ps-font-size ps-font
))
2969 (ps-output (format "/f1 %s /%s DefFont\n" ps-font-size ps-font-bold
))
2970 (ps-output (format "/f2 %s /%s DefFont\n" ps-font-size ps-font-italic
))
2971 (ps-output (format "/f3 %s /%s DefFont\n" ps-font-size ps-font-bold-italic
))
2973 (ps-output "\nBeginDoc\n\n")
2974 (ps-output "%%EndPrologue\n"))
2976 (defun ps-header-dirpart ()
2977 (let ((fname (buffer-file-name)))
2979 (if (string-equal (buffer-name) (file-name-nondirectory fname
))
2980 (file-name-directory fname
)
2984 (defun ps-get-buffer-name ()
2986 ;; Indulge Jim this little easter egg:
2987 ((string= (buffer-name) "ps-print.el")
2988 "Hey, Cool! It's ps-print.el!!!")
2989 ;; Indulge Jack this other little easter egg:
2990 ((string= (buffer-name) "sokoban.el")
2991 "Super! C'est sokoban.el!")
2994 (and (buffer-modified-p) " (unsaved)")))))
2996 (defun ps-begin-job ()
2997 (setq ps-page-count
0))
2999 (defun ps-end-file ()
3000 (ps-output "\n%%Trailer\n")
3001 (ps-output (format "%%%%Pages: %d\n" (1+ (/ (1- ps-page-count
)
3002 ps-number-of-columns
))))
3003 (ps-output "\nEndDoc\n\n%%EOF\n"))
3006 (defun ps-header-height ()
3007 (+ ps-header-title-line-height
3008 (* ps-header-line-height
(1- ps-header-lines
))
3009 (* 2 ps-header-pad
)))
3012 (defun ps-next-page ()
3017 (defun ps-begin-page (&optional dummypage
)
3018 (ps-get-page-dimensions)
3019 (setq ps-width-remaining ps-print-width
)
3020 (setq ps-height-remaining ps-print-height
)
3022 ;; Print only when a new real page begins.
3023 (when (zerop (mod ps-page-count ps-number-of-columns
))
3024 (ps-output (format "\n%%%%Page: %d %d\n"
3025 (1+ (/ ps-page-count ps-number-of-columns
))
3026 (1+ (/ ps-page-count ps-number-of-columns
)))))
3028 (ps-output "BeginDSCPage\n")
3029 (ps-output (format "/LineNumber %d def\n" ps-showline-count
)
3030 (format "/PageNumber %d def\n" (incf ps-page-count
)))
3031 (ps-output "/PageCount 0 def\n")
3033 (when ps-print-header
3034 (ps-generate-header "HeaderLinesLeft" ps-left-header
)
3035 (ps-generate-header "HeaderLinesRight" ps-right-header
)
3036 (ps-output (format "%d SetHeaderLines\n" ps-header-lines
)))
3040 (ps-output "BeginPage\n")
3041 (ps-set-font ps-current-font
)
3042 (ps-set-bg ps-current-bg
)
3043 (ps-set-color ps-current-color
))
3045 (defun ps-end-page ()
3046 (setq ps-showpage-count
(+ 1 ps-showpage-count
))
3047 (ps-output "EndPage\n")
3048 (ps-output "EndDSCPage\n"))
3050 (defun ps-dummy-page ()
3051 (setq ps-showpage-count
(+ 1 ps-showpage-count
))
3052 (ps-output "%%Page: " (format "- %d\n" ps-showpage-count
)
3054 /PrintHeader false def
3059 (defun ps-next-line ()
3060 (setq ps-showline-count
(1+ ps-showline-count
))
3061 (if (< ps-height-remaining ps-line-height
)
3063 (setq ps-width-remaining ps-print-width
)
3064 (setq ps-height-remaining
(- ps-height-remaining ps-line-height
))
3067 (defun ps-continue-line ()
3068 (if (< ps-height-remaining ps-line-height
)
3070 (setq ps-width-remaining ps-print-width
)
3071 (setq ps-height-remaining
(- ps-height-remaining ps-line-height
))
3074 ;; [jack] Why hard and soft ?
3076 (defun ps-hard-lf ()
3079 (defun ps-soft-lf ()
3082 (defun ps-find-wrappoint (from to char-width
)
3083 (let ((avail (truncate (/ ps-width-remaining char-width
)))
3086 (cons to
(* todo char-width
))
3087 (cons (+ from avail
) ps-width-remaining
))))
3089 (defun ps-basic-plot-string (from to
&optional bg-color
)
3090 (let* ((wrappoint (ps-find-wrappoint from to ps-avg-char-width
))
3091 (to (car wrappoint
))
3092 (string (buffer-substring-no-properties from to
)))
3093 (ps-output-string string
)
3097 (defun ps-basic-plot-whitespace (from to
&optional bg-color
)
3098 (let* ((wrappoint (ps-find-wrappoint from to ps-space-width
))
3099 (to (car wrappoint
)))
3100 (ps-output (format "%d W\n" (- to from
)))
3103 (defun ps-plot (plotfunc from to
&optional bg-color
)
3105 (let* ((wrappoint (funcall plotfunc from to bg-color
))
3106 (plotted-to (car wrappoint
))
3107 (plotted-width (cdr wrappoint
)))
3108 (setq from plotted-to
)
3109 (setq ps-width-remaining
(- ps-width-remaining plotted-width
))
3111 (ps-continue-line))))
3112 (if ps-razzle-dazzle
3113 (let* ((q-todo (- (point-max) (point-min)))
3114 (q-done (- (point) (point-min)))
3115 (chunkfrac (/ q-todo
8))
3116 (chunksize (if (> chunkfrac
1000) 1000 chunkfrac
)))
3117 (if (> (- q-done ps-razchunk
) chunksize
)
3119 (setq ps-razchunk q-done
)
3122 (/ (* 100 q-done
) q-todo
)
3123 (/ q-done
(/ q-todo
100))))
3124 (message "Formatting...%3d%%" foo
))))))
3126 (defun ps-set-font (font)
3127 (setq ps-current-font font
)
3128 (ps-output (format "/f%d F\n" ps-current-font
)))
3130 (defun ps-set-bg (color)
3131 (if (setq ps-current-bg color
)
3132 (ps-output (format ps-color-format
(nth 0 color
) (nth 1 color
)
3135 (ps-output "false BG\n")))
3137 (defun ps-set-color (color)
3138 (if (setq ps-current-color color
)
3140 (setq ps-current-color ps-default-fg
))
3141 (ps-output (format ps-color-format
(nth 0 ps-current-color
)
3142 (nth 1 ps-current-color
) (nth 2 ps-current-color
))
3146 (defvar ps-current-effect
0)
3149 (defun ps-plot-region (from to font
&optional fg-color bg-color effects
)
3150 (if (not (equal font ps-current-font
))
3153 ;; Specify a foreground color only if one's specified and it's
3154 ;; different than the current.
3155 (if (not (equal fg-color ps-current-color
))
3156 (ps-set-color fg-color
))
3158 (if (not (equal bg-color ps-current-bg
))
3159 (ps-set-bg bg-color
))
3161 ;; Specify effects (underline, overline, box, etc)
3163 ((not (integerp effects
))
3164 (ps-output "0 EF\n")
3165 (setq ps-current-effect
0))
3166 ((/= effects ps-current-effect
)
3167 (ps-output (number-to-string effects
) " EF\n")
3168 (setq ps-current-effect effects
)))
3170 ;; Starting at the beginning of the specified region...
3174 ;; ...break the region up into chunks separated by tabs, linefeeds,
3175 ;; pagefeeds, control characters, and plot each chunk.
3177 (if (re-search-forward "[\000-\037\177-\377]" to t
)
3178 ;; region whith some control characters
3179 (let ((match (char-after (match-beginning 0))))
3180 (if (= match ?
\t) ; tab
3182 (save-excursion (beginning-of-line) (point))))
3183 (ps-plot 'ps-basic-plot-string from
(- (point) 1)
3186 (setq from
(+ linestart
(current-column)))
3187 (if (re-search-forward "[ \t]+" to t
)
3188 (ps-plot 'ps-basic-plot-whitespace
3189 from
(+ linestart
(current-column))
3191 ;; any other control character except tab
3192 (ps-plot 'ps-basic-plot-string from
(- (point) 1) bg-color
)
3194 ((= match ?
\n) ; newline
3197 ((= match ?
\f) ; form feed
3200 ((<= match ?
\037) ; characters from ^@ to ^_
3201 (ps-control-character (format "^%c" (+ match ?
@))))
3203 ((= match ?
\177) ; del (127) is printed ^?
3204 (ps-control-character "^?"))
3206 (t ; characters from 128 to 255
3207 (ps-control-character (format "\\%o" match
)))))
3208 (setq from
(point)))
3209 ;; region without control characters
3210 (ps-plot 'ps-basic-plot-string from to bg-color
)
3213 (defun ps-control-character (str)
3214 (let* ((from (1- (point)))
3217 (wrappoint (ps-find-wrappoint from to ps-avg-char-width
)))
3218 (if (< (car wrappoint
) to
)
3220 (setq ps-width-remaining
(- ps-width-remaining
(* len ps-avg-char-width
)))
3221 (ps-output-string str
)
3222 (ps-output " S\n")))
3224 (defun ps-color-value (x-color-value)
3225 ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
3226 (/ x-color-value ps-print-color-scale
))
3228 (defun ps-color-values (x-color)
3229 (cond ((fboundp 'x-color-values
)
3230 (x-color-values x-color
))
3231 ((fboundp 'pixel-components
)
3232 (pixel-components x-color
))
3233 (t (error "No available function to determine X color values."))))
3236 (defun ps-get-face (face)
3237 "Return face description on `ps-print-face-extension-alist'.
3239 If FACE is not in `ps-print-face-extension-alist',
3240 insert it and return the description.
3242 If FACE is not a valid face name, it is used default face."
3243 (or (assq face ps-print-face-extension-alist
)
3244 (let* ((the-face (if (facep face
) face
'default
))
3245 (font (face-font the-face t
))
3249 (logior (if (memq 'bold font
) 1 0)
3250 (if (memq 'italic font
) 2 0)
3251 (if (face-underline-p the-face
) 4 0))
3252 (face-foreground the-face
)
3253 (face-background the-face
)))))
3254 (or (and (eq the-face
'default
)
3255 (assq the-face ps-print-face-extension-alist
))
3256 (setq ps-print-face-extension-alist
3258 ps-print-face-extension-alist
)))
3262 (defun ps-face-attributes (face)
3263 (let* ((face-vector (cdr (ps-get-face face
)))
3264 (effects (logior (aref face-vector
0)
3265 (if (memq face ps-ref-bold-faces
) 1 0)
3266 (if (memq face ps-ref-italic-faces
) 2 0)
3267 (if (memq face ps-ref-underlined-faces
) 4 0))))
3268 (vector effects
(aref face-vector
1) (aref face-vector
2))))
3271 (defun ps-face-attribute-list (face-or-list)
3272 (if (listp face-or-list
)
3274 (let ((effects 0) foreground background face-attr face
)
3276 (setq face
(car face-or-list
)
3277 face-attr
(ps-face-attributes face
)
3278 effects
(logior effects
(aref face-attr
0)))
3279 (or foreground
(setq foreground
(aref face-attr
1)))
3280 (or background
(setq background
(aref face-attr
2)))
3281 (setq face-or-list
(cdr face-or-list
)))
3282 (vector effects foreground background
))
3284 (ps-face-attributes face-or-list
)))
3287 (defun ps-plot-with-face (from to face
)
3289 (let* ((face-bit (ps-face-attribute-list face
))
3290 (effect (aref face-bit
0))
3291 (foreground (aref face-bit
1))
3292 (background (aref face-bit
2))
3293 (fg-color (if (and ps-print-color-p foreground
)
3294 (mapcar 'ps-color-value
3295 (ps-color-values foreground
))
3297 (bg-color (if (and ps-print-color-p background
)
3298 (mapcar 'ps-color-value
3299 (ps-color-values background
)))))
3300 (ps-plot-region from to
(logand effect
3)
3301 fg-color bg-color
(lsh effect -
2)))
3302 (ps-plot-region from to
0))
3306 (defun ps-emacs-face-kind-p (face kind kind-regex kind-list
)
3307 (let ((frame-font (face-font face
))
3308 (face-defaults (face-font face t
)))
3310 ;; Check FACE defaults:
3311 (and (listp face-defaults
)
3312 (memq kind face-defaults
))
3313 ;; Check the user's preferences
3314 (memq face kind-list
))))
3316 (defun ps-xemacs-face-kind-p (face kind kind-regex kind-list
)
3317 (let* ((frame-font (or (face-font face
) (face-font 'default
)))
3318 (kind-cons (assq kind
(x-font-properties frame-font
)))
3319 (kind-spec (cdr-safe kind-cons
))
3320 (case-fold-search t
))
3322 (or (and kind-spec
(string-match kind-regex kind-spec
))
3323 ;; Kludge-compatible:
3324 (memq face kind-list
))))
3326 (defun ps-face-bold-p (face)
3327 (if (eq ps-print-emacs-type
'emacs
)
3328 (ps-emacs-face-kind-p face
'bold
"-\\(bold\\|demibold\\)-"
3330 (ps-xemacs-face-kind-p face
'WEIGHT_NAME
"bold\\|demibold"
3333 (defun ps-face-italic-p (face)
3334 (if (eq ps-print-emacs-type
'emacs
)
3335 (ps-emacs-face-kind-p face
'italic
"-[io]-" ps-italic-faces
)
3337 (ps-xemacs-face-kind-p face
'ANGLE_NAME
"i\\|o" ps-italic-faces
)
3338 (ps-xemacs-face-kind-p face
'SLANT
"i\\|o" ps-italic-faces
))))
3340 (defun ps-face-underlined-p (face)
3341 (or (face-underline-p face
)
3342 (memq face ps-underlined-faces
)))
3344 ;; Ensure that face-list is fbound.
3345 (or (fboundp 'face-list
) (defalias 'face-list
'list-faces
))
3347 (defun ps-build-reference-face-lists ()
3348 (if ps-auto-font-detect
3349 (let ((faces (face-list))
3351 (setq ps-ref-bold-faces nil
3352 ps-ref-italic-faces nil
3353 ps-ref-underlined-faces nil
)
3355 (setq the-face
(car faces
))
3356 (if (ps-face-italic-p the-face
)
3357 (setq ps-ref-italic-faces
3358 (cons the-face ps-ref-italic-faces
)))
3359 (if (ps-face-bold-p the-face
)
3360 (setq ps-ref-bold-faces
3361 (cons the-face ps-ref-bold-faces
)))
3362 (if (ps-face-underlined-p the-face
)
3363 (setq ps-ref-underlined-faces
3364 (cons the-face ps-ref-underlined-faces
)))
3365 (setq faces
(cdr faces
))))
3366 (setq ps-ref-bold-faces ps-bold-faces
)
3367 (setq ps-ref-italic-faces ps-italic-faces
)
3368 (setq ps-ref-underlined-faces ps-underlined-faces
))
3369 (setq ps-build-face-reference nil
))
3371 (defun ps-mapper (extent list
)
3372 (nconc list
(list (list (extent-start-position extent
) 'push extent
)
3373 (list (extent-end-position extent
) 'pull extent
)))
3376 (defun ps-extent-sorter (a b
)
3377 (< (extent-priority a
) (extent-priority b
)))
3379 (defun ps-print-ensure-fontified (start end
)
3380 (if (and (boundp 'lazy-lock-mode
) lazy-lock-mode
)
3381 (if (fboundp 'lazy-lock-fontify-region
)
3382 (lazy-lock-fontify-region start end
) ; the new
3383 (lazy-lock-fontify-buffer)))) ; the old
3385 (defun ps-generate-postscript-with-faces (from to
)
3386 ;; Some initialization...
3387 (setq ps-current-effect
0)
3389 ;; Build the reference lists of faces if necessary.
3390 (if (or ps-always-build-face-reference
3391 ps-build-face-reference
)
3393 (message "Collecting face information...")
3394 (ps-build-reference-face-lists)))
3395 ;; Set the color scale. We do it here instead of in the defvar so
3396 ;; that ps-print can be dumped into emacs. This expression can't be
3397 ;; evaluated at dump-time because X isn't initialized.
3398 (setq ps-print-color-scale
3399 (if ps-print-color-p
3400 (float (car (ps-color-values "white")))
3402 ;; Generate some PostScript.
3404 (narrow-to-region from to
)
3405 (let ((face 'default
)
3407 (ps-print-ensure-fontified from to
)
3409 ((or (eq ps-print-emacs-type
'lucid
)
3410 (eq ps-print-emacs-type
'xemacs
))
3411 ;; Build the list of extents...
3412 (let ((a (cons 'dummy nil
))
3413 record type extent extent-list
)
3414 (map-extents 'ps-mapper nil from to a
)
3415 (setq a
(sort (cdr a
) 'car-less-than-car
))
3417 (setq extent-list nil
)
3419 ;; Loop through the extents...
3421 (setq record
(car a
))
3423 (setq position
(car record
))
3424 (setq record
(cdr record
))
3426 (setq type
(car record
))
3427 (setq record
(cdr record
))
3429 (setq extent
(car record
))
3431 ;; Plot up to this record.
3432 ;; XEmacs 19.12: for some reason, we're getting into a
3433 ;; situation in which some of the records have
3434 ;; positions less than 'from'. Since we've narrowed
3435 ;; the buffer, this'll generate errors. This is a
3436 ;; hack, but don't call ps-plot-with-face unless from >
3438 (if (and (>= from
(point-min))
3439 (<= position
(point-max)))
3440 (ps-plot-with-face from position face
))
3444 (if (extent-face extent
)
3445 (setq extent-list
(sort (cons extent extent-list
)
3446 'ps-extent-sorter
))))
3449 (setq extent-list
(sort (delq extent extent-list
)
3450 'ps-extent-sorter
))))
3454 (extent-face (car extent-list
))
3457 (setq from position
)
3460 ((eq ps-print-emacs-type
'emacs
)
3461 (let ((property-change from
)
3462 (overlay-change from
))
3464 (if (< property-change to
) ; Don't search for property change
3465 ; unless previous search succeeded.
3466 (setq property-change
3467 (next-property-change from nil to
)))
3468 (if (< overlay-change to
) ; Don't search for overlay change
3469 ; unless previous search succeeded.
3470 (setq overlay-change
3471 (min (next-overlay-change from
) to
)))
3473 (min property-change overlay-change
))
3474 ;; The code below is not quite correct,
3475 ;; because a non-nil overlay invisible property
3476 ;; which is inactive according to the current value
3477 ;; of buffer-invisibility-spec nonetheless overrides
3478 ;; a face text property.
3480 (cond ((let ((prop (get-text-property from
'invisible
)))
3481 ;; Decide whether this invisible property
3482 ;; really makes the text invisible.
3483 (if (eq buffer-invisibility-spec t
)
3485 (or (memq prop buffer-invisibility-spec
)
3486 (assq prop buffer-invisibility-spec
))))
3488 ((get-text-property from
'face
))
3490 (let ((overlays (overlays-at from
))
3491 (face-priority -
1)) ; text-property
3493 (let* ((overlay (car overlays
))
3494 (overlay-face (overlay-get overlay
'face
))
3495 (overlay-invisible (overlay-get overlay
'invisible
))
3496 (overlay-priority (or (overlay-get overlay
3499 (if (and (or overlay-invisible overlay-face
)
3500 (> overlay-priority face-priority
))
3501 (setq face
(cond ((if (eq buffer-invisibility-spec t
)
3502 (not (null overlay-invisible
))
3503 (or (memq overlay-invisible
3504 buffer-invisibility-spec
)
3505 (assq overlay-invisible
3506 buffer-invisibility-spec
)))
3508 ((and face overlay-face
)))
3509 face-priority overlay-priority
)))
3510 (setq overlays
(cdr overlays
))))
3511 ;; Plot up to this record.
3512 (ps-plot-with-face from position face
)
3513 (setq from position
)))))
3514 (ps-plot-with-face from to face
))))
3516 (defun ps-generate-postscript (from to
)
3517 (ps-plot-region from to
0 nil
))
3519 (defun ps-generate (buffer from to genfunc
)
3521 (let ((from (min to from
))
3523 ;; This avoids trouble if chars with read-only properties
3524 ;; are copied into ps-spool-buffer.
3525 (inhibit-read-only t
))
3527 (narrow-to-region from to
)
3528 (if ps-razzle-dazzle
3529 (message "Formatting...%3d%%" (setq ps-razchunk
0)))
3531 (setq ps-source-buffer buffer
)
3532 (setq ps-spool-buffer
(get-buffer-create ps-spool-buffer-name
))
3533 (ps-init-output-queue)
3534 (let (safe-marker completed-safely needs-begin-file
)
3537 (set-buffer ps-spool-buffer
)
3539 ;; Get a marker and make it point to the current end of the
3540 ;; buffer, If an error occurs, we'll delete everything from
3541 ;; the end of this marker onwards.
3542 (setq safe-marker
(make-marker))
3543 (set-marker safe-marker
(point-max))
3545 (goto-char (point-min))
3546 (if (looking-at (regexp-quote ps-adobe-tag
))
3548 (setq needs-begin-file t
))
3550 (set-buffer ps-source-buffer
)
3551 (if needs-begin-file
(ps-begin-file))
3554 (set-buffer ps-source-buffer
)
3555 (funcall genfunc from to
)
3558 (if (and ps-spool-duplex
3559 (= (mod ps-page-count
2) 1))
3563 ;; Back to the PS output buffer to set the page count
3564 (set-buffer ps-spool-buffer
)
3565 (goto-char (point-max))
3566 (while (re-search-backward "^/PageCount 0 def$" nil t
)
3567 (replace-match (format "/PageCount %d def" ps-page-count
) t
))
3569 ;; Setting this variable tells the unwind form that the
3570 ;; the postscript was generated without error.
3571 (setq completed-safely t
))
3573 ;; Unwind form: If some bad mojo occurred while generating
3574 ;; postscript, delete all the postscript that was generated.
3575 ;; This protects the previously spooled files from getting
3577 (if (and (markerp safe-marker
) (not completed-safely
))
3579 (set-buffer ps-spool-buffer
)
3580 (delete-region (marker-position safe-marker
) (point-max))))))
3582 (if ps-razzle-dazzle
3583 (message "Formatting...done"))))))
3585 (defun ps-do-despool (filename)
3586 (if (or (not (boundp 'ps-spool-buffer
))
3587 (not (symbol-value 'ps-spool-buffer
)))
3588 (message "No spooled PostScript to print")
3593 (if ps-razzle-dazzle
3594 (message "Saving..."))
3595 (set-buffer ps-spool-buffer
)
3596 (setq filename
(expand-file-name filename
))
3597 (write-region (point-min) (point-max) filename
)
3598 (if ps-razzle-dazzle
3599 (message "Wrote %s" filename
)))
3600 ;; Else, spool to the printer
3601 (if ps-razzle-dazzle
3602 (message "Printing..."))
3604 (set-buffer ps-spool-buffer
)
3605 (if (and (eq system-type
'ms-dos
)
3606 (stringp (symbol-value 'dos-ps-printer
)))
3607 (write-region (point-min) (point-max)
3608 (symbol-value 'dos-ps-printer
) t
0)
3609 (let ((binary-process-input t
)) ; for MS-DOS
3610 (apply 'call-process-region
3611 (point-min) (point-max) ps-lpr-command nil
3612 (if (fboundp 'start-process
) 0 nil
)
3615 (if ps-razzle-dazzle
3616 (message "Printing...done")))
3617 (kill-buffer ps-spool-buffer
)))
3619 (defun ps-kill-emacs-check ()
3621 (if (and (setq ps-buffer
(get-buffer ps-spool-buffer-name
))
3622 (buffer-modified-p ps-buffer
))
3623 (if (y-or-n-p "Unprinted PostScript waiting; print now? ")
3625 (if (and (setq ps-buffer
(get-buffer ps-spool-buffer-name
))
3626 (buffer-modified-p ps-buffer
))
3627 (if (yes-or-no-p "Unprinted PostScript waiting; exit anyway? ")
3629 (error "Unprinted PostScript")))))
3631 (if (fboundp 'add-hook
)
3632 (funcall 'add-hook
'kill-emacs-hook
'ps-kill-emacs-check
)
3634 (message "Won't override existing kill-emacs-hook")
3635 (setq kill-emacs-hook
'ps-kill-emacs-check
)))
3637 ;;; Sample Setup Code:
3639 ;; This stuff is for anybody that's brave enough to look this far,
3640 ;; and able to figure out how to use it. It isn't really part of
3641 ;; ps-print, but I'll leave it here in hopes it might be useful:
3643 ;; WARNING!!! The following code is *sample* code only. Don't use it
3644 ;; unless you understand what it does!
3646 (defmacro ps-prsc
()
3647 `(if (eq ps-print-emacs-type
'emacs
) [f22] 'f22))
3648 (defmacro ps-c-prsc ()
3649 `(if (eq ps-print-emacs-type 'emacs) [C-f22] '(control f22)))
3650 (defmacro ps-s-prsc ()
3651 `(if (eq ps-print-emacs-type 'emacs) [S-f22] '(shift f22)))
3653 ;; Look in an article or mail message for the Subject: line. To be
3654 ;; placed in `ps-left-headers'.
3655 (defun ps-article-subject ()
3657 (goto-char (point-min))
3658 (if (re-search-forward "^Subject:[ \t]+\\(.*\\)$" nil t)
3659 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
3662 ;; Look in an article or mail message for the From: line. Sorta-kinda
3663 ;; understands RFC-822 addresses and can pull the real name out where
3664 ;; it's provided. To be placed in `ps-left-headers'.
3665 (defun ps-article-author ()
3667 (goto-char (point-min))
3668 (if (re-search-forward "^From:[ \t]+\\(.*\\)$" nil t)
3669 (let ((fromstring (buffer-substring-no-properties (match-beginning 1)
3673 ;; Try first to match addresses that look like
3674 ;; thompson@wg2.waii.com (Jim Thompson)
3675 ((string-match ".*[ \t]+(\\(.*\\))" fromstring)
3676 (substring fromstring (match-beginning 1) (match-end 1)))
3678 ;; Next try to match addresses that look like
3679 ;; Jim Thompson <thompson@wg2.waii.com>
3680 ((string-match "\\(.*\\)[ \t]+<.*>" fromstring)
3681 (substring fromstring (match-beginning 1) (match-end 1)))
3683 ;; Couldn't find a real name -- show the address instead.
3687 ;; A hook to bind to gnus-Article-prepare-hook. This will set the
3688 ;; `ps-left-headers' specially for gnus articles. Unfortunately,
3689 ;; `gnus-article-mode-hook' is called only once, the first time the *Article*
3690 ;; buffer enters that mode, so it would only work for the first time
3691 ;; we ran gnus. The second time, this hook wouldn't get set up. The
3692 ;; only alternative is `gnus-article-prepare-hook'.
3693 (defun ps-gnus-article-prepare-hook ()
3694 (setq ps-header-lines 3)
3695 (setq ps-left-header
3696 ;; The left headers will display the article's subject, its
3697 ;; author, and the newsgroup it was in.
3698 (list 'ps-article-subject 'ps-article-author 'gnus-newsgroup-name)))
3700 ;; A hook to bind to vm-mode-hook to locally bind prsc and set the
3701 ;; ps-left-headers specially for mail messages. This header setup would
3702 ;; also work, I think, for RMAIL.
3703 (defun ps-vm-mode-hook ()
3704 (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary)
3705 (setq ps-header-lines 3)
3706 (setq ps-left-header
3707 ;; The left headers will display the message's subject, its
3708 ;; author, and the name of the folder it was in.
3709 (list 'ps-article-subject 'ps-article-author 'buffer-name)))
3711 ;; Every now and then I forget to switch from the *Summary* buffer to
3712 ;; the *Article* before hitting prsc, and a nicely formatted list of
3713 ;; article subjects shows up at the printer. This function, bound to
3714 ;; prsc for the gnus *Summary* buffer means I don't have to switch
3716 ;; sb: Updated for Gnus 5.
3717 (defun ps-gnus-print-article-from-summary ()
3719 (let ((ps-buf (or (and (boundp 'gnus-article-buffer)
3720 (symbol-value 'gnus-article-buffer))
3722 (if (get-buffer ps-buf)
3725 (ps-spool-buffer-with-faces)))))
3727 ;; See `ps-gnus-print-article-from-summary'. This function does the
3728 ;; same thing for vm.
3729 (defun ps-vm-print-message-from-summary ()
3731 (if (and (boundp 'vm-mail-buffer) (symbol-value 'vm-mail-buffer))
3733 (set-buffer (symbol-value 'vm-mail-buffer))
3734 (ps-spool-buffer-with-faces))))
3736 ;; A hook to bind to bind to `gnus-summary-setup-buffer' to locally bind
3738 (defun ps-gnus-summary-setup ()
3739 (local-set-key (ps-prsc) 'ps-gnus-print-article-from-summary))
3741 ;; Look in an article or mail message for the Subject: line. To be
3742 ;; placed in `ps-left-headers'.
3743 (defun ps-info-file ()
3745 (goto-char (point-min))
3746 (if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)" nil t)
3747 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
3750 ;; Look in an article or mail message for the Subject: line. To be
3751 ;; placed in `ps-left-headers'.
3752 (defun ps-info-node ()
3754 (goto-char (point-min))
3755 (if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)" nil t)
3756 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
3759 (defun ps-info-mode-hook ()
3760 (setq ps-left-header
3761 ;; The left headers will display the node name and file name.
3762 (list 'ps-info-node 'ps-info-file)))
3764 ;; WARNING! The following function is a *sample* only, and is *not*
3765 ;; meant to be used as a whole unless you understand what the effects
3766 ;; will be! (In fact, this is a copy of Jim's setup for ps-print --
3767 ;; I'd be very surprised if it was useful to *anybody*, without
3770 (defun ps-jts-ps-setup ()
3771 (global-set-key (ps-prsc) 'ps-spool-buffer-with-faces) ;f22 is prsc
3772 (global-set-key (ps-s-prsc) 'ps-spool-region-with-faces)
3773 (global-set-key (ps-c-prsc) 'ps-despool)
3774 (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook)
3775 (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup)
3776 (add-hook 'vm-mode-hook 'ps-vm-mode-hook)
3777 (add-hook 'vm-mode-hooks 'ps-vm-mode-hook)
3778 (add-hook 'Info-mode-hook 'ps-info-mode-hook)
3779 (setq ps-spool-duplex t)
3780 (setq ps-print-color-p nil)
3781 (setq ps-lpr-command "lpr")
3782 (setq ps-lpr-switches '("-Jjct,duplex_long"))
3785 ;; WARNING! The following function is a *sample* only, and is *not*
3786 ;; meant to be used as a whole unless it corresponds to your needs.
3787 ;; (In fact, this is a copy of Jack's setup for ps-print --
3788 ;; I would not be that surprised if it was useful to *anybody*,
3789 ;; without modification.)
3791 (defun ps-jack-setup ()
3792 (setq ps-print-color-p nil
3793 ps-lpr-command "lpr"
3794 ps-lpr-switches (list)
3798 ps-number-of-columns 2
3800 ps-left-margin (/ (* 72 1.0) 2.54) ; 1.0 cm
3801 ps-right-margin (/ (* 72 1.0) 2.54) ; 1.0 cm
3802 ps-inter-column (/ (* 72 1.0) 2.54) ; 1.0 cm
3803 ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
3804 ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
3805 ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm
3806 ps-header-line-pad .15
3808 ps-print-header-frame t
3813 ps-font-family 'Courier
3815 ps-header-font-family 'Helvetica
3816 ps-header-font-size 6
3817 ps-header-title-font-size 8)
3822 ;;; ps-print.el ends here