1 ;;; ps-print.el --- Print text from the buffer as PostScript
3 ;; Copyright (C) 1993, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc.
5 ;; Author: Jim Thompson (was <thompson@wg2.waii.com>)
6 ;; Author: Jacques Duthen (was <duthen@cegelec-red.fr>)
7 ;; Author: Vinicius Jose Latorre <vinicius@cpqd.com.br>
8 ;; Author: Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
9 ;; Maintainer: Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
10 ;; Maintainer: Vinicius Jose Latorre <vinicius@cpqd.com.br>
11 ;; Keywords: wp, print, PostScript
12 ;; Time-stamp: <99/12/11 20:14:41 vinicius>
15 (defconst ps-print-version
"5.0.2"
16 "ps-print.el, v 5.0.2 <99/12/11 vinicius>
18 Vinicius's last change version -- this file may have been edited as part of
19 Emacs without changes to the version number. When reporting bugs,
20 please also report the version of Emacs, if any, that ps-print was
23 Please send all bug fixes and enhancements to
24 Vinicius Jose Latorre <vinicius@cpqd.com.br>.
27 ;; This file is part of GNU Emacs.
29 ;; GNU Emacs is free software; you can redistribute it and/or modify
30 ;; it under the terms of the GNU General Public License as published by
31 ;; the Free Software Foundation; either version 2, or (at your option)
34 ;; GNU Emacs is distributed in the hope that it will be useful,
35 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
36 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
37 ;; GNU General Public License for more details.
39 ;; You should have received a copy of the GNU General Public License
40 ;; along with GNU Emacs; see the file COPYING. If not, write to the
41 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
42 ;; Boston, MA 02111-1307, USA.
46 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51 ;; This package provides printing of Emacs buffers on PostScript printers;
52 ;; the buffer's bold and italic text attributes are preserved in the printer
53 ;; output. ps-print is intended for use with Emacs or Lucid Emacs, together
54 ;; with a fontifying package such as font-lock or hilit.
56 ;; ps-print uses the same face attributes defined through font-lock or hilit
57 ;; to print a PostScript file, but some faces are better seeing on the screen
58 ;; than on paper, specially when you have a black/white PostScript printer.
60 ;; ps-print allows a remap of face to another one that it is better to print,
61 ;; for example, the face font-lock-comment-face (if you are using font-lock)
62 ;; could have bold or italic attribute when printing, besides foreground color.
63 ;; 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-hook' 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 ;; The variable `ps-printer-name' determines the name of a local printer for
184 ;; printing PostScript files.
186 ;; NOTE: `ps-lpr-command' and `ps-lpr-switches' take their initial values
187 ;; from the variables `lpr-command' and `lpr-switches'. If you have
188 ;; `lpr-command' set to invoke a pretty-printer such as `enscript',
189 ;; then ps-print won't work properly. `ps-lpr-command' must name
190 ;; a program that does not format the files it prints.
191 ;; `ps-printer-name' takes its initial value from the variable
194 ;; The variable `ps-print-region-function' specifies a function to print the
195 ;; region on a PostScript printer.
196 ;; See definition of `call-process-region' for calling conventions. The fourth
197 ;; and the sixth arguments are both nil.
203 ;; All dimensions are floats in PostScript points.
204 ;; 1 inch == 2.54 cm == 72 points
205 ;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points
207 ;; The variable `ps-paper-type' determines the size of paper ps-print
208 ;; formats for; it should contain one of the symbols:
209 ;; `a4' `a3' `letter' `legal' `letter-small' `tabloid'
210 ;; `ledger' `statement' `executive' `a4small' `b4' `b5'
212 ;; The variable `ps-landscape-mode' determines the orientation
213 ;; of the printing on the page:
214 ;; nil means `portrait' mode, non-nil means `landscape' mode.
215 ;; There is no oblique mode yet, though this is easy to do in ps.
217 ;; In landscape mode, the text is NOT scaled: you may print 70 lines
218 ;; in portrait mode and only 50 lignes in landscape mode.
219 ;; The margins represent margins in the printed paper:
220 ;; the top margin is the margin between the top of the page
221 ;; and the printed header, whatever the orientation is.
223 ;; The variable `ps-number-of-columns' determines the number of columns
224 ;; both in landscape and portrait mode.
226 ;; - (the standard) one column portrait mode
227 ;; - (my favorite) two columns landscape mode (which spares trees)
229 ;; - one column landscape mode for files with very long lines.
230 ;; - multi-column portrait or landscape mode
236 ;; The horizontal layout is determined by the variables
237 ;; `ps-left-margin' `ps-inter-column' `ps-right-margin'
240 ;; ------------------------------------------
242 ;; | lm | text | ic | text | ic | text | rm |
244 ;; ------------------------------------------
246 ;; If `ps-number-of-columns' is 1, `ps-inter-column' is not relevant.
247 ;; Usually, lm = rm > 0 and ic = lm
248 ;; If (ic < 0), the text of adjacent columns can overlap.
254 ;; The vertical layout is determined by the variables
255 ;; `ps-bottom-margin' `ps-top-margin' `ps-header-offset'
258 ;; |--------| |--------|
260 ;; |--------| |--------|
264 ;; |--------| or | text |
268 ;; |--------| |--------|
270 ;; |--------| |--------|
272 ;; If `ps-print-header' is nil, `ps-header-offset' is not relevant.
273 ;; The margins represent margins in the printed paper:
274 ;; the top margin is the margin between the top of the page
275 ;; and the printed header, whatever the orientation is.
281 ;; ps-print can print headers at the top of each column or at the top
282 ;; of each page; the default headers contain the following four items:
283 ;; on the left, the name of the buffer and, if the buffer is visiting
284 ;; a file, the file's directory; on the right, the page number and
285 ;; date of printing. The default headers look something like this:
288 ;; /home/jct/emacs-lisp/ps/new 94/12/31
290 ;; When printing on duplex printers, left and right are reversed so
291 ;; that the page numbers are toward the outside (cf. `ps-spool-duplex').
293 ;; Headers are configurable:
294 ;; To turn them off completely, set `ps-print-header' to nil.
295 ;; To turn off the header's gaudy framing box,
296 ;; set `ps-print-header-frame' to nil.
298 ;; To print only one header at the top of each page,
299 ;; set `ps-print-only-one-header' to t.
301 ;; The font family and size of text in the header are determined
302 ;; by the variables `ps-header-font-family', `ps-header-font-size' and
303 ;; `ps-header-title-font-size' (see below).
305 ;; The variable `ps-header-line-pad' determines the portion of a header
306 ;; title line height to insert between the header frame and the text
307 ;; it contains, both in the vertical and horizontal directions:
308 ;; .5 means half a line.
310 ;; Page numbers are printed in `n/m' format, indicating page n of m pages;
311 ;; to omit the total page count and just print the page number,
312 ;; set `ps-show-n-of-n' to nil.
314 ;; The amount of information in the header can be changed by changing
315 ;; the number of lines. To show less, set `ps-header-lines' to 1, and
316 ;; the header will show only the buffer name and page number. To show
317 ;; more, set `ps-header-lines' to 3, and the header will show the time of
318 ;; printing below the date.
320 ;; To change the content of the headers, change the variables
321 ;; `ps-left-header' and `ps-right-header'.
322 ;; These variables are lists, specifying top-to-bottom the text
323 ;; to display on the left or right side of the header.
324 ;; Each element of the list should be a string or a symbol.
325 ;; Strings are inserted directly into the PostScript arrays,
326 ;; and should contain the PostScript string delimiters '(' and ')'.
328 ;; Symbols in the header format lists can either represent functions
329 ;; or variables. Functions are called, and should return a string to
330 ;; show in the header. Variables should contain strings to display in
331 ;; the header. In either case, function or variable, the PostScript
332 ;; string delimiters are added by ps-print, and should not be part of
333 ;; the returned value.
335 ;; Here's an example: say we want the left header to display the text
341 ;; where we have a function to return "Moe"
343 ;; (defun moe-func ()
346 ;; a variable specifying "Larry"
348 ;; (setq larry-var "Larry")
350 ;; and a literal for "Curly". Here's how `ps-left-header' should be
353 ;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)"))
355 ;; Note that Curly has the PostScript string delimiters inside his
356 ;; quotes -- those aren't misplaced lisp delimiters!
358 ;; Without them, PostScript would attempt to call the undefined
359 ;; function Curly, which would result in a PostScript error.
361 ;; Since most printers don't report PostScript errors except by
362 ;; aborting the print job, this kind of error can be hard to track down.
364 ;; Consider yourself warned!
367 ;; PostScript Prologue Header
368 ;; --------------------------
370 ;; It is possible to add PostScript prologue header comments besides that
371 ;; ps-print generates by setting the variable `ps-print-prologue-header'.
373 ;; `ps-print-prologue-header' may be a string or a symbol function which returns
374 ;; a string. Note that this string is inserted on PostScript prologue header
375 ;; section which is used to define some document characteristic through
376 ;; PostScript special comments, like "%%Requirements: jog\n".
378 ;; By default `ps-print-prologue-header' is nil.
380 ;; ps-print always inserts the %%Requirements: comment, so if you need to insert
381 ;; more requirements put them first in `ps-print-prologue-header' using the
382 ;; "%%+" comment. For example, if you need to set numcopies to 3 and jog on
383 ;; requirements and set %%LanguageLevel: to 2, do:
385 ;; (setq ps-print-prologue-header
386 ;; "%%+ numcopies(3) jog\n%%LanguageLevel: 2\n")
388 ;; The duplex requirement is inserted by ps-print (see section Duplex Printers).
390 ;; Do not forget to terminate the string with "\n".
392 ;; For more information about PostScript document comments, see:
393 ;; PostScript Language Reference Manual (2nd edition)
394 ;; Adobe Systems Incorporated
395 ;; Appendix G: Document Structuring Conventions -- Version 3.0
401 ;; If you have a duplex-capable printer (one that prints both sides of the
402 ;; paper), set `ps-spool-duplex' to t.
403 ;; ps-print will insert blank pages to make sure each buffer starts on the
404 ;; correct side of the paper.
406 ;; The variable `ps-spool-config' specifies who is the responsable for setting
407 ;; duplex and page size switches. Valid values are:
409 ;; lpr-switches duplex and page size are configured by `ps-lpr-switches'.
410 ;; Don't forget to set `ps-lpr-switches' to select duplex
411 ;; printing for your printer.
413 ;; setpagedevice duplex and page size are configured by ps-print using the
414 ;; setpagedevice PostScript operator.
416 ;; nil duplex and page size are configured by ps-print *not* using
417 ;; the setpagedevice PostScript operator.
419 ;; Any other value is treated as nil.
421 ;; The default value is `lpr-switches'.
423 ;; WARNING: The setpagedevice PostScript operator affects ghostview utility when
424 ;; viewing file generated using landscape. Also on some printers,
425 ;; setpagedevice affects zebra stripes; on other printers,
426 ;; setpagedevice affects the left margin.
427 ;; Besides all that, if your printer does not have the paper size
428 ;; specified by setpagedevice, your printing will be aborted.
429 ;; So, if you need to use setpagedevice, set `ps-spool-config' to
430 ;; `setpagedevice', generate a test file and send it to your printer;
431 ;; if the printed file isn't ok, set `ps-spool-config' to nil.
433 ;; The variable `ps-spool-tumble' specifies how the page images on opposite
434 ;; sides of a sheet are oriented with respect to each other. If
435 ;; `ps-spool-tumble' is nil, produces output suitable for binding on the left or
436 ;; right. If `ps-spool-tumble' is non-nil, produces output suitable for binding
437 ;; at the top or bottom. It has effect only when `ps-spool-duplex' is non-nil.
438 ;; The default value is nil.
440 ;; Some printer system prints a header page and forces the first page be printed
441 ;; on header page back, when using duplex. If your printer system has this
442 ;; behavior, set variable `ps-banner-page-when-duplexing' to t.
444 ;; When `ps-banner-page-when-duplexing' is non-nil means the very first page is
445 ;; skipped. It's like the very first character of buffer (or region) is ^L
448 ;; The default for `ps-banner-page-when-duplexing' is nil (*don't* skip the very
455 ;; The variable `ps-n-up-printing' specifies the number of pages per sheet of
456 ;; paper. The value specified must be between 1 and 100. The default is 1.
458 ;; NOTE: some PostScript printer may crash printing if `ps-n-up-printing' is set
459 ;; to a high value (for example, 23). If this happens, set a lower value.
461 ;; The variable `ps-n-up-margin' specifies the margin in points between the
462 ;; sheet border and the n-up printing. The default is 1 cm (or 0.3937 inches,
465 ;; If variable `ps-n-up-border-p' is non-nil a border is drawn around each page.
468 ;; The variable `ps-n-up-filling' specifies how page matrix is filled on each
469 ;; sheet of paper. Following are the valid values for `ps-n-up-filling' with a
470 ;; filling example using a 3x4 page matrix:
472 ;; left-top 1 2 3 4 left-bottom 9 10 11 12
474 ;; 9 10 11 12 1 2 3 4
476 ;; right-top 4 3 2 1 right-bottom 12 11 10 9
478 ;; 12 11 10 9 4 3 2 1
480 ;; top-left 1 4 7 10 bottom-left 3 6 9 12
484 ;; top-right 10 7 4 1 bottom-right 12 9 6 3
488 ;; Any other value is treated as left-top.
490 ;; The default value is left-top.
493 ;; Control And 8-bit Characters
494 ;; ----------------------------
496 ;; The variable `ps-print-control-characters' specifies whether you want to see
497 ;; a printable form for control and 8-bit characters, that is, instead of
498 ;; sending, for example, a ^D (\004) to printer, it is sent the string "^D".
500 ;; Valid values for `ps-print-control-characters' are:
502 ;; 8-bit This is the value to use when you want an ASCII encoding of
503 ;; any control or non-ASCII character. Control characters are
504 ;; encoded as "^D", and non-ASCII characters have an
507 ;; control-8-bit This is the value to use when you want an ASCII encoding of
508 ;; any control character, whether it is 7 or 8-bit.
509 ;; European 8-bits accented characters are printed according
512 ;; control Only ASCII control characters have an ASCII encoding.
513 ;; European 8-bits accented characters are printed according
516 ;; nil No ASCII encoding. Any character is printed according the
519 ;; Any other value is treated as nil.
521 ;; The default is `control-8-bit'.
523 ;; Characters TAB, NEWLINE and FORMFEED are always treated by ps-print engine.
526 ;; Printing Multi-byte Buffer
527 ;; --------------------------
529 ;; See ps-mule.el for documentation.
535 ;; The variable `ps-line-number' specifies whether to number each line;
536 ;; non-nil means do so. The default is nil (don't number each line).
542 ;; Zebra stripes are a kind of background that appear "underneath" the text
543 ;; and can make the text easier to read. They look like this:
545 ;; XXXXXXXXXXXXXXXXXXXXXXXX
546 ;; XXXXXXXXXXXXXXXXXXXXXXXX
547 ;; XXXXXXXXXXXXXXXXXXXXXXXX
551 ;; XXXXXXXXXXXXXXXXXXXXXXXX
552 ;; XXXXXXXXXXXXXXXXXXXXXXXX
553 ;; XXXXXXXXXXXXXXXXXXXXXXXX
555 ;; The blocks of X's represent rectangles filled with a light gray color.
556 ;; Each rectangle extends all the way across the page.
558 ;; The height, in lines, of each rectangle is controlled by
559 ;; the variable `ps-zebra-stripe-height', which is 3 by default.
560 ;; The distance between stripes equals the height of a stripe.
562 ;; The variable `ps-zebra-stripes' controls whether to print zebra stripes.
563 ;; Non-nil means yes, nil means no. The default is nil.
565 ;; The variable `ps-zebra-gray' controls the zebra stripes gray scale.
566 ;; It should be a float number between 0.0 (black color) and 1.0 (white color).
567 ;; The default is 0.95.
569 ;; See also section How Ps-Print Has A Text And/Or Image On Background.
575 ;; ps-print has the following hook variables:
578 ;; It is evaluated once before any printing process. This is the right
579 ;; place to initialize ps-print global data.
580 ;; For an example, see section Adding a New Font Family.
582 ;; `ps-print-begin-sheet-hook'
583 ;; It is evaluated on each beginning of sheet of paper.
584 ;; If `ps-n-up-printing' is equal to 1, `ps-print-begin-page-hook' is never
587 ;; `ps-print-begin-page-hook'
588 ;; It is evaluated on each beginning of page, except in the beginning
589 ;; of page that `ps-print-begin-sheet-hook' is evaluated.
591 ;; `ps-print-begin-column-hook'
592 ;; It is evaluated on each beginning of column, except in the beginning
593 ;; of column that `ps-print-begin-page-hook' is evaluated or that
594 ;; `ps-print-begin-sheet-hook' is evaluated.
600 ;; ps-print now knows rather precisely some fonts: the variable
601 ;; `ps-font-info-database' contains information for a list of font families
602 ;; (currently mainly `Courier' `Helvetica' `Times' `Palatino' `Helvetica-Narrow'
603 ;; `NewCenturySchlbk'). Each font family contains the font names for standard,
604 ;; bold, italic and bold-italic characters, a reference size (usually 10) and
605 ;; the corresponding line height, width of a space and average character width.
607 ;; The variable `ps-font-family' determines which font family is to be used for
608 ;; ordinary text. If its value does not correspond to a known font family, an
609 ;; error message is printed into the `*Messages*' buffer, which lists the
610 ;; currently available font families.
612 ;; The variable `ps-font-size' determines the size (in points) of the font for
613 ;; ordinary text, when generating PostScript. Its value is a float or a cons of
614 ;; floats which has the following form:
616 ;; (LANDSCAPE-SIZE . PORTRAIT-SIZE)
618 ;; Similarly, the variable `ps-header-font-family' determines which font family
619 ;; is to be used for text in the header.
621 ;; The variable `ps-header-font-size' determines the font size, in points, for
622 ;; text in the header (similar to `ps-font-size').
624 ;; The variable `ps-header-title-font-size' determines the font size, in points,
625 ;; for the top line of text in the header (similar to `ps-font-size').
628 ;; Adding a New Font Family
629 ;; ------------------------
631 ;; To use a new font family, you MUST first teach ps-print
632 ;; this font, i.e., add its information to `ps-font-info-database',
633 ;; otherwise ps-print cannot correctly place line and page breaks.
635 ;; For example, assuming `Helvetica' is unknown,
636 ;; you first need to do the following ONLY ONCE:
638 ;; - create a new buffer
639 ;; - generate the PostScript image to a file (C-u M-x ps-print-buffer)
640 ;; - open this file and find the line:
641 ;; `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage'
642 ;; - delete the leading `%' (which is the PostScript comment character)
643 ;; - replace in this line `Courier' by the new font (say `Helvetica')
645 ;; `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage'
646 ;; - send this file to the printer (or to ghostscript).
647 ;; You should read the following on the output page:
649 ;; For Helvetica 10 point, the line height is 11.56, the space width is 2.78
650 ;; and a crude estimate of average character width is 5.09243
652 ;; - Add these values to the `ps-font-info-database':
653 ;; (setq ps-font-info-database
655 ;; '((Helvetica ; the family key
656 ;; (fonts (normal . "Helvetica")
657 ;; (bold . "Helvetica-Bold")
658 ;; (italic . "Helvetica-Oblique")
659 ;; (bold-italic . "Helvetica-BoldOblique"))
661 ;; (line-height . 11.56)
662 ;; (space-width . 2.78)
663 ;; (avg-char-width . 5.09243)))
664 ;; ps-font-info-database))
665 ;; - Now you can use this font family with any size:
666 ;; (setq ps-font-family 'Helvetica)
667 ;; - if you want to use this family in another emacs session, you must
668 ;; put into your `~/.emacs':
669 ;; (require 'ps-print)
670 ;; (setq ps-font-info-database (append ...)))
671 ;; if you don't want to load ps-print, you have to copy the whole value:
672 ;; (setq ps-font-info-database '(<your stuff> <the standard stuff>))
673 ;; or, use `ps-print-hook' (see section Hooks):
674 ;; (add-hook 'ps-print-hook
676 ;; (or (assq 'Helvetica ps-font-info-database)
677 ;; (setq ps-font-info-database (append ...)))))
679 ;; You can create new `mixed' font families like:
681 ;; (fonts (normal . "Courier-Bold")
682 ;; (bold . "Helvetica")
683 ;; (italic . "Zapf-Chancery-MediumItalic")
684 ;; (bold-italic . "NewCenturySchlbk-BoldItalic")
685 ;; (w3-table-hack-x-face . "LineDrawNormal"))
687 ;; (line-height . 10.55)
688 ;; (space-width . 6.0)
689 ;; (avg-char-width . 6.0))
691 ;; Now you can use your new font family with any size:
692 ;; (setq ps-font-family 'my-mixed-family)
694 ;; Note that on above example the `w3-table-hack-x-face' entry refers to
695 ;; a face symbol, so when printing this face it'll be used the font
696 ;; `LineDrawNormal'. If the face `w3-table-hack-x-face' is remapped to
697 ;; use bold and/or italic attribute, the corresponding entry (bold, italic
698 ;; or bold-italic) will be used instead of `w3-table-hack-x-face' entry.
700 ;; Note also that the font family entry order is irrelevant, so the above
701 ;; example could also be written:
704 ;; (fonts (w3-table-hack-x-face . "LineDrawNormal")
705 ;; (bold . "Helvetica")
706 ;; (bold-italic . "NewCenturySchlbk-BoldItalic")
707 ;; (italic . "Zapf-Chancery-MediumItalic")
708 ;; (normal . "Courier-Bold"))
709 ;; (avg-char-width . 6.0)
710 ;; (space-width . 6.0)
711 ;; (line-height . 10.55))
713 ;; Despite the note above, it is recommended that some convention about
714 ;; entry order be used.
716 ;; You can get information on all the fonts resident in YOUR printer
717 ;; by uncommenting the line:
718 ;; % 3 cm 20 cm moveto ReportAllFontInfo showpage
720 ;; The PostScript file should be sent to YOUR PostScript printer.
721 ;; If you send it to ghostscript or to another PostScript printer,
722 ;; you may get slightly different results.
723 ;; Anyway, as ghostscript fonts are autoload, you won't get
727 ;; How Ps-Print Deals With Faces
728 ;; -----------------------------
730 ;; The ps-print-*-with-faces commands attempt to determine which faces
731 ;; should be printed in bold or italic, but their guesses aren't
732 ;; always right. For example, you might want to map colors into faces
733 ;; so that blue faces print in bold, and red faces in italic.
735 ;; It is possible to force ps-print to consider specific faces bold,
736 ;; italic or underline, no matter what font they are displayed in, by setting
737 ;; the variables `ps-bold-faces', `ps-italic-faces' and `ps-underlined-faces'.
738 ;; These variables contain lists of faces that ps-print should consider bold,
739 ;; italic or underline; to set them, put code like the following into your
742 ;; (setq ps-bold-faces '(my-blue-face))
743 ;; (setq ps-italic-faces '(my-red-face))
744 ;; (setq ps-underlined-faces '(my-green-face))
746 ;; Faces like bold-italic that are both bold and italic should go in
749 ;; ps-print keeps internal lists of which fonts are bold and which are
750 ;; italic; these lists are built the first time you invoke ps-print.
751 ;; For the sake of efficiency, the lists are built only once; the same
752 ;; lists are referred in later invocations of ps-print.
754 ;; Because these lists are built only once, it's possible for them to
755 ;; get out of sync, if a face changes, or if new faces are added. To
756 ;; get the lists back in sync, you can set the variable
757 ;; `ps-build-face-reference' to t, and the lists will be rebuilt the
758 ;; next time ps-print is invoked. If you need that the lists always be
759 ;; rebuilt when ps-print is invoked, set the variable
760 ;; `ps-always-build-face-reference' to t.
763 ;; How Ps-Print Deals With Color
764 ;; -----------------------------
766 ;; ps-print detects faces with foreground and background colors
767 ;; defined and embeds color information in the PostScript image.
768 ;; The default foreground and background colors are defined by the
769 ;; variables `ps-default-fg' and `ps-default-bg'.
770 ;; On black-and-white printers, colors are displayed in grayscale.
771 ;; To turn off color output, set `ps-print-color-p' to nil.
774 ;; How Ps-Print Maps Faces
775 ;; -----------------------
777 ;; As ps-print uses PostScript to print buffers, it is possible to have
778 ;; other attributes associated with faces. So the new attributes used
781 ;; strikeout - like underline, but the line is in middle of text.
782 ;; overline - like underline, but the line is over the text.
783 ;; shadow - text will have a shadow.
784 ;; box - text will be surrounded by a box.
785 ;; outline - print characters as hollow outlines.
787 ;; See the documentation for `ps-extend-face'.
789 ;; Let's, for example, remap `font-lock-keyword-face' to another foreground
790 ;; color and bold attribute:
792 ;; (ps-extend-face '(font-lock-keyword-face "RoyalBlue" nil bold) 'MERGE)
794 ;; If you want to use a new face, define it first with `defface',
795 ;; and then call `ps-extend-face' to specify how to print it.
798 ;; How Ps-Print Has A Text And/Or Image On Background
799 ;; --------------------------------------------------
801 ;; ps-print can print texts and/or EPS PostScript images on background; it is
802 ;; possible to define the following text attributes: font name, font size,
803 ;; initial position, angle, gray scale and pages to print.
805 ;; It has the following EPS PostScript images attributes: file name containing
806 ;; the image, initial position, X and Y scales, angle and pages to print.
808 ;; See documentation for `ps-print-background-text' and
809 ;; `ps-print-background-image'.
811 ;; For example, if we wish to print text "preliminary" on all pages and text
812 ;; "special" on page 5 and from page 11 to page 17, we could specify:
814 ;; (setq ps-print-background-text
817 ;; "LeftMargin" "BottomMargin PrintHeight add" ; X and Y position
818 ;; ; (upper left corner)
820 ;; "PrintHeight neg PrintPageWidth atan" ; angle
821 ;; 5 (11 . 17)) ; page list
824 ;; Similarly, we could print image "~/images/EPS-image1.ps" on all pages and
825 ;; image "~/images/EPS-image2.ps" on page 5 and from page 11 to page 17, we
828 ;; (setq ps-print-background-image
829 ;; '(("~/images/EPS-image1.ps"
830 ;; "LeftMargin" "BottomMargin") ; X and Y position (lower left corner)
831 ;; ("~/images/EPS-image2.ps"
832 ;; "LeftMargin" "BottomMargin PrintHeight 2 div add" ; X and Y position
833 ;; ; (upper left corner)
835 ;; 5 (11 . 17)) ; page list
838 ;; If it is not possible to read (or does not exist) an image file, that file
841 ;; The printing order is:
843 ;; 1. Print zebra stripes
844 ;; 2. Print background texts that it should be on all pages
845 ;; 3. Print background images that it should be on all pages
846 ;; 4. Print background texts only for current page (if any)
847 ;; 5. Print background images only for current page (if any)
849 ;; 7. Print buffer text (with faces, if specified) and line number
855 ;; Some tools are provided to help you customize your font setup.
857 ;; `ps-setup' returns (some part of) the current setup.
859 ;; To avoid wrapping too many lines, you may want to adjust the
860 ;; left and right margins and the font size. On UN*X systems, do:
861 ;; pr -t file | awk '{printf "%3d %s\n", length($0), $0}' | sort -r | head
862 ;; to determine the longest lines of your file.
863 ;; Then, the command `ps-line-lengths' will give you the correspondence
864 ;; between a line length (number of characters) and the maximum font
865 ;; size which doesn't wrap such a line with the current ps-print setup.
867 ;; The commands `ps-nb-pages-buffer' and `ps-nb-pages-region' display
868 ;; the correspondence between a number of pages and the maximum font
869 ;; size which allow the number of lines of the current buffer or of
870 ;; its current region to fit in this number of pages.
872 ;; NOTE: line folding is not taken into account in this process and could
873 ;; change the results.
875 ;; The command `ps-print-customize' activates a customization buffer for
879 ;; New since version 1.5
880 ;; ---------------------
882 ;; Color output capability.
883 ;; Automatic detection of font attributes (bold, italic).
884 ;; Configurable headers with page numbers.
886 ;; Support for different paper sizes.
887 ;; Better conformance to PostScript Document Structure Conventions.
890 ;; New since version 2.8
891 ;; ---------------------
893 ;; [vinicius] 991211 Vinicius Jose Latorre <vinicius@cpqd.com.br>
895 ;; `ps-print-customize'.
897 ;; [vinicius] 990703 Vinicius Jose Latorre <vinicius@cpqd.com.br>
899 ;; Better customization.
900 ;; `ps-banner-page-when-duplexing' and `ps-zebra-gray'.
902 ;; [vinicius] 990513 Vinicius Jose Latorre <vinicius@cpqd.com.br>
905 ;; Hook: `ps-print-begin-sheet-hook'.
907 ;; [keinichi] 990509 Kein'ichi Handa <handa@etl.go.jp>
909 ;; `ps-print-region-function'
911 ;; [vinicius] 990301 Vinicius Jose Latorre <vinicius@cpqd.com.br>
913 ;; PostScript tumble and setpagedevice.
915 ;; [vinicius] 980922 Vinicius Jose Latorre <vinicius@cpqd.com.br>
917 ;; PostScript prologue header comment insertion.
918 ;; Skip invisible text better.
920 ;; [keinichi] 980819 Kein'ichi Handa <handa@etl.go.jp>
922 ;; Multi-byte buffer handling.
924 ;; [vinicius] 980306 Vinicius Jose Latorre <vinicius@cpqd.com.br>
926 ;; Skip invisible text.
928 ;; [vinicius] 971130 Vinicius Jose Latorre <vinicius@cpqd.com.br>
930 ;; Hooks: `ps-print-hook', `ps-print-begin-page-hook' and
931 ;; `ps-print-begin-column-hook'.
932 ;; Put one header per page over the columns.
933 ;; Better database font management.
934 ;; Better control characters handling.
936 ;; [vinicius] 971121 Vinicius Jose Latorre <vinicius@cpqd.com.br>
938 ;; Dynamic evaluation at print time of `ps-lpr-switches'.
939 ;; Handle control characters.
941 ;; New face attributes.
944 ;; Text and/or image on background.
946 ;; [jack] 960517 Jacques Duthen <duthen@cegelec-red.fr>
948 ;; Font family and float size for text and header.
951 ;; Tools for page setup.
954 ;; Known bugs and limitations of ps-print
955 ;; --------------------------------------
957 ;; Although color printing will work in XEmacs 19.12, it doesn't work
958 ;; well; in particular, bold or italic fonts don't print in the right
961 ;; Invisible properties aren't correctly ignored in XEmacs 19.12.
963 ;; Automatic font-attribute detection doesn't work well, especially
964 ;; with hilit19 and older versions of get-create-face. Users having
965 ;; problems with auto-font detection should use the lists
966 ;; `ps-italic-faces', `ps-bold-faces' and `ps-underlined-faces' and/or
967 ;; turn off automatic detection by setting `ps-auto-font-detect' to nil.
969 ;; Automatic font-attribute detection doesn't work with XEmacs 19.12
970 ;; in tty mode; use the lists `ps-italic-faces', `ps-bold-faces' and
971 ;; `ps-underlined-faces' instead.
973 ;; Still too slow; could use some hand-optimization.
975 ;; Default background color isn't working.
977 ;; Faces are always treated as opaque.
979 ;; Epoch and Emacs 18 not supported. At all.
981 ;; Fixed-pitch fonts work better for line folding, but are not required.
983 ;; `ps-nb-pages-buffer' and `ps-nb-pages-region' don't take care
990 ;; Avoid page break inside a paragraph.
991 ;; Add `ps-non-bold-faces' and `ps-non-italic-faces' (should be easy).
992 ;; Improve the memory management for big files (hard?).
993 ;; `ps-nb-pages-buffer' and `ps-nb-pages-region' should take care
1000 ;; Thanks to Kein'ichi Handa <handa@etl.go.jp> for multi-byte buffer handling.
1002 ;; Thanks to Matthew O Persico <Matthew.Persico@lazard.com> for line number on
1005 ;; Thanks to Theodore Jump <tjump@cais.com> for adjust PostScript code order on
1008 ;; Thanks to Roland Ducournau <ducour@lirmm.fr> for
1009 ;; `ps-print-control-characters' variable documentation.
1011 ;; Thanks to Marcus G Daniels <marcus@cathcart.sysc.pdx.edu> for a better
1012 ;; database font management.
1014 ;; Thanks to Martin Boyer <gamin@videotron.ca> for some ideas on putting one
1015 ;; header per page over the columns and correct line numbers when printing a
1018 ;; Thanks to Steven L Baur <steve@miranova.com> for dynamic evaluation at
1019 ;; print time of `ps-lpr-switches'.
1021 ;; Thanks to Kevin Rodgers <kevinr@ihs.com> for handling control characters
1022 ;; (his code was severely modified, but the main idea was kept).
1024 ;; Thanks to some suggestions on:
1025 ;; * Face color map: Marco Melgazzi <marco@techie.com>
1026 ;; * XEmacs compatibility: William J. Henney <will@astrosmo.unam.mx>
1027 ;; * Check `ps-paper-type': Sudhakar Frederick <sfrederi@asc.corp.mot.com>
1029 ;; Thanks to Jacques Duthen <duthen@cegelec-red.fr> (Jack) for the 3.4 version
1030 ;; I started from. [vinicius]
1032 ;; Thanks to Jim Thompson <?@?> for the 2.8 version I started from.
1035 ;; Thanks to Kevin Rodgers <kevinr@ihs.com> for adding support for
1036 ;; color and the invisible property.
1038 ;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing
1039 ;; the initial port to Emacs 19. His code is no longer part of
1040 ;; ps-print, but his work is still appreciated.
1042 ;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org,
1043 ;; for adding underline support. Their code also is no longer part of
1044 ;; ps-print, but their efforts are not forgotten.
1046 ;; Thanks also to all of you who mailed code to add features to
1047 ;; ps-print; although I didn't use your code, I still appreciate your
1048 ;; sharing it with me.
1050 ;; Thanks to all who mailed comments, encouragement, and criticism.
1051 ;; Thanks also to all who responded to my survey; I had too many
1052 ;; responses to reply to them all, but I greatly appreciate your
1056 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1060 (unless (featurep 'lisp-float-type
)
1061 (error "`ps-print' requires floating point support"))
1064 ;; For Emacs 20.2 and the earlier version.
1066 (or (fboundp 'set-buffer-multibyte
)
1067 (defun set-buffer-multibyte (arg)
1068 (setq enable-multibyte-characters arg
)))
1070 (or (fboundp 'string-as-unibyte
)
1071 (defun string-as-unibyte (arg) arg
))
1073 (or (fboundp 'string-as-multibyte
)
1074 (defun string-as-multibyte (arg) arg
))
1076 (or (fboundp 'charset-after
)
1077 (defun charset-after (&optional arg
)
1078 (char-charset (char-after arg
))))
1081 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1085 ;;; Interface to the command system
1087 (defgroup postscript nil
1092 (defgroup ps-print nil
1093 "PostScript generator for Emacs 19"
1098 (defgroup ps-print-horizontal nil
1099 "Horizontal page layout"
1104 (defgroup ps-print-vertical nil
1105 "Vertical page layout"
1110 (defgroup ps-print-header nil
1116 (defgroup ps-print-font nil
1117 "Fonts customization"
1122 (defgroup ps-print-color nil
1123 "Color customization"
1128 (defgroup ps-print-face nil
1129 "Faces customization"
1135 (defgroup ps-print-n-up nil
1136 "N-up customization"
1141 (defgroup ps-print-zebra nil
1142 "Zebra customization"
1147 (defgroup ps-print-background nil
1148 "Background customization"
1153 (defgroup ps-print-printer nil
1154 "Printer customization"
1159 (defgroup ps-print-page nil
1160 "Page customization"
1166 (defcustom ps-print-prologue-header nil
1167 "*PostScript prologue header comments besides that ps-print generates.
1169 `ps-print-prologue-header' may be a string or a symbol function which
1170 returns a string. Note that this string is inserted on PostScript prologue
1171 header section which is used to define some document characteristic through
1172 PostScript special comments, like \"%%Requirements: jog\\n\".
1174 ps-print always inserts the %%Requirements: comment, so if you need to insert
1175 more requirements put them first in `ps-print-prologue-header' using the
1176 \"%%+\" comment. For example, if you need to set numcopies to 3 and jog on
1177 requirements and set %%LanguageLevel: to 2, do:
1179 (setq ps-print-prologue-header
1180 \"%%+ numcopies(3) jog\\n%%LanguageLevel: 2\\n\")
1182 The duplex requirement is inserted by ps-print (see `ps-spool-duplex').
1184 Do not forget to terminate the string with \"\\n\".
1186 For more information about PostScript document comments, see:
1187 PostScript Language Reference Manual (2nd edition)
1188 Adobe Systems Incorporated
1189 Appendix G: Document Structuring Conventions -- Version 3.0"
1190 :type
'(choice :tag
"Prologue Header"
1191 string symbol
(other :tag
"nil" nil
))
1194 (defcustom ps-printer-name
(and (boundp 'printer-name
)
1196 "*The name of a local printer for printing PostScript files.
1198 On Unix-like systems, a string value should be a name understood by
1199 lpr's -P option; a value of nil means use the value of `printer-name'
1200 instead. Any other value will be ignored.
1202 On MS-DOS and MS-Windows systems, a string value is taken as the name of
1203 the printer device or port to which PostScript files are written,
1204 provided `ps-lpr-command' is \"\". By default it is the same as
1205 `printer-name'; typical non-default settings would be \"LPT1\" to
1206 \"LPT3\" for parallel printers, or \"COM1\" to \"COM4\" or \"AUX\" for
1207 serial printers, or \"//hostname/printer\" for a shared network printer.
1208 You can also set it to a name of a file, in which case the output gets
1209 appended to that file. \(Note that `ps-print' package already has
1210 facilities for printing to a file, so you might as well use them instead
1211 of changing the setting of this variable.\) If you want to silently
1212 discard the printed output, set this to \"NUL\"."
1213 :type
'(choice :tag
"Printer Name"
1214 file
(other :tag
"Pipe to ps-lpr-command" pipe
))
1215 :group
'ps-print-printer
)
1217 (defcustom ps-lpr-command lpr-command
1218 "*Name of program for printing a PostScript file.
1220 On MS-DOS and MS-Windows systems, if the value is an empty string then
1221 Emacs will write directly to the printer port named by `ps-printer-name'.
1222 The programs `print' and `nprint' (the standard print programs on Windows
1223 NT and Novell Netware respectively) are handled specially, using
1224 `ps-printer-name' as the destination for output; any other program is
1225 treated like `lpr' except that an explicit filename is given as the last
1228 :group
'ps-print-printer
)
1230 (defcustom ps-lpr-switches lpr-switches
1231 "*A list of extra switches to pass to `ps-lpr-command'."
1232 :type
'(repeat string
)
1233 :group
'ps-print-printer
)
1235 (defcustom ps-print-region-function nil
1236 "*Specify a function to print the region on a PostScript printer.
1237 See definition of `call-process-region' for calling conventions. The fourth and
1238 the sixth arguments are both nil."
1240 :group
'ps-print-printer
)
1244 ;; All page dimensions are in PostScript points.
1245 ;; 1 inch == 2.54 cm == 72 points
1246 ;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points
1248 ;; Letter 8.5 inch x 11.0 inch
1249 ;; Legal 8.5 inch x 14.0 inch
1250 ;; A4 8.26 inch x 11.69 inch = 21.0 cm x 29.7 cm
1252 ;; LetterSmall 7.68 inch x 10.16 inch
1253 ;; Tabloid 11.0 inch x 17.0 inch
1254 ;; Ledger 17.0 inch x 11.0 inch
1255 ;; Statement 5.5 inch x 8.5 inch
1256 ;; Executive 7.5 inch x 10.0 inch
1257 ;; A3 11.69 inch x 16.5 inch = 29.7 cm x 42.0 cm
1258 ;; A4Small 7.47 inch x 10.85 inch
1259 ;; B4 10.125 inch x 14.33 inch
1260 ;; B5 7.16 inch x 10.125 inch
1262 (defcustom ps-page-dimensions-database
1263 (list (list 'a4
(/ (* 72 21.0) 2.54) (/ (* 72 29.7) 2.54) "A4")
1264 (list 'a3
(/ (* 72 29.7) 2.54) (/ (* 72 42.0) 2.54) "A3")
1265 (list 'letter
(* 72 8.5) (* 72 11.0) "Letter")
1266 (list 'legal
(* 72 8.5) (* 72 14.0) "Legal")
1267 (list 'letter-small
(* 72 7.68) (* 72 10.16) "LetterSmall")
1268 (list 'tabloid
(* 72 11.0) (* 72 17.0) "Tabloid")
1269 (list 'ledger
(* 72 17.0) (* 72 11.0) "Ledger")
1270 (list 'statement
(* 72 5.5) (* 72 8.5) "Statement")
1271 (list 'executive
(* 72 7.5) (* 72 10.0) "Executive")
1272 (list 'a4small
(* 72 7.47) (* 72 10.85) "A4Small")
1273 (list 'b4
(* 72 10.125) (* 72 14.33) "B4")
1274 (list 'b5
(* 72 7.16) (* 72 10.125) "B5"))
1275 "*List associating a symbolic paper type to its width, height and doc media.
1276 See `ps-paper-type'."
1277 :type
'(repeat (list :tag
"Paper Type"
1278 (symbol :tag
"Name")
1279 (number :tag
"Width")
1280 (number :tag
"Height")
1281 (string :tag
"Media")))
1282 :group
'ps-print-page
)
1285 (defcustom ps-paper-type
'letter
1286 "*Specify the size of paper to format for.
1287 Should be one of the paper types defined in `ps-page-dimensions-database', for
1288 example `letter', `legal' or `a4'."
1289 :type
'(symbol :validate
(lambda (wid)
1290 (if (assq (widget-value wid
)
1291 ps-page-dimensions-database
)
1293 (widget-put wid
:error
"Unknown paper size")
1295 :group
'ps-print-page
)
1297 (defcustom ps-landscape-mode nil
1298 "*Non-nil means print in landscape mode."
1300 :group
'ps-print-page
)
1302 (defcustom ps-print-control-characters
'control-8-bit
1303 "*Specify the printable form for control and 8-bit characters.
1304 That is, instead of sending, for example, a ^D (\\004) to printer,
1305 it is sent the string \"^D\".
1309 `8-bit' This is the value to use when you want an ASCII encoding of
1310 any control or non-ASCII character. Control characters are
1311 encoded as \"^D\", and non-ASCII characters have an
1314 `control-8-bit' This is the value to use when you want an ASCII encoding of
1315 any control character, whether it is 7 or 8-bit.
1316 European 8-bits accented characters are printed according
1319 `control' Only ASCII control characters have an ASCII encoding.
1320 European 8-bits accented characters are printed according
1323 nil No ASCII encoding. Any character is printed according the
1326 Any other value is treated as nil."
1327 :type
'(choice :tag
"Control Char"
1328 (const 8-bit
) (const control-8-bit
)
1329 (const control
) (other :tag
"nil" nil
))
1332 (defcustom ps-n-up-printing
1
1333 "*Specify the number of pages per sheet paper."
1335 :tag
"N Up Printing"
1338 (if (and (< 0 (widget-value wid
))
1339 (<= (widget-value wid
) 100))
1343 "Number of pages per sheet paper must be between 1 and 100.")
1345 :group
'ps-print-n-up
)
1347 (defcustom ps-n-up-margin
(/ (* 72 1.0) 2.54) ; 1 cm
1348 "*Specify the margin in points between the sheet border and n-up printing."
1350 :group
'ps-print-n-up
)
1352 (defcustom ps-n-up-border-p t
1353 "*Non-nil means a border is drawn around each page."
1355 :group
'ps-print-n-up
)
1357 (defcustom ps-n-up-filling
'left-top
1358 "*Specify how page matrix is filled on each sheet of paper.
1360 Following are the valid values for `ps-n-up-filling' with a filling example
1361 using a 3x4 page matrix:
1363 `left-top' 1 2 3 4 `left-bottom' 9 10 11 12
1367 `right-top' 4 3 2 1 `right-bottom' 12 11 10 9
1371 `top-left' 1 4 7 10 `bottom-left' 3 6 9 12
1375 `top-right' 10 7 4 1 `bottom-right' 12 9 6 3
1379 Any other value is treated as `left-top'."
1380 :type
'(choice :tag
"N-Up Filling"
1381 (const left-top
) (const left-bottom
)
1382 (const right-top
) (const right-bottom
)
1383 (const top-left
) (const bottom-left
)
1384 (const top-right
) (const bottom-right
))
1385 :group
'ps-print-n-up
)
1387 (defcustom ps-number-of-columns
(if ps-landscape-mode
2 1)
1388 "*Specify the number of columns"
1392 (defcustom ps-zebra-stripes nil
1393 "*Non-nil means print zebra stripes.
1394 See also documentation for `ps-zebra-stripe-height' and `ps-zebra-gray'."
1396 :group
'ps-print-zebra
)
1398 (defcustom ps-zebra-stripe-height
3
1399 "*Number of zebra stripe lines.
1400 See also documentation for `ps-zebra-stripes' and `ps-zebra-gray'."
1402 :group
'ps-print-zebra
)
1404 (defcustom ps-zebra-gray
0.95
1405 "*Zebra stripe gray scale.
1406 See also documentation for `ps-zebra-stripes' and `ps-zebra-stripe-height'."
1408 :group
'ps-print-zebra
)
1410 (defcustom ps-line-number nil
1411 "*Non-nil means print line number."
1415 (defcustom ps-print-background-image nil
1416 "*EPS image list to be printed on background.
1420 (FILENAME X Y XSCALE YSCALE ROTATION PAGES...)
1422 FILENAME is a file name which contains an EPS image or some PostScript
1423 programming like EPS.
1424 FILENAME is ignored, if it doesn't exist or is read protected.
1426 X and Y are relative positions on paper to put the image.
1427 If X and Y are nil, the image is centralized on paper.
1429 XSCALE and YSCALE are scale factor to be applied to image before printing.
1430 If XSCALE and YSCALE are nil, the original size is used.
1432 ROTATION is the image rotation angle; if nil, the default is 0.
1434 PAGES designates the page to print background image.
1435 PAGES may be a number or a cons cell (FROM . TO) designating FROM page
1437 If PAGES is nil, print background image on all pages.
1439 X, Y, XSCALE, YSCALE and ROTATION may be a floating point number,
1440 an integer number or a string. If it is a string, the string should contain
1441 PostScript programming that returns a float or integer value.
1443 For example, if you wish to print an EPS image on all pages do:
1445 '((\"~/images/EPS-image.ps\"))"
1446 :type
'(repeat (list (file :tag
"EPS File")
1447 (choice :tag
"X" number string
(const nil
))
1448 (choice :tag
"Y" number string
(const nil
))
1449 (choice :tag
"X Scale" number string
(const nil
))
1450 (choice :tag
"Y Scale" number string
(const nil
))
1451 (choice :tag
"Rotation" number string
(const nil
))
1452 (repeat :tag
"Pages" :inline t
1453 (radio (integer :tag
"Page")
1455 (integer :tag
"From")
1456 (integer :tag
"To"))))))
1457 :group
'ps-print-background
)
1459 (defcustom ps-print-background-text nil
1460 "*Text list to be printed on background.
1464 (STRING X Y FONT FONTSIZE GRAY ROTATION PAGES...)
1466 STRING is the text to be printed on background.
1468 X and Y are positions on paper to put the text.
1469 If X and Y are nil, the text is positioned at lower left corner.
1471 FONT is a font name to be used on printing the text.
1472 If nil, \"Times-Roman\" is used.
1474 FONTSIZE is font size to be used, if nil, 200 is used.
1476 GRAY is the text gray factor (should be very light like 0.8).
1477 If nil, the default is 0.85.
1479 ROTATION is the text rotation angle; if nil, the angle is given by
1480 the diagonal from lower left corner to upper right corner.
1482 PAGES designates the page to print background text.
1483 PAGES may be a number or a cons cell (FROM . TO) designating FROM page
1485 If PAGES is nil, print background text on all pages.
1487 X, Y, FONTSIZE, GRAY and ROTATION may be a floating point number,
1488 an integer number or a string. If it is a string, the string should contain
1489 PostScript programming that returns a float or integer value.
1491 For example, if you wish to print text \"Preliminary\" on all pages do:
1493 '((\"Preliminary\"))"
1494 :type
'(repeat (list (string :tag
"Text")
1495 (choice :tag
"X" number string
(const nil
))
1496 (choice :tag
"Y" number string
(const nil
))
1497 (choice :tag
"Font" string
(const nil
))
1498 (choice :tag
"Fontsize" number string
(const nil
))
1499 (choice :tag
"Gray" number string
(const nil
))
1500 (choice :tag
"Rotation" number string
(const nil
))
1501 (repeat :tag
"Pages" :inline t
1502 (radio (integer :tag
"Page")
1504 (integer :tag
"From")
1505 (integer :tag
"To"))))))
1506 :group
'ps-print-background
)
1508 ;;; Horizontal layout
1510 ;; ------------------------------------------
1512 ;; | lm | text | ic | text | ic | text | rm |
1514 ;; ------------------------------------------
1516 (defcustom ps-left-margin
(/ (* 72 2.0) 2.54) ; 2 cm
1517 "*Left margin in points (1/72 inch)."
1519 :group
'ps-print-horizontal
)
1521 (defcustom ps-right-margin
(/ (* 72 2.0) 2.54) ; 2 cm
1522 "*Right margin in points (1/72 inch)."
1524 :group
'ps-print-horizontal
)
1526 (defcustom ps-inter-column
(/ (* 72 2.0) 2.54) ; 2 cm
1527 "*Horizontal space between columns in points (1/72 inch)."
1529 :group
'ps-print-horizontal
)
1545 (defcustom ps-bottom-margin
(/ (* 72 1.5) 2.54) ; 1.5 cm
1546 "*Bottom margin in points (1/72 inch)."
1548 :group
'ps-print-vertical
)
1550 (defcustom ps-top-margin
(/ (* 72 1.5) 2.54) ; 1.5 cm
1551 "*Top margin in points (1/72 inch)."
1553 :group
'ps-print-vertical
)
1555 (defcustom ps-header-offset
(/ (* 72 1.0) 2.54) ; 1.0 cm
1556 "*Vertical space in points (1/72 inch) between the main text and the header."
1558 :group
'ps-print-vertical
)
1560 (defcustom ps-header-line-pad
0.15
1561 "*Portion of a header title line height to insert between the header frame
1562 and the text it contains, both in the vertical and horizontal directions."
1564 :group
'ps-print-vertical
)
1568 (defcustom ps-print-header t
1569 "*Non-nil means print a header at the top of each page.
1570 By default, the header displays the buffer name, page number, and, if
1571 the buffer is visiting a file, the file's directory. Headers are
1572 customizable by changing variables `ps-left-header' and
1575 :group
'ps-print-header
)
1577 (defcustom ps-print-only-one-header nil
1578 "*Non-nil means print only one header at the top of each page.
1579 This is useful when printing more than one column, so it is possible
1580 to have only one header over all columns or one header per column.
1581 See also `ps-print-header'."
1583 :group
'ps-print-header
)
1585 (defcustom ps-print-header-frame t
1586 "*Non-nil means draw a gaudy frame around the header."
1588 :group
'ps-print-header
)
1590 (defcustom ps-header-lines
2
1591 "*Number of lines to display in page header, when generating PostScript."
1593 :group
'ps-print-header
)
1594 (make-variable-buffer-local 'ps-header-lines
)
1596 (defcustom ps-show-n-of-n t
1597 "*Non-nil means show page numbers as N/M, meaning page N of M.
1598 NOTE: page numbers are displayed as part of headers,
1599 see variable `ps-print-headers'."
1601 :group
'ps-print-header
)
1603 (defcustom ps-spool-config
(if (memq system-type
'(ms-dos windows-nt
))
1606 "*Specify who is responsable for setting duplex and page size switches.
1610 `lpr-switches' duplex and page size are configured by `ps-lpr-switches'.
1611 Don't forget to set `ps-lpr-switches' to select duplex
1612 printing for your printer.
1614 `setpagedevice' duplex and page size are configured by ps-print using the
1615 setpagedevice PostScript operator.
1617 nil duplex and page size are configured by ps-print *not* using
1618 the setpagedevice PostScript operator.
1620 Any other value is treated as nil.
1622 WARNING: The setpagedevice PostScript operator affects ghostview utility when
1623 viewing file generated using landscape. Also on some printers,
1624 setpagedevice affects zebra stripes; on other printers, setpagedevice
1625 affects the left margin.
1626 Besides all that, if your printer does not have the paper size
1627 specified by setpagedevice, your printing will be aborted.
1628 So, if you need to use setpagedevice, set `ps-spool-config' to
1629 `setpagedevice', generate a test file and send it to your printer; if
1630 the printed file isn't ok, set `ps-spool-config' to nil."
1631 :type
'(choice :tag
"Spool Config"
1632 (const lpr-switches
) (const setpagedevice
)
1633 (other :tag
"nil" nil
))
1634 :group
'ps-print-header
)
1636 (defcustom ps-spool-duplex nil
; Not many people have duplex printers,
1637 ; so default to nil.
1638 "*Non-nil generates PostScript for a two-sided printer.
1639 For a duplex printer, the `ps-spool-*' and `ps-print-*' commands will insert
1640 blank pages as needed between print jobs so that the next buffer printed will
1641 start on the right page. Also, if headers are turned on, the headers will be
1642 reversed on duplex printers so that the page numbers fall to the left on
1643 even-numbered pages.
1645 See also `ps-spool-tumble'."
1647 :group
'ps-print-header
)
1649 (defcustom ps-spool-tumble nil
1650 "*Specify how the page images on opposite sides of a sheet are oriented.
1651 If `ps-spool-tumble' is nil, produces output suitable for binding on the left or
1652 right. If `ps-spool-tumble' is non-nil, produces output suitable for binding at
1655 It has effect only when `ps-spool-duplex' is non-nil."
1657 :group
'ps-print-header
)
1661 (defcustom ps-font-info-database
1662 '((Courier ; the family key
1663 (fonts (normal .
"Courier")
1664 (bold .
"Courier-Bold")
1665 (italic .
"Courier-Oblique")
1666 (bold-italic .
"Courier-BoldOblique"))
1668 (line-height .
10.55)
1670 (avg-char-width .
6.0))
1671 (Helvetica ; the family key
1672 (fonts (normal .
"Helvetica")
1673 (bold .
"Helvetica-Bold")
1674 (italic .
"Helvetica-Oblique")
1675 (bold-italic .
"Helvetica-BoldOblique"))
1677 (line-height .
11.56)
1678 (space-width .
2.78)
1679 (avg-char-width .
5.09243))
1681 (fonts (normal .
"Times-Roman")
1682 (bold .
"Times-Bold")
1683 (italic .
"Times-Italic")
1684 (bold-italic .
"Times-BoldItalic"))
1686 (line-height .
11.0)
1688 (avg-char-width .
4.71432))
1690 (fonts (normal .
"Palatino-Roman")
1691 (bold .
"Palatino-Bold")
1692 (italic .
"Palatino-Italic")
1693 (bold-italic .
"Palatino-BoldItalic"))
1695 (line-height .
12.1)
1697 (avg-char-width .
5.08676))
1699 (fonts (normal .
"Helvetica-Narrow")
1700 (bold .
"Helvetica-Narrow-Bold")
1701 (italic .
"Helvetica-Narrow-Oblique")
1702 (bold-italic .
"Helvetica-Narrow-BoldOblique"))
1704 (line-height .
11.56)
1705 (space-width .
2.2796)
1706 (avg-char-width .
4.17579))
1708 (fonts (normal .
"NewCenturySchlbk-Roman")
1709 (bold .
"NewCenturySchlbk-Bold")
1710 (italic .
"NewCenturySchlbk-Italic")
1711 (bold-italic .
"NewCenturySchlbk-BoldItalic"))
1713 (line-height .
12.15)
1714 (space-width .
2.78)
1715 (avg-char-width .
5.31162))
1716 ;; got no bold for the next ones
1718 (fonts (normal .
"AvantGarde-Book")
1719 (italic .
"AvantGarde-BookOblique"))
1721 (line-height .
11.77)
1722 (space-width .
2.77)
1723 (avg-char-width .
5.45189))
1725 (fonts (normal .
"AvantGarde-Demi")
1726 (italic .
"AvantGarde-DemiOblique"))
1728 (line-height .
12.72)
1730 (avg-char-width .
5.51351))
1732 (fonts (normal .
"Bookman-Demi")
1733 (italic .
"Bookman-DemiItalic"))
1735 (line-height .
11.77)
1737 (avg-char-width .
6.05946))
1739 (fonts (normal .
"Bookman-Light")
1740 (italic .
"Bookman-LightItalic"))
1742 (line-height .
11.79)
1744 (avg-char-width .
5.67027))
1745 ;; got no bold and no italic for the next ones
1747 (fonts (normal .
"Symbol"))
1749 (line-height .
13.03)
1751 (avg-char-width .
3.24324))
1753 (fonts (normal .
"Zapf-Dingbats"))
1755 (line-height .
9.63)
1756 (space-width .
2.78)
1757 (avg-char-width .
2.78))
1758 (Zapf-Chancery-MediumItalic
1759 (fonts (normal .
"Zapf-Chancery-MediumItalic"))
1761 (line-height .
11.45)
1763 (avg-char-width .
4.10811))
1765 "*Font info database: font family (the key), name, bold, italic, bold-italic,
1766 reference size, line height, space width, average character width.
1767 To get the info for another specific font (say Helvetica), do the following:
1768 - create a new buffer
1769 - generate the PostScript image to a file (C-u M-x ps-print-buffer)
1770 - open this file and delete the leading `%' (which is the PostScript
1771 comment character) from the line
1772 `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage'
1774 `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage'
1775 - add the values to `ps-font-info-database'.
1776 You can get all the fonts of YOUR printer using `ReportAllFontInfo'."
1777 :type
'(repeat (list :tag
"Font Definition"
1778 (symbol :tag
"Font Family")
1780 (const :format
"" fonts
)
1781 (repeat :tag
"Faces"
1782 (cons (choice (const normal
)
1786 (symbol :tag
"Face"))
1787 (string :tag
"Font Name"))))
1789 (const :format
"" size
)
1790 (number :tag
"Reference Size"))
1792 (const :format
"" line-height
)
1793 (number :tag
"Line Height"))
1795 (const :format
"" space-width
)
1796 (number :tag
"Space Width"))
1798 (const :format
"" avg-char-width
)
1799 (number :tag
"Average Character Width"))))
1800 :group
'ps-print-font
)
1802 (defcustom ps-font-family
'Courier
1803 "*Font family name for ordinary text, when generating PostScript."
1805 :group
'ps-print-font
)
1807 (defcustom ps-font-size
'(7 .
8.5)
1808 "*Font size, in points, for ordinary text, when generating PostScript."
1809 :type
'(choice (number :tag
"Text Size")
1810 (cons :tag
"Landscape/Portrait"
1811 (number :tag
"Landscape Text Size")
1812 (number :tag
"Portrait Text Size")))
1813 :group
'ps-print-font
)
1815 (defcustom ps-header-font-family
'Helvetica
1816 "*Font family name for text in the header, when generating PostScript."
1818 :group
'ps-print-font
)
1820 (defcustom ps-header-font-size
'(10 .
12)
1821 "*Font size, in points, for text in the header, when generating PostScript."
1822 :type
'(choice (number :tag
"Header Size")
1823 (cons :tag
"Landscape/Portrait"
1824 (number :tag
"Landscape Header Size")
1825 (number :tag
"Portrait Header Size")))
1826 :group
'ps-print-font
)
1828 (defcustom ps-header-title-font-size
'(12 .
14)
1829 "*Font size, in points, for the top line of text in header, in PostScript."
1830 :type
'(choice (number :tag
"Header Title Size")
1831 (cons :tag
"Landscape/Portrait"
1832 (number :tag
"Landscape Header Title Size")
1833 (number :tag
"Portrait Header Title Size")))
1834 :group
'ps-print-font
)
1838 ;; Printing color requires x-color-values.
1839 (defcustom ps-print-color-p
(or (fboundp 'x-color-values
) ; Emacs
1840 (fboundp 'color-instance-rgb-components
))
1842 "*Non-nil means print the buffer's text in color."
1844 :group
'ps-print-color
)
1846 (defcustom ps-default-fg
'(0.0
0.0 0.0)
1847 "*RGB values of the default foreground color. Defaults to black."
1848 :type
'(list (number :tag
"Red") (number :tag
"Green") (number :tag
"Blue"))
1849 :group
'ps-print-color
)
1851 (defcustom ps-default-bg
'(1.0
1.0 1.0)
1852 "*RGB values of the default background color. Defaults to white."
1853 :type
'(list (number :tag
"Red") (number :tag
"Green") (number :tag
"Blue"))
1854 :group
'ps-print-color
)
1856 (defcustom ps-auto-font-detect t
1857 "*Non-nil means automatically detect bold/italic face attributes.
1858 If nil, we rely solely on the lists `ps-bold-faces', `ps-italic-faces',
1859 and `ps-underlined-faces'."
1861 :group
'ps-print-font
)
1863 (defcustom ps-bold-faces
1864 (unless ps-print-color-p
1865 '(font-lock-function-name-face
1866 font-lock-builtin-face
1867 font-lock-variable-name-face
1868 font-lock-keyword-face
1869 font-lock-warning-face
))
1870 "*A list of the \(non-bold\) faces that should be printed in bold font.
1871 This applies to generating PostScript."
1872 :type
'(repeat face
)
1873 :group
'ps-print-face
)
1875 (defcustom ps-italic-faces
1876 (unless ps-print-color-p
1877 '(font-lock-variable-name-face
1879 font-lock-string-face
1880 font-lock-comment-face
1881 font-lock-warning-face
))
1882 "*A list of the \(non-italic\) faces that should be printed in italic font.
1883 This applies to generating PostScript."
1884 :type
'(repeat face
)
1885 :group
'ps-print-face
)
1887 (defcustom ps-underlined-faces
1888 (unless ps-print-color-p
1889 '(font-lock-function-name-face
1890 font-lock-constant-face
1891 font-lock-warning-face
))
1892 "*A list of the \(non-underlined\) faces that should be printed underlined.
1893 This applies to generating PostScript."
1894 :type
'(repeat face
)
1895 :group
'ps-print-face
)
1897 (defcustom ps-left-header
1898 (list 'ps-get-buffer-name
'ps-header-dirpart
)
1899 "*The items to display (each on a line) on the left part of the page header.
1900 This applies to generating PostScript.
1902 The value should be a list of strings and symbols, each representing an
1903 entry in the PostScript array HeaderLinesLeft.
1905 Strings are inserted unchanged into the array; those representing
1906 PostScript string literals should be delimited with PostScript string
1907 delimiters '(' and ')'.
1909 For symbols with bound functions, the function is called and should
1910 return a string to be inserted into the array. For symbols with bound
1911 values, the value should be a string to be inserted into the array.
1912 In either case, function or variable, the string value has PostScript
1913 string delimiters added to it."
1914 :type
'(repeat (choice string symbol
))
1915 :group
'ps-print-header
)
1916 (make-variable-buffer-local 'ps-left-header
)
1918 (defcustom ps-right-header
1919 (list "/pagenumberstring load" 'time-stamp-mon-dd-yyyy
'time-stamp-hh
:mm
:ss
)
1920 "*The items to display (each on a line) on the right part of the page header.
1921 This applies to generating PostScript.
1923 See the variable `ps-left-header' for a description of the format of
1925 :type
'(repeat (choice string symbol
))
1926 :group
'ps-print-header
)
1927 (make-variable-buffer-local 'ps-right-header
)
1929 (defcustom ps-razzle-dazzle t
1930 "*Non-nil means report progress while formatting buffer."
1934 (defcustom ps-adobe-tag
"%!PS-Adobe-3.0\n"
1935 "*Contains the header line identifying the output as PostScript.
1936 By default, `ps-adobe-tag' contains the standard identifier. Some
1937 printers require slightly different versions of this line."
1941 (defcustom ps-build-face-reference t
1942 "*Non-nil means build the reference face lists.
1944 ps-print sets this value to nil after it builds its internal reference
1945 lists of bold and italic faces. By settings its value back to t, you
1946 can force ps-print to rebuild the lists the next time you invoke one
1947 of the ...-with-faces commands.
1949 You should set this value back to t after you change the attributes of
1950 any face, or create new faces. Most users shouldn't have to worry
1951 about its setting, though."
1953 :group
'ps-print-face
)
1955 (defcustom ps-always-build-face-reference nil
1956 "*Non-nil means always rebuild the reference face lists.
1958 If this variable is non-nil, ps-print will rebuild its internal
1959 reference lists of bold and italic faces *every* time one of the
1960 ...-with-faces commands is called. Most users shouldn't need to set this
1963 :group
'ps-print-face
)
1965 (defcustom ps-banner-page-when-duplexing nil
1966 "*Non-nil means the very first page is skipped.
1967 It's like the very first character of buffer (or region) is ^L (\\014)."
1969 :group
'ps-print-header
)
1972 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1977 (defun ps-print-customize ()
1978 "Customization of ps-print group."
1980 (customize-group 'ps-print
))
1983 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1988 (defun ps-print-buffer (&optional filename
)
1989 "Generate and print a PostScript image of the buffer.
1991 Interactively, when you use a prefix argument (C-u), the command
1992 prompts the user for a file name, and saves the PostScript image
1993 in that file instead of sending it to the printer.
1995 Noninteractively, the argument FILENAME is treated as follows: if it
1996 is nil, send the image to the printer. If FILENAME is a string, save
1997 the PostScript image in a file with that name."
1998 (interactive (list (ps-print-preprint current-prefix-arg
)))
1999 (ps-print-without-faces (point-min) (point-max) filename
))
2003 (defun ps-print-buffer-with-faces (&optional filename
)
2004 "Generate and print a PostScript image of the buffer.
2005 Like `ps-print-buffer', but includes font, color, and underline
2006 information in the generated image. This command works only if you
2007 are using a window system, so it has a way to determine color values."
2008 (interactive (list (ps-print-preprint current-prefix-arg
)))
2009 (ps-print-with-faces (point-min) (point-max) filename
))
2013 (defun ps-print-region (from to
&optional filename
)
2014 "Generate and print a PostScript image of the region.
2015 Like `ps-print-buffer', but prints just the current region."
2016 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg
)))
2017 (ps-print-without-faces from to filename t
))
2021 (defun ps-print-region-with-faces (from to
&optional filename
)
2022 "Generate and print a PostScript image of the region.
2023 Like `ps-print-region', but includes font, color, and underline
2024 information in the generated image. This command works only if you
2025 are using a window system, so it has a way to determine color values."
2026 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg
)))
2027 (ps-print-with-faces from to filename t
))
2031 (defun ps-spool-buffer ()
2032 "Generate and spool a PostScript image of the buffer.
2033 Like `ps-print-buffer' except that the PostScript image is saved in a
2034 local buffer to be sent to the printer later.
2036 Use the command `ps-despool' to send the spooled images to the printer."
2038 (ps-spool-without-faces (point-min) (point-max)))
2042 (defun ps-spool-buffer-with-faces ()
2043 "Generate and spool a PostScript image of the buffer.
2044 Like `ps-spool-buffer', but includes font, color, and underline
2045 information in the generated image. This command works only if you
2046 are using a window system, so it has a way to determine color values.
2048 Use the command `ps-despool' to send the spooled images to the printer."
2050 (ps-spool-with-faces (point-min) (point-max)))
2054 (defun ps-spool-region (from to
)
2055 "Generate a PostScript image of the region and spool locally.
2056 Like `ps-spool-buffer', but spools just the current region.
2058 Use the command `ps-despool' to send the spooled images to the printer."
2060 (ps-spool-without-faces from to t
))
2064 (defun ps-spool-region-with-faces (from to
)
2065 "Generate a PostScript image of the region and spool locally.
2066 Like `ps-spool-region', but includes font, color, and underline
2067 information in the generated image. This command works only if you
2068 are using a window system, so it has a way to determine color values.
2070 Use the command `ps-despool' to send the spooled images to the printer."
2072 (ps-spool-with-faces from to t
))
2075 (defun ps-despool (&optional filename
)
2076 "Send the spooled PostScript to the printer.
2078 Interactively, when you use a prefix argument (C-u), the command
2079 prompts the user for a file name, and saves the spooled PostScript
2080 image in that file instead of sending it to the printer.
2082 Noninteractively, the argument FILENAME is treated as follows: if it
2083 is nil, send the image to the printer. If FILENAME is a string, save
2084 the PostScript image in a file with that name."
2085 (interactive (list (ps-print-preprint current-prefix-arg
)))
2086 (ps-do-despool filename
))
2089 (defun ps-line-lengths ()
2090 "Display the correspondence between a line length and a font size,
2091 using the current ps-print setup.
2092 Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"
2094 (ps-line-lengths-internal))
2097 (defun ps-nb-pages-buffer (nb-lines)
2098 "Display number of pages to print this buffer, for various font heights.
2099 The table depends on the current ps-print setup."
2100 (interactive (list (count-lines (point-min) (point-max))))
2101 (ps-nb-pages nb-lines
))
2104 (defun ps-nb-pages-region (nb-lines)
2105 "Display number of pages to print the region, for various font heights.
2106 The table depends on the current ps-print setup."
2107 (interactive (list (count-lines (mark) (point))))
2108 (ps-nb-pages nb-lines
))
2112 "Return the current PostScript-generation setup."
2115 \(setq ps-print-color-p %s
2119 ps-print-region-function %s
2122 ps-landscape-mode %s
2123 ps-number-of-columns %s
2126 ps-zebra-stripe-height %s
2130 ps-print-control-characters %s
2132 ps-print-background-image %s
2134 ps-print-background-text %s
2136 ps-print-prologue-header %s
2144 ps-header-line-pad %s
2146 ps-print-only-one-header %s
2147 ps-print-header-frame %s
2153 ps-banner-page-when-duplexing %s
2160 ps-multibyte-buffer %s
2163 ps-header-font-family %s
2164 ps-header-font-size %s
2165 ps-header-title-font-size %s)
2169 (ps-print-quote ps-lpr-switches
)
2171 (ps-print-quote ps-print-region-function
)
2172 (ps-print-quote ps-paper-type
)
2174 ps-number-of-columns
2176 ps-zebra-stripe-height
2179 (ps-print-quote ps-print-control-characters
)
2180 (ps-print-quote ps-print-background-image
)
2181 (ps-print-quote ps-print-background-text
)
2182 (ps-print-quote ps-print-prologue-header
)
2191 ps-print-only-one-header
2192 ps-print-header-frame
2195 (ps-print-quote ps-spool-config
)
2198 ps-banner-page-when-duplexing
2202 (ps-print-quote ps-n-up-filling
)
2203 (ps-print-quote ps-multibyte-buffer
) ; see `ps-mule.el'
2204 (ps-print-quote ps-font-family
)
2205 (ps-print-quote ps-font-size
)
2206 (ps-print-quote ps-header-font-family
)
2207 (ps-print-quote ps-header-font-size
)
2208 (ps-print-quote ps-header-title-font-size
)))
2211 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2212 ;; Utility functions and variables:
2215 (defun ps-print-quote (sym)
2218 ((or (symbolp sym
) (listp sym
))
2225 (defvar ps-print-emacs-type
2226 (cond ((string-match "XEmacs" emacs-version
) 'xemacs
)
2227 ((string-match "Lucid" emacs-version
) 'lucid
)
2228 ((string-match "Epoch" emacs-version
) 'epoch
)
2231 (if (or (eq ps-print-emacs-type
'lucid
)
2232 (eq ps-print-emacs-type
'xemacs
))
2233 (if (< emacs-minor-version
12)
2234 (setq ps-print-color-p nil
))
2235 (require 'faces
)) ; face-font, face-underline-p,
2238 ;; Return t if the device (which can be changed during an emacs session)
2239 ;; can handle colors.
2240 ;; This is function is not yet implemented for GNU emacs.
2241 (cond ((and (eq ps-print-emacs-type
'xemacs
)
2242 (>= emacs-minor-version
12)) ; xemacs
2243 (defun ps-color-device ()
2244 (eq (device-class) 'color
))
2248 (defun ps-color-device ()
2253 (require 'time-stamp
)
2255 (defconst ps-print-prologue-1
2257 % ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4:
2258 /ISOLatin1Encoding where { pop } {
2259 % -- The ISO Latin-1 encoding vector isn't known, so define it.
2260 % -- The first half is the same as the standard encoding,
2261 % -- except for minus instead of hyphen at code 055.
2263 StandardEncoding 0 45 getinterval aload pop
2265 StandardEncoding 46 82 getinterval aload pop
2266 %*** NOTE: the following are missing in the Adobe documentation,
2267 %*** but appear in the displayed table:
2268 %*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240.
2270 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
2271 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
2272 /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
2273 /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron
2275 /space /exclamdown /cent /sterling
2276 /currency /yen /brokenbar /section
2277 /dieresis /copyright /ordfeminine /guillemotleft
2278 /logicalnot /hyphen /registered /macron
2279 /degree /plusminus /twosuperior /threesuperior
2280 /acute /mu /paragraph /periodcentered
2281 /cedilla /onesuperior /ordmasculine /guillemotright
2282 /onequarter /onehalf /threequarters /questiondown
2284 /Agrave /Aacute /Acircumflex /Atilde
2285 /Adieresis /Aring /AE /Ccedilla
2286 /Egrave /Eacute /Ecircumflex /Edieresis
2287 /Igrave /Iacute /Icircumflex /Idieresis
2288 /Eth /Ntilde /Ograve /Oacute
2289 /Ocircumflex /Otilde /Odieresis /multiply
2290 /Oslash /Ugrave /Uacute /Ucircumflex
2291 /Udieresis /Yacute /Thorn /germandbls
2293 /agrave /aacute /acircumflex /atilde
2294 /adieresis /aring /ae /ccedilla
2295 /egrave /eacute /ecircumflex /edieresis
2296 /igrave /iacute /icircumflex /idieresis
2297 /eth /ntilde /ograve /oacute
2298 /ocircumflex /otilde /odieresis /divide
2299 /oslash /ugrave /uacute /ucircumflex
2300 /udieresis /yacute /thorn /ydieresis
2304 /reencodeFontISO { %def
2306 length 12 add dict % Make a new font (a new dict the same size
2307 % as the old one) with room for our new symbols.
2309 begin % Make the new font the current dictionary.
2313 { def } { pop pop } ifelse
2314 } forall % Copy each of the symbols from the old dictionary
2315 % to the new one except for the font ID.
2317 currentdict /FontType get 0 ne {
2318 /Encoding ISOLatin1Encoding def % Override the encoding with
2319 % the ISOLatin1 encoding.
2322 % Use the font's bounding box to determine the ascent, descent,
2323 % and overall height; don't forget that these values have to be
2324 % transformed using the font's matrix.
2331 % | | | | Ascent (usually > 0)
2333 % (0 0) -> +--+----+-------->
2335 % | | v Descent (usually < 0)
2336 % (x1 y1) --> +----+ - -
2338 currentdict /FontType get 0 ne {
2339 /FontBBox load aload pop % -- x1 y1 x2 y2
2340 FontMatrix transform /Ascent exch def pop
2341 FontMatrix transform /Descent exch def pop
2343 /PrimaryFont FDepVector 0 get def
2344 PrimaryFont /FontBBox get aload pop
2345 PrimaryFont /FontMatrix get transform /Ascent exch def pop
2346 PrimaryFont /FontMatrix get transform /Descent exch def pop
2349 /FontHeight Ascent Descent sub def % use `sub' because descent < 0
2351 % Define these in case they're not in the FontInfo
2352 % (also, here they're easier to get to).
2353 /UnderlinePosition Descent 0.70 mul def
2354 /OverlinePosition Descent UnderlinePosition sub Ascent add def
2355 /StrikeoutPosition Ascent 0.30 mul def
2356 /LineThickness FontHeight 0.05 mul def
2357 /Xshadow FontHeight 0.08 mul def
2358 /Yshadow FontHeight -0.09 mul def
2359 /SpaceBackground Descent neg UnderlinePosition add def
2360 /XBox Descent neg def
2361 /YBox LineThickness 0.7 mul def
2363 currentdict % Leave the new font on the stack
2364 end % Stop using the font as the current dictionary.
2365 definefont % Put the font into the font dictionary
2366 pop % Discard the returned font.
2369 /DefFont { % Font definition
2370 findfont exch scalefont reencodeFontISO
2373 /F { % Font selection
2375 dup /Ascent get /Ascent exch def
2376 dup /Descent get /Descent exch def
2377 dup /FontHeight get /FontHeight exch def
2378 dup /UnderlinePosition get /UnderlinePosition exch def
2379 dup /OverlinePosition get /OverlinePosition exch def
2380 dup /StrikeoutPosition get /StrikeoutPosition exch def
2381 dup /LineThickness get /LineThickness exch def
2382 dup /Xshadow get /Xshadow exch def
2383 dup /Yshadow get /Yshadow exch def
2384 dup /SpaceBackground get /SpaceBackground exch def
2385 dup /XBox get /XBox exch def
2386 dup /YBox get /YBox exch def
2390 /FG /setrgbcolor load def
2403 % | Ascent (usually > 0)
2405 % | Descent (usually < 0)
2409 /dobackground { % width --
2410 currentpoint % -- width x y
2414 0 Ascent rmoveto % B
2416 0 Descent Ascent sub rlineto % D
2419 bgcolor aload pop setrgbcolor
2424 /eolbg { % dobackground until right margin
2425 PrintWidth % -- x-eol
2426 currentpoint pop % -- cur-x
2427 sub % -- width until eol
2431 /PLN {PrintLineNumber {doLineNumber}if} def
2433 /SL { % Soft Linefeed
2435 0 currentpoint exch pop LineHeight sub moveto
2438 /HL {SL PLN} def % Hard Linefeed
2441 /dcp { currentpoint exch 40 string cvs print (, ) print = } def
2442 /dp { print 2 copy exch 40 string cvs print (, ) print = } def
2445 ( ) stringwidth % Get the width of a space in the current font.
2446 pop % Discard the Y component.
2447 mul % Multiply the width of a space
2448 % by the number of spaces to plot
2449 bg { dup dobackground } if
2454 /EF {/Effect exch def} def
2456 % stack: string |- --
2457 % effect: 1 - underline 2 - strikeout 4 - overline
2458 % 8 - shadow 16 - box 32 - outline
2460 /xx currentpoint dup Descent add /yy exch def
2461 Ascent add /YY exch def def
2462 dup stringwidth pop xx add /XX exch def
2464 /yy yy Yshadow add def
2465 /XX XX Xshadow add def
2470 {SpaceBackground doBox}
2471 {xx yy XX YY doRect}
2474 Effect 16 and 0 ne {false 0 doBox}if % box
2475 Effect 8 and 0 ne {dup doShadow}if % shadow
2477 {true doOutline} % outline
2478 {show} % normal text
2480 Effect 1 and 0 ne {UnderlinePosition Hline}if % underline
2481 Effect 2 and 0 ne {StrikeoutPosition Hline}if % strikeout
2482 Effect 4 and 0 ne {OverlinePosition Hline}if % overline
2485 % stack: position |- --
2487 currentpoint exch pop add dup
2493 LineThickness setlinewidth stroke
2497 % stack: fill-or-not delta |- --
2500 xx XBox sub dd sub yy YBox sub dd sub
2501 XX XBox add dd add YY YBox add dd add
2505 % stack: fill-or-not lower-x lower-y upper-x upper-y |- --
2518 % top of stack: fill-or-not
2520 {LineThickness setlinewidth stroke}
2525 % stack: string |- --
2528 Xshadow Yshadow rmoveto
2535 % stack: string fill-or-not |- --
2538 /-ox- currentpoint /-oy- exch def def
2540 LineThickness setlinewidth
2543 st dup true charpath
2544 -fillp- {gsave FillBgColor grestore}if
2546 -oy- add /-oy- exch def
2547 -ox- add /-ox- exch def
2555 /FillBgColor {bgcolor aload pop setrgbcolor fill} bind def
2557 /L0 6 /Times-Italic DefFont
2566 0.0 0.0 0.0 setrgbcolor
2567 /L0 findfont setfont
2570 {LineNumber 6 string cvs ( ) strcat}
2572 dup stringwidth pop neg 0 rmoveto
2576 /LineNumber LineNumber 1 add def
2584 /double-zebra ZebraHeight ZebraHeight add def
2585 /yiter double-zebra LineHeight mul neg def
2586 /xiter PrintWidth InterColumn add def
2587 NumberOfColumns {LinesPerColumn doColumnZebra xiter 0 rmoveto}repeat
2591 % stack: lines-per-column |- --
2594 dup double-zebra idiv {ZebraHeight doZebra 0 yiter rmoveto}repeat
2596 dup 0 le {pop}{dup ZebraHeight gt {pop ZebraHeight}if doZebra}ifelse
2600 % stack: zebra-height (in lines) |- --
2602 /zh exch 0.05 sub LineHeight mul def
2604 0 LineHeight 0.65 mul rmoveto
2605 PrintWidth 0 rlineto
2607 PrintWidth neg 0 rlineto
2613 % tx ty rotation xscale yscale xpos ypos BeginBackImage
2615 /-save-image- save def
2624 -save-image- restore
2627 % string fontsize fontname rotation gray xpos ypos ShowBackText
2633 findfont exch dup /-offset- exch -0.25 mul def scalefont setfont
2635 /-saveLineThickness- LineThickness def
2636 /LineThickness 1 def
2638 /LineThickness -saveLineThickness- def
2643 % ---- Remember space width of the normal text font `f0'.
2644 /SpaceWidth /f0 findfont setfont ( ) stringwidth pop def
2645 % ---- save the state of the document (useful for ghostscript!)
2647 % ---- [andrewi] set PageSize based on chosen dimensions
2650 {<< /PageSize [PageWidth LandscapePageHeight] >> setpagedevice}
2654 % ---- translate to bottom-right corner of Portrait page
2655 LandscapePageHeight 0 translate
2659 % ---- [jack] Kludge: my ghostscript window is 21x27.7 instead of 21x29.7
2660 /JackGhostscript where {pop 1 27.7 29.7 div scale}if
2661 % ---- N-Up printing
2665 PageWidth 0 translate
2668 N-Up-Margin dup translate
2672 /WW LandscapePageHeight def
2674 /HH LandscapePageHeight def
2677 WW N-Up-Margin sub N-Up-Margin sub
2679 {N-Up-Lines div HH}{N-Up-Columns N-Up-Missing add div WW}ifelse
2681 0 N-Up-Repeat 1 sub LandscapePageHeight mul translate
2682 % ---- go to start position in page matrix
2683 N-Up-XStart N-Up-Missing 0.5 mul
2685 LandscapePageHeight mul N-Up-YStart add
2687 PageWidth mul add N-Up-YStart
2691 /ColumnWidth PrintWidth InterColumn add def
2692 % ---- translate to lower left corner of TEXT
2693 LeftMargin BottomMargin translate
2694 % ---- define where printing will start
2695 /f0 F % this installs Ascent
2696 /PrintStartY PrintHeight Ascent sub def
2698 /N-Up-Counter N-Up-End 1 sub def
2699 SkipFirstPage{save showpage restore}if
2703 % ---- restore the state of the document (useful for ghostscript!)
2708 % ---- when 1st column, save the state of the page
2712 % ---- save the state of the column
2713 /columnState save def
2716 /PrintHeaderWidth PrintOnlyOneHeader{PrintPageWidth}{PrintWidth}ifelse def
2719 % ---- when 1st column, print all background effects
2721 0 PrintStartY moveto % move to where printing will start
2722 Zebra {printZebra}if
2723 printGlobalBackground
2724 printLocalBackground
2727 PrintOnlyOneHeader{ColumnIndex 1 eq}{true}ifelse {
2728 PrintHeaderFrame {HeaderFrame}if
2732 0 PrintStartY moveto % move to where printing will start
2741 ColumnIndex NumberOfColumns eq {
2742 % ---- restore the state of the page
2745 % ---- N-up printing
2748 % ---- Next page on same row
2749 /N-Up-Counter N-Up-Counter 1 sub def
2750 N-Up-XColumn N-Up-YColumn
2752 % ---- Next page on next line
2753 /N-Up-Counter N-Up-End 1 sub def
2754 N-Up-XLine N-Up-YLine
2759 % ---- restore the state of the current column
2761 % ---- and translate to the next column
2762 ColumnWidth 0 translate
2763 /ColumnIndex ColumnIndex 1 add def
2767 % stack: number-of-pages-per-sheet |- --
2769 /sheetState save def
2770 /pages-per-sheet exch def
2771 % ---- N-up printing
2772 N-Up 1 gt N-Up-Border and pages-per-sheet 0 gt and {
2776 LeftMargin neg BottomMargin neg moveto
2781 0 LandscapePageHeight rlineto
2782 PageWidth neg 0 rlineto
2785 /pages-per-sheet pages-per-sheet 1 sub def
2786 pages-per-sheet 0 le{exit}if
2787 N-Up-XColumn N-Up-YColumn rmoveto
2789 pages-per-sheet 0 le{exit}if
2790 N-Up-XLine N-Up-XColumn sub N-Up-YLine rmoveto
2801 /SetHeaderLines { % nb-lines --
2802 /HeaderLines exch def
2805 HeaderLines 1 sub HeaderLineHeight mul add
2806 HeaderTitleLineHeight add
2808 /HeaderHeight exch def
2815 % |-+-------| <-- (x y)
2819 % |-+-------| <-- (0 0)
2823 /HeaderFrameStart { % -- x y
2824 0 PrintHeight HeaderOffset add
2828 PrintHeaderWidth 0 rlineto
2829 0 HeaderHeight rlineto
2830 PrintHeaderWidth neg 0 rlineto
2831 0 HeaderHeight neg rlineto
2837 % ---- fill a black rectangle (the shadow of the next one)
2838 HeaderFrameStart moveto
2842 % ---- do the next rectangle ...
2843 HeaderFrameStart moveto
2845 gsave 0.9 setgray fill grestore % filled with grey
2846 gsave 0 setgray stroke grestore % drawn with black
2852 exch HeaderPad add exch % horizontal pad
2854 HeaderPad add % vertical pad
2856 HeaderLineHeight HeaderLines 1 sub mul add
2860 dup length 3 -1 roll dup length dup 4 -1 roll add string dup
2861 0 5 -1 roll putinterval
2862 dup 4 2 roll exch putinterval
2866 PageNumber 32 string cvs
2869 PageCount 32 string cvs strcat
2876 HeaderLinesRight HeaderLinesLeft % -- rightLines leftLines
2878 % ---- hack: `PN 1 and' == `PN 2 modulo'
2880 % ---- if even page number and duplex, then exchange left and right
2881 PageNumber 1 and 0 eq DuplexValue and { exch } if
2883 { % ---- process the left lines
2887 dup xcheck { exec } if
2890 0 HeaderLineHeight neg rmoveto
2895 { % ---- process the right lines
2899 dup xcheck { exec } if
2901 PrintHeaderWidth exch sub HeaderPad 2 mul sub 0 rmoveto
2904 0 HeaderLineHeight neg rmoveto
2910 /t0 3 1 roll DefFont
2913 /sw ( ) stringwidth pop def
2914 /aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch
2915 stringwidth pop exch div def
2916 /t1 12 /Helvetica-Oblique DefFont
2919 (languagelevel = ) show
2920 gs_languagelevel 32 string cvs show
2922 0 FontHeight neg rmoveto
2928 ( point, the line height is ) show
2929 lh 32 string cvs show
2930 (, the space width is ) show
2931 sw 32 string cvs show
2934 0 FontHeight neg rmoveto
2936 (and a crude estimate of average character width is ) show
2937 aw 32 string cvs show
2940 0 FontHeight neg rmoveto
2947 /ReportAllFontInfo {
2949 { % key = font name value = font dictionary
2950 pop 10 exch ReportFontInfo
2954 % 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage
2955 % 3 cm 20 cm moveto ReportAllFontInfo showpage
2958 [(This PostScript printer is not configured with this document page size.)
2959 (Duplex printing is not supported on this PostScript printer.)]def
2961 % stack: error-index proc |- --
2964 1 cm LandscapePageHeight 0.5 mul moveto
2965 /Courier findfont 10 scalefont setfont
2967 (ps-print error:) show
2970 ErrorMessages exch get show
2972 $error /newerror false put
2979 (defconst ps-print-prologue-2
2981 % ---- These lines must be kept together because...
2984 /HeaderTitleLineHeight FontHeight def
2987 /HeaderLineHeight FontHeight def
2988 /HeaderDescent Descent def
2990 % ---- ...because `F' has a side-effect on `FontHeight' and `Descent'
2994 (defconst ps-print-duplex-feature
2996 % --- duplex feature verification
2999 {<< /Duplex DuplexValue /Tumble TumbleValue >> setpagedevice}
3002 DuplexValue setduplexmode TumbleValue settumble
3008 ;; Start Editing Here:
3010 (defvar ps-source-buffer nil
)
3011 (defvar ps-spool-buffer-name
"*PostScript*")
3012 (defvar ps-spool-buffer nil
)
3014 (defvar ps-output-head nil
)
3015 (defvar ps-output-tail nil
)
3017 (defvar ps-page-postscript
0)
3018 (defvar ps-page-order
0)
3019 (defvar ps-page-count
0)
3020 (defvar ps-showline-count
1)
3022 (defvar ps-control-or-escape-regexp nil
)
3024 (defvar ps-background-pages nil
)
3025 (defvar ps-background-all-pages nil
)
3026 (defvar ps-background-text-count
0)
3027 (defvar ps-background-image-count
0)
3029 (defvar ps-current-font
0)
3030 (defvar ps-default-color
(and ps-print-color-p ps-default-fg
)) ; black
3031 (defvar ps-current-color ps-default-color
)
3032 (defvar ps-current-bg nil
)
3034 (defvar ps-razchunk
0)
3036 (defvar ps-color-p nil
)
3037 (defvar ps-color-format
3038 (if (eq ps-print-emacs-type
'emacs
)
3040 ;; Emacs understands the %f format; we'll use it to limit color RGB
3041 ;; values to three decimals to cut down some on the size of the
3042 ;; PostScript output.
3045 ;; Lucid emacsen will have to make do with %s (princ) for floats.
3048 ;; These values determine how much print-height to deduct when headers
3049 ;; are turned on. This is a pretty clumsy way of handling it, but
3050 ;; it'll do for now.
3052 (defvar ps-header-pad
0
3053 "Vertical and horizontal space between the header frame and the text.
3054 This is in units of points (1/72 inch).")
3056 ;; Define accessors to the dimensions list.
3058 (defmacro ps-page-dimensions-get-width
(dims) `(nth 0 ,dims
))
3059 (defmacro ps-page-dimensions-get-height
(dims) `(nth 1 ,dims
))
3060 (defmacro ps-page-dimensions-get-media
(dims) `(nth 2 ,dims
))
3062 (defvar ps-landscape-page-height nil
)
3064 (defvar ps-print-width nil
)
3065 (defvar ps-print-height nil
)
3067 (defvar ps-height-remaining nil
)
3068 (defvar ps-width-remaining nil
)
3070 (defvar ps-print-color-scale nil
)
3072 (defvar ps-font-size-internal nil
)
3073 (defvar ps-header-font-size-internal nil
)
3074 (defvar ps-header-title-font-size-internal nil
)
3077 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3078 ;; Internal Variables
3081 (defvar ps-print-face-extension-alist nil
3082 "Alist of symbolic faces *WITH* extension features (box, outline, etc).
3083 An element of this list has the following form:
3085 (FACE . [BITS FG BG])
3087 FACE is a symbol denoting a face name
3088 BITS is a bit vector, where each bit correspond
3089 to a feature (bold, underline, etc)
3090 (see documentation for `ps-print-face-map-alist')
3091 FG foreground color (string or nil)
3092 BG background color (string or nil)
3094 Don't change this list directly; instead,
3095 use `ps-extend-face' and `ps-extend-face-list'.
3096 See documentation for `ps-extend-face' for valid extension symbol.")
3099 (defvar ps-print-face-alist nil
3100 "Alist of symbolic faces *WITHOUT* extension features (box, outline, etc).
3102 An element of this list has the same form as an element of
3103 `ps-print-face-extension-alist'.
3105 Don't change this list directly; this list is used by `ps-face-attributes',
3106 `ps-map-face' and `ps-build-reference-face-lists'.")
3109 (defconst ps-print-face-map-alist
3118 "Alist of all features and the corresponding bit mask.
3119 Each symbol correspond to one bit in a bit vector.")
3122 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3127 (defun ps-extend-face-list (face-extension-list &optional merge-p
)
3128 "Extend face in `ps-print-face-extension-alist'.
3130 If optional MERGE-P is non-nil, extensions in FACE-EXTENSION-LIST are merged
3131 with face extension in `ps-print-face-extension-alist'; otherwise, overrides.
3133 The elements in FACE-EXTENSION-LIST is like those for `ps-extend-face'.
3135 See `ps-extend-face' for documentation."
3136 (while face-extension-list
3137 (ps-extend-face (car face-extension-list
) merge-p
)
3138 (setq face-extension-list
(cdr face-extension-list
))))
3142 (defun ps-extend-face (face-extension &optional merge-p
)
3143 "Extend face in `ps-print-face-extension-alist'.
3145 If optional MERGE-P is non-nil, extensions in FACE-EXTENSION list are merged
3146 with face extensions in `ps-print-face-extension-alist'; otherwise, overrides.
3148 The elements of FACE-EXTENSION list have the form:
3150 (FACE-NAME FOREGROUND BACKGROUND EXTENSION...)
3152 FACE-NAME is a face name symbol.
3154 FOREGROUND and BACKGROUND may be nil or a string that denotes the
3155 foreground and background colors respectively.
3157 EXTENSION is one of the following symbols:
3158 bold - use bold font.
3159 italic - use italic font.
3160 underline - put a line under text.
3161 strikeout - like underline, but the line is in middle of text.
3162 overline - like underline, but the line is over the text.
3163 shadow - text will have a shadow.
3164 box - text will be surrounded by a box.
3165 outline - print characters as hollow outlines.
3167 If EXTENSION is any other symbol, it is ignored."
3168 (let* ((face-name (nth 0 face-extension
))
3169 (foreground (nth 1 face-extension
))
3170 (background (nth 2 face-extension
))
3171 (ps-face (cdr (assq face-name ps-print-face-extension-alist
)))
3172 (face-vector (or ps-face
(vector 0 nil nil
)))
3173 (face-bit (ps-extension-bit face-extension
)))
3175 (aset face-vector
0 (if merge-p
3176 (logior (aref face-vector
0) face-bit
)
3178 (and foreground
(stringp foreground
) (aset face-vector
1 foreground
))
3179 (and background
(stringp background
) (aset face-vector
2 background
))
3180 ;; if face does not exist, insert it
3182 (setq ps-print-face-extension-alist
3183 (cons (cons face-name face-vector
)
3184 ps-print-face-extension-alist
)))))
3187 (defun ps-extension-bit (face-extension)
3189 ;; map valid symbol extension to bit vector
3190 (setq face-extension
(cdr (cdr face-extension
)))
3191 (while (setq face-extension
(cdr face-extension
))
3192 (setq face-bit
(logior face-bit
3193 (or (cdr (assq (car face-extension
)
3194 ps-print-face-map-alist
))
3199 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3200 ;; Adapted from font-lock: (obsolete stuff)
3201 ;; Originally face attributes were specified via `font-lock-face-attributes'.
3202 ;; Users then changed the default face attributes by setting that variable.
3203 ;; However, we try and be back-compatible and respect its value if set except
3204 ;; for faces where M-x customize has been used to save changes for the face.
3207 (defun ps-font-lock-face-attributes ()
3208 (and (boundp 'font-lock-mode
) (symbol-value 'font-lock-mode
)
3209 (boundp 'font-lock-face-attributes
)
3210 (let ((face-attributes font-lock-face-attributes
))
3211 (while face-attributes
3212 (let* ((face-attribute
3213 (car (prog1 face-attributes
3214 (setq face-attributes
(cdr face-attributes
)))))
3215 (face (car face-attribute
)))
3216 ;; Rustle up a `defface' SPEC from a
3217 ;; `font-lock-face-attributes' entry.
3218 (unless (get face
'saved-face
)
3219 (let ((foreground (nth 1 face-attribute
))
3220 (background (nth 2 face-attribute
))
3221 (bold-p (nth 3 face-attribute
))
3222 (italic-p (nth 4 face-attribute
))
3223 (underline-p (nth 5 face-attribute
))
3226 (setq face-spec
(cons ':foreground
3227 (cons foreground face-spec
))))
3229 (setq face-spec
(cons ':background
3230 (cons background face-spec
))))
3232 (setq face-spec
(append '(:bold t
) face-spec
)))
3234 (setq face-spec
(append '(:italic t
) face-spec
)))
3236 (setq face-spec
(append '(:underline t
) face-spec
)))
3237 (custom-declare-face face
(list (list t face-spec
)) nil
)
3241 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3242 ;; Internal functions and variables
3245 (make-local-hook 'ps-print-hook
)
3246 (make-local-hook 'ps-print-begin-sheet-hook
)
3247 (make-local-hook 'ps-print-begin-page-hook
)
3248 (make-local-hook 'ps-print-begin-column-hook
)
3251 (defun ps-print-without-faces (from to
&optional filename region-p
)
3252 (ps-spool-without-faces from to region-p
)
3253 (ps-do-despool filename
))
3256 (defun ps-spool-without-faces (from to
&optional region-p
)
3257 (run-hooks 'ps-print-hook
)
3258 (ps-printing-region region-p
)
3259 (ps-generate (current-buffer) from to
'ps-generate-postscript
))
3262 (defun ps-print-with-faces (from to
&optional filename region-p
)
3263 (ps-spool-with-faces from to region-p
)
3264 (ps-do-despool filename
))
3267 (defun ps-spool-with-faces (from to
&optional region-p
)
3268 (run-hooks 'ps-print-hook
)
3269 (ps-printing-region region-p
)
3270 (ps-generate (current-buffer) from to
'ps-generate-postscript-with-faces
))
3273 (defun ps-count-lines (from to
)
3274 (+ (count-lines from to
)
3277 (if (= (current-column) 0) 1 0))))
3280 (defvar ps-printing-region nil
3281 "Variable used to indicate if the region that ps-print is printing.
3282 It is a cons, the car of which is the line number where the region begins, and
3283 its cdr is the total number of lines in the buffer. Formatting functions can
3284 use this information to print the original line number (and not the number of
3285 lines printed), and to indicate in the header that the printout is of a partial
3289 (defvar ps-printing-region-p nil
3290 "Non-nil means ps-print is printing a region.")
3293 (defun ps-printing-region (region-p)
3294 (setq ps-printing-region-p region-p
3297 (ps-count-lines (point-min) (region-beginning))
3299 (ps-count-lines (point-min) (point-max)))))
3302 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3303 ;; Internal functions
3306 (defsubst ps-font-alist
(font-sym)
3307 (get font-sym
'fonts
))
3309 (defun ps-font (font-sym font-type
)
3310 "Font family name for text of `font-type', when generating PostScript."
3311 (let* ((font-list (ps-font-alist font-sym
))
3312 (normal-font (cdr (assq 'normal font-list
))))
3313 (while (and font-list
(not (eq font-type
(car (car font-list
)))))
3314 (setq font-list
(cdr font-list
)))
3315 (or (cdr (car font-list
)) normal-font
)))
3317 (defun ps-fonts (font-sym)
3318 (mapcar 'cdr
(ps-font-alist font-sym
)))
3320 (defun ps-font-number (font-sym font-type
)
3321 (or (ps-alist-position font-type
(ps-font-alist font-sym
))
3324 (defsubst ps-line-height
(font-sym)
3325 "The height of a line, for generating PostScript.
3326 This is the value that ps-print uses to determine the height,
3327 y-dimension, of the lines of text it has printed, and thus affects the
3328 point at which page-breaks are placed.
3329 The line-height is *not* the same as the point size of the font."
3330 (get font-sym
'line-height
))
3332 (defsubst ps-title-line-height
(font-sym)
3333 "The height of a `title' line, for generating PostScript.
3334 This is the value that ps-print uses to determine the height,
3335 y-dimension, of the lines of text it has printed, and thus affects the
3336 point at which page-breaks are placed.
3337 The title-line-height is *not* the same as the point size of the font."
3338 (get font-sym
'title-line-height
))
3340 (defsubst ps-space-width
(font-sym)
3341 "The width of a space character, for generating PostScript.
3342 This value is used in expanding tab characters."
3343 (get font-sym
'space-width
))
3345 (defsubst ps-avg-char-width
(font-sym)
3346 "The average width, in points, of a character, for generating PostScript.
3347 This is the value that ps-print uses to determine the length,
3348 x-dimension, of the text it has printed, and thus affects the point at
3349 which long lines wrap around."
3350 (get font-sym
'avg-char-width
))
3352 (defun ps-line-lengths-internal ()
3353 "Display the correspondence between a line length and a font size,
3354 using the current ps-print setup.
3355 Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"
3356 (let ((buf (get-buffer-create "*Line-lengths*"))
3357 (ifs ps-font-size-internal
) ; initial font size
3358 (icw (ps-avg-char-width 'ps-font-for-text
)) ; initial character width
3359 (print-width (progn (ps-get-page-dimensions)
3361 (ps-setup (ps-setup)) ; setup for the current buffer
3362 (fs-min 5) ; minimum font size
3363 cw-min
; minimum character width
3364 nb-cpl-max
; maximum nb of characters per line
3365 (fs-max 14) ; maximum font size
3366 cw-max
; maximum character width
3367 nb-cpl-min
; minimum nb of characters per line
3368 fs
; current font size
3369 cw
; current character width
3370 nb-cpl
; current nb of characters per line
3372 (setq cw-min
(/ (* icw fs-min
) ifs
)
3373 nb-cpl-max
(floor (/ print-width cw-min
))
3374 cw-max
(/ (* icw fs-max
) ifs
)
3375 nb-cpl-min
(floor (/ print-width cw-max
))
3378 (goto-char (point-max))
3379 (or (bolp) (insert "\n"))
3381 "nb char per line / font size\n")
3382 (while (<= nb-cpl nb-cpl-max
)
3383 (setq cw
(/ print-width
(float nb-cpl
))
3384 fs
(/ (* ifs cw
) icw
))
3385 (insert (format "%3s %s\n" nb-cpl fs
))
3386 (setq nb-cpl
(1+ nb-cpl
)))
3388 (display-buffer buf
'not-this-window
)))
3390 (defun ps-nb-pages (nb-lines)
3391 "Display correspondence between font size and the number of pages.
3392 The correspondence is based on having NB-LINES lines of text,
3393 and on the current ps-print setup."
3394 (let ((buf (get-buffer-create "*Nb-Pages*"))
3395 (ifs ps-font-size-internal
) ; initial font size
3396 (ilh (ps-line-height 'ps-font-for-text
)) ; initial line height
3397 (page-height (progn (ps-get-page-dimensions)
3399 (ps-setup (ps-setup)) ; setup for the current buffer
3400 (fs-min 4) ; minimum font size
3401 lh-min
; minimum line height
3402 nb-lpp-max
; maximum nb of lines per page
3403 nb-page-min
; minimum nb of pages
3404 (fs-max 14) ; maximum font size
3405 lh-max
; maximum line height
3406 nb-lpp-min
; minimum nb of lines per page
3407 nb-page-max
; maximum nb of pages
3408 fs
; current font size
3409 lh
; current line height
3410 nb-lpp
; current nb of lines per page
3411 nb-page
; current nb of pages
3413 (setq lh-min
(/ (* ilh fs-min
) ifs
)
3414 nb-lpp-max
(floor (/ page-height lh-min
))
3415 nb-page-min
(ceiling (/ (float nb-lines
) nb-lpp-max
))
3416 lh-max
(/ (* ilh fs-max
) ifs
)
3417 nb-lpp-min
(floor (/ page-height lh-max
))
3418 nb-page-max
(ceiling (/ (float nb-lines
) nb-lpp-min
))
3419 nb-page nb-page-min
)
3421 (goto-char (point-max))
3422 (or (bolp) (insert "\n"))
3424 (format "%d lines\n" nb-lines
)
3425 "nb page / font size\n")
3426 (while (<= nb-page nb-page-max
)
3427 (setq nb-lpp
(ceiling (/ nb-lines
(float nb-page
)))
3428 lh
(/ page-height nb-lpp
)
3429 fs
(/ (* ifs lh
) ilh
))
3430 (insert (format "%s %s\n" nb-page fs
))
3431 (setq nb-page
(1+ nb-page
)))
3433 (display-buffer buf
'not-this-window
)))
3435 ;; macros used in `ps-select-font'
3436 (defmacro ps-lookup
(key) `(cdr (assq ,key font-entry
)))
3437 (defmacro ps-size-scale
(key) `(/ (* (ps-lookup ,key
) font-size
) size
))
3439 (defun ps-select-font (font-family sym font-size title-font-size
)
3440 (let ((font-entry (cdr (assq font-family ps-font-info-database
))))
3442 (error "Don't have data to scale font %s. Known fonts families are %s"
3444 (mapcar 'car ps-font-info-database
)))
3445 (let ((size (ps-lookup 'size
)))
3446 (put sym
'fonts
(ps-lookup 'fonts
))
3447 (put sym
'space-width
(ps-size-scale 'space-width
))
3448 (put sym
'avg-char-width
(ps-size-scale 'avg-char-width
))
3449 (put sym
'line-height
(ps-size-scale 'line-height
))
3450 (put sym
'title-line-height
3451 (/ (* (ps-lookup 'line-height
) title-font-size
) size
)))))
3453 (defun ps-get-page-dimensions ()
3454 (let ((page-dimensions (cdr (assq ps-paper-type ps-page-dimensions-database
)))
3455 page-width page-height
)
3457 ((null page-dimensions
)
3458 (error "`ps-paper-type' must be one of:\n%s"
3459 (mapcar 'car ps-page-dimensions-database
)))
3460 ((< ps-number-of-columns
1)
3461 (error "The number of columns %d should be positive"
3462 ps-number-of-columns
)))
3464 (ps-select-font ps-font-family
'ps-font-for-text
3465 ps-font-size-internal ps-font-size-internal
)
3466 (ps-select-font ps-header-font-family
'ps-font-for-header
3467 ps-header-font-size-internal
3468 ps-header-title-font-size-internal
)
3470 (setq page-width
(ps-page-dimensions-get-width page-dimensions
)
3471 page-height
(ps-page-dimensions-get-height page-dimensions
))
3474 (if ps-landscape-mode
3475 ;; exchange width and height
3476 (setq page-width
(prog1 page-height
(setq page-height page-width
))))
3478 ;; It is used to get the lower right corner (only in landscape mode)
3479 (setq ps-landscape-page-height page-height
)
3481 ;; | lm | text | ic | text | ic | text | rm |
3482 ;; page-width == lm + n * pw + (n - 1) * ic + rm
3483 ;; => pw == (page-width - lm -rm - (n - 1) * ic) / n
3484 (setq ps-print-width
(/ (- page-width
3485 ps-left-margin ps-right-margin
3486 (* (1- ps-number-of-columns
) ps-inter-column
))
3487 ps-number-of-columns
))
3488 (if (<= ps-print-width
0)
3489 (error "Bad horizontal layout:
3491 ps-left-margin == %s
3492 ps-right-margin == %s
3493 ps-inter-column == %s
3494 ps-number-of-columns == %s
3495 | lm | text | ic | text | ic | text | rm |
3496 page-width == lm + n * print-width + (n - 1) * ic + rm
3497 => print-width == %d !"
3502 ps-number-of-columns
3505 (setq ps-print-height
3506 (- page-height ps-bottom-margin ps-top-margin
))
3507 (if (<= ps-print-height
0)
3508 (error "Bad vertical layout:
3510 ps-bottom-margin == %s
3511 page-height == bm + print-height + tm
3512 => print-height == %d !"
3516 ;; If headers are turned on, deduct the height of the header from
3517 ;; the print height.
3519 (setq ps-header-pad
(* ps-header-line-pad
3520 (ps-title-line-height 'ps-font-for-header
))
3521 ps-print-height
(- ps-print-height
3524 (ps-title-line-height 'ps-font-for-header
)
3525 (* (ps-line-height 'ps-font-for-header
)
3526 (1- ps-header-lines
))
3528 (if (<= ps-print-height
0)
3529 (error "Bad vertical layout:
3531 ps-bottom-margin == %s
3532 ps-header-offset == %s
3535 page-height == bm + print-height + tm - ho - hh
3536 => print-height == %d !"
3542 (ps-title-line-height 'ps-font-for-header
)
3543 (* (ps-line-height 'ps-font-for-header
)
3544 (1- ps-header-lines
))
3548 (defun ps-print-preprint (&optional filename
)
3550 (or (numberp filename
)
3552 (let* ((name (concat (file-name-nondirectory (or (buffer-file-name)
3555 (prompt (format "Save PostScript to file: (default %s) " name
))
3556 (res (read-file-name prompt default-directory name nil
)))
3557 (while (cond ((not (file-writable-p res
))
3559 (setq prompt
"is unwritable"))
3560 ((file-exists-p res
)
3561 (setq prompt
"exists")
3562 (not (y-or-n-p (format "File `%s' exists; overwrite? "
3565 (setq res
(read-file-name
3566 (format "File %s; save PostScript to file: " prompt
)
3567 (file-name-directory res
) nil nil
3568 (file-name-nondirectory res
))))
3569 (if (file-directory-p res
)
3570 (expand-file-name name
(file-name-as-directory res
))
3573 ;; The following functions implement a simple list-buffering scheme so
3574 ;; that ps-print doesn't have to repeatedly switch between buffers
3575 ;; while spooling. The functions `ps-output' and `ps-output-string' build
3576 ;; up the lists; the function `ps-flush-output' takes the lists and
3577 ;; insert its contents into the spool buffer (*PostScript*).
3579 (defvar ps-string-escape-codes
3580 (let ((table (make-vector 256 nil
))
3582 ;; control characters
3583 (while (<= char ?
\037)
3584 (aset table char
(format "\\%03o" char
))
3585 (setq char
(1+ char
)))
3586 ;; printable characters
3587 (while (< char ?
\177)
3588 (aset table char
(format "%c" char
))
3589 (setq char
(1+ char
)))
3590 ;; DEL and 8-bit characters
3591 (while (<= char ?
\377)
3592 (aset table char
(format "\\%o" char
))
3593 (setq char
(1+ char
)))
3594 ;; Override ASCII formatting characters with named escape code:
3595 (aset table ?
\n "\\n") ; [NL] linefeed
3596 (aset table ?
\r "\\r") ; [CR] carriage return
3597 (aset table ?
\t "\\t") ; [HT] horizontal tab
3598 (aset table ?
\b "\\b") ; [BS] backspace
3599 (aset table ?
\f "\\f") ; [NP] form feed
3600 ;; Escape PostScript escape and string delimiter characters:
3601 (aset table ?
\\ "\\\\")
3602 (aset table ?\
( "\\(")
3603 (aset table ?\
) "\\)")
3605 "Vector used to map characters to PostScript string escape codes.")
3607 (defun ps-output-string-prim (string)
3608 (insert "(") ;insert start-string delimiter
3609 (save-excursion ;insert string
3610 (insert (string-as-unibyte string
)))
3611 ;; Find and quote special characters as necessary for PS
3612 ;; This skips everything except control chars, non-ASCII chars, (, ) and \.
3613 (while (progn (skip-chars-forward " -'*-[]-~") (not (eobp)))
3614 (let ((special (following-char)))
3616 (insert (aref ps-string-escape-codes special
))))
3617 (goto-char (point-max))
3618 (insert ")")) ;insert end-string delimiter
3620 (defun ps-init-output-queue ()
3621 (setq ps-output-head
'("")
3622 ps-output-tail ps-output-head
))
3624 (defun ps-output (&rest args
)
3625 (setcdr ps-output-tail args
)
3626 (while (cdr ps-output-tail
)
3627 (setq ps-output-tail
(cdr ps-output-tail
))))
3629 (defun ps-output-string (string)
3630 (ps-output t string
))
3632 (defun ps-output-list (the-list)
3633 (mapcar 'ps-output the-list
))
3635 ;; Output strings in the list ARGS in the PostScript prologue part.
3636 (defun ps-output-prologue (args)
3637 (ps-output 'prologue
(if (stringp args
) (list args
) args
)))
3639 (defun ps-flush-output ()
3641 (set-buffer ps-spool-buffer
)
3642 (goto-char (point-max))
3643 (while ps-output-head
3644 (let ((it (car ps-output-head
)))
3647 (setq ps-output-head
(cdr ps-output-head
))
3648 (ps-output-string-prim (car ps-output-head
)))
3650 (setq ps-output-head
(cdr ps-output-head
))
3652 (search-backward "\nBeginDoc")
3654 (apply 'insert
(car ps-output-head
))))
3657 (setq ps-output-head
(cdr ps-output-head
))))
3658 (ps-init-output-queue))
3660 (defun ps-insert-file (fname)
3662 ;; Check to see that the file exists and is readable; if not, throw
3664 (or (file-readable-p fname
)
3665 (error "Could not read file `%s'" fname
))
3667 (set-buffer ps-spool-buffer
)
3668 (goto-char (point-max))
3669 (insert-file fname
)))
3671 ;; These functions insert the arrays that define the contents of the
3674 (defun ps-generate-header-line (fonttag &optional content
)
3675 (ps-output " [ " fonttag
" ")
3677 ;; Literal strings should be output as is -- the string must
3678 ;; contain its own PS string delimiters, '(' and ')', if necessary.
3680 (ps-output content
))
3682 ;; Functions are called -- they should return strings; they will be
3683 ;; inserted as strings and the PS string delimiters added.
3684 ((and (symbolp content
) (fboundp content
))
3685 (ps-output-string (funcall content
)))
3687 ;; Variables will have their contents inserted. They should
3688 ;; contain strings, and will be inserted as strings.
3689 ((and (symbolp content
) (boundp content
))
3690 (ps-output-string (symbol-value content
)))
3692 ;; Anything else will get turned into an empty string.
3694 (ps-output-string "")))
3697 (defun ps-generate-header (name contents
)
3698 (ps-output "/" name
" [\n")
3699 (if (> ps-header-lines
0)
3701 (ps-generate-header-line "/h0" (car contents
))
3702 (while (and (< count ps-header-lines
)
3703 (setq contents
(cdr contents
)))
3704 (ps-generate-header-line "/h1" (car contents
))
3705 (setq count
(1+ count
)))
3706 (ps-output "] def\n"))))
3709 (defun ps-output-boolean (name bool
&optional no-def
)
3710 (ps-output (format "/%s %s%s"
3711 name
(if bool
"true" "false") (if no-def
"\n" " def\n"))))
3714 (defun ps-background-pages (page-list func
)
3718 (let ((start (if (consp pages
) (car pages
) pages
))
3719 (end (if (consp pages
) (cdr pages
) pages
)))
3720 (and (integerp start
) (integerp end
) (<= start end
)
3721 (add-to-list 'ps-background-pages
(vector start end func
)))))
3723 (setq ps-background-all-pages
(cons func ps-background-all-pages
))))
3726 (defconst ps-boundingbox-re
3728 \\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)\\s-+\\([0-9.]+\\)")
3731 (defun ps-get-boundingbox ()
3733 (set-buffer ps-spool-buffer
)
3735 (if (re-search-forward ps-boundingbox-re nil t
)
3736 (vector (string-to-number ; lower x
3737 (buffer-substring (match-beginning 1) (match-end 1)))
3738 (string-to-number ; lower y
3739 (buffer-substring (match-beginning 2) (match-end 2)))
3740 (string-to-number ; upper x
3741 (buffer-substring (match-beginning 3) (match-end 3)))
3742 (string-to-number ; upper y
3743 (buffer-substring (match-beginning 4) (match-end 4))))
3744 (vector 0 0 0 0)))))
3747 ;; Emacs understands the %f format; we'll use it to limit color RGB values
3748 ;; to three decimals to cut down some on the size of the PostScript output.
3749 ;; Lucid emacsen will have to make do with %s (princ) for floats.
3751 (defvar ps-float-format
(if (eq ps-print-emacs-type
'emacs
)
3753 "%s ")) ; Lucid emacsen
3756 (defun ps-float-format (value &optional default
)
3757 (let ((literal (or value default
)))
3759 (format (if (numberp literal
)
3766 (defun ps-background-text ()
3769 (setq ps-background-text-count
(1+ ps-background-text-count
))
3770 (ps-output (format "/ShowBackText-%d {\n" ps-background-text-count
))
3771 (ps-output-string (nth 0 text
)) ; text
3774 (ps-float-format (nth 4 text
) 200.0) ; font size
3775 (format "/%s " (or (nth 3 text
) "Times-Roman")) ; font name
3776 (ps-float-format (nth 6 text
)
3777 "PrintHeight PrintPageWidth atan") ; rotation
3778 (ps-float-format (nth 5 text
) 0.85) ; gray
3779 (ps-float-format (nth 1 text
) "0") ; x position
3780 (ps-float-format (nth 2 text
) "BottomMargin") ; y position
3781 "\nShowBackText} def\n")
3782 (ps-background-pages (nthcdr 7 text
) ; page list
3783 (format "ShowBackText-%d\n"
3784 ps-background-text-count
)))
3785 ps-print-background-text
))
3788 (defun ps-background-image ()
3791 (let ((image-file (expand-file-name (nth 0 image
))))
3792 (if (file-readable-p image-file
)
3794 (setq ps-background-image-count
(1+ ps-background-image-count
))
3796 (format "/ShowBackImage-%d {\n--back-- "
3797 ps-background-image-count
)
3798 (ps-float-format (nth 5 image
) 0.0) ; rotation
3799 (ps-float-format (nth 3 image
) 1.0) ; x scale
3800 (ps-float-format (nth 4 image
) 1.0) ; y scale
3801 (ps-float-format (nth 1 image
) ; x position
3802 "PrintPageWidth 2 div")
3803 (ps-float-format (nth 2 image
) ; y position
3804 "PrintHeight 2 div BottomMargin add")
3805 "\nBeginBackImage\n")
3806 (ps-insert-file image-file
)
3807 ;; coordinate adjustment to centralize image
3808 ;; around x and y position
3809 (let ((box (ps-get-boundingbox)))
3811 (set-buffer ps-spool-buffer
)
3813 (if (re-search-backward "^--back--" nil t
)
3817 (- (+ (/ (- (aref box
2) (aref box
0)) 2.0)
3820 (- (+ (/ (- (aref box
3) (aref box
1)) 2.0)
3823 (ps-output "\nEndBackImage} def\n")
3824 (ps-background-pages (nthcdr 6 image
) ; page list
3825 (format "ShowBackImage-%d\n"
3826 ps-background-image-count
))))))
3827 ps-print-background-image
))
3830 (defun ps-background (page-number)
3831 (let (has-local-background)
3832 (mapcar #'(lambda (range)
3833 (and (<= (aref range
0) page-number
)
3834 (<= page-number
(aref range
1))
3835 (if has-local-background
3836 (ps-output (aref range
2))
3837 (setq has-local-background t
)
3838 (ps-output "/printLocalBackground {\n"
3840 ps-background-pages
)
3841 (and has-local-background
(ps-output "} def\n"))))
3844 ;; Return a list of the distinct elements of LIST.
3845 ;; Elements are compared with `equal'.
3846 (defun ps-remove-duplicates (list)
3847 (let (new (tail list
))
3849 (or (member (car tail
) new
)
3850 (setq new
(cons (car tail
) new
)))
3851 (setq tail
(cdr tail
)))
3855 ;; Find the first occurrence of ITEM in LIST.
3856 ;; Return the index of the matching item, or nil if not found.
3857 ;; Elements are compared with `eq'.
3858 (defun ps-alist-position (item list
)
3859 (let ((tail list
) (index 0) found
)
3861 (if (setq found
(eq (car (car tail
)) item
))
3863 (setq index
(1+ index
)
3868 (defconst ps-n-up-database
4005 ;; Ledger paper size is a special case, it is the only paper size where the
4006 ;; normal size is landscaped, that is, the height is smaller than width.
4007 ;; So, we use the special value `pag' in the `landscape' field.
4151 "Alist which is the page matrix database used for N-up printing.
4153 Each element has the following form:
4156 (MAX LANDSCAPE LINES COLUMNS COL-MISSING)
4160 PAGE is the page size used (see `ps-paper-type').
4161 MAX is the maximum elements of this page matrix.
4162 LANDSCAPE specifies if page matrix is landscaped, has the following valid
4164 nil the sheet is in portrait mode.
4165 t the sheet is in landscape mode.
4166 pag the sheet is in portrait mode and page is in landscape mode.
4167 LINES is the number of lines of page matrix.
4168 COLUMNS is the number of columns of page matrix.
4169 COL-MISSING is the number of columns missing to fill the sheet.")
4172 (defmacro ps-n-up-landscape
(mat) `(nth 1 ,mat
))
4173 (defmacro ps-n-up-lines
(mat) `(nth 2 ,mat
))
4174 (defmacro ps-n-up-columns
(mat) `(nth 3 ,mat
))
4175 (defmacro ps-n-up-missing
(mat) `(nth 4 ,mat
))
4178 (defun ps-n-up-printing ()
4179 ;; force `ps-n-up-printing' be in range 1 to 100.
4180 (setq ps-n-up-printing
(max (min ps-n-up-printing
100) 1))
4181 ;; find suitable page matrix for a given `ps-paper-type'.
4182 (let ((the-list (cdr (assq ps-paper-type ps-n-up-database
))))
4184 (while (> ps-n-up-printing
(caar the-list
))
4185 (setq the-list
(cdr the-list
))))
4189 (defconst ps-n-up-filling-database
4191 "PageWidth" ; N-Up-XColumn
4193 "N-Up-End 1 sub PageWidth mul neg" ; N-Up-XLine
4194 "LandscapePageHeight neg" ; N-Up-YLine
4195 "N-Up-Lines" ; N-Up-Repeat
4196 "N-Up-Columns" ; N-Up-End
4200 "PageWidth" ; N-Up-XColumn
4202 "N-Up-End 1 sub PageWidth mul neg" ; N-Up-XLine
4203 "LandscapePageHeight" ; N-Up-YLine
4204 "N-Up-Lines" ; N-Up-Repeat
4205 "N-Up-Columns" ; N-Up-End
4207 "N-Up-Repeat 1 sub LandscapePageHeight mul neg") ; N-Up-YStart
4209 "PageWidth neg" ; N-Up-XColumn
4211 "N-Up-End 1 sub PageWidth mul" ; N-Up-XLine
4212 "LandscapePageHeight neg" ; N-Up-YLine
4213 "N-Up-Lines" ; N-Up-Repeat
4214 "N-Up-Columns" ; N-Up-End
4215 "N-Up-End 1 sub PageWidth mul" ; N-Up-XStart
4218 "PageWidth neg" ; N-Up-XColumn
4220 "N-Up-End 1 sub PageWidth mul" ; N-Up-XLine
4221 "LandscapePageHeight" ; N-Up-YLine
4222 "N-Up-Lines" ; N-Up-Repeat
4223 "N-Up-Columns" ; N-Up-End
4224 "N-Up-End 1 sub PageWidth mul" ; N-Up-XStart
4225 "N-Up-Repeat 1 sub LandscapePageHeight mul neg") ; N-Up-YStart
4228 "LandscapePageHeight neg" ; N-Up-YColumn
4229 "PageWidth" ; N-Up-XLine
4230 "N-Up-End 1 sub LandscapePageHeight mul" ; N-Up-YLine
4231 "N-Up-Columns" ; N-Up-Repeat
4232 "N-Up-Lines" ; N-Up-End
4237 "LandscapePageHeight" ; N-Up-YColumn
4238 "PageWidth" ; N-Up-XLine
4239 "N-Up-End 1 sub LandscapePageHeight mul neg" ; N-Up-YLine
4240 "N-Up-Columns" ; N-Up-Repeat
4241 "N-Up-Lines" ; N-Up-End
4243 "N-Up-End 1 sub LandscapePageHeight mul neg") ; N-Up-YStart
4246 "LandscapePageHeight neg" ; N-Up-YColumn
4247 "PageWidth neg" ; N-Up-XLine
4248 "N-Up-End 1 sub LandscapePageHeight mul" ; N-Up-YLine
4249 "N-Up-Columns" ; N-Up-Repeat
4250 "N-Up-Lines" ; N-Up-End
4251 "N-Up-Repeat 1 sub PageWidth mul" ; N-Up-XStart
4255 "LandscapePageHeight" ; N-Up-YColumn
4256 "PageWidth neg" ; N-Up-XLine
4257 "N-Up-End 1 sub LandscapePageHeight mul neg" ; N-Up-YLine
4258 "N-Up-Columns" ; N-Up-Repeat
4259 "N-Up-Lines" ; N-Up-End
4260 "N-Up-Repeat 1 sub PageWidth mul" ; N-Up-XStart
4261 "N-Up-End 1 sub LandscapePageHeight mul neg")) ; N-Up-YStart
4262 "Alist for n-up printing initializations.
4264 Each element has the following form:
4266 (KIND XCOL YCOL XLIN YLIN REPEAT END XSTART YSTART)
4269 KIND is a valid value of `ps-n-up-filling'.
4270 XCOL YCOL are the relative position for the next column.
4271 XLIN YLIN are the relative position for the beginning of next line.
4272 REPEAT is the number of repetions for external loop.
4273 END is the number of repetions for internal loop and also the number of pages in
4275 XSTART YSTART are the relative position for the first page in a sheet.")
4278 (defun ps-n-up-filling ()
4279 (cdr (or (assq ps-n-up-filling ps-n-up-filling-database
)
4280 (assq 'left-top ps-n-up-filling-database
))))
4283 (defmacro ps-n-up-xcolumn
(init) `(nth 0 ,init
))
4284 (defmacro ps-n-up-ycolumn
(init) `(nth 1 ,init
))
4285 (defmacro ps-n-up-xline
(init) `(nth 2 ,init
))
4286 (defmacro ps-n-up-yline
(init) `(nth 3 ,init
))
4287 (defmacro ps-n-up-repeat
(init) `(nth 4 ,init
))
4288 (defmacro ps-n-up-end
(init) `(nth 5 ,init
))
4289 (defmacro ps-n-up-xstart
(init) `(nth 6 ,init
))
4290 (defmacro ps-n-up-ystart
(init) `(nth 7 ,init
))
4293 (defun ps-begin-file ()
4294 (ps-get-page-dimensions)
4295 (setq ps-page-postscript
0
4297 ps-background-text-count
0
4298 ps-background-image-count
0
4299 ps-background-pages nil
4300 ps-background-all-pages nil
)
4302 (let ((dimensions (cdr (assq ps-paper-type ps-page-dimensions-database
)))
4303 (tumble (if ps-landscape-mode
(not ps-spool-tumble
) ps-spool-tumble
))
4304 (n-up (ps-n-up-printing))
4305 (n-up-filling (ps-n-up-filling)))
4306 (and (> ps-n-up-printing
1) (setq tumble
(not tumble
)))
4309 "%%Title: " (buffer-name) ; Take job name from name of
4310 ; first buffer printed
4311 "\n%%Creator: " (user-full-name)
4312 " (using ps-print v" ps-print-version
4313 ")\n%%CreationDate: "
4314 (time-stamp-hh:mm
:ss
) " " (time-stamp-mon-dd-yyyy)
4316 (if ps-landscape-mode
"Landscape" "Portrait")
4317 "\n%%DocumentNeededResources: font Times-Roman Times-Italic\n%%+ font "
4318 (mapconcat 'identity
4319 (ps-remove-duplicates
4320 (append (ps-fonts 'ps-font-for-text
)
4321 (list (ps-font 'ps-font-for-header
'normal
)
4322 (ps-font 'ps-font-for-header
'bold
))))
4324 "\n%%DocumentMedia: " (ps-page-dimensions-get-media dimensions
)
4325 (format " %d" (round (ps-page-dimensions-get-width dimensions
)))
4326 (format " %d" (round (ps-page-dimensions-get-height dimensions
)))
4327 " 0 () ()\n%%PageOrder: Ascend\n%%Pages: (atend)\n%%Requirements:"
4329 (format " duplex%s" (if tumble
"(tumble)\n" "\n"))
4332 (let ((comments (if (functionp ps-print-prologue-header
)
4333 (funcall ps-print-prologue-header
)
4334 ps-print-prologue-header
)))
4335 (and (stringp comments
)
4336 (ps-output comments
)))
4338 (ps-output "%%EndComments\n\n%%BeginPrologue\n\n"
4339 "/gs_languagelevel /languagelevel where {pop languagelevel}{1}ifelse def\n\n")
4341 (ps-output-boolean "SkipFirstPage " ps-banner-page-when-duplexing
)
4342 (ps-output-boolean "LandscapeMode "
4343 (or ps-landscape-mode
4344 (eq (ps-n-up-landscape n-up
) 'pag
)))
4345 (ps-output (format "/NumberOfColumns %d def\n" ps-number-of-columns
)
4347 (format "/LandscapePageHeight %s def\n" ps-landscape-page-height
)
4348 (format "/PrintPageWidth %s def\n"
4349 (- (* (+ ps-print-width ps-inter-column
)
4350 ps-number-of-columns
)
4352 (format "/PrintWidth %s def\n" ps-print-width
)
4353 (format "/PrintHeight %s def\n" ps-print-height
)
4355 (format "/LeftMargin %s def\n" ps-left-margin
)
4356 (format "/RightMargin %s def\n" ps-right-margin
)
4357 (format "/InterColumn %s def\n" ps-inter-column
)
4359 (format "/BottomMargin %s def\n" ps-bottom-margin
)
4360 (format "/TopMargin %s def\n" ps-top-margin
) ; not used
4361 (format "/HeaderOffset %s def\n" ps-header-offset
)
4362 (format "/HeaderPad %s def\n" ps-header-pad
))
4364 (ps-output-boolean "PrintHeader " ps-print-header
)
4365 (ps-output-boolean "PrintOnlyOneHeader" ps-print-only-one-header
)
4366 (ps-output-boolean "PrintHeaderFrame " ps-print-header-frame
)
4367 (ps-output-boolean "ShowNofN " ps-show-n-of-n
)
4368 (ps-output-boolean "DuplexValue " ps-spool-duplex
)
4369 (ps-output-boolean "TumbleValue " tumble
)
4371 (let ((line-height (ps-line-height 'ps-font-for-text
)))
4372 (ps-output (format "/LineHeight %s def\n" line-height
)
4373 (format "/LinesPerColumn %d def\n"
4374 (round (/ (+ ps-print-height
4375 (* line-height
0.45))
4378 (ps-output-boolean "Zebra " ps-zebra-stripes
)
4379 (ps-output-boolean "PrintLineNumber " ps-line-number
)
4380 (ps-output (format "/ZebraHeight %d def\n" ps-zebra-stripe-height
)
4381 (format "/ZebraGray %s def\n" ps-zebra-gray
)
4382 "/UseSetpagedevice "
4383 (if (eq ps-spool-config
'setpagedevice
)
4384 "/setpagedevice where {pop true}{false}ifelse def\n"
4387 "PrintPageWidth LeftMargin add RightMargin add def\n\n"
4388 (format "/N-Up %d def\n" ps-n-up-printing
))
4389 (ps-output-boolean "N-Up-Landscape" (eq (ps-n-up-landscape n-up
) t
))
4390 (ps-output-boolean "N-Up-Border " ps-n-up-border-p
)
4391 (ps-output (format "/N-Up-Lines %d def\n" (ps-n-up-lines n-up
))
4392 (format "/N-Up-Columns %d def\n" (ps-n-up-columns n-up
))
4393 (format "/N-Up-Missing %d def\n" (ps-n-up-missing n-up
))
4394 (format "/N-Up-Margin %s" ps-n-up-margin
)
4395 " def\n/N-Up-Repeat "
4396 (if ps-landscape-mode
4397 (ps-n-up-end n-up-filling
)
4398 (ps-n-up-repeat n-up-filling
))
4400 (if ps-landscape-mode
4401 (ps-n-up-repeat n-up-filling
)
4402 (ps-n-up-end n-up-filling
))
4403 " def\n/N-Up-XColumn " (ps-n-up-xcolumn n-up-filling
)
4404 " def\n/N-Up-YColumn " (ps-n-up-ycolumn n-up-filling
)
4405 " def\n/N-Up-XLine " (ps-n-up-xline n-up-filling
)
4406 " def\n/N-Up-YLine " (ps-n-up-yline n-up-filling
)
4407 " def\n/N-Up-XStart " (ps-n-up-xstart n-up-filling
)
4408 " def\n/N-Up-YStart " (ps-n-up-ystart n-up-filling
) " def\n")
4410 (ps-background-text)
4411 (ps-background-image)
4412 (setq ps-background-all-pages
(nreverse ps-background-all-pages
)
4413 ps-background-pages
(nreverse ps-background-pages
))
4415 (ps-output ps-print-prologue-1
)
4417 (ps-output "/printGlobalBackground {\n")
4418 (ps-output-list ps-background-all-pages
)
4419 (ps-output "} def\n/printLocalBackground {\n} def\n")
4422 (ps-output (format "/h0 %s (%s) cvn DefFont\n" ; /h0 14 /Helvetica-Bold DefFont
4423 ps-header-title-font-size-internal
4424 (ps-font 'ps-font-for-header
'bold
))
4425 (format "/h1 %s (%s) cvn DefFont\n" ; /h1 12 /Helvetica DefFont
4426 ps-header-font-size-internal
4427 (ps-font 'ps-font-for-header
'normal
)))
4429 (ps-output ps-print-prologue-2
)
4432 (let ((font (ps-font-alist 'ps-font-for-text
))
4435 (ps-output (format "/f%d %s (%s) cvn DefFont\n"
4437 ps-font-size-internal
4438 (ps-font 'ps-font-for-text
(car (car font
)))))
4439 (setq font
(cdr font
)
4442 (let ((font-entry (cdr (assq ps-font-family ps-font-info-database
))))
4443 (ps-output (format "/SpaceWidthRatio %f def\n"
4444 (/ (ps-lookup 'space-width
) (ps-lookup 'size
)))))
4446 (ps-output "\n%%EndPrologue\n\n%%BeginSetup\n")
4447 (unless (eq ps-spool-config
'lpr-switches
)
4448 (ps-output "\n%%BeginFeature: *Duplex "
4449 (ps-boolean-capitalized ps-spool-duplex
)
4451 (ps-boolean-capitalized tumble
)
4452 ps-print-duplex-feature
4454 (ps-output "\n/Lines 0 def\n/PageCount 0 def\n\nBeginDoc\n%%EndSetup\n"))
4457 (defun ps-boolean-capitalized (bool)
4458 (if bool
"True" "False"))
4461 (defun ps-header-dirpart ()
4462 (let ((fname (buffer-file-name)))
4464 (if (string-equal (buffer-name) (file-name-nondirectory fname
))
4465 (abbreviate-file-name (file-name-directory fname
))
4470 (defun ps-get-buffer-name ()
4472 ;; Indulge Jim this little easter egg:
4473 ((string= (buffer-name) "ps-print.el")
4474 "Hey, Cool! It's ps-print.el!!!")
4475 ;; Indulge Jack this other little easter egg:
4476 ((string= (buffer-name) "sokoban.el")
4477 "Super! C'est sokoban.el!")
4479 (and ps-printing-region-p
"Subset of: ")
4481 (and (buffer-modified-p) " (unsaved)")))))
4484 (defun ps-get-font-size (font-sym)
4485 (let ((font-size (symbol-value font-sym
)))
4486 (cond ((numberp font-size
)
4488 ((and (consp font-size
)
4489 (numberp (car font-size
))
4490 (numberp (cdr font-size
)))
4491 (if ps-landscape-mode
4495 (error "Invalid font size `%S' for `%S'" font-size font-sym
)))))
4498 (defun ps-begin-job ()
4500 (set-buffer ps-spool-buffer
)
4501 (goto-char (point-max))
4502 (and (re-search-backward "^%%Trailer$" nil t
)
4503 (delete-region (match-beginning 0) (point-max))))
4504 (setq ps-showline-count
(car ps-printing-region
)
4506 ps-font-size-internal
(ps-get-font-size 'ps-font-size
)
4507 ps-header-font-size-internal
(ps-get-font-size 'ps-header-font-size
)
4508 ps-header-title-font-size-internal
4509 (ps-get-font-size 'ps-header-title-font-size
)
4510 ps-control-or-escape-regexp
4511 (cond ((eq ps-print-control-characters
'8-bit
)
4512 (string-as-unibyte "[\000-\037\177-\377]"))
4513 ((eq ps-print-control-characters
'control-8-bit
)
4514 (string-as-unibyte "[\000-\037\177-\237]"))
4515 ((eq ps-print-control-characters
'control
)
4519 (defmacro ps-page-number
()
4520 `(1+ (/ (1- ps-page-count
) ps-number-of-columns
)))
4522 (defun ps-end-file ()
4523 ;; Back to the PS output buffer to set the last page n-up printing
4525 (let ((pages-per-sheet (mod ps-page-postscript ps-n-up-printing
))
4527 (set-buffer ps-spool-buffer
)
4528 (goto-char (point-max))
4529 (and (> pages-per-sheet
0)
4530 (re-search-backward "^[0-9]+ BeginSheet$" nil t
)
4531 (replace-match (format "%d BeginSheet" pages-per-sheet
) t
))))
4533 (and ps-spool-duplex
(= (mod ps-page-order
2) 1)
4535 ;; Set end of PostScript file
4536 (ps-output "EndSheet\n\n%%Trailer\n%%Pages: "
4537 (format "%d" ps-page-order
)
4538 "\n\nEndDoc\n\n%%EOF\n"))
4541 (defun ps-next-page ()
4547 (defun ps-header-sheet ()
4548 ;; Print only when a new sheet begins.
4549 (setq ps-page-postscript
(1+ ps-page-postscript
)
4550 ps-page-order
(1+ ps-page-order
))
4551 (and (> ps-page-order
1)
4552 (ps-output "EndSheet\n"))
4553 (ps-output (format "\n%%%%Page: %d %d\n"
4554 ps-page-postscript ps-page-order
))
4555 (ps-output (format "%d BeginSheet\nBeginDSCPage\n" ps-n-up-printing
)))
4558 (defsubst ps-header-page
()
4559 ;; set total line and page number when printing has finished
4560 ;; (see `ps-generate')
4563 (zerop (mod ps-page-count ps-number-of-columns
))
4564 (setq ps-page-count
(1+ ps-page-count
)))
4566 (if (zerop (mod ps-page-postscript ps-n-up-printing
))
4567 ;; Print only when a new sheet begins.
4570 'ps-print-begin-sheet-hook
)
4571 ;; Print only when a new page begins.
4572 (setq ps-page-postscript
(1+ ps-page-postscript
))
4573 (ps-output "BeginDSCPage\n")
4574 'ps-print-begin-page-hook
)
4575 (ps-background ps-page-postscript
))
4576 ;; Print only when a new column begins.
4577 (ps-output "BeginDSCPage\n")
4578 'ps-print-begin-column-hook
)))
4580 (defun ps-begin-page ()
4581 (ps-get-page-dimensions)
4582 (setq ps-width-remaining ps-print-width
4583 ps-height-remaining ps-print-height
)
4587 (ps-output (format "/LineNumber %d def\n" ps-showline-count
)
4588 (format "/PageNumber %d def\n" (if ps-print-only-one-header
4592 (when ps-print-header
4593 (ps-generate-header "HeaderLinesLeft" ps-left-header
)
4594 (ps-generate-header "HeaderLinesRight" ps-right-header
)
4595 (ps-output (format "%d SetHeaderLines\n" ps-header-lines
)))
4597 (ps-output "BeginPage\n")
4598 (ps-set-font ps-current-font
)
4599 (ps-set-bg ps-current-bg
)
4600 (ps-set-color ps-current-color
)
4601 (ps-mule-begin-page))
4603 (defun ps-end-page ()
4604 (ps-output "EndPage\nEndDSCPage\n"))
4606 (defun ps-dummy-page ()
4607 (let ((ps-n-up-printing 0))
4609 (ps-output "/PrintHeader false def
4611 /PrintLineNumber false def
4615 (setq ps-page-postscript ps-n-up-printing
))
4617 (defun ps-next-line ()
4618 (setq ps-showline-count
(1+ ps-showline-count
))
4619 (let ((lh (ps-line-height 'ps-font-for-text
)))
4620 (if (< ps-height-remaining lh
)
4622 (setq ps-width-remaining ps-print-width
4623 ps-height-remaining
(- ps-height-remaining lh
))
4624 (ps-output "HL\n"))))
4626 (defun ps-continue-line ()
4627 (let ((lh (ps-line-height 'ps-font-for-text
)))
4628 (if (< ps-height-remaining lh
)
4630 (setq ps-width-remaining ps-print-width
4631 ps-height-remaining
(- ps-height-remaining lh
))
4632 (ps-output "SL\n"))))
4634 (defun ps-find-wrappoint (from to char-width
)
4635 (let ((avail (truncate (/ ps-width-remaining char-width
)))
4638 (cons to
(* todo char-width
))
4639 (cons (+ from avail
) ps-width-remaining
))))
4641 (defun ps-basic-plot-string (from to
&optional bg-color
)
4642 (let* ((wrappoint (ps-find-wrappoint from to
4643 (ps-avg-char-width 'ps-font-for-text
)))
4644 (to (car wrappoint
))
4645 (string (buffer-substring-no-properties from to
)))
4646 (ps-mule-prepare-ascii-font string
)
4647 (ps-output-string string
)
4651 (defun ps-basic-plot-whitespace (from to
&optional bg-color
)
4652 (let* ((wrappoint (ps-find-wrappoint from to
4653 (ps-space-width 'ps-font-for-text
)))
4654 (to (car wrappoint
)))
4655 (ps-output (format "%d W\n" (- to from
)))
4658 (defun ps-plot (plotfunc from to
&optional bg-color
)
4660 (let* ((wrappoint (funcall plotfunc from to bg-color
))
4661 (plotted-to (car wrappoint
))
4662 (plotted-width (cdr wrappoint
)))
4663 (setq from plotted-to
4664 ps-width-remaining
(- ps-width-remaining plotted-width
))
4666 (ps-continue-line))))
4667 (if ps-razzle-dazzle
4668 (let* ((q-todo (- (point-max) (point-min)))
4669 (q-done (- (point) (point-min)))
4670 (chunkfrac (/ q-todo
8))
4671 (chunksize (min chunkfrac
1000)))
4672 (if (> (- q-done ps-razchunk
) chunksize
)
4674 (setq ps-razchunk q-done
)
4675 (message "Formatting...%3d%%"
4677 (/ (* 100 q-done
) q-todo
)
4678 (/ q-done
(/ q-todo
100)))
4681 (defvar ps-last-font nil
)
4683 (defun ps-set-font (font)
4684 (setq ps-last-font
(format "f%d" (setq ps-current-font font
)))
4685 (ps-output (format "/%s F\n" ps-last-font
)))
4687 (defun ps-set-bg (color)
4688 (if (setq ps-current-bg color
)
4689 (ps-output (format ps-color-format
4690 (nth 0 color
) (nth 1 color
) (nth 2 color
))
4692 (ps-output "false BG\n")))
4694 (defun ps-set-color (color)
4695 (setq ps-current-color
(or color ps-default-fg
))
4696 (ps-output (format ps-color-format
4697 (nth 0 ps-current-color
)
4698 (nth 1 ps-current-color
) (nth 2 ps-current-color
))
4702 (defvar ps-current-effect
0)
4705 (defun ps-plot-region (from to font
&optional fg-color bg-color effects
)
4706 (if (not (equal font ps-current-font
))
4709 ;; Specify a foreground color only if one's specified and it's
4710 ;; different than the current.
4711 (if (not (equal fg-color ps-current-color
))
4712 (ps-set-color fg-color
))
4714 (if (not (equal bg-color ps-current-bg
))
4715 (ps-set-bg bg-color
))
4717 ;; Specify effects (underline, overline, box, etc)
4719 ((not (integerp effects
))
4720 (ps-output "0 EF\n")
4721 (setq ps-current-effect
0))
4722 ((/= effects ps-current-effect
)
4723 (ps-output (number-to-string effects
) " EF\n")
4724 (setq ps-current-effect effects
)))
4726 ;; Starting at the beginning of the specified region...
4730 ;; ...break the region up into chunks separated by tabs, linefeeds,
4731 ;; pagefeeds, control characters, and plot each chunk.
4733 (if (re-search-forward ps-control-or-escape-regexp to t
)
4734 ;; region with some control characters or some multi-byte characters
4735 (let* ((match-point (match-beginning 0))
4736 (match (char-after match-point
))
4737 (composition (find-composition from
(1+ match-point
))))
4739 (if (and (nth 2 composition
)
4740 (<= (car composition
) match-point
))
4742 (setq match-point
(car composition
)
4744 (goto-char (nth 1 composition
)))
4745 (setq composition nil
)))
4746 (when (< from match-point
)
4747 (ps-mule-set-ascii-font)
4748 (ps-plot 'ps-basic-plot-string from match-point bg-color
))
4750 ((= match ?
\t) ; tab
4751 (let ((linestart (line-beginning-position)))
4753 (setq from
(+ linestart
(current-column)))
4754 (when (re-search-forward "[ \t]+" to t
)
4755 (ps-mule-set-ascii-font)
4756 (ps-plot 'ps-basic-plot-whitespace
4757 from
(+ linestart
(current-column))
4760 ((= match ?
\n) ; newline
4763 ((= match ?
\f) ; form feed
4764 ;; do not skip page if previous character is NEWLINE and
4765 ;; it is a beginning of page.
4766 (or (and (= (char-after (1- match-point
)) ?
\n)
4767 (= ps-height-remaining ps-print-height
))
4770 (composition ; a composite sequence
4771 (ps-plot 'ps-mule-plot-composition match-point
(point) bg-color
))
4773 ; characters from ^@ to ^_ and
4774 ((> match
255) ; a multi-byte character
4775 (let* ((charset (char-charset match
))
4776 (composition (find-composition match-point to
))
4777 (stop (if (nth 2 composition
) (car composition
) to
)))
4778 (or (eq charset
'composition
)
4779 (while (and (< (point) stop
) (eq (charset-after) charset
))
4781 (ps-plot 'ps-mule-plot-string match-point
(point) bg-color
)))
4783 (t ; characters from 127 to 255
4784 (ps-control-character match
)))
4785 (setq from
(point)))
4786 ;; region without control characters nor multi-byte characters
4787 (ps-mule-set-ascii-font)
4788 (ps-plot 'ps-basic-plot-string from to bg-color
)
4791 (defvar ps-string-control-codes
4792 (let ((table (make-vector 256 nil
))
4794 ;; control character
4795 (while (<= char ?
\037)
4796 (aset table char
(format "^%c" (+ char ?
@)))
4797 (setq char
(1+ char
)))
4798 ;; printable character
4799 (while (< char ?
\177)
4800 (aset table char
(format "%c" char
))
4801 (setq char
(1+ char
)))
4803 (aset table char
"^?")
4805 (while (<= (setq char
(1+ char
)) ?
\377)
4806 (aset table char
(format "\\%o" char
)))
4808 "Vector used to map characters to a printable string.")
4810 (defun ps-control-character (char)
4811 (let* ((str (aref ps-string-control-codes char
))
4815 (char-width (ps-avg-char-width 'ps-font-for-text
))
4816 (wrappoint (ps-find-wrappoint from to char-width
)))
4817 (if (< (car wrappoint
) to
)
4819 (setq ps-width-remaining
(- ps-width-remaining
(* len char-width
)))
4820 (ps-mule-prepare-ascii-font str
)
4821 (ps-output-string str
)
4822 (ps-output " S\n")))
4824 (defun ps-color-value (x-color-value)
4825 ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
4826 (/ x-color-value ps-print-color-scale
))
4829 (cond ((eq ps-print-emacs-type
'emacs
) ; emacs
4831 (defun ps-color-values (x-color)
4832 (if (fboundp 'x-color-values
)
4833 (x-color-values x-color
)
4834 (error "No available function to determine X color values.")))
4839 (defun ps-color-values (x-color)
4840 (cond ((fboundp 'x-color-values
)
4841 (x-color-values x-color
))
4842 ((and (fboundp 'color-instance-rgb-components
)
4844 (color-instance-rgb-components
4845 (if (color-instance-p x-color
)
4847 (make-color-instance
4848 (if (color-specifier-p x-color
)
4849 (color-name x-color
)
4852 (error "No available function to determine X color values."))))
4856 (defun ps-face-attributes (face)
4857 "Return face attribute vector.
4859 If FACE is not in `ps-print-face-extension-alist' or in
4860 `ps-print-face-alist', insert it on `ps-print-face-alist' and
4861 return the attribute vector.
4863 If FACE is not a valid face name, it is used default face."
4864 (cdr (or (assq face ps-print-face-extension-alist
)
4865 (assq face ps-print-face-alist
)
4866 (let* ((the-face (if (facep face
) face
'default
))
4867 (new-face (ps-screen-to-bit-face the-face
)))
4868 (or (and (eq the-face
'default
)
4869 (assq the-face ps-print-face-alist
))
4870 (setq ps-print-face-alist
(cons new-face ps-print-face-alist
)))
4874 (defun ps-face-attribute-list (face-or-list)
4875 (if (listp face-or-list
)
4878 foreground background face-attr
)
4880 (setq face-attr
(ps-face-attributes (car face-or-list
))
4881 effects
(logior effects
(aref face-attr
0)))
4882 (or foreground
(setq foreground
(aref face-attr
1)))
4883 (or background
(setq background
(aref face-attr
2)))
4884 (setq face-or-list
(cdr face-or-list
)))
4885 (vector effects foreground background
))
4887 (ps-face-attributes face-or-list
)))
4890 (defconst ps-font-type
(vector nil
'bold
'italic
'bold-italic
))
4893 (defun ps-plot-with-face (from to face
)
4895 ((null face
) ; print text with null face
4896 (ps-plot-region from to
0))
4897 ((eq face
'emacs--invisible--face
)) ; skip invisible text!!!
4898 (t ; otherwise, text has a valid face
4899 (let* ((face-bit (ps-face-attribute-list face
))
4900 (effect (aref face-bit
0))
4901 (foreground (aref face-bit
1))
4902 (background (aref face-bit
2))
4903 (fg-color (if (and ps-color-p foreground
)
4904 (mapcar 'ps-color-value
4905 (ps-color-values foreground
))
4907 (bg-color (and ps-color-p background
4908 (mapcar 'ps-color-value
4909 (ps-color-values background
)))))
4912 (ps-font-number 'ps-font-for-text
4913 (or (aref ps-font-type
(logand effect
3))
4915 fg-color bg-color
(lsh effect -
2)))))
4919 (defun ps-xemacs-face-kind-p (face kind kind-regex kind-list
)
4920 (let* ((frame-font (or (face-font-instance face
)
4921 (face-font-instance 'default
)))
4922 (kind-cons (and frame-font
4924 (font-instance-properties frame-font
))))
4925 (kind-spec (cdr-safe kind-cons
))
4926 (case-fold-search t
))
4927 (or (and kind-spec
(string-match kind-regex kind-spec
))
4928 ;; Kludge-compatible:
4929 (memq face kind-list
))))
4932 (cond ((eq ps-print-emacs-type
'emacs
) ; emacs
4934 (defun ps-face-bold-p (face)
4935 (or (face-bold-p face
)
4936 (memq face ps-bold-faces
)))
4938 (defun ps-face-italic-p (face)
4939 (or (face-italic-p face
)
4940 (memq face ps-italic-faces
)))
4945 (defun ps-face-bold-p (face)
4946 (ps-xemacs-face-kind-p face
'WEIGHT_NAME
"bold\\|demibold"
4949 (defun ps-face-italic-p (face)
4950 (or (ps-xemacs-face-kind-p face
'ANGLE_NAME
"i\\|o" ps-italic-faces
)
4951 (ps-xemacs-face-kind-p face
'SLANT
"i\\|o" ps-italic-faces
)))
4955 (defun ps-face-underlined-p (face)
4956 (or (face-underline-p face
)
4957 (memq face ps-underlined-faces
)))
4960 ;; Ensure that face-list is fbound.
4961 (or (fboundp 'face-list
) (defalias 'face-list
'list-faces
))
4964 (defun ps-build-reference-face-lists ()
4965 ;; Ensure that face database is updated with faces on
4966 ;; `font-lock-face-attributes' (obsolete stuff)
4967 (ps-font-lock-face-attributes)
4968 ;; Now, rebuild reference face lists
4969 (setq ps-print-face-alist nil
)
4970 (if ps-auto-font-detect
4971 (mapcar 'ps-map-face
(face-list))
4972 (mapcar 'ps-set-face-bold ps-bold-faces
)
4973 (mapcar 'ps-set-face-italic ps-italic-faces
)
4974 (mapcar 'ps-set-face-underline ps-underlined-faces
))
4975 (setq ps-build-face-reference nil
))
4978 (defun ps-set-face-bold (face)
4979 (ps-set-face-attribute face
1))
4981 (defun ps-set-face-italic (face)
4982 (ps-set-face-attribute face
2))
4984 (defun ps-set-face-underline (face)
4985 (ps-set-face-attribute face
4))
4988 (defun ps-set-face-attribute (face effect
)
4989 (let ((face-bit (cdr (ps-map-face face
))))
4990 (aset face-bit
0 (logior (aref face-bit
0) effect
))))
4993 (defun ps-map-face (face)
4994 (let* ((face-map (ps-screen-to-bit-face face
))
4995 (ps-face-bit (cdr (assq (car face-map
) ps-print-face-alist
))))
4997 ;; if face exists, merge both
4998 (let ((face-bit (cdr face-map
)))
4999 (aset ps-face-bit
0 (logior (aref ps-face-bit
0) (aref face-bit
0)))
5000 (or (aref ps-face-bit
1) (aset ps-face-bit
1 (aref face-bit
1)))
5001 (or (aref ps-face-bit
2) (aset ps-face-bit
2 (aref face-bit
2))))
5002 ;; if face does not exist, insert it
5003 (setq ps-print-face-alist
(cons face-map ps-print-face-alist
)))
5007 (defun ps-screen-to-bit-face (face)
5009 (vector (logior (if (ps-face-bold-p face
) 1 0) ; bold
5010 (if (ps-face-italic-p face
) 2 0) ; italic
5011 (if (ps-face-underlined-p face
) 4 0)) ; underline
5012 (face-foreground face
)
5013 (face-background face
))))
5016 (cond ((not (eq ps-print-emacs-type
'emacs
))
5020 (defun ps-mapper (extent list
)
5021 (nconc list
(list (list (extent-start-position extent
) 'push extent
)
5022 (list (extent-end-position extent
) 'pull extent
)))
5025 (defun ps-extent-sorter (a b
)
5026 (< (extent-priority a
) (extent-priority b
)))
5030 (defun ps-print-ensure-fontified (start end
)
5031 (and (boundp 'lazy-lock-mode
) (symbol-value 'lazy-lock-mode
)
5032 (lazy-lock-fontify-region start end
)))
5034 (defun ps-generate-postscript-with-faces (from to
)
5035 ;; Some initialization...
5036 (setq ps-current-effect
0)
5038 ;; Build the reference lists of faces if necessary.
5039 (if (or ps-always-build-face-reference
5040 ps-build-face-reference
)
5042 (message "Collecting face information...")
5043 (ps-build-reference-face-lists)))
5044 ;; Set the color scale. We do it here instead of in the defvar so
5045 ;; that ps-print can be dumped into emacs. This expression can't be
5046 ;; evaluated at dump-time because X isn't initialized.
5047 (setq ps-color-p
(and ps-print-color-p
(ps-color-device))
5048 ps-print-color-scale
(if ps-color-p
5049 (float (car (ps-color-values "white")))
5051 ;; Generate some PostScript.
5053 (narrow-to-region from to
)
5054 (ps-print-ensure-fontified from to
)
5055 (let ((face 'default
)
5058 ((or (eq ps-print-emacs-type
'lucid
)
5059 (eq ps-print-emacs-type
'xemacs
))
5060 ;; Build the list of extents...
5061 (let ((a (cons 'dummy nil
))
5062 record type extent extent-list
)
5063 (map-extents 'ps-mapper nil from to a
)
5064 (setq a
(sort (cdr a
) 'car-less-than-car
)
5067 ;; Loop through the extents...
5069 (setq record
(car a
)
5071 position
(car record
)
5077 extent
(car record
))
5079 ;; Plot up to this record.
5080 ;; XEmacs 19.12: for some reason, we're getting into a
5081 ;; situation in which some of the records have
5082 ;; positions less than 'from'. Since we've narrowed
5083 ;; the buffer, this'll generate errors. This is a
5084 ;; hack, but don't call ps-plot-with-face unless from >
5086 (and (>= from
(point-min)) (<= position
(point-max))
5087 (ps-plot-with-face from position face
))
5091 (and (extent-face extent
)
5092 (setq extent-list
(sort (cons extent extent-list
)
5093 'ps-extent-sorter
))))
5096 (setq extent-list
(sort (delq extent extent-list
)
5097 'ps-extent-sorter
))))
5099 (setq face
(if extent-list
5100 (extent-face (car extent-list
))
5105 ((eq ps-print-emacs-type
'emacs
)
5106 (let ((property-change from
)
5107 (overlay-change from
)
5108 (save-buffer-invisibility-spec buffer-invisibility-spec
)
5109 (buffer-invisibility-spec nil
))
5111 (and (< property-change to
) ; Don't search for property change
5112 ; unless previous search succeeded.
5113 (setq property-change
(next-property-change from nil to
)))
5114 (and (< overlay-change to
) ; Don't search for overlay change
5115 ; unless previous search succeeded.
5116 (setq overlay-change
(min (next-overlay-change from
) to
)))
5117 (setq position
(min property-change overlay-change
))
5118 ;; The code below is not quite correct,
5119 ;; because a non-nil overlay invisible property
5120 ;; which is inactive according to the current value
5121 ;; of buffer-invisibility-spec nonetheless overrides
5122 ;; a face text property.
5124 (cond ((let ((prop (get-text-property from
'invisible
)))
5125 ;; Decide whether this invisible property
5126 ;; really makes the text invisible.
5127 (if (eq save-buffer-invisibility-spec t
)
5129 (or (memq prop save-buffer-invisibility-spec
)
5130 (assq prop save-buffer-invisibility-spec
))))
5131 'emacs--invisible--face
)
5132 ((get-text-property from
'face
))
5134 (let ((overlays (overlays-at from
))
5135 (face-priority -
1)) ; text-property
5136 (while (and overlays
5137 (not (eq face
'emacs--invisible--face
)))
5138 (let* ((overlay (car overlays
))
5139 (overlay-invisible (overlay-get overlay
'invisible
))
5140 (overlay-priority (or (overlay-get overlay
'priority
)
5142 (and (> overlay-priority face-priority
)
5144 (cond ((if (eq save-buffer-invisibility-spec t
)
5145 (not (null overlay-invisible
))
5146 (or (memq overlay-invisible
5147 save-buffer-invisibility-spec
)
5148 (assq overlay-invisible
5149 save-buffer-invisibility-spec
)))
5150 'emacs--invisible--face
)
5151 ((overlay-get overlay
'face
))
5153 face-priority overlay-priority
)))
5154 (setq overlays
(cdr overlays
))))
5155 ;; Plot up to this record.
5156 (ps-plot-with-face from position face
)
5157 (setq from position
)))))
5158 (ps-plot-with-face from to face
))))
5160 (defun ps-generate-postscript (from to
)
5161 (ps-plot-region from to
0 nil
))
5163 (defun ps-generate (buffer from to genfunc
)
5165 (let ((from (min to from
))
5167 ;; This avoids trouble if chars with read-only properties
5168 ;; are copied into ps-spool-buffer.
5169 (inhibit-read-only t
))
5171 (narrow-to-region from to
)
5172 (and ps-razzle-dazzle
5173 (message "Formatting...%3d%%" (setq ps-razchunk
0)))
5174 (setq ps-source-buffer buffer
5175 ps-spool-buffer
(get-buffer-create ps-spool-buffer-name
))
5176 (ps-init-output-queue)
5177 (let (safe-marker completed-safely needs-begin-file
)
5180 (set-buffer ps-spool-buffer
)
5181 (set-buffer-multibyte nil
)
5183 ;; Get a marker and make it point to the current end of the
5184 ;; buffer, If an error occurs, we'll delete everything from
5185 ;; the end of this marker onwards.
5186 (setq safe-marker
(make-marker))
5187 (set-marker safe-marker
(point-max))
5189 (goto-char (point-min))
5190 (or (looking-at (regexp-quote ps-adobe-tag
))
5191 (setq needs-begin-file t
))
5193 (set-buffer ps-source-buffer
)
5195 (when needs-begin-file
5197 (ps-mule-initialize))
5198 (ps-mule-begin-job from to
)
5200 (set-buffer ps-source-buffer
)
5201 (funcall genfunc from to
)
5208 ;; Setting this variable tells the unwind form that the
5209 ;; the PostScript was generated without error.
5210 (setq completed-safely t
))
5212 ;; Unwind form: If some bad mojo occurred while generating
5213 ;; PostScript, delete all the PostScript that was generated.
5214 ;; This protects the previously spooled files from getting
5216 (and (markerp safe-marker
) (not completed-safely
)
5218 (set-buffer ps-spool-buffer
)
5219 (delete-region (marker-position safe-marker
) (point-max))))))
5221 (and ps-razzle-dazzle
(message "Formatting...done"))))))
5224 (defun ps-end-job ()
5225 (let ((total-lines (cdr ps-printing-region
))
5226 (total-pages (if ps-print-only-one-header
5230 (set-buffer ps-spool-buffer
)
5231 ;; Back to the PS output buffer to set the page count
5232 (goto-char (point-min))
5233 (and (re-search-forward "^/Lines 0 def\n/PageCount 0 def$" nil t
)
5234 (replace-match (format "/Lines %d def\n/PageCount %d def"
5235 total-lines total-pages
) t
))))
5238 ;; Permit dynamic evaluation at print time of `ps-lpr-switches'.
5239 (defun ps-do-despool (filename)
5240 (if (or (not (boundp 'ps-spool-buffer
))
5241 (not (symbol-value 'ps-spool-buffer
)))
5242 (message "No spooled PostScript to print")
5245 (and ps-razzle-dazzle
(message "Saving..."))
5246 (set-buffer ps-spool-buffer
)
5247 (setq filename
(expand-file-name filename
))
5248 (let ((coding-system-for-write 'raw-text-unix
))
5249 (write-region (point-min) (point-max) filename
))
5250 (and ps-razzle-dazzle
(message "Wrote %s" filename
)))
5251 ;; Else, spool to the printer
5252 (and ps-razzle-dazzle
(message "Printing..."))
5254 (set-buffer ps-spool-buffer
)
5255 (let* ((coding-system-for-write 'raw-text-unix
)
5256 (ps-printer-name (or ps-printer-name
5257 (and (boundp 'printer-name
)
5260 (append (and (stringp ps-printer-name
)
5261 (list (concat "-P" ps-printer-name
)))
5263 (apply (or ps-print-region-function
'call-process-region
)
5264 (point-min) (point-max) ps-lpr-command nil
5265 (and (fboundp 'start-process
) 0)
5267 (ps-flatten-list ; dynamic evaluation
5268 (mapcar 'ps-eval-switch ps-lpr-switches
)))))
5269 (and ps-razzle-dazzle
(message "Printing...done")))
5270 (kill-buffer ps-spool-buffer
)))
5272 ;; Dynamic evaluation
5273 (defun ps-eval-switch (arg)
5274 (cond ((stringp arg
) arg
)
5275 ((functionp arg
) (apply arg nil
))
5276 ((symbolp arg
) (symbol-value arg
))
5277 ((consp arg
) (apply (car arg
) (cdr arg
)))
5280 ;; `ps-flatten-list' is defined here (copied from "message.el" and
5281 ;; enhanced to handle dotted pairs as well) until we can get some
5282 ;; sensible autoloads, or `flatten-list' gets put somewhere decent.
5284 ;; (ps-flatten-list '((a . b) c (d . e) (f g h) i . j))
5285 ;; => (a b c d e f g h i j)
5287 (defun ps-flatten-list (&rest list
)
5288 (ps-flatten-list-1 list
))
5290 (defun ps-flatten-list-1 (list)
5291 (cond ((null list
) nil
)
5292 ((consp list
) (append (ps-flatten-list-1 (car list
))
5293 (ps-flatten-list-1 (cdr list
))))
5296 (defun ps-kill-emacs-check ()
5298 (and (setq ps-buffer
(get-buffer ps-spool-buffer-name
))
5299 (buffer-modified-p ps-buffer
)
5300 (y-or-n-p "Unprinted PostScript waiting; print now? ")
5302 (and (setq ps-buffer
(get-buffer ps-spool-buffer-name
))
5303 (buffer-modified-p ps-buffer
)
5304 (not (yes-or-no-p "Unprinted PostScript waiting; exit anyway? "))
5305 (error "Unprinted PostScript"))))
5307 (cond ((fboundp 'add-hook
)
5308 (funcall 'add-hook
'kill-emacs-hook
'ps-kill-emacs-check
))
5310 (message "Won't override existing `kill-emacs-hook'"))
5312 (setq kill-emacs-hook
'ps-kill-emacs-check
)))
5315 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5316 ;;; Sample Setup Code:
5319 ;; This stuff is for anybody that's brave enough to look this far,
5320 ;; and able to figure out how to use it. It isn't really part of
5321 ;; ps-print, but I'll leave it here in hopes it might be useful:
5323 ;; WARNING!!! The following code is *sample* code only.
5324 ;; Don't use it unless you understand what it does!
5326 (defmacro ps-prsc
()
5327 `(if (eq ps-print-emacs-type
'emacs
) [f22] 'f22))
5328 (defmacro ps-c-prsc ()
5329 `(if (eq ps-print-emacs-type 'emacs) [C-f22] '(control f22)))
5330 (defmacro ps-s-prsc ()
5331 `(if (eq ps-print-emacs-type 'emacs) [S-f22] '(shift f22)))
5333 ;; A hook to bind to `rmail-mode-hook' to locally bind prsc and set the
5334 ;; `ps-left-headers' specially for mail messages.
5335 (defun ps-rmail-mode-hook ()
5336 (local-set-key (ps-prsc) 'ps-rmail-print-message-from-summary)
5337 (setq ps-header-lines 3
5339 ;; The left headers will display the message's subject, its
5340 ;; author, and the name of the folder it was in.
5341 '(ps-article-subject ps-article-author buffer-name)))
5343 ;; See `ps-gnus-print-article-from-summary'. This function does the
5344 ;; same thing for rmail.
5345 (defun ps-rmail-print-message-from-summary ()
5347 (ps-print-message-from-summary 'rmail-summary-buffer "RMAIL"))
5349 ;; Used in `ps-rmail-print-article-from-summary',
5350 ;; `ps-gnus-print-article-from-summary' and `ps-vm-print-message-from-summary'.
5351 (defun ps-print-message-from-summary (summary-buffer summary-default)
5352 (let ((ps-buf (or (and (boundp summary-buffer)
5353 (symbol-value summary-buffer))
5355 (and (get-buffer ps-buf)
5358 (ps-spool-buffer-with-faces)))))
5360 ;; Look in an article or mail message for the Subject: line. To be
5361 ;; placed in `ps-left-headers'.
5362 (defun ps-article-subject ()
5364 (goto-char (point-min))
5365 (if (re-search-forward "^Subject:[ \t]+\\(.*\\)$" nil t)
5366 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
5369 ;; Look in an article or mail message for the From: line. Sorta-kinda
5370 ;; understands RFC-822 addresses and can pull the real name out where
5371 ;; it's provided. To be placed in `ps-left-headers'.
5372 (defun ps-article-author ()
5374 (goto-char (point-min))
5375 (if (re-search-forward "^From:[ \t]+\\(.*\\)$" nil t)
5376 (let ((fromstring (buffer-substring-no-properties (match-beginning 1)
5380 ;; Try first to match addresses that look like
5381 ;; thompson@wg2.waii.com (Jim Thompson)
5382 ((string-match ".*[ \t]+(\\(.*\\))" fromstring)
5383 (substring fromstring (match-beginning 1) (match-end 1)))
5385 ;; Next try to match addresses that look like
5386 ;; Jim Thompson <thompson@wg2.waii.com>
5387 ((string-match "\\(.*\\)[ \t]+<.*>" fromstring)
5388 (substring fromstring (match-beginning 1) (match-end 1)))
5390 ;; Couldn't find a real name -- show the address instead.
5394 ;; A hook to bind to `gnus-article-prepare-hook'. This will set the
5395 ;; `ps-left-headers' specially for gnus articles. Unfortunately,
5396 ;; `gnus-article-mode-hook' is called only once, the first time the *Article*
5397 ;; buffer enters that mode, so it would only work for the first time
5398 ;; we ran gnus. The second time, this hook wouldn't get set up. The
5399 ;; only alternative is `gnus-article-prepare-hook'.
5400 (defun ps-gnus-article-prepare-hook ()
5401 (setq ps-header-lines 3
5403 ;; The left headers will display the article's subject, its
5404 ;; author, and the newsgroup it was in.
5405 '(ps-article-subject ps-article-author gnus-newsgroup-name)))
5407 ;; A hook to bind to `vm-mode-hook' to locally bind prsc and set the
5408 ;; `ps-left-headers' specially for mail messages.
5409 (defun ps-vm-mode-hook ()
5410 (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary)
5411 (setq ps-header-lines 3
5413 ;; The left headers will display the message's subject, its
5414 ;; author, and the name of the folder it was in.
5415 '(ps-article-subject ps-article-author buffer-name)))
5417 ;; Every now and then I forget to switch from the *Summary* buffer to
5418 ;; the *Article* before hitting prsc, and a nicely formatted list of
5419 ;; article subjects shows up at the printer. This function, bound to
5420 ;; prsc for the gnus *Summary* buffer means I don't have to switch
5422 ;; sb: Updated for Gnus 5.
5423 (defun ps-gnus-print-article-from-summary ()
5425 (ps-print-message-from-summary 'gnus-article-buffer "*Article*"))
5427 ;; See `ps-gnus-print-article-from-summary'. This function does the
5428 ;; same thing for vm.
5429 (defun ps-vm-print-message-from-summary ()
5431 (ps-print-message-from-summary 'vm-mail-buffer ""))
5433 ;; A hook to bind to bind to `gnus-summary-setup-buffer' to locally bind
5435 (defun ps-gnus-summary-setup ()
5436 (local-set-key (ps-prsc) 'ps-gnus-print-article-from-summary))
5438 ;; Look in an article or mail message for the Subject: line. To be
5439 ;; placed in `ps-left-headers'.
5440 (defun ps-info-file ()
5442 (goto-char (point-min))
5443 (if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)" nil t)
5444 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
5447 ;; Look in an article or mail message for the Subject: line. To be
5448 ;; placed in `ps-left-headers'.
5449 (defun ps-info-node ()
5451 (goto-char (point-min))
5452 (if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)" nil t)
5453 (buffer-substring-no-properties (match-beginning 1) (match-end 1))
5456 (defun ps-info-mode-hook ()
5457 (setq ps-left-header
5458 ;; The left headers will display the node name and file name.
5459 '(ps-info-node ps-info-file)))
5461 ;; WARNING! The following function is a *sample* only, and is *not*
5462 ;; meant to be used as a whole unless you understand what the effects
5463 ;; will be! (In fact, this is a copy of Jim's setup for ps-print --
5464 ;; I'd be very surprised if it was useful to *anybody*, without
5467 (defun ps-jts-ps-setup ()
5468 (global-set-key (ps-prsc) 'ps-spool-buffer-with-faces) ;f22 is prsc
5469 (global-set-key (ps-s-prsc) 'ps-spool-region-with-faces)
5470 (global-set-key (ps-c-prsc) 'ps-despool)
5471 (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook)
5472 (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup)
5473 (add-hook 'vm-mode-hook 'ps-vm-mode-hook)
5474 (add-hook 'vm-mode-hooks 'ps-vm-mode-hook)
5475 (add-hook 'Info-mode-hook 'ps-info-mode-hook)
5476 (setq ps-spool-duplex t
5477 ps-print-color-p nil
5478 ps-lpr-command "lpr"
5479 ps-lpr-switches '("-Jjct,duplex_long"))
5482 ;; WARNING! The following function is a *sample* only, and is *not*
5483 ;; meant to be used as a whole unless it corresponds to your needs.
5484 ;; (In fact, this is a copy of Jack's setup for ps-print --
5485 ;; I would not be that surprised if it was useful to *anybody*,
5486 ;; without modification.)
5488 (defun ps-jack-setup ()
5489 (setq ps-print-color-p nil
5490 ps-lpr-command "lpr"
5495 ps-number-of-columns 2
5497 ps-left-margin (/ (* 72 1.0) 2.54) ; 1.0 cm
5498 ps-right-margin (/ (* 72 1.0) 2.54) ; 1.0 cm
5499 ps-inter-column (/ (* 72 1.0) 2.54) ; 1.0 cm
5500 ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
5501 ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm
5502 ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm
5503 ps-header-line-pad .15
5505 ps-print-header-frame t
5510 ps-font-family 'Courier
5512 ps-header-font-family 'Helvetica
5513 ps-header-font-size 6
5514 ps-header-title-font-size 8)
5518 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5519 ;; To make this file smaller, some commands go in a separate file.
5520 ;; But autoload them here to make the separation invisible.
5522 (autoload 'ps-mule-prepare-ascii-font "ps-mule"
5523 "Setup special ASCII font for STRING.
5524 STRING should contain only ASCII characters.")
5526 (autoload 'ps-mule-set-ascii-font "ps-mule"
5527 "Adjust current font if current charset is not ASCII.")
5529 (autoload 'ps-mule-plot-string "ps-mule"
5530 "Generate PostScript code for ploting characters in the region FROM and TO.
5532 It is assumed that all characters in this region belong to the same charset.
5534 Optional argument BG-COLOR specifies background color.
5538 (ENDPOS . RUN-WIDTH)
5540 Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
5543 (autoload 'ps-mule-initialize "ps-mule"
5544 "Initialize global data for printing multi-byte characters.")
5546 (autoload 'ps-mule-begin-job "ps-mule"
5547 "Start printing job for multi-byte chars between FROM and TO.
5548 This checks if all multi-byte characters in the region are printable or not.")
5550 (autoload 'ps-mule-begin-page "ps-mule"
5551 "Initialize multi-byte charset for printing current page.")
5554 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
5558 ;;; ps-print.el ends here