1 ;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19.
3 ;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.
5 ;; Author: Jim Thompson <thompson@wg2.waii.com>
6 ;; Keywords: print, PostScript
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;; ps-print|James C. Thompson|thompson@wg2.waii.com|
26 ;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print)|
27 ;; 26-Feb-1994|2.8|~/packages/ps-print.el|
29 ;; Baseline-version: 2.8. (Jim's last change version -- this
30 ;; file may have been edited as part of Emacs without changes to the
31 ;; version number. When reporting bugs, please also report the
32 ;; version of Emacs, if any, that ps-print was distributed with.)
36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
40 ;; This package provides printing of Emacs buffers on PostScript
41 ;; printers; the buffer's bold and italic text attributes are
42 ;; preserved in the printer output. Ps-print is intended for use with
43 ;; Emacs 19 or Lucid Emacs, together with a fontifying package such as
44 ;; font-lock or hilit.
51 ;; Ps-print provides eight commands for generating PostScript images
55 ;; ps-print-buffer-with-faces
57 ;; ps-print-region-with-faces
59 ;; ps-spool-buffer-with-faces
61 ;; ps-spool-region-with-faces
63 ;; These commands all perform essentially the same function: they
64 ;; generate PostScript images suitable for printing on a PostScript
65 ;; printer or displaying with GhostScript. These commands are
66 ;; collectively referred to as "ps-print- commands".
68 ;; The word "print" or "spool" in the command name determines when the
69 ;; PostScript image is sent to the printer:
71 ;; print - The PostScript image is immediately sent to the
74 ;; spool - The PostScript image is saved temporarily in an
75 ;; Emacs buffer. Many images may be spooled locally
76 ;; before printing them. To send the spooled images
77 ;; to the printer, use the command ps-despool.
79 ;; The spooling mechanism was designed for printing lots of small
80 ;; files (mail messages or netnews articles) to save paper that would
81 ;; otherwise be wasted on banner pages, and to make it easier to find
82 ;; your output at the printer (it's easier to pick up one 50-page
83 ;; printout than to find 50 single-page printouts).
85 ;; Ps-print has a hook in the kill-emacs-hooks so that you won't
86 ;; accidently quit from Emacs while you have unprinted PostScript
87 ;; waiting in the spool buffer. If you do attempt to exit with
88 ;; spooled PostScript, you'll be asked if you want to print it, and if
89 ;; you decline, you'll be asked to confirm the exit; this is modeled
90 ;; on the confirmation that Emacs uses for modified buffers.
92 ;; The word "buffer" or "region" in the command name determines how
93 ;; much of the buffer is printed:
95 ;; buffer - Print the entire buffer.
97 ;; region - Print just the current region.
99 ;; The -with-faces suffix on the command name means that the command
100 ;; will include font, color, and underline information in the
101 ;; PostScript image, so the printed image can look as pretty as the
102 ;; buffer. The ps-print- commands without the -with-faces suffix
103 ;; don't include font, color, or underline information; images printed
104 ;; with these commands aren't as pretty, but are faster to generate.
106 ;; Two ps-print- command examples:
108 ;; ps-print-buffer - print the entire buffer,
109 ;; without font, color, or
110 ;; underline information, and
111 ;; send it immediately to the
114 ;; ps-spool-region-with-faces - print just the current region;
115 ;; include font, color, and
116 ;; underline information, and
117 ;; spool the image in Emacs to
118 ;; send to the printer later.
123 ;; To print your buffer, type
125 ;; M-x ps-print-buffer
127 ;; or substitute one of the other seven ps-print- commands. The
128 ;; command will generate the PostScript image and print or spool it as
129 ;; specified. By giving the command a prefix argument
131 ;; C-u M-x ps-print-buffer
133 ;; it will save the PostScript image to a file instead of sending it
134 ;; to the printer; you will be prompted for the name of the file to
135 ;; save the image to. The prefix argument is ignored by the commands
136 ;; that spool their images, but you may save the spooled images to a
137 ;; file by giving a prefix argument to ps-despool:
139 ;; C-u M-x ps-despool
141 ;; When invoked this way, ps-despool will prompt you for the name of
142 ;; the file to save to.
144 ;; Any of the ps-print- commands can be bound to keys; I recommend
145 ;; binding ps-spool-buffer-with-faces, ps-spool-region-with-faces, and
146 ;; ps-despool. Here are the bindings I use on my Sun 4 keyboard:
148 ;; (global-set-key 'f22 'ps-spool-buffer-with-faces) ;f22 is prsc
149 ;; (global-set-key '(shift f22) 'ps-spool-region-with-faces)
150 ;; (global-set-key '(control f22) 'ps-despool)
153 ;; The Printer Interface
155 ;; The variables ps-lpr-command and ps-lpr-switches determine what
156 ;; command is used to send the PostScript images to the printer, and
157 ;; what arguments to give the command. These are analogous to lpr-
158 ;; command and lpr-switches.
160 ;; NOTE: ps-lpr-command and ps-lpr-switches take their initial values
161 ;; from the variables lpr-command and lpr-switches. If you have
162 ;; lpr-command set to invoke a pretty-printer such as enscript,
163 ;; then ps-print won't work properly. ps-lpr-command must name
164 ;; a program that does not format the files it prints.
167 ;; How Ps-Print Deals With Fonts
169 ;; The ps-print-*-with-faces commands attempt to determine which faces
170 ;; should be printed in bold or italic, but their guesses aren't
171 ;; always right. For example, you might want to map colors into faces
172 ;; so that blue faces print in bold, and red faces in italic.
174 ;; It is possible to force ps-print to consider specific faces bold or
175 ;; italic, no matter what font they are displayed in, by setting the
176 ;; variables ps-bold-faces and ps-italic-faces. These variables
177 ;; contain lists of faces that ps-print should consider bold or
178 ;; italic; to set them, put code like the following into your .emacs
181 ;; (setq ps-bold-faces '(my-blue-face))
182 ;; (setq ps-italic-faces '(my-red-face))
184 ;; Faces like bold-italic that are both bold and italic should go in
187 ;; Ps-print does not attempt to guess the sizes of fonts; all text is
188 ;; rendered using the Courier font family, in 10 point size. To
189 ;; change the font family, change the variables ps-font, ps-font-bold,
190 ;; ps-font-italic, and ps-font-bold-italic; fixed-pitch fonts work
191 ;; best, but are not required. To change the font size, change the
192 ;; variable ps-font-size.
194 ;; If you change the font family or size, you MUST also change the
195 ;; variables ps-line-height, ps-avg-char-width, and ps-space-width, or
196 ;; ps-print cannot correctly place line and page breaks.
198 ;; Ps-print keeps internal lists of which fonts are bold and which are
199 ;; italic; these lists are built the first time you invoke ps-print.
200 ;; For the sake of efficiency, the lists are built only once; the same
201 ;; lists are referred in later invokations of ps-print.
203 ;; Because these lists are built only once, it's possible for them to
204 ;; get out of sync, if a face changes, or if new faces are added. To
205 ;; get the lists back in sync, you can set the variable
206 ;; ps-build-face-reference to t, and the lists will be rebuilt the
207 ;; next time ps-print is invoked.
210 ;; How Ps-Print Deals With Color
212 ;; Ps-print detects faces with foreground and background colors
213 ;; defined and embeds color information in the PostScript image. The
214 ;; default foreground and background colors are defined by the
215 ;; variables ps-default-fg and ps-default-bg. On black-and-white
216 ;; printers, colors are displayed in grayscale. To turn off color
217 ;; output, set ps-print-color-p to nil.
222 ;; Ps-print can print headers at the top of each page; the default
223 ;; headers contain the following four items: on the left, the name of
224 ;; the buffer and, if the buffer is visiting a file, the file's
225 ;; directory; on the right, the page number and date of printing. The
226 ;; default headers look something like this:
229 ;; /home/jct/emacs-lisp/ps/new 94/12/31
231 ;; When printing on duplex printers, left and right are reversed so
232 ;; that the page numbers are toward the outside.
234 ;; Headers are configurable. To turn them off completely, set
235 ;; ps-print-header to nil. To turn off the header's gaudy framing
236 ;; box, set ps-print-header-frame to nil. Page numbers are printed in
237 ;; "n/m" format, indicating page n of m pages; to omit the total page
238 ;; count and just print the page number, set ps-show-n-of-n to nil.
240 ;; The amount of information in the header can be changed by changing
241 ;; the number of lines. To show less, set ps-header-lines to 1, and
242 ;; the header will show only the buffer name and page number. To show
243 ;; more, set ps-header-lines to 3, and the header will show the time of
244 ;; printing below the date.
246 ;; To change the content of the headers, change the variables
247 ;; ps-left-header and ps-right-header. These variables are lists,
248 ;; specifying top-to-bottom the text to display on the left or right
249 ;; side of the header. Each element of the list should be a string or
250 ;; a symbol. Strings are inserted directly into the PostScript
251 ;; arrays, and should contain the PostScript string delimiters '(' and
254 ;; Symbols in the header format lists can either represent functions
255 ;; or variables. Functions are called, and should return a string to
256 ;; show in the header. Variables should contain strings to display in
257 ;; the header. In either case, function or variable, the PostScript
258 ;; strings delimeters are added by ps-print, and should not be part of
259 ;; the returned value.
261 ;; Here's an example: say we want the left header to display the text
267 ;; where we have a function to return "Moe"
269 ;; (defun moe-func ()
272 ;; a variable specifying "Larry"
274 ;; (setq larry-var "Larry")
276 ;; and a literal for "Curly". Here's how ps-left-header should be
279 ;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)"))
281 ;; Note that Curly has the PostScript string delimiters inside his
282 ;; quotes -- those aren't misplaced lisp delimiters! Without them,
283 ;; PostScript would attempt to call the undefined function Curly,
284 ;; which would result in a PostScript error. Since most printers
285 ;; don't report PostScript errors except by aborting the print job,
286 ;; this kind of error can be hard to track down. Consider yourself
292 ;; If you have a duplex-capable printer (one that prints both sides of
293 ;; the paper), set ps-spool-duplex to t. Ps-print will insert blank
294 ;; pages to make sure each buffer starts on the correct side of the
295 ;; paper. Don't forget to set ps-lpr-switches to select duplex
296 ;; printing for your printer.
301 ;; The variable ps-paper-type determines the size of paper ps-print
302 ;; formats for; it should contain one of the symbols ps-letter,
303 ;; ps-legal, or ps-a4. The default is ps-letter.
306 ;; Make sure that the variables ps-lpr-command and ps-lpr-switches
307 ;; contain appropriate values for your system; see the usage notes
308 ;; below and the documentation of these variables.
311 ;; New since version 1.5
312 ;; ---------------------
313 ;; Color output capability.
315 ;; Automatic detection of font attributes (bold, italic).
317 ;; Configurable headers with page numbers.
321 ;; Support for different paper sizes.
323 ;; Better conformance to PostScript Document Structure Conventions.
326 ;; Known bugs and limitations of ps-print:
327 ;; --------------------------------------
328 ;; Although color printing will work in XEmacs 19.12, it doesn't work
329 ;; well; in particular, bold or italic fonts don't print in the right
332 ;; Invisible properties aren't correctly ignored in XEmacs 19.12.
334 ;; Automatic font-attribute detection doesn't work well, especially
335 ;; with hilit19 and older versions of get-create-face. Users having
336 ;; problems with auto-font detection should use the lists ps-italic-
337 ;; faces and ps-bold-faces and/or turn off automatic detection by
338 ;; setting ps-auto-font-detect to nil.
340 ;; Automatic font-attribute detection doesn't work with XEmacs 19.12
341 ;; in tty mode; use the lists ps-italic-faces and ps-bold-faces
344 ;; Still too slow; could use some hand-optimization.
346 ;; ASCII Control characters other than tab, linefeed and pagefeed are
349 ;; Default background color isn't working.
351 ;; Faces are always treated as opaque.
353 ;; Epoch and Emacs 18 not supported. At all.
358 ;; 2-up and 4-up capability.
362 ;; Wide-print (landscape) capability.
367 ;; Thanks to Kevin Rodgers <kevinr@ihs.com> for adding support for
368 ;; color and the invisible property.
370 ;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing
371 ;; the initial port to Emacs 19. His code is no longer part of
372 ;; ps-print, but his work is still appreciated.
374 ;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org,
375 ;; for adding underline support. Their code also is no longer part of
376 ;; ps-print, but their efforts are not forgotten.
378 ;; Thanks also to all of you who mailed code to add features to
379 ;; ps-print; although I didn't use your code, I still appreciate your
380 ;; sharing it with me.
382 ;; Thanks to all who mailed comments, encouragement, and criticism.
383 ;; Thanks also to all who responded to my survey; I had too many
384 ;; responses to reply to them all, but I greatly appreciate your
388 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
392 (defconst ps-print-version "2.8"
393 "ps-print.el,v 2.8 1995/05/04 12:06:10 jct Exp
395 Jim's last change version -- this file may have been edited as part of
396 Emacs without changes to the version number. When reporting bugs,
397 please also report the version of Emacs, if any, that ps-print was
400 Please send all bug fixes and enhancements to
401 Jim Thompson <thompson@wg2.waii.com>.")
403 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
406 (defvar ps-lpr-command lpr-command
407 "*The shell command for printing a PostScript file.")
409 (defvar ps-lpr-switches lpr-switches
410 "*A list of extra switches to pass to `ps-lpr-command'.")
412 (defvar ps-spool-duplex nil ; Not many people have duplex
413 ; printers, so default to nil.
414 "*Non-nil indicates spooling is for a two-sided printer.
415 For a duplex printer, the `ps-spool-*' commands will insert blank pages
416 as needed between print jobs so that the next buffer printed will
417 start on the right page. Also, if headers are turned on, the headers
418 will be reversed on duplex printers so that the page numbers fall to
419 the left on even-numbered pages.")
421 (defvar ps-paper-type 'ps-letter
422 "*Specifies the size of paper to format for. Should be one of
423 `ps-letter', `ps-legal', or `ps-a4'.")
425 (defvar ps-print-header t
426 "*Non-nil means print a header at the top of each page.
427 By default, the header displays the buffer name, page number, and, if
428 the buffer is visiting a file, the file's directory. Headers are
429 customizable by changing variables `ps-header-left' and
432 (defvar ps-print-header-frame t
433 "*Non-nil means draw a gaudy frame around the header.")
435 (defvar ps-show-n-of-n t
436 "*Non-nil means show page numbers as N/M, meaning page N of M.
437 Note: page numbers are displayed as part of headers, see variable
438 `ps-print-headers'.")
440 (defvar ps-print-color-p (and (or (fboundp 'x-color-values) ; Emacs
441 (fboundp 'pixel-components)) ; XEmacs
443 ; Printing color requires both floating point and x-color-values.
444 "*If non-nil, print the buffer's text in color.")
446 (defvar ps-default-fg '(0.0 0.0 0.0)
447 "*RGB values of the default foreground color. Defaults to black.")
449 (defvar ps-default-bg '(1.0 1.0 1.0)
450 "*RGB values of the default background color. Defaults to white.")
452 (defvar ps-font-size 10
453 "*Font size, in points, for generating Postscript.")
455 (defvar ps-font "Courier"
456 "*Font family name for ordinary text, when generating Postscript.")
458 (defvar ps-font-bold "Courier-Bold"
459 "*Font family name for bold text, when generating Postscript.")
461 (defvar ps-font-italic "Courier-Oblique"
462 "*Font family name for italic text, when generating Postscript.")
464 (defvar ps-font-bold-italic "Courier-BoldOblique"
465 "*Font family name for bold italic text, when generating Postscript.")
467 (defvar ps-avg-char-width (if (fboundp 'float) 5.6 6)
468 "*The average width, in points, of a character, for generating Postscript.
469 This is the value that ps-print uses to determine the length,
470 x-dimension, of the text it has printed, and thus affects the point at
471 which long lines wrap around. If you change the font or
472 font size, you will probably have to adjust this value to match.")
474 (defvar ps-space-width (if (fboundp 'float) 5.6 6)
475 "*The width of a space character, for generating Postscript.
476 This value is used in expanding tab characters.")
478 (defvar ps-line-height (if (fboundp 'float) 11.29 11)
479 "*The height of a line, for generating Postscript.
480 This is the value that ps-print uses to determine the height,
481 y-dimension, of the lines of text it has printed, and thus affects the
482 point at which page-breaks are placed. If you change the font or font
483 size, you will probably have to adjust this value to match. The
484 line-height is *not* the same as the point size of the font.")
486 (defvar ps-auto-font-detect t
487 "*Non-nil means automatically detect bold/italic face attributes.
488 nil means rely solely on the lists `ps-bold-faces', `ps-italic-faces',
489 and `ps-underlined-faces'.")
491 (defvar ps-bold-faces '()
492 "*A list of the \(non-bold\) faces that should be printed in bold font.
493 This applies to generating Postscript.")
495 (defvar ps-italic-faces '()
496 "*A list of the \(non-italic\) faces that should be printed in italic font.
497 This applies to generating Postscript.")
499 (defvar ps-underlined-faces '()
500 "*A list of the \(non-underlined\) faces that should be printed underlined.
501 This applies to generating Postscript.")
503 (defvar ps-header-lines 2
504 "*Number of lines to display in page header, when generating Postscript.")
505 (make-variable-buffer-local 'ps-header-lines)
507 (defvar ps-left-header
508 (list 'ps-get-buffer-name 'ps-header-dirpart)
509 "*The items to display on the right part of the page header.
510 This applies to generating Postscript.
512 The value should be a list of strings and symbols, each representing an
513 entry in the PostScript array HeaderLinesLeft.
515 Strings are inserted unchanged into the array; those representing
516 PostScript string literals should be delimited with PostScript string
517 delimiters '(' and ')'.
519 For symbols with bound functions, the function is called and should
520 return a string to be inserted into the array. For symbols with bound
521 values, the value should be a string to be inserted into the array.
522 In either case, function or variable, the string value has PostScript
523 string delimiters added to it.")
524 (make-variable-buffer-local 'ps-left-header)
526 (defvar ps-right-header
527 (list "/pagenumberstring load" 'time-stamp-yy/mm/dd 'time-stamp-hh:mm:ss)
528 "*The items to display on the left part of the page header.
529 This applies to generating Postscript.
531 See the variable `ps-left-header' for a description of the format of
533 (make-variable-buffer-local 'ps-right-header)
535 (defvar ps-razzle-dazzle t
536 "*Non-nil means report progress while formatting buffer.")
538 (defvar ps-adobe-tag "%!PS-Adobe-1.0\n"
539 "*Contains the header line identifying the output as PostScript.
540 By default, `ps-adobe-tag' contains the standard identifier. Some
541 printers require slightly different versions of this line.")
543 (defvar ps-build-face-reference t
544 "*Non-nil means build the reference face lists.
546 Ps-print sets this value to nil after it builds its internal reference
547 lists of bold and italic faces. By settings its value back to t, you
548 can force ps-print to rebuild the lists the next time you invoke one
549 of the ...-with-faces commands.
551 You should set this value back to t after you change the attributes of
552 any face, or create new faces. Most users shouldn't have to worry
553 about its setting, though.")
555 (defvar ps-always-build-face-reference nil
556 "*Non-nil means always rebuild the reference face lists.
558 If this variable is non-nil, ps-print will rebuild its internal
559 reference lists of bold and italic faces *every* time one of the
560 -with-faces commands is called. Most users shouldn't need to set this
563 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
567 (defun ps-print-buffer (&optional filename)
568 "Generate and print a PostScript image of the buffer.
570 When called with a numeric prefix argument (C-u), prompts the user for
571 the name of a file to save the PostScript image in, instead of sending
574 More specifically, the FILENAME argument is treated as follows: if it
575 is nil, send the image to the printer. If FILENAME is a string, save
576 the PostScript image in a file with that name. If FILENAME is a
577 number, prompt the user for the name of the file to save in."
579 (interactive (list (ps-print-preprint current-prefix-arg)))
580 (ps-generate (current-buffer) (point-min) (point-max)
581 'ps-generate-postscript)
582 (ps-do-despool filename))
586 (defun ps-print-buffer-with-faces (&optional filename)
587 "Generate and print a PostScript image of the buffer.
588 Like `ps-print-buffer', but includes font, color, and underline
589 information in the generated image. This command works only if you
590 are using a window system, so it has a way to determine color values."
591 (interactive (list (ps-print-preprint current-prefix-arg)))
592 (ps-generate (current-buffer) (point-min) (point-max)
593 'ps-generate-postscript-with-faces)
594 (ps-do-despool filename))
598 (defun ps-print-region (from to &optional filename)
599 "Generate and print a PostScript image of the region.
600 Like `ps-print-buffer', but prints just the current region."
602 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg)))
603 (ps-generate (current-buffer) from to
604 'ps-generate-postscript)
605 (ps-do-despool filename))
609 (defun ps-print-region-with-faces (from to &optional filename)
610 "Generate and print a PostScript image of the region.
611 Like `ps-print-region', but includes font, color, and underline
612 information in the generated image. This command works only if you
613 are using a window system, so it has a way to determine color values."
615 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg)))
616 (ps-generate (current-buffer) from to
617 'ps-generate-postscript-with-faces)
618 (ps-do-despool filename))
622 (defun ps-spool-buffer ()
623 "Generate and spool a PostScript image of the buffer.
624 Like `ps-print-buffer' except that the PostScript image is saved in a
625 local buffer to be sent to the printer later.
627 Use the command `ps-despool' to send the spooled images to the printer."
629 (ps-generate (current-buffer) (point-min) (point-max)
630 'ps-generate-postscript))
634 (defun ps-spool-buffer-with-faces ()
635 "Generate and spool a PostScript image of the buffer.
636 Like `ps-spool-buffer', but includes font, color, and underline
637 information in the generated image. This command works only if you
638 are using a window system, so it has a way to determine color values.
640 Use the command `ps-despool' to send the spooled images to the printer."
643 (ps-generate (current-buffer) (point-min) (point-max)
644 'ps-generate-postscript-with-faces))
648 (defun ps-spool-region (from to)
649 "Generate a PostScript image of the region and spool locally.
650 Like `ps-spool-buffer', but spools just the current region.
652 Use the command `ps-despool' to send the spooled images to the printer."
654 (ps-generate (current-buffer) from to
655 'ps-generate-postscript))
659 (defun ps-spool-region-with-faces (from to)
660 "Generate a PostScript image of the region and spool locally.
661 Like `ps-spool-region', but includes font, color, and underline
662 information in the generated image. This command works only if you
663 are using a window system, so it has a way to determine color values.
665 Use the command `ps-despool' to send the spooled images to the printer."
667 (ps-generate (current-buffer) from to
668 'ps-generate-postscript-with-faces))
671 (defun ps-despool (&optional filename)
672 "Send the spooled PostScript to the printer.
674 When called with a numeric prefix argument (C-u), prompt the user for
675 the name of a file to save the spooled PostScript in, instead of sending
678 More specifically, the FILENAME argument is treated as follows: if it
679 is nil, send the image to the printer. If FILENAME is a string, save
680 the PostScript image in a file with that name. If FILENAME is a
681 number, prompt the user for the name of the file to save in."
682 (interactive (list (ps-print-preprint current-prefix-arg)))
683 (ps-do-despool filename))
685 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
686 ;; Utility functions and variables:
688 (defvar ps-print-emacs-type
689 (cond ((string-match "XEmacs" emacs-version) 'xemacs)
690 ((string-match "Lucid" emacs-version) 'lucid)
691 ((string-match "Epoch" emacs-version) 'epoch)
694 (if (or (eq ps-print-emacs-type 'lucid)
695 (eq ps-print-emacs-type 'xemacs))
696 (if (< emacs-minor-version 12)
697 (setq ps-print-color-p nil))
698 (require 'faces)) ; face-font, face-underline-p,
701 (require 'time-stamp)
703 (defvar ps-print-prologue "% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4:
704 % If the ISOLatin1Encoding vector isn't known, define it.
705 /ISOLatin1Encoding where { pop } {
706 % Define the ISO Latin-1 encoding vector.
707 % The first half is the same as the standard encoding,
708 % except for minus instead of hyphen at code 055.
710 StandardEncoding 0 45 getinterval aload pop
712 StandardEncoding 46 82 getinterval aload pop
713 %*** NOTE: the following are missing in the Adobe documentation,
714 %*** but appear in the displayed table:
715 %*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240.
717 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
718 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
719 /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
720 /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron
722 /space /exclamdown /cent /sterling
723 /currency /yen /brokenbar /section
724 /dieresis /copyright /ordfeminine /guillemotleft
725 /logicalnot /hyphen /registered /macron
726 /degree /plusminus /twosuperior /threesuperior
727 /acute /mu /paragraph /periodcentered
728 /cedilla /onesuperior /ordmasculine /guillemotright
729 /onequarter /onehalf /threequarters /questiondown
731 /Agrave /Aacute /Acircumflex /Atilde
732 /Adieresis /Aring /AE /Ccedilla
733 /Egrave /Eacute /Ecircumflex /Edieresis
734 /Igrave /Iacute /Icircumflex /Idieresis
735 /Eth /Ntilde /Ograve /Oacute
736 /Ocircumflex /Otilde /Odieresis /multiply
737 /Oslash /Ugrave /Uacute /Ucircumflex
738 /Udieresis /Yacute /Thorn /germandbls
740 /agrave /aacute /acircumflex /atilde
741 /adieresis /aring /ae /ccedilla
742 /egrave /eacute /ecircumflex /edieresis
743 /igrave /iacute /icircumflex /idieresis
744 /eth /ntilde /ograve /oacute
745 /ocircumflex /otilde /odieresis /divide
746 /oslash /ugrave /uacute /ucircumflex
747 /udieresis /yacute /thorn /ydieresis
751 /reencodeFontISO { %def
753 length 5 add dict % Make a new font (a new dict
754 % the same size as the old
755 % one) with room for our new
758 begin % Make the new font the
759 % current dictionary.
763 { def } { pop pop } ifelse
764 } forall % Copy each of the symbols
765 % from the old dictionary to
766 % the new except for the font
769 /Encoding ISOLatin1Encoding def % Override the encoding with
770 % the ISOLatin1 encoding.
772 % Use the font's bounding box to determine the ascent, descent,
773 % and overall height; don't forget that these values have to be
774 % transformed using the font's matrix.
776 FontMatrix transform /Ascent exch def pop
777 FontMatrix transform /Descent exch def pop
778 /FontHeight Ascent Descent sub def
780 % Define these in case they're not in the FontInfo (also, here
781 % they're easier to get to.
782 /UnderlinePosition 1 def
783 /UnderlineThickness 1 def
785 % Get the underline position and thickness if they're defined.
786 currentdict /FontInfo known {
789 dup /UnderlinePosition known {
790 dup /UnderlinePosition get
791 0 exch FontMatrix transform exch pop
792 /UnderlinePosition exch def
795 dup /UnderlineThickness known {
796 /UnderlineThickness get
797 0 exch FontMatrix transform exch pop
798 /UnderlineThickness exch def
803 currentdict % Leave the new font on the
806 end % Stop using the font as the
807 % current dictionary.
809 definefont % Put the font into the font
812 pop % Discard the returned font.
816 findfont exch scalefont reencodeFontISO
821 dup /Ascent get /Ascent exch def
822 dup /Descent get /Descent exch def
823 dup /FontHeight get /FontHeight exch def
824 dup /UnderlinePosition get /UnderlinePosition exch def
825 dup /UnderlineThickness get /UnderlineThickness exch def
829 /FG /setrgbcolor load def
834 { mark 4 1 roll ] /bgcolor exch def } if
837 /dobackground { % width --
844 0 Descent Ascent sub rlineto
847 bgcolor aload pop setrgbcolor
852 /dobackgroundstring { % string --
857 /dounderline { % fromx fromy --
860 UnderlineThickness setlinewidth
862 UnderlinePosition add moveto
863 UnderlinePosition add lineto
870 PrintWidth LeftMargin add exch sub dobackground
874 currentpoint exch pop
875 PrintWidth LeftMargin add exch dounderline
878 /SL { % Soft Linefeed
881 currentpoint LineHeight sub LeftMargin exch moveto pop
884 /HL /SL load def % Hard Linefeed
886 /sp1 { currentpoint 3 -1 roll } def
889 /dcp { currentpoint exch 40 string cvs print (, ) print = } def
891 exch 40 string cvs print (, ) print = } def
894 bg { dup dobackgroundstring } if
897 ul { dounderline } if
902 ( ) stringwidth % Get the width of a space
903 pop % Discard the Y component
904 mul % Multiply the width of a
905 % space by the number of
907 bg { dup dobackground } if
909 ul { dounderline } if
918 PrintHeaderFrame { HeaderFrame } if
922 BottomMargin PrintHeight add
923 moveto % move to where printing will
930 showpage % Spit out a page
939 /UL { /ul exch def } def
941 /h0 14 /Helvetica-Bold Font
942 /h1 12 /Helvetica Font
946 /HeaderLineHeight FontHeight def
947 /HeaderDescent Descent def
951 /HeaderOffset TopMargin 2 div def
952 /HeaderLines exch def
953 /HeaderHeight HeaderLines HeaderLineHeight mul HeaderPad 2 mul add def
954 /PrintHeight PrintHeight HeaderHeight sub def
958 LeftMargin BottomMargin PrintHeight add HeaderOffset add
963 0 HeaderHeight rlineto
964 PrintWidth neg 0 rlineto
965 0 HeaderHeight neg rlineto
971 HeaderFrameStart moveto
975 HeaderFrameStart moveto
977 gsave 0.9 setgray fill grestore
978 gsave 0 setgray stroke grestore
984 exch HeaderPad add exch
985 HeaderLineHeight HeaderLines 1 sub mul add HeaderDescent sub HeaderPad add
989 dup length 3 -1 roll dup length dup 4 -1 roll add string dup
990 0 5 -1 roll putinterval
991 dup 4 2 roll exch putinterval
995 PageNumber 32 string cvs
998 PageCount 32 string cvs strcat
1005 HeaderLinesRight HeaderLinesLeft
1006 Duplex PageNumber 1 and 0 eq and { exch } if
1012 dup xcheck { exec } if
1015 0 HeaderLineHeight neg rmoveto
1024 dup xcheck { exec } if
1026 PrintWidth exch sub HeaderPad 2 mul sub 0 rmoveto
1029 0 HeaderLineHeight neg rmoveto
1038 /sw ( ) stringwidth pop def
1039 /aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch
1040 stringwidth pop exch div def
1041 /t1 12 /Helvetica-Oblique Font
1049 ( point, the line height is ) show
1050 lh 32 string cvs show
1051 (, the space width is ) show
1052 sw 32 string cvs show
1055 0 FontHeight neg rmoveto
1056 (and a crude estimate of average character width is ) show
1057 aw 32 string cvs show
1062 % 10 /Courier ReportFontInfo
1065 ;; Start Editing Here:
1067 (defvar ps-source-buffer nil)
1068 (defvar ps-spool-buffer-name "*PostScript*")
1069 (defvar ps-spool-buffer nil)
1071 (defvar ps-output-head nil)
1072 (defvar ps-output-tail nil)
1074 (defvar ps-page-count 0)
1075 (defvar ps-showpage-count 0)
1077 (defvar ps-current-font 0)
1078 (defvar ps-current-underline-p nil)
1079 (defvar ps-default-color (if ps-print-color-p ps-default-fg)) ; black
1080 (defvar ps-current-color ps-default-color)
1081 (defvar ps-current-bg nil)
1083 (defvar ps-razchunk 0)
1085 (defvar ps-color-format (if (eq ps-print-emacs-type 'emacs)
1087 ;;Emacs understands the %f format; we'll
1088 ;;use it to limit color RGB values to
1089 ;;three decimals to cut down some on the
1090 ;;size of the PostScript output.
1093 ;; Lucid emacsen will have to make do with
1094 ;; %s (princ) for floats.
1097 ;; These values determine how much print-height to deduct when headers
1098 ;; are turned on. This is a pretty clumsy way of handling it, but
1099 ;; it'll do for now.
1100 (defvar ps-header-title-line-height (if (fboundp 'float) 16.0 16));Helvetica 14
1101 (defvar ps-header-line-height (if (fboundp 'float) 13.7 14));Helvetica 12
1102 (defvar ps-header-pad 2)
1104 ;; LetterSmall 7.68 inch 10.16 inch
1105 ;; Tabloid 11.0 inch 17.0 inch
1106 ;; Ledger 17.0 inch 11.0 inch
1107 ;; Statement 5.5 inch 8.5 inch
1108 ;; Executive 7.5 inch 10.0 inch
1109 ;; A3 11.69 inch 16.5 inch
1110 ;; A4Small 7.47 inch 10.85 inch
1111 ;; B4 10.125 inch 14.33 inch
1112 ;; B5 7.16 inch 10.125 inch
1114 ;; All page dimensions are in PostScript points.
1116 (defvar ps-left-margin 72) ; 1 inch
1117 (defvar ps-right-margin 72) ; 1 inch
1118 (defvar ps-bottom-margin 36) ; 1/2 inch
1119 (defvar ps-top-margin 72) ; 1 inch
1121 ;; Letter 8.5 inch x 11.0 inch
1122 (defvar ps-letter-page-height 792) ; 11 inches
1123 (defvar ps-letter-page-width 612) ; 8.5 inches
1125 ;; Legal 8.5 inch x 14.0 inch
1126 (defvar ps-legal-page-height 1008) ; 14.0 inches
1127 (defvar ps-legal-page-width 612) ; 8.5 inches
1129 ;; A4 8.26 inch x 11.69 inch
1130 (defvar ps-a4-page-height 842) ; 11.69 inches
1131 (defvar ps-a4-page-width 595) ; 8.26 inches
1133 (defvar ps-pages-alist
1134 (list (list 'ps-letter ps-letter-page-width ps-letter-page-height)
1135 (list 'ps-legal ps-legal-page-width ps-legal-page-height)
1136 (list 'ps-a4 ps-a4-page-width ps-a4-page-height)))
1138 ;; Define some constants to index into the page lists.
1139 (defvar ps-page-width-i 1)
1140 (defvar ps-page-height-i 2)
1142 (defvar ps-page-dimensions nil)
1143 (defvar ps-print-width nil)
1144 (defvar ps-print-height nil)
1146 (defvar ps-height-remaining)
1147 (defvar ps-width-remaining)
1149 (defvar ps-ref-bold-faces nil)
1150 (defvar ps-ref-italic-faces nil)
1151 (defvar ps-ref-underlined-faces nil)
1153 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1154 ;; Internal functions
1156 (defun ps-get-page-dimensions ()
1157 (setq ps-page-dimensions (assq ps-paper-type ps-pages-alist))
1158 (let ((ps-page-width (nth ps-page-width-i ps-page-dimensions))
1159 (ps-page-height (nth ps-page-height-i ps-page-dimensions)))
1160 (setq ps-print-height (- ps-page-height ps-top-margin ps-bottom-margin))
1161 (setq ps-print-width (- ps-page-width ps-left-margin ps-right-margin))))
1163 (defun ps-print-preprint (&optional filename)
1165 (or (numberp filename)
1167 (let* ((name (concat (buffer-name) ".ps"))
1168 (prompt (format "Save PostScript to file: (default %s) "
1170 (read-file-name prompt default-directory
1173 ;; The following functions implement a simple list-buffering scheme so
1174 ;; that ps-print doesn't have to repeatedly switch between buffers
1175 ;; while spooling. The functions ps-output and ps-output-string build
1176 ;; up the lists; the function ps-flush-output takes the lists and
1177 ;; insert its contents into the spool buffer (*PostScript*).
1179 (defun ps-output-string-prim (string)
1180 (insert "(") ;insert start-string delimiter
1181 (save-excursion ;insert string
1184 ;; Find and quote special characters as necessary for PS
1185 (while (re-search-forward "[()\\]" nil t)
1190 (goto-char (point-max))
1191 (insert ")")) ;insert end-string delimiter
1193 (defun ps-init-output-queue ()
1194 (setq ps-output-head (list ""))
1195 (setq ps-output-tail ps-output-head))
1197 (defun ps-output (&rest args)
1198 (setcdr ps-output-tail args)
1199 (while (cdr ps-output-tail)
1200 (setq ps-output-tail (cdr ps-output-tail))))
1202 (defun ps-output-string (string)
1203 (ps-output t string))
1205 (defun ps-flush-output ()
1207 (set-buffer ps-spool-buffer)
1208 (goto-char (point-max))
1209 (while ps-output-head
1210 (let ((it (car ps-output-head)))
1213 (setq ps-output-head (cdr ps-output-head))
1214 (ps-output-string-prim (car ps-output-head))))
1215 (setq ps-output-head (cdr ps-output-head))))
1216 (ps-init-output-queue))
1218 (defun ps-insert-file (fname)
1221 ;; Check to see that the file exists and is readable; if not, throw
1223 (if (not (file-readable-p fname))
1224 (error "Could not read file `%s'" fname))
1227 (set-buffer ps-spool-buffer)
1228 (goto-char (point-max))
1229 (insert-file fname)))
1231 ;; These functions insert the arrays that define the contents of the
1234 (defun ps-generate-header-line (fonttag &optional content)
1235 (ps-output " [ " fonttag " ")
1237 ;; Literal strings should be output as is -- the string must
1238 ;; contain its own PS string delimiters, '(' and ')', if necessary.
1240 (ps-output content))
1242 ;; Functions are called -- they should return strings; they will be
1243 ;; inserted as strings and the PS string delimiters added.
1244 ((and (symbolp content) (fboundp content))
1245 (ps-output-string (funcall content)))
1247 ;; Variables will have their contents inserted. They should
1248 ;; contain strings, and will be inserted as strings.
1249 ((and (symbolp content) (boundp content))
1250 (ps-output-string (symbol-value content)))
1252 ;; Anything else will get turned into an empty string.
1254 (ps-output-string "")))
1257 (defun ps-generate-header (name contents)
1258 (ps-output "/" name " [\n")
1259 (if (> ps-header-lines 0)
1261 (ps-generate-header-line "/h0" (car contents))
1262 (while (and (< count ps-header-lines)
1263 (setq contents (cdr contents)))
1264 (ps-generate-header-line "/h1" (car contents))
1265 (setq count (+ count 1)))
1266 (ps-output "] def\n"))))
1268 (defun ps-output-boolean (name bool)
1269 (ps-output (format "/%s %s def\n" name (if bool "true" "false"))))
1271 (defun ps-begin-file ()
1272 (setq ps-showpage-count 0)
1274 (ps-output ps-adobe-tag)
1275 (ps-output "%%Title: " (buffer-name) "\n") ;Take job name from name of
1276 ;first buffer printed
1277 (ps-output "%%Creator: " (user-full-name) "\n")
1278 (ps-output "%%CreationDate: "
1279 (time-stamp-hh:mm:ss) " " (time-stamp-mon-dd-yyyy) "\n")
1280 (ps-output "%% DocumentFonts: Helvetica Helvetica-Bold "
1281 ps-font " " ps-font-bold " " ps-font-italic " "
1282 ps-font-bold-italic "\n")
1283 (ps-output "%%Pages: (atend)\n")
1284 (ps-output "%%EndComments\n\n")
1286 (ps-output-boolean "Duplex" ps-spool-duplex)
1287 (ps-output-boolean "PrintHeader" ps-print-header)
1288 (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame)
1289 (ps-output-boolean "ShowNofN" ps-show-n-of-n)
1291 (ps-output (format "/LeftMargin %d def\n" ps-left-margin))
1292 (ps-output (format "/RightMargin %d def\n" ps-right-margin))
1293 (ps-output (format "/BottomMargin %d def\n" ps-bottom-margin))
1294 (ps-output (format "/TopMargin %d def\n" ps-top-margin))
1296 (ps-get-page-dimensions)
1297 (ps-output (format "/PrintWidth %d def\n" ps-print-width))
1298 (ps-output (format "/PrintHeight %d def\n" ps-print-height))
1300 (ps-output (format "/LineHeight %s def\n" ps-line-height))
1302 (ps-output ps-print-prologue)
1304 (ps-output (format "/f0 %d /%s Font\n" ps-font-size ps-font))
1305 (ps-output (format "/f1 %d /%s Font\n" ps-font-size ps-font-bold))
1306 (ps-output (format "/f2 %d /%s Font\n" ps-font-size ps-font-italic))
1307 (ps-output (format "/f3 %d /%s Font\n" ps-font-size
1308 ps-font-bold-italic))
1310 (ps-output "%%EndPrologue\n"))
1312 (defun ps-header-dirpart ()
1313 (let ((fname (buffer-file-name)))
1315 (if (string-equal (buffer-name) (file-name-nondirectory fname))
1316 (file-name-directory fname)
1320 (defun ps-get-buffer-name ()
1321 ;; Indulge me this little easter egg:
1322 (if (string= (buffer-name) "ps-print.el")
1323 "Hey, Cool! It's ps-print.el!!!"
1326 (defun ps-begin-job ()
1327 (setq ps-page-count 0))
1329 (defun ps-end-file ()
1330 (ps-output "%%Trailer\n")
1331 (ps-output "%%Pages: " (format "%d\n" ps-showpage-count)))
1333 (defun ps-next-page ()
1338 (defun ps-begin-page (&optional dummypage)
1339 (ps-get-page-dimensions)
1340 (setq ps-width-remaining ps-print-width)
1341 (setq ps-height-remaining ps-print-height)
1343 ;; If headers are turned on, deduct the height of the header from
1344 ;; the print height remaining. Clumsy clumsy clumsy.
1346 (setq ps-height-remaining
1347 (- ps-height-remaining
1348 ps-header-title-line-height
1349 (* ps-header-line-height (- ps-header-lines 1))
1350 (* 2 ps-header-pad))))
1352 (setq ps-page-count (+ ps-page-count 1))
1354 (ps-output "\n%%Page: "
1355 (format "%d %d\n" ps-page-count (+ 1 ps-showpage-count)))
1356 (ps-output "BeginDSCPage\n")
1357 (ps-output (format "/PageNumber %d def\n" ps-page-count))
1358 (ps-output "/PageCount 0 def\n")
1362 (ps-generate-header "HeaderLinesLeft" ps-left-header)
1363 (ps-generate-header "HeaderLinesRight" ps-right-header)
1364 (ps-output (format "%d SetHeaderLines\n" ps-header-lines))))
1366 (ps-output "BeginPage\n")
1367 (ps-set-font ps-current-font)
1368 (ps-set-bg ps-current-bg)
1369 (ps-set-color ps-current-color)
1370 (ps-set-underline ps-current-underline-p))
1372 (defun ps-end-page ()
1373 (setq ps-showpage-count (+ 1 ps-showpage-count))
1374 (ps-output "EndPage\n")
1375 (ps-output "EndDSCPage\n"))
1377 (defun ps-dummy-page ()
1378 (setq ps-showpage-count (+ 1 ps-showpage-count))
1379 (ps-output "%%Page: " (format "- %d\n" ps-showpage-count)
1381 /PrintHeader false def
1386 (defun ps-next-line ()
1387 (if (< ps-height-remaining ps-line-height)
1389 (setq ps-width-remaining ps-print-width)
1390 (setq ps-height-remaining (- ps-height-remaining ps-line-height))
1393 (defun ps-continue-line ()
1394 (if (< ps-height-remaining ps-line-height)
1396 (setq ps-width-remaining ps-print-width)
1397 (setq ps-height-remaining (- ps-height-remaining ps-line-height))
1400 (defun ps-hard-lf ()
1403 (defun ps-soft-lf ()
1406 (defun ps-find-wrappoint (from to char-width)
1407 (let ((avail (truncate (/ ps-width-remaining char-width)))
1410 (cons to (* todo char-width))
1411 (cons (+ from avail) ps-width-remaining))))
1413 (defun ps-basic-plot-string (from to &optional bg-color)
1414 (let* ((wrappoint (ps-find-wrappoint from to ps-avg-char-width))
1415 (to (car wrappoint))
1416 (string (buffer-substring from to)))
1417 (ps-output-string string)
1418 (ps-output " S\n") ;
1421 (defun ps-basic-plot-whitespace (from to &optional bg-color)
1422 (let* ((wrappoint (ps-find-wrappoint from to ps-space-width))
1423 (to (car wrappoint)))
1425 (ps-output (format "%d W\n" (- to from)))
1428 (defun ps-plot (plotfunc from to &optional bg-color)
1430 (let* ((wrappoint (funcall plotfunc from to bg-color))
1431 (plotted-to (car wrappoint))
1432 (plotted-width (cdr wrappoint)))
1433 (setq from plotted-to)
1434 (setq ps-width-remaining (- ps-width-remaining plotted-width))
1436 (ps-continue-line))))
1437 (if ps-razzle-dazzle
1438 (let* ((q-todo (- (point-max) (point-min)))
1439 (q-done (- (point) (point-min)))
1440 (chunkfrac (/ q-todo 8))
1441 (chunksize (if (> chunkfrac 1000) 1000 chunkfrac)))
1442 (if (> (- q-done ps-razchunk) chunksize)
1444 (setq ps-razchunk q-done)
1447 (/ (* 100 q-done) q-todo)
1448 (/ q-done (/ q-todo 100))))
1449 (message "Formatting...%d%%" foo))))))
1451 (defun ps-set-font (font)
1452 (setq ps-current-font font)
1453 (ps-output (format "/f%d F\n" ps-current-font)))
1455 (defvar ps-print-color-scale nil)
1457 (defun ps-set-bg (color)
1458 (if (setq ps-current-bg color)
1459 (ps-output (format ps-color-format (nth 0 color) (nth 1 color)
1462 (ps-output "false BG\n")))
1464 (defun ps-set-color (color)
1465 (if (setq ps-current-color color)
1467 (setq ps-current-color ps-default-fg))
1468 (ps-output (format ps-color-format (nth 0 ps-current-color)
1469 (nth 1 ps-current-color) (nth 2 ps-current-color))
1472 (defun ps-set-underline (underline-p)
1473 (ps-output (if underline-p "true" "false") " UL\n")
1474 (setq ps-current-underline-p underline-p))
1476 (defun ps-plot-region (from to font fg-color &optional bg-color underline-p)
1478 (if (not (equal font ps-current-font))
1481 ;; Specify a foreground color only if one's specified and it's
1482 ;; different than the current.
1483 (if (not (equal fg-color ps-current-color))
1484 (ps-set-color fg-color))
1486 (if (not (equal bg-color ps-current-bg))
1487 (ps-set-bg bg-color))
1489 ;; Toggle underlining if different.
1490 (if (not (equal underline-p ps-current-underline-p))
1491 (ps-set-underline underline-p))
1493 ;; Starting at the beginning of the specified region...
1497 ;; ...break the region up into chunks separated by tabs, linefeeds,
1498 ;; and pagefeeds, and plot each chunk.
1500 (if (re-search-forward "[\t\n\f]" to t)
1501 (let ((match (char-after (match-beginning 0))))
1505 (save-excursion (beginning-of-line) (point))))
1506 (ps-plot 'ps-basic-plot-string from (- (point) 1)
1509 (setq from (+ linestart (current-column)))
1510 (if (re-search-forward "[ \t]+" to t)
1511 (ps-plot 'ps-basic-plot-whitespace
1512 from (+ linestart (current-column))
1516 (ps-plot 'ps-basic-plot-string from (- (point) 1)
1522 (ps-plot 'ps-basic-plot-string from (- (point) 1)
1525 (setq from (point)))
1526 (ps-plot 'ps-basic-plot-string from to bg-color)
1529 (defun ps-color-value (x-color-value)
1530 ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
1531 (/ x-color-value ps-print-color-scale))
1533 (defun ps-color-values (x-color)
1534 (cond ((fboundp 'x-color-values)
1535 (x-color-values x-color))
1536 ((fboundp 'pixel-components)
1537 (pixel-components x-color))
1538 (t (error "No available function to determine X color values."))))
1540 (defun ps-face-attributes (face)
1541 (let ((differs (face-differs-from-default-p face)))
1542 (list (memq face ps-ref-bold-faces)
1543 (memq face ps-ref-italic-faces)
1544 (memq face ps-ref-underlined-faces)
1545 (and differs (face-foreground face))
1546 (and differs (face-background face)))))
1548 (defun ps-face-attribute-list (face-or-list)
1549 (if (listp face-or-list)
1550 (let (bold-p italic-p underline-p foreground background face-attr face)
1552 (setq face (car face-or-list))
1553 (setq face-attr (ps-face-attributes face))
1554 (setq bold-p (or bold-p (nth 0 face-attr)))
1555 (setq italic-p (or italic-p (nth 1 face-attr)))
1556 (setq underline-p (or underline-p (nth 2 face-attr)))
1559 (setq foreground (nth 3 face-attr)))
1562 (setq background (nth 4 face-attr)))
1563 (setq face-or-list (cdr face-or-list)))
1564 (list bold-p italic-p underline-p foreground background))
1566 (ps-face-attributes face-or-list)))
1568 (defun ps-plot-with-face (from to face)
1570 (let* ((face-attr (ps-face-attribute-list face))
1571 (bold-p (nth 0 face-attr))
1572 (italic-p (nth 1 face-attr))
1573 (underline-p (nth 2 face-attr))
1574 (foreground (nth 3 face-attr))
1575 (background (nth 4 face-attr))
1576 (fg-color (if (and ps-print-color-p foreground)
1577 (mapcar 'ps-color-value
1578 (ps-color-values foreground))
1580 (bg-color (if (and ps-print-color-p background)
1581 (mapcar 'ps-color-value
1582 (ps-color-values background)))))
1583 (ps-plot-region from to
1584 (cond ((and bold-p italic-p) 3)
1588 ; (or fg-color '(0.0 0.0 0.0))
1590 bg-color underline-p))
1594 (defun ps-emacs-face-kind-p (face kind kind-regex kind-list)
1595 (let ((frame-font (face-font face))
1596 (face-defaults (face-font face t)))
1598 ;; Check FACE defaults:
1599 (and (listp face-defaults)
1600 (memq kind face-defaults))
1602 ;; Check the user's preferences
1603 (memq face kind-list))))
1605 (defun ps-xemacs-face-kind-p (face kind kind-regex kind-list)
1606 (let* ((frame-font (or (face-font face) (face-font 'default)))
1607 (kind-cons (assq kind (x-font-properties frame-font)))
1608 (kind-spec (cdr-safe kind-cons))
1609 (case-fold-search t))
1611 (or (and kind-spec (string-match kind-regex kind-spec))
1612 ;; Kludge-compatible:
1613 (memq face kind-list))))
1615 (defun ps-face-bold-p (face)
1616 (if (eq ps-print-emacs-type 'emacs)
1617 (ps-emacs-face-kind-p face 'bold "-\\(bold\\|demibold\\)-"
1619 (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold"
1622 (defun ps-face-italic-p (face)
1623 (if (eq ps-print-emacs-type 'emacs)
1624 (ps-emacs-face-kind-p face 'italic "-[io]-" ps-italic-faces)
1626 (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o" ps-italic-faces)
1627 (ps-xemacs-face-kind-p face 'SLANT "i\\|o" ps-italic-faces))))
1629 (defun ps-face-underlined-p (face)
1630 (or (face-underline-p face)
1631 (memq face ps-underlined-faces)))
1633 ;; Ensure that face-list is fbound.
1634 (or (fboundp 'face-list) (defalias 'face-list 'list-faces))
1636 (defun ps-build-reference-face-lists ()
1637 (if ps-auto-font-detect
1638 (let ((faces (face-list))
1640 (setq ps-ref-bold-faces nil
1641 ps-ref-italic-faces nil
1642 ps-ref-underlined-faces nil)
1644 (setq the-face (car faces))
1645 (if (ps-face-italic-p the-face)
1646 (setq ps-ref-italic-faces
1647 (cons the-face ps-ref-italic-faces)))
1648 (if (ps-face-bold-p the-face)
1649 (setq ps-ref-bold-faces
1650 (cons the-face ps-ref-bold-faces)))
1651 (if (ps-face-underlined-p the-face)
1652 (setq ps-ref-underlined-faces
1653 (cons the-face ps-ref-underlined-faces)))
1654 (setq faces (cdr faces))))
1655 (setq ps-ref-bold-faces ps-bold-faces)
1656 (setq ps-ref-italic-faces ps-italic-faces)
1657 (setq ps-ref-underlined-faces ps-underlined-faces))
1658 (setq ps-build-face-reference nil))
1660 (defun ps-mapper (extent list)
1661 (nconc list (list (list (extent-start-position extent) 'push extent)
1662 (list (extent-end-position extent) 'pull extent)))
1665 (defun ps-sorter (a b)
1666 (< (car a) (car b)))
1668 (defun ps-extent-sorter (a b)
1669 (< (extent-priority a) (extent-priority b)))
1671 (defun ps-print-ensure-fontified (start end)
1672 (if (and (boundp 'lazy-lock-mode) lazy-lock-mode)
1673 (if (fboundp 'lazy-lock-fontify-region)
1674 (lazy-lock-fontify-region start end)
1675 (lazy-lock-fontify-buffer))))
1677 (defun ps-generate-postscript-with-faces (from to)
1678 ;; Build the reference lists of faces if necessary.
1679 (if (or ps-always-build-face-reference
1680 ps-build-face-reference)
1682 (message "Collecting face information...")
1683 (ps-build-reference-face-lists)))
1684 ;; Set the color scale. We do it here instead of in the defvar so
1685 ;; that ps-print can be dumped into emacs. This expression can't be
1686 ;; evaluated at dump-time because X isn't initialized.
1687 (setq ps-print-color-scale
1688 (if ps-print-color-p
1689 (float (car (ps-color-values "white")))
1691 ;; Generate some PostScript.
1693 (narrow-to-region from to)
1694 (let ((face 'default)
1696 (ps-print-ensure-fontified from to)
1697 (cond ((or (eq ps-print-emacs-type 'lucid) (eq ps-print-emacs-type 'xemacs))
1698 ;; Build the list of extents...
1699 (let ((a (cons 'dummy nil))
1700 record type extent extent-list)
1701 (map-extents 'ps-mapper nil from to a)
1703 (setq a (sort a 'ps-sorter))
1705 (setq extent-list nil)
1707 ;; Loop through the extents...
1709 (setq record (car a))
1711 (setq position (car record))
1712 (setq record (cdr record))
1714 (setq type (car record))
1715 (setq record (cdr record))
1717 (setq extent (car record))
1719 ;; Plot up to this record.
1720 ;; XEmacs 19.12: for some reason, we're getting into a
1721 ;; situation in which some of the records have
1722 ;; positions less than 'from'. Since we've narrowed
1723 ;; the buffer, this'll generate errors. This is a
1724 ;; hack, but don't call ps-plot-with-face unless from >
1726 (if (and (>= from (point-min))
1727 (<= position (point-max)))
1728 (ps-plot-with-face from position face))
1732 (if (extent-face extent)
1733 (setq extent-list (sort (cons extent extent-list)
1734 'ps-extent-sorter))))
1737 (setq extent-list (sort (delq extent extent-list)
1738 'ps-extent-sorter))))
1742 (extent-face (car extent-list))
1745 (setq from position)
1748 ((eq ps-print-emacs-type 'emacs)
1749 (let ((property-change from)
1750 (overlay-change from))
1752 (if (< property-change to) ; Don't search for property change
1753 ; unless previous search succeeded.
1754 (setq property-change
1755 (next-property-change from nil to)))
1756 (if (< overlay-change to) ; Don't search for overlay change
1757 ; unless previous search succeeded.
1758 (setq overlay-change
1759 (min (next-overlay-change from) to)))
1761 (min property-change overlay-change))
1763 (cond ((get-text-property from 'invisible) nil)
1764 ((get-text-property from 'face))
1766 (let ((overlays (overlays-at from))
1767 (face-priority -1)) ; text-property
1769 (let* ((overlay (car overlays))
1770 (overlay-face (overlay-get overlay 'face))
1771 (overlay-invisible (overlay-get overlay 'invisible))
1772 (overlay-priority (or (overlay-get overlay
1775 (if (and (or overlay-invisible overlay-face)
1776 (> overlay-priority face-priority))
1777 (setq face (cond (overlay-invisible nil)
1778 ((and face overlay-face)))
1779 face-priority overlay-priority)))
1780 (setq overlays (cdr overlays))))
1781 ;; Plot up to this record.
1782 (ps-plot-with-face from position face)
1783 (setq from position)))))
1784 (ps-plot-with-face from to face))))
1786 (defun ps-generate-postscript (from to)
1787 (ps-plot-region from to 0 nil))
1789 (defun ps-generate (buffer from to genfunc)
1790 (let ((from (min to from))
1793 (narrow-to-region from to)
1794 (if ps-razzle-dazzle
1795 (message "Formatting...%d%%" (setq ps-razchunk 0)))
1797 (setq ps-source-buffer buffer)
1798 (setq ps-spool-buffer (get-buffer-create ps-spool-buffer-name))
1799 (ps-init-output-queue)
1800 (let (safe-marker completed-safely needs-begin-file)
1803 (set-buffer ps-spool-buffer)
1805 ;; Get a marker and make it point to the current end of the
1806 ;; buffer, If an error occurs, we'll delete everything from
1807 ;; the end of this marker onwards.
1808 (setq safe-marker (make-marker))
1809 (set-marker safe-marker (point-max))
1811 (goto-char (point-min))
1812 (if (looking-at (regexp-quote "%!PS-Adobe-1.0"))
1814 (setq needs-begin-file t))
1816 (set-buffer ps-source-buffer)
1817 (if needs-begin-file (ps-begin-file))
1820 (set-buffer ps-source-buffer)
1821 (funcall genfunc from to)
1824 (if (and ps-spool-duplex
1825 (= (mod ps-page-count 2) 1))
1829 ;; Back to the PS output buffer to set the page count
1830 (set-buffer ps-spool-buffer)
1831 (goto-char (point-max))
1832 (while (re-search-backward "^/PageCount 0 def$" nil t)
1833 (replace-match (format "/PageCount %d def" ps-page-count) t))
1835 ;; Setting this variable tells the unwind form that the
1836 ;; the postscript was generated without error.
1837 (setq completed-safely t))
1839 ;; Unwind form: If some bad mojo ocurred while generating
1840 ;; postscript, delete all the postscript that was generated.
1841 ;; This protects the previously spooled files from getting
1843 (if (and (markerp safe-marker) (not completed-safely))
1845 (set-buffer ps-spool-buffer)
1846 (delete-region (marker-position safe-marker) (point-max))))))
1848 (if ps-razzle-dazzle
1849 (message "Formatting...done")))))
1851 (defun ps-do-despool (filename)
1852 (if (or (not (boundp 'ps-spool-buffer))
1853 (not ps-spool-buffer))
1854 (message "No spooled PostScript to print")
1859 (if ps-razzle-dazzle
1860 (message "Saving..."))
1861 (set-buffer ps-spool-buffer)
1862 (setq filename (expand-file-name filename))
1863 (write-region (point-min) (point-max) filename)
1864 (if ps-razzle-dazzle
1865 (message "Wrote %s" filename)))
1866 ;; Else, spool to the printer
1867 (if ps-razzle-dazzle
1868 (message "Printing..."))
1870 (set-buffer ps-spool-buffer)
1871 (if (eq system-type 'ms-dos)
1872 (write-region (point-min) (point-max) "PRN")
1873 (apply 'call-process-region
1874 (point-min) (point-max) ps-lpr-command nil 0 nil
1876 (if ps-razzle-dazzle
1877 (message "Printing...done")))
1878 (kill-buffer ps-spool-buffer)))
1880 (defun ps-kill-emacs-check ()
1882 (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
1883 (buffer-modified-p ps-buffer))
1884 (if (y-or-n-p "Unprinted PostScript waiting; print now? ")
1886 (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
1887 (buffer-modified-p ps-buffer))
1888 (if (yes-or-no-p "Unprinted PostScript waiting; exit anyway? ")
1890 (error "Unprinted PostScript")))))
1892 (if (fboundp 'add-hook)
1893 (add-hook 'kill-emacs-hook 'ps-kill-emacs-check)
1895 (message "Won't override existing kill-emacs-hook")
1896 (setq kill-emacs-hook 'ps-kill-emacs-check)))
1898 ;;; Sample Setup Code:
1900 ;; This stuff is for anybody that's brave enough to look this far,
1901 ;; and able to figure out how to use it. It isn't really part of ps-
1902 ;; print, but I'll leave it here in hopes it might be useful:
1904 ;; WARNING!!! The following code is *sample* code only. Don't use it
1905 ;; unless you understand what it does!
1907 (defmacro ps-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs)
1909 (defmacro ps-c-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs)
1912 (defmacro ps-s-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs)
1916 ;; Look in an article or mail message for the Subject: line. To be
1917 ;; placed in ps-left-headers.
1918 (defun ps-article-subject ()
1920 (goto-char (point-min))
1921 (if (re-search-forward "^Subject:[ \t]+\\(.*\\)$")
1922 (buffer-substring (match-beginning 1) (match-end 1))
1925 ;; Look in an article or mail message for the From: line. Sorta-kinda
1926 ;; understands RFC-822 addresses and can pull the real name out where
1927 ;; it's provided. To be placed in ps-left-headers.
1928 (defun ps-article-author ()
1930 (goto-char (point-min))
1931 (if (re-search-forward "^From:[ \t]+\\(.*\\)$")
1932 (let ((fromstring (buffer-substring (match-beginning 1) (match-end 1))))
1935 ;; Try first to match addresses that look like
1936 ;; thompson@wg2.waii.com (Jim Thompson)
1937 ((string-match ".*[ \t]+(\\(.*\\))" fromstring)
1938 (substring fromstring (match-beginning 1) (match-end 1)))
1940 ;; Next try to match addresses that look like
1941 ;; Jim Thompson <thompson@wg2.waii.com>
1942 ((string-match "\\(.*\\)[ \t]+<.*>" fromstring)
1943 (substring fromstring (match-beginning 1) (match-end 1)))
1945 ;; Couldn't find a real name -- show the address instead.
1949 ;; A hook to bind to gnus-Article-prepare-hook. This will set the ps-
1950 ;; left-headers specially for gnus articles. Unfortunately, gnus-
1951 ;; article-mode-hook is called only once, the first time the *Article*
1952 ;; buffer enters that mode, so it would only work for the first time
1953 ;; we ran gnus. The second time, this hook wouldn't get set up. The
1954 ;; only alternative is gnus-article-prepare-hook.
1955 (defun ps-gnus-article-prepare-hook ()
1956 (setq ps-header-lines 3)
1957 (setq ps-left-header
1958 ;; The left headers will display the article's subject, its
1959 ;; author, and the newsgroup it was in.
1960 (list 'ps-article-subject 'ps-article-author 'gnus-newsgroup-name)))
1962 ;; A hook to bind to vm-mode-hook to locally bind prsc and set the ps-
1963 ;; left-headers specially for mail messages. This header setup would
1964 ;; also work, I think, for RMAIL.
1965 (defun ps-vm-mode-hook ()
1966 (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary)
1967 (setq ps-header-lines 3)
1968 (setq ps-left-header
1969 ;; The left headers will display the message's subject, its
1970 ;; author, and the name of the folder it was in.
1971 (list 'ps-article-subject 'ps-article-author 'buffer-name)))
1973 ;; Every now and then I forget to switch from the *Summary* buffer to
1974 ;; the *Article* before hitting prsc, and a nicely formatted list of
1975 ;; article subjects shows up at the printer. This function, bound to
1976 ;; prsc for the gnus *Summary* buffer means I don't have to switch
1978 (defun ps-gnus-print-article-from-summary ()
1980 (if (get-buffer "*Article*")
1982 (set-buffer "*Article*")
1983 (ps-spool-buffer-with-faces))))
1985 ;; See ps-gnus-print-article-from-summary. This function does the
1986 ;; same thing for vm.
1987 (defun ps-vm-print-message-from-summary ()
1991 (set-buffer vm-mail-buffer)
1992 (ps-spool-buffer-with-faces))))
1994 ;; A hook to bind to bind to gnus-summary-setup-buffer to locally bind
1996 (defun ps-gnus-summary-setup ()
1997 (local-set-key (ps-prsc) 'ps-gnus-print-article-from-summary))
1999 ;; Look in an article or mail message for the Subject: line. To be
2000 ;; placed in ps-left-headers.
2001 (defun ps-info-file ()
2003 (goto-char (point-min))
2004 (if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)")
2005 (buffer-substring (match-beginning 1) (match-end 1))
2008 ;; Look in an article or mail message for the Subject: line. To be
2009 ;; placed in ps-left-headers.
2010 (defun ps-info-node ()
2012 (goto-char (point-min))
2013 (if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)")
2014 (buffer-substring (match-beginning 1) (match-end 1))
2017 (defun ps-info-mode-hook ()
2018 (setq ps-left-header
2019 ;; The left headers will display the node name and file name.
2020 (list 'ps-info-node 'ps-info-file)))
2022 ;; WARNING! The following function is a *sample* only, and is *not*
2023 ;; meant to be used as a whole unless you understand what the effects
2024 ;; will be! (In fact, this is a copy if my setup for ps-print -- I'd
2025 ;; be very surprised if it was useful to *anybody*, without
2028 (defun ps-jts-ps-setup ()
2029 (global-set-key (ps-prsc) 'ps-spool-buffer-with-faces) ;f22 is prsc
2030 (global-set-key (ps-s-prsc) 'ps-spool-region-with-faces)
2031 (global-set-key (ps-c-prsc) 'ps-despool)
2032 (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook)
2033 (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup)
2034 (add-hook 'vm-mode-hook 'ps-vm-mode-hook)
2035 (add-hook 'vm-mode-hooks 'ps-vm-mode-hook)
2036 (add-hook 'Info-mode-hook 'ps-info-mode-hook)
2037 (setq ps-spool-duplex t)
2038 (setq ps-print-color-p nil)
2039 (setq ps-lpr-command "lpr")
2040 (setq ps-lpr-switches '("-Jjct,duplex_long")))
2044 ;;; ps-print.el ends here