1 ;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19.
3 ;; Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
5 ;; Author: Jim Thompson <thompson@wg2.waii.com>
7 ;; Keywords: print, PostScript
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
27 ;; ps-print|James C. Thompson|thompson@wg2.waii.com|
28 ;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print)|
29 ;; 26-Feb-1994|2.8|~/packages/ps-print.el|
31 ;; Baseline-version: 2.8. (Jim's last change version -- this
32 ;; file may have been edited as part of Emacs without changes to the
33 ;; version number. When reporting bugs, please also report the
34 ;; version of Emacs, if any, that ps-print was distributed with.)
38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
42 ;; This package provides printing of Emacs buffers on PostScript
43 ;; printers; the buffer's bold and italic text attributes are
44 ;; preserved in the printer output. Ps-print is intended for use with
45 ;; Emacs 19 or Lucid Emacs, together with a fontifying package such as
46 ;; font-lock or hilit.
53 ;; Ps-print provides eight commands for generating PostScript images
57 ;; ps-print-buffer-with-faces
59 ;; ps-print-region-with-faces
61 ;; ps-spool-buffer-with-faces
63 ;; ps-spool-region-with-faces
65 ;; These commands all perform essentially the same function: they
66 ;; generate PostScript images suitable for printing on a PostScript
67 ;; printer or displaying with GhostScript. These commands are
68 ;; collectively referred to as "ps-print- commands".
70 ;; The word "print" or "spool" in the command name determines when the
71 ;; PostScript image is sent to the printer:
73 ;; print - The PostScript image is immediately sent to the
76 ;; spool - The PostScript image is saved temporarily in an
77 ;; Emacs buffer. Many images may be spooled locally
78 ;; before printing them. To send the spooled images
79 ;; to the printer, use the command ps-despool.
81 ;; The spooling mechanism was designed for printing lots of small
82 ;; files (mail messages or netnews articles) to save paper that would
83 ;; otherwise be wasted on banner pages, and to make it easier to find
84 ;; your output at the printer (it's easier to pick up one 50-page
85 ;; printout than to find 50 single-page printouts).
87 ;; Ps-print has a hook in the kill-emacs-hooks so that you won't
88 ;; accidentally quit from Emacs while you have unprinted PostScript
89 ;; waiting in the spool buffer. If you do attempt to exit with
90 ;; spooled PostScript, you'll be asked if you want to print it, and if
91 ;; you decline, you'll be asked to confirm the exit; this is modeled
92 ;; on the confirmation that Emacs uses for modified buffers.
94 ;; The word "buffer" or "region" in the command name determines how
95 ;; much of the buffer is printed:
97 ;; buffer - Print the entire buffer.
99 ;; region - Print just the current region.
101 ;; The -with-faces suffix on the command name means that the command
102 ;; will include font, color, and underline information in the
103 ;; PostScript image, so the printed image can look as pretty as the
104 ;; buffer. The ps-print- commands without the -with-faces suffix
105 ;; don't include font, color, or underline information; images printed
106 ;; with these commands aren't as pretty, but are faster to generate.
108 ;; Two ps-print- command examples:
110 ;; ps-print-buffer - print the entire buffer,
111 ;; without font, color, or
112 ;; underline information, and
113 ;; send it immediately to the
116 ;; ps-spool-region-with-faces - print just the current region;
117 ;; include font, color, and
118 ;; underline information, and
119 ;; spool the image in Emacs to
120 ;; send to the printer later.
125 ;; To print your buffer, type
127 ;; M-x ps-print-buffer
129 ;; or substitute one of the other seven ps-print- commands. The
130 ;; command will generate the PostScript image and print or spool it as
131 ;; specified. By giving the command a prefix argument
133 ;; C-u M-x ps-print-buffer
135 ;; it will save the PostScript image to a file instead of sending it
136 ;; to the printer; you will be prompted for the name of the file to
137 ;; save the image to. The prefix argument is ignored by the commands
138 ;; that spool their images, but you may save the spooled images to a
139 ;; file by giving a prefix argument to ps-despool:
141 ;; C-u M-x ps-despool
143 ;; When invoked this way, ps-despool will prompt you for the name of
144 ;; the file to save to.
146 ;; Any of the ps-print- commands can be bound to keys; I recommend
147 ;; binding ps-spool-buffer-with-faces, ps-spool-region-with-faces, and
148 ;; ps-despool. Here are the bindings I use on my Sun 4 keyboard:
150 ;; (global-set-key 'f22 'ps-spool-buffer-with-faces) ;f22 is prsc
151 ;; (global-set-key '(shift f22) 'ps-spool-region-with-faces)
152 ;; (global-set-key '(control f22) 'ps-despool)
155 ;; The Printer Interface
157 ;; The variables ps-lpr-command and ps-lpr-switches determine what
158 ;; command is used to send the PostScript images to the printer, and
159 ;; what arguments to give the command. These are analogous to lpr-
160 ;; command and lpr-switches.
162 ;; NOTE: ps-lpr-command and ps-lpr-switches take their initial values
163 ;; from the variables lpr-command and lpr-switches. If you have
164 ;; lpr-command set to invoke a pretty-printer such as enscript,
165 ;; then ps-print won't work properly. ps-lpr-command must name
166 ;; a program that does not format the files it prints.
169 ;; How Ps-Print Deals With Fonts
171 ;; The ps-print-*-with-faces commands attempt to determine which faces
172 ;; should be printed in bold or italic, but their guesses aren't
173 ;; always right. For example, you might want to map colors into faces
174 ;; so that blue faces print in bold, and red faces in italic.
176 ;; It is possible to force ps-print to consider specific faces bold or
177 ;; italic, no matter what font they are displayed in, by setting the
178 ;; variables ps-bold-faces and ps-italic-faces. These variables
179 ;; contain lists of faces that ps-print should consider bold or
180 ;; italic; to set them, put code like the following into your .emacs
183 ;; (setq ps-bold-faces '(my-blue-face))
184 ;; (setq ps-italic-faces '(my-red-face))
186 ;; Faces like bold-italic that are both bold and italic should go in
189 ;; Ps-print does not attempt to guess the sizes of fonts; all text is
190 ;; rendered using the Courier font family, in 10 point size. To
191 ;; change the font family, change the variables ps-font, ps-font-bold,
192 ;; ps-font-italic, and ps-font-bold-italic; fixed-pitch fonts work
193 ;; best, but are not required. To change the font size, change the
194 ;; variable ps-font-size.
196 ;; If you change the font family or size, you MUST also change the
197 ;; variables ps-line-height, ps-avg-char-width, and ps-space-width, or
198 ;; ps-print cannot correctly place line and page breaks.
200 ;; Ps-print keeps internal lists of which fonts are bold and which are
201 ;; italic; these lists are built the first time you invoke ps-print.
202 ;; For the sake of efficiency, the lists are built only once; the same
203 ;; lists are referred in later invocations of ps-print.
205 ;; Because these lists are built only once, it's possible for them to
206 ;; get out of sync, if a face changes, or if new faces are added. To
207 ;; get the lists back in sync, you can set the variable
208 ;; ps-build-face-reference to t, and the lists will be rebuilt the
209 ;; next time ps-print is invoked.
212 ;; How Ps-Print Deals With Color
214 ;; Ps-print detects faces with foreground and background colors
215 ;; defined and embeds color information in the PostScript image. The
216 ;; default foreground and background colors are defined by the
217 ;; variables ps-default-fg and ps-default-bg. On black-and-white
218 ;; printers, colors are displayed in grayscale. To turn off color
219 ;; output, set ps-print-color-p to nil.
224 ;; Ps-print can print headers at the top of each page; the default
225 ;; headers contain the following four items: on the left, the name of
226 ;; the buffer and, if the buffer is visiting a file, the file's
227 ;; directory; on the right, the page number and date of printing. The
228 ;; default headers look something like this:
231 ;; /home/jct/emacs-lisp/ps/new 94/12/31
233 ;; When printing on duplex printers, left and right are reversed so
234 ;; that the page numbers are toward the outside.
236 ;; Headers are configurable. To turn them off completely, set
237 ;; ps-print-header to nil. To turn off the header's gaudy framing
238 ;; box, set ps-print-header-frame to nil. Page numbers are printed in
239 ;; "n/m" format, indicating page n of m pages; to omit the total page
240 ;; count and just print the page number, set ps-show-n-of-n to nil.
242 ;; The amount of information in the header can be changed by changing
243 ;; the number of lines. To show less, set ps-header-lines to 1, and
244 ;; the header will show only the buffer name and page number. To show
245 ;; more, set ps-header-lines to 3, and the header will show the time of
246 ;; printing below the date.
248 ;; To change the content of the headers, change the variables
249 ;; ps-left-header and ps-right-header. These variables are lists,
250 ;; specifying top-to-bottom the text to display on the left or right
251 ;; side of the header. Each element of the list should be a string or
252 ;; a symbol. Strings are inserted directly into the PostScript
253 ;; arrays, and should contain the PostScript string delimiters '(' and
256 ;; Symbols in the header format lists can either represent functions
257 ;; or variables. Functions are called, and should return a string to
258 ;; show in the header. Variables should contain strings to display in
259 ;; the header. In either case, function or variable, the PostScript
260 ;; string delimiters are added by ps-print, and should not be part of
261 ;; the returned value.
263 ;; Here's an example: say we want the left header to display the text
269 ;; where we have a function to return "Moe"
271 ;; (defun moe-func ()
274 ;; a variable specifying "Larry"
276 ;; (setq larry-var "Larry")
278 ;; and a literal for "Curly". Here's how ps-left-header should be
281 ;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)"))
283 ;; Note that Curly has the PostScript string delimiters inside his
284 ;; quotes -- those aren't misplaced lisp delimiters! Without them,
285 ;; PostScript would attempt to call the undefined function Curly,
286 ;; which would result in a PostScript error. Since most printers
287 ;; don't report PostScript errors except by aborting the print job,
288 ;; this kind of error can be hard to track down. Consider yourself
294 ;; If you have a duplex-capable printer (one that prints both sides of
295 ;; the paper), set ps-spool-duplex to t. Ps-print will insert blank
296 ;; pages to make sure each buffer starts on the correct side of the
297 ;; paper. Don't forget to set ps-lpr-switches to select duplex
298 ;; printing for your printer.
303 ;; The variable ps-paper-type determines the size of paper ps-print
304 ;; formats for; it should contain one of the symbols ps-letter,
305 ;; ps-legal, or ps-a4. The default is ps-letter.
308 ;; Make sure that the variables ps-lpr-command and ps-lpr-switches
309 ;; contain appropriate values for your system; see the usage notes
310 ;; below and the documentation of these variables.
313 ;; New since version 1.5
314 ;; ---------------------
315 ;; Color output capability.
317 ;; Automatic detection of font attributes (bold, italic).
319 ;; Configurable headers with page numbers.
323 ;; Support for different paper sizes.
325 ;; Better conformance to PostScript Document Structure Conventions.
328 ;; Known bugs and limitations of ps-print:
329 ;; --------------------------------------
330 ;; Although color printing will work in XEmacs 19.12, it doesn't work
331 ;; well; in particular, bold or italic fonts don't print in the right
334 ;; Invisible properties aren't correctly ignored in XEmacs 19.12.
336 ;; Automatic font-attribute detection doesn't work well, especially
337 ;; with hilit19 and older versions of get-create-face. Users having
338 ;; problems with auto-font detection should use the lists ps-italic-
339 ;; faces and ps-bold-faces and/or turn off automatic detection by
340 ;; setting ps-auto-font-detect to nil.
342 ;; Automatic font-attribute detection doesn't work with XEmacs 19.12
343 ;; in tty mode; use the lists ps-italic-faces and ps-bold-faces
346 ;; Still too slow; could use some hand-optimization.
348 ;; ASCII Control characters other than tab, linefeed and pagefeed are
351 ;; Default background color isn't working.
353 ;; Faces are always treated as opaque.
355 ;; Epoch and Emacs 18 not supported. At all.
360 ;; 2-up and 4-up capability.
364 ;; Wide-print (landscape) capability.
369 ;; Thanks to Kevin Rodgers <kevinr@ihs.com> for adding support for
370 ;; color and the invisible property.
372 ;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing
373 ;; the initial port to Emacs 19. His code is no longer part of
374 ;; ps-print, but his work is still appreciated.
376 ;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org,
377 ;; for adding underline support. Their code also is no longer part of
378 ;; ps-print, but their efforts are not forgotten.
380 ;; Thanks also to all of you who mailed code to add features to
381 ;; ps-print; although I didn't use your code, I still appreciate your
382 ;; sharing it with me.
384 ;; Thanks to all who mailed comments, encouragement, and criticism.
385 ;; Thanks also to all who responded to my survey; I had too many
386 ;; responses to reply to them all, but I greatly appreciate your
390 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
394 (defconst ps-print-version
"2.8"
395 "ps-print.el,v 2.8 1995/05/04 12:06:10 jct Exp
397 Jim's last change version -- this file may have been edited as part of
398 Emacs without changes to the version number. When reporting bugs,
399 please also report the version of Emacs, if any, that ps-print was
402 Please send all bug fixes and enhancements to
403 Jim Thompson <thompson@wg2.waii.com>.")
405 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
408 (defvar ps-lpr-command lpr-command
409 "*The shell command for printing a PostScript file.")
411 (defvar ps-lpr-switches lpr-switches
412 "*A list of extra switches to pass to `ps-lpr-command'.")
414 (defvar ps-spool-duplex nil
; Not many people have duplex
415 ; printers, so default to nil.
416 "*Non-nil indicates spooling is for a two-sided printer.
417 For a duplex printer, the `ps-spool-*' commands will insert blank pages
418 as needed between print jobs so that the next buffer printed will
419 start on the right page. Also, if headers are turned on, the headers
420 will be reversed on duplex printers so that the page numbers fall to
421 the left on even-numbered pages.")
423 (defvar ps-paper-type
'ps-letter
424 "*Specifies the size of paper to format for. Should be one of
425 `ps-letter', `ps-legal', or `ps-a4'.")
427 (defvar ps-print-header t
428 "*Non-nil means print a header at the top of each page.
429 By default, the header displays the buffer name, page number, and, if
430 the buffer is visiting a file, the file's directory. Headers are
431 customizable by changing variables `ps-header-left' and
434 (defvar ps-print-header-frame t
435 "*Non-nil means draw a gaudy frame around the header.")
437 (defvar ps-show-n-of-n t
438 "*Non-nil means show page numbers as N/M, meaning page N of M.
439 Note: page numbers are displayed as part of headers, see variable
440 `ps-print-headers'.")
442 (defvar ps-print-color-p
(and (or (fboundp 'x-color-values
) ; Emacs
443 (fboundp 'pixel-components
)) ; XEmacs
445 ; Printing color requires both floating point and x-color-values.
446 "*If non-nil, print the buffer's text in color.")
448 (defvar ps-default-fg
'(0.0
0.0 0.0)
449 "*RGB values of the default foreground color. Defaults to black.")
451 (defvar ps-default-bg
'(1.0
1.0 1.0)
452 "*RGB values of the default background color. Defaults to white.")
454 (defvar ps-font-size
10
455 "*Font size, in points, for generating Postscript.")
457 (defvar ps-font
"Courier"
458 "*Font family name for ordinary text, when generating Postscript.")
460 (defvar ps-font-bold
"Courier-Bold"
461 "*Font family name for bold text, when generating Postscript.")
463 (defvar ps-font-italic
"Courier-Oblique"
464 "*Font family name for italic text, when generating Postscript.")
466 (defvar ps-font-bold-italic
"Courier-BoldOblique"
467 "*Font family name for bold italic text, when generating Postscript.")
469 (defvar ps-avg-char-width
(if (fboundp 'float
) 5.6 6)
470 "*The average width, in points, of a character, for generating Postscript.
471 This is the value that ps-print uses to determine the length,
472 x-dimension, of the text it has printed, and thus affects the point at
473 which long lines wrap around. If you change the font or
474 font size, you will probably have to adjust this value to match.")
476 (defvar ps-space-width
(if (fboundp 'float
) 5.6 6)
477 "*The width of a space character, for generating Postscript.
478 This value is used in expanding tab characters.")
480 (defvar ps-line-height
(if (fboundp 'float
) 11.29 11)
481 "*The height of a line, for generating Postscript.
482 This is the value that ps-print uses to determine the height,
483 y-dimension, of the lines of text it has printed, and thus affects the
484 point at which page-breaks are placed. If you change the font or font
485 size, you will probably have to adjust this value to match. The
486 line-height is *not* the same as the point size of the font.")
488 (defvar ps-auto-font-detect t
489 "*Non-nil means automatically detect bold/italic face attributes.
490 nil means rely solely on the lists `ps-bold-faces', `ps-italic-faces',
491 and `ps-underlined-faces'.")
493 (defvar ps-bold-faces
'()
494 "*A list of the \(non-bold\) faces that should be printed in bold font.
495 This applies to generating Postscript.")
497 (defvar ps-italic-faces
'()
498 "*A list of the \(non-italic\) faces that should be printed in italic font.
499 This applies to generating Postscript.")
501 (defvar ps-underlined-faces
'()
502 "*A list of the \(non-underlined\) faces that should be printed underlined.
503 This applies to generating Postscript.")
505 (defvar ps-header-lines
2
506 "*Number of lines to display in page header, when generating Postscript.")
507 (make-variable-buffer-local 'ps-header-lines
)
509 (defvar ps-left-header
510 (list 'ps-get-buffer-name
'ps-header-dirpart
)
511 "*The items to display on the right part of the page header.
512 This applies to generating Postscript.
514 The value should be a list of strings and symbols, each representing an
515 entry in the PostScript array HeaderLinesLeft.
517 Strings are inserted unchanged into the array; those representing
518 PostScript string literals should be delimited with PostScript string
519 delimiters '(' and ')'.
521 For symbols with bound functions, the function is called and should
522 return a string to be inserted into the array. For symbols with bound
523 values, the value should be a string to be inserted into the array.
524 In either case, function or variable, the string value has PostScript
525 string delimiters added to it.")
526 (make-variable-buffer-local 'ps-left-header
)
528 (defvar ps-right-header
529 (list "/pagenumberstring load" 'time-stamp-yy
/mm
/dd
'time-stamp-hh
:mm
:ss
)
530 "*The items to display on the left part of the page header.
531 This applies to generating Postscript.
533 See the variable `ps-left-header' for a description of the format of
535 (make-variable-buffer-local 'ps-right-header
)
537 (defvar ps-razzle-dazzle t
538 "*Non-nil means report progress while formatting buffer.")
540 (defvar ps-adobe-tag
"%!PS-Adobe-1.0\n"
541 "*Contains the header line identifying the output as PostScript.
542 By default, `ps-adobe-tag' contains the standard identifier. Some
543 printers require slightly different versions of this line.")
545 (defvar ps-build-face-reference t
546 "*Non-nil means build the reference face lists.
548 Ps-print sets this value to nil after it builds its internal reference
549 lists of bold and italic faces. By settings its value back to t, you
550 can force ps-print to rebuild the lists the next time you invoke one
551 of the ...-with-faces commands.
553 You should set this value back to t after you change the attributes of
554 any face, or create new faces. Most users shouldn't have to worry
555 about its setting, though.")
557 (defvar ps-always-build-face-reference nil
558 "*Non-nil means always rebuild the reference face lists.
560 If this variable is non-nil, ps-print will rebuild its internal
561 reference lists of bold and italic faces *every* time one of the
562 -with-faces commands is called. Most users shouldn't need to set this
565 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
569 (defun ps-print-buffer (&optional filename
)
570 "Generate and print a PostScript image of the buffer.
572 When called with a numeric prefix argument (C-u), prompts the user for
573 the name of a file to save the PostScript image in, instead of sending
576 More specifically, the FILENAME argument is treated as follows: if it
577 is nil, send the image to the printer. If FILENAME is a string, save
578 the PostScript image in a file with that name. If FILENAME is a
579 number, prompt the user for the name of the file to save in."
581 (interactive (list (ps-print-preprint current-prefix-arg
)))
582 (ps-generate (current-buffer) (point-min) (point-max)
583 'ps-generate-postscript
)
584 (ps-do-despool filename
))
588 (defun ps-print-buffer-with-faces (&optional filename
)
589 "Generate and print a PostScript image of the buffer.
590 Like `ps-print-buffer', but includes font, color, and underline
591 information in the generated image. This command works only if you
592 are using a window system, so it has a way to determine color values."
593 (interactive (list (ps-print-preprint current-prefix-arg
)))
594 (ps-generate (current-buffer) (point-min) (point-max)
595 'ps-generate-postscript-with-faces
)
596 (ps-do-despool filename
))
600 (defun ps-print-region (from to
&optional filename
)
601 "Generate and print a PostScript image of the region.
602 Like `ps-print-buffer', but prints just the current region."
604 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg
)))
605 (ps-generate (current-buffer) from to
606 'ps-generate-postscript
)
607 (ps-do-despool filename
))
611 (defun ps-print-region-with-faces (from to
&optional filename
)
612 "Generate and print a PostScript image of the region.
613 Like `ps-print-region', but includes font, color, and underline
614 information in the generated image. This command works only if you
615 are using a window system, so it has a way to determine color values."
617 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg
)))
618 (ps-generate (current-buffer) from to
619 'ps-generate-postscript-with-faces
)
620 (ps-do-despool filename
))
624 (defun ps-spool-buffer ()
625 "Generate and spool a PostScript image of the buffer.
626 Like `ps-print-buffer' except that the PostScript image is saved in a
627 local buffer to be sent to the printer later.
629 Use the command `ps-despool' to send the spooled images to the printer."
631 (ps-generate (current-buffer) (point-min) (point-max)
632 'ps-generate-postscript
))
636 (defun ps-spool-buffer-with-faces ()
637 "Generate and spool a PostScript image of the buffer.
638 Like `ps-spool-buffer', but includes font, color, and underline
639 information in the generated image. This command works only if you
640 are using a window system, so it has a way to determine color values.
642 Use the command `ps-despool' to send the spooled images to the printer."
645 (ps-generate (current-buffer) (point-min) (point-max)
646 'ps-generate-postscript-with-faces
))
650 (defun ps-spool-region (from to
)
651 "Generate a PostScript image of the region and spool locally.
652 Like `ps-spool-buffer', but spools just the current region.
654 Use the command `ps-despool' to send the spooled images to the printer."
656 (ps-generate (current-buffer) from to
657 'ps-generate-postscript
))
661 (defun ps-spool-region-with-faces (from to
)
662 "Generate a PostScript image of the region and spool locally.
663 Like `ps-spool-region', but includes font, color, and underline
664 information in the generated image. This command works only if you
665 are using a window system, so it has a way to determine color values.
667 Use the command `ps-despool' to send the spooled images to the printer."
669 (ps-generate (current-buffer) from to
670 'ps-generate-postscript-with-faces
))
673 (defun ps-despool (&optional filename
)
674 "Send the spooled PostScript to the printer.
676 When called with a numeric prefix argument (C-u), prompt the user for
677 the name of a file to save the spooled PostScript in, instead of sending
680 More specifically, the FILENAME argument is treated as follows: if it
681 is nil, send the image to the printer. If FILENAME is a string, save
682 the PostScript image in a file with that name. If FILENAME is a
683 number, prompt the user for the name of the file to save in."
684 (interactive (list (ps-print-preprint current-prefix-arg
)))
685 (ps-do-despool filename
))
687 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
688 ;; Utility functions and variables:
690 (defvar ps-print-emacs-type
691 (cond ((string-match "XEmacs" emacs-version
) 'xemacs
)
692 ((string-match "Lucid" emacs-version
) 'lucid
)
693 ((string-match "Epoch" emacs-version
) 'epoch
)
696 (if (or (eq ps-print-emacs-type
'lucid
)
697 (eq ps-print-emacs-type
'xemacs
))
698 (if (< emacs-minor-version
12)
699 (setq ps-print-color-p nil
))
700 (require 'faces
)) ; face-font, face-underline-p,
703 (require 'time-stamp
)
705 (defvar ps-print-prologue
"% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4:
706 % If the ISOLatin1Encoding vector isn't known, define it.
707 /ISOLatin1Encoding where { pop } {
708 % Define the ISO Latin-1 encoding vector.
709 % The first half is the same as the standard encoding,
710 % except for minus instead of hyphen at code 055.
712 StandardEncoding 0 45 getinterval aload pop
714 StandardEncoding 46 82 getinterval aload pop
715 %*** NOTE: the following are missing in the Adobe documentation,
716 %*** but appear in the displayed table:
717 %*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240.
719 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
720 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
721 /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
722 /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron
724 /space /exclamdown /cent /sterling
725 /currency /yen /brokenbar /section
726 /dieresis /copyright /ordfeminine /guillemotleft
727 /logicalnot /hyphen /registered /macron
728 /degree /plusminus /twosuperior /threesuperior
729 /acute /mu /paragraph /periodcentered
730 /cedilla /onesuperior /ordmasculine /guillemotright
731 /onequarter /onehalf /threequarters /questiondown
733 /Agrave /Aacute /Acircumflex /Atilde
734 /Adieresis /Aring /AE /Ccedilla
735 /Egrave /Eacute /Ecircumflex /Edieresis
736 /Igrave /Iacute /Icircumflex /Idieresis
737 /Eth /Ntilde /Ograve /Oacute
738 /Ocircumflex /Otilde /Odieresis /multiply
739 /Oslash /Ugrave /Uacute /Ucircumflex
740 /Udieresis /Yacute /Thorn /germandbls
742 /agrave /aacute /acircumflex /atilde
743 /adieresis /aring /ae /ccedilla
744 /egrave /eacute /ecircumflex /edieresis
745 /igrave /iacute /icircumflex /idieresis
746 /eth /ntilde /ograve /oacute
747 /ocircumflex /otilde /odieresis /divide
748 /oslash /ugrave /uacute /ucircumflex
749 /udieresis /yacute /thorn /ydieresis
753 /reencodeFontISO { %def
755 length 5 add dict % Make a new font (a new dict
756 % the same size as the old
757 % one) with room for our new
760 begin % Make the new font the
761 % current dictionary.
765 { def } { pop pop } ifelse
766 } forall % Copy each of the symbols
767 % from the old dictionary to
768 % the new except for the font
771 /Encoding ISOLatin1Encoding def % Override the encoding with
772 % the ISOLatin1 encoding.
774 % Use the font's bounding box to determine the ascent, descent,
775 % and overall height; don't forget that these values have to be
776 % transformed using the font's matrix.
778 FontMatrix transform /Ascent exch def pop
779 FontMatrix transform /Descent exch def pop
780 /FontHeight Ascent Descent sub def
782 % Define these in case they're not in the FontInfo (also, here
783 % they're easier to get to.
784 /UnderlinePosition 1 def
785 /UnderlineThickness 1 def
787 % Get the underline position and thickness if they're defined.
788 currentdict /FontInfo known {
791 dup /UnderlinePosition known {
792 dup /UnderlinePosition get
793 0 exch FontMatrix transform exch pop
794 /UnderlinePosition exch def
797 dup /UnderlineThickness known {
798 /UnderlineThickness get
799 0 exch FontMatrix transform exch pop
800 /UnderlineThickness exch def
805 currentdict % Leave the new font on the
808 end % Stop using the font as the
809 % current dictionary.
811 definefont % Put the font into the font
814 pop % Discard the returned font.
818 findfont exch scalefont reencodeFontISO
823 dup /Ascent get /Ascent exch def
824 dup /Descent get /Descent exch def
825 dup /FontHeight get /FontHeight exch def
826 dup /UnderlinePosition get /UnderlinePosition exch def
827 dup /UnderlineThickness get /UnderlineThickness exch def
831 /FG /setrgbcolor load def
836 { mark 4 1 roll ] /bgcolor exch def } if
839 /dobackground { % width --
846 0 Descent Ascent sub rlineto
849 bgcolor aload pop setrgbcolor
854 /dobackgroundstring { % string --
859 /dounderline { % fromx fromy --
862 UnderlineThickness setlinewidth
864 UnderlinePosition add moveto
865 UnderlinePosition add lineto
872 PrintWidth LeftMargin add exch sub dobackground
876 currentpoint exch pop
877 PrintWidth LeftMargin add exch dounderline
880 /SL { % Soft Linefeed
883 currentpoint LineHeight sub LeftMargin exch moveto pop
886 /HL /SL load def % Hard Linefeed
888 /sp1 { currentpoint 3 -1 roll } def
891 /dcp { currentpoint exch 40 string cvs print (, ) print = } def
893 exch 40 string cvs print (, ) print = } def
896 bg { dup dobackgroundstring } if
899 ul { dounderline } if
904 ( ) stringwidth % Get the width of a space
905 pop % Discard the Y component
906 mul % Multiply the width of a
907 % space by the number of
909 bg { dup dobackground } if
911 ul { dounderline } if
920 PrintHeaderFrame { HeaderFrame } if
924 BottomMargin PrintHeight add
925 moveto % move to where printing will
932 showpage % Spit out a page
941 /UL { /ul exch def } def
943 /h0 14 /Helvetica-Bold Font
944 /h1 12 /Helvetica Font
948 /HeaderLineHeight FontHeight def
949 /HeaderDescent Descent def
953 /HeaderOffset TopMargin 2 div def
954 /HeaderLines exch def
955 /HeaderHeight HeaderLines HeaderLineHeight mul HeaderPad 2 mul add def
956 /PrintHeight PrintHeight HeaderHeight sub def
960 LeftMargin BottomMargin PrintHeight add HeaderOffset add
965 0 HeaderHeight rlineto
966 PrintWidth neg 0 rlineto
967 0 HeaderHeight neg rlineto
973 HeaderFrameStart moveto
977 HeaderFrameStart moveto
979 gsave 0.9 setgray fill grestore
980 gsave 0 setgray stroke grestore
986 exch HeaderPad add exch
987 HeaderLineHeight HeaderLines 1 sub mul add HeaderDescent sub HeaderPad add
991 dup length 3 -1 roll dup length dup 4 -1 roll add string dup
992 0 5 -1 roll putinterval
993 dup 4 2 roll exch putinterval
997 PageNumber 32 string cvs
1000 PageCount 32 string cvs strcat
1007 HeaderLinesRight HeaderLinesLeft
1008 Duplex PageNumber 1 and 0 eq and { exch } if
1014 dup xcheck { exec } if
1017 0 HeaderLineHeight neg rmoveto
1026 dup xcheck { exec } if
1028 PrintWidth exch sub HeaderPad 2 mul sub 0 rmoveto
1031 0 HeaderLineHeight neg rmoveto
1040 /sw ( ) stringwidth pop def
1041 /aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch
1042 stringwidth pop exch div def
1043 /t1 12 /Helvetica-Oblique Font
1051 ( point, the line height is ) show
1052 lh 32 string cvs show
1053 (, the space width is ) show
1054 sw 32 string cvs show
1057 0 FontHeight neg rmoveto
1058 (and a crude estimate of average character width is ) show
1059 aw 32 string cvs show
1064 % 10 /Courier ReportFontInfo
1067 ;; Start Editing Here:
1069 (defvar ps-source-buffer nil
)
1070 (defvar ps-spool-buffer-name
"*PostScript*")
1071 (defvar ps-spool-buffer nil
)
1073 (defvar ps-output-head nil
)
1074 (defvar ps-output-tail nil
)
1076 (defvar ps-page-count
0)
1077 (defvar ps-showpage-count
0)
1079 (defvar ps-current-font
0)
1080 (defvar ps-current-underline-p nil
)
1081 (defvar ps-default-color
(if ps-print-color-p ps-default-fg
)) ; black
1082 (defvar ps-current-color ps-default-color
)
1083 (defvar ps-current-bg nil
)
1085 (defvar ps-razchunk
0)
1087 (defvar ps-color-format
(if (eq ps-print-emacs-type
'emacs
)
1089 ;;Emacs understands the %f format; we'll
1090 ;;use it to limit color RGB values to
1091 ;;three decimals to cut down some on the
1092 ;;size of the PostScript output.
1095 ;; Lucid emacsen will have to make do with
1096 ;; %s (princ) for floats.
1099 ;; These values determine how much print-height to deduct when headers
1100 ;; are turned on. This is a pretty clumsy way of handling it, but
1101 ;; it'll do for now.
1102 (defvar ps-header-title-line-height
(if (fboundp 'float
) 16.0 16));Helvetica 14
1103 (defvar ps-header-line-height
(if (fboundp 'float
) 13.7 14));Helvetica 12
1104 (defvar ps-header-pad
2)
1106 ;; LetterSmall 7.68 inch 10.16 inch
1107 ;; Tabloid 11.0 inch 17.0 inch
1108 ;; Ledger 17.0 inch 11.0 inch
1109 ;; Statement 5.5 inch 8.5 inch
1110 ;; Executive 7.5 inch 10.0 inch
1111 ;; A3 11.69 inch 16.5 inch
1112 ;; A4Small 7.47 inch 10.85 inch
1113 ;; B4 10.125 inch 14.33 inch
1114 ;; B5 7.16 inch 10.125 inch
1116 ;; All page dimensions are in PostScript points.
1118 (defvar ps-left-margin
72) ; 1 inch
1119 (defvar ps-right-margin
72) ; 1 inch
1120 (defvar ps-bottom-margin
36) ; 1/2 inch
1121 (defvar ps-top-margin
72) ; 1 inch
1123 ;; Letter 8.5 inch x 11.0 inch
1124 (defvar ps-letter-page-height
792) ; 11 inches
1125 (defvar ps-letter-page-width
612) ; 8.5 inches
1127 ;; Legal 8.5 inch x 14.0 inch
1128 (defvar ps-legal-page-height
1008) ; 14.0 inches
1129 (defvar ps-legal-page-width
612) ; 8.5 inches
1131 ;; A4 8.26 inch x 11.69 inch
1132 (defvar ps-a4-page-height
842) ; 11.69 inches
1133 (defvar ps-a4-page-width
595) ; 8.26 inches
1135 (defvar ps-pages-alist
1136 (list (list 'ps-letter ps-letter-page-width ps-letter-page-height
)
1137 (list 'ps-legal ps-legal-page-width ps-legal-page-height
)
1138 (list 'ps-a4 ps-a4-page-width ps-a4-page-height
)))
1140 ;; Define some constants to index into the page lists.
1141 (defvar ps-page-width-i
1)
1142 (defvar ps-page-height-i
2)
1144 (defvar ps-page-dimensions nil
)
1145 (defvar ps-print-width nil
)
1146 (defvar ps-print-height nil
)
1148 (defvar ps-height-remaining
)
1149 (defvar ps-width-remaining
)
1151 (defvar ps-ref-bold-faces nil
)
1152 (defvar ps-ref-italic-faces nil
)
1153 (defvar ps-ref-underlined-faces nil
)
1155 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1156 ;; Internal functions
1158 (defun ps-get-page-dimensions ()
1159 (setq ps-page-dimensions
(assq ps-paper-type ps-pages-alist
))
1160 (let ((ps-page-width (nth ps-page-width-i ps-page-dimensions
))
1161 (ps-page-height (nth ps-page-height-i ps-page-dimensions
)))
1162 (setq ps-print-height
(- ps-page-height ps-top-margin ps-bottom-margin
))
1163 (setq ps-print-width
(- ps-page-width ps-left-margin ps-right-margin
))))
1165 (defun ps-print-preprint (&optional filename
)
1167 (or (numberp filename
)
1169 (let* ((name (concat (buffer-name) ".ps"))
1170 (prompt (format "Save PostScript to file: (default %s) "
1172 (res (read-file-name prompt default-directory name nil
)))
1173 (if (file-directory-p res
)
1174 (expand-file-name name
(file-name-as-directory res
))
1177 ;; The following functions implement a simple list-buffering scheme so
1178 ;; that ps-print doesn't have to repeatedly switch between buffers
1179 ;; while spooling. The functions ps-output and ps-output-string build
1180 ;; up the lists; the function ps-flush-output takes the lists and
1181 ;; insert its contents into the spool buffer (*PostScript*).
1183 (defun ps-output-string-prim (string)
1184 (insert "(") ;insert start-string delimiter
1185 (save-excursion ;insert string
1188 ;; Find and quote special characters as necessary for PS
1189 (while (re-search-forward "[()\\]" nil t
)
1194 (goto-char (point-max))
1195 (insert ")")) ;insert end-string delimiter
1197 (defun ps-init-output-queue ()
1198 (setq ps-output-head
(list ""))
1199 (setq ps-output-tail ps-output-head
))
1201 (defun ps-output (&rest args
)
1202 (setcdr ps-output-tail args
)
1203 (while (cdr ps-output-tail
)
1204 (setq ps-output-tail
(cdr ps-output-tail
))))
1206 (defun ps-output-string (string)
1207 (ps-output t string
))
1209 (defun ps-flush-output ()
1211 (set-buffer ps-spool-buffer
)
1212 (goto-char (point-max))
1213 (while ps-output-head
1214 (let ((it (car ps-output-head
)))
1217 (setq ps-output-head
(cdr ps-output-head
))
1218 (ps-output-string-prim (car ps-output-head
))))
1219 (setq ps-output-head
(cdr ps-output-head
))))
1220 (ps-init-output-queue))
1222 (defun ps-insert-file (fname)
1225 ;; Check to see that the file exists and is readable; if not, throw
1227 (if (not (file-readable-p fname
))
1228 (error "Could not read file `%s'" fname
))
1231 (set-buffer ps-spool-buffer
)
1232 (goto-char (point-max))
1233 (insert-file fname
)))
1235 ;; These functions insert the arrays that define the contents of the
1238 (defun ps-generate-header-line (fonttag &optional content
)
1239 (ps-output " [ " fonttag
" ")
1241 ;; Literal strings should be output as is -- the string must
1242 ;; contain its own PS string delimiters, '(' and ')', if necessary.
1244 (ps-output content
))
1246 ;; Functions are called -- they should return strings; they will be
1247 ;; inserted as strings and the PS string delimiters added.
1248 ((and (symbolp content
) (fboundp content
))
1249 (ps-output-string (funcall content
)))
1251 ;; Variables will have their contents inserted. They should
1252 ;; contain strings, and will be inserted as strings.
1253 ((and (symbolp content
) (boundp content
))
1254 (ps-output-string (symbol-value content
)))
1256 ;; Anything else will get turned into an empty string.
1258 (ps-output-string "")))
1261 (defun ps-generate-header (name contents
)
1262 (ps-output "/" name
" [\n")
1263 (if (> ps-header-lines
0)
1265 (ps-generate-header-line "/h0" (car contents
))
1266 (while (and (< count ps-header-lines
)
1267 (setq contents
(cdr contents
)))
1268 (ps-generate-header-line "/h1" (car contents
))
1269 (setq count
(+ count
1)))
1270 (ps-output "] def\n"))))
1272 (defun ps-output-boolean (name bool
)
1273 (ps-output (format "/%s %s def\n" name
(if bool
"true" "false"))))
1275 (defun ps-begin-file ()
1276 (setq ps-showpage-count
0)
1278 (ps-output ps-adobe-tag
)
1279 (ps-output "%%Title: " (buffer-name) "\n") ;Take job name from name of
1280 ;first buffer printed
1281 (ps-output "%%Creator: " (user-full-name) "\n")
1282 (ps-output "%%CreationDate: "
1283 (time-stamp-hh:mm
:ss
) " " (time-stamp-mon-dd-yyyy) "\n")
1284 (ps-output "%% DocumentFonts: Helvetica Helvetica-Bold "
1285 ps-font
" " ps-font-bold
" " ps-font-italic
" "
1286 ps-font-bold-italic
"\n")
1287 (ps-output "%%Pages: (atend)\n")
1288 (ps-output "%%EndComments\n\n")
1290 (ps-output-boolean "Duplex" ps-spool-duplex
)
1291 (ps-output-boolean "PrintHeader" ps-print-header
)
1292 (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame
)
1293 (ps-output-boolean "ShowNofN" ps-show-n-of-n
)
1295 (ps-output (format "/LeftMargin %d def\n" ps-left-margin
))
1296 (ps-output (format "/RightMargin %d def\n" ps-right-margin
))
1297 (ps-output (format "/BottomMargin %d def\n" ps-bottom-margin
))
1298 (ps-output (format "/TopMargin %d def\n" ps-top-margin
))
1300 (ps-get-page-dimensions)
1301 (ps-output (format "/PrintWidth %d def\n" ps-print-width
))
1302 (ps-output (format "/PrintHeight %d def\n" ps-print-height
))
1304 (ps-output (format "/LineHeight %s def\n" ps-line-height
))
1306 (ps-output ps-print-prologue
)
1308 (ps-output (format "/f0 %d /%s Font\n" ps-font-size ps-font
))
1309 (ps-output (format "/f1 %d /%s Font\n" ps-font-size ps-font-bold
))
1310 (ps-output (format "/f2 %d /%s Font\n" ps-font-size ps-font-italic
))
1311 (ps-output (format "/f3 %d /%s Font\n" ps-font-size
1312 ps-font-bold-italic
))
1314 (ps-output "%%EndPrologue\n"))
1316 (defun ps-header-dirpart ()
1317 (let ((fname (buffer-file-name)))
1319 (if (string-equal (buffer-name) (file-name-nondirectory fname
))
1320 (file-name-directory fname
)
1324 (defun ps-get-buffer-name ()
1325 ;; Indulge me this little easter egg:
1326 (if (string= (buffer-name) "ps-print.el")
1327 "Hey, Cool! It's ps-print.el!!!"
1330 (defun ps-begin-job ()
1331 (setq ps-page-count
0))
1333 (defun ps-end-file ()
1334 (ps-output "%%Trailer\n")
1335 (ps-output "%%Pages: " (format "%d\n" ps-showpage-count
)))
1337 (defun ps-next-page ()
1342 (defun ps-begin-page (&optional dummypage
)
1343 (ps-get-page-dimensions)
1344 (setq ps-width-remaining ps-print-width
)
1345 (setq ps-height-remaining ps-print-height
)
1347 ;; If headers are turned on, deduct the height of the header from
1348 ;; the print height remaining. Clumsy clumsy clumsy.
1350 (setq ps-height-remaining
1351 (- ps-height-remaining
1352 ps-header-title-line-height
1353 (* ps-header-line-height
(- ps-header-lines
1))
1354 (* 2 ps-header-pad
))))
1356 (setq ps-page-count
(+ ps-page-count
1))
1358 (ps-output "\n%%Page: "
1359 (format "%d %d\n" ps-page-count
(+ 1 ps-showpage-count
)))
1360 (ps-output "BeginDSCPage\n")
1361 (ps-output (format "/PageNumber %d def\n" ps-page-count
))
1362 (ps-output "/PageCount 0 def\n")
1366 (ps-generate-header "HeaderLinesLeft" ps-left-header
)
1367 (ps-generate-header "HeaderLinesRight" ps-right-header
)
1368 (ps-output (format "%d SetHeaderLines\n" ps-header-lines
))))
1370 (ps-output "BeginPage\n")
1371 (ps-set-font ps-current-font
)
1372 (ps-set-bg ps-current-bg
)
1373 (ps-set-color ps-current-color
)
1374 (ps-set-underline ps-current-underline-p
))
1376 (defun ps-end-page ()
1377 (setq ps-showpage-count
(+ 1 ps-showpage-count
))
1378 (ps-output "EndPage\n")
1379 (ps-output "EndDSCPage\n"))
1381 (defun ps-dummy-page ()
1382 (setq ps-showpage-count
(+ 1 ps-showpage-count
))
1383 (ps-output "%%Page: " (format "- %d\n" ps-showpage-count
)
1385 /PrintHeader false def
1390 (defun ps-next-line ()
1391 (if (< ps-height-remaining ps-line-height
)
1393 (setq ps-width-remaining ps-print-width
)
1394 (setq ps-height-remaining
(- ps-height-remaining ps-line-height
))
1397 (defun ps-continue-line ()
1398 (if (< ps-height-remaining ps-line-height
)
1400 (setq ps-width-remaining ps-print-width
)
1401 (setq ps-height-remaining
(- ps-height-remaining ps-line-height
))
1404 (defun ps-hard-lf ()
1407 (defun ps-soft-lf ()
1410 (defun ps-find-wrappoint (from to char-width
)
1411 (let ((avail (truncate (/ ps-width-remaining char-width
)))
1414 (cons to
(* todo char-width
))
1415 (cons (+ from avail
) ps-width-remaining
))))
1417 (defun ps-basic-plot-string (from to
&optional bg-color
)
1418 (let* ((wrappoint (ps-find-wrappoint from to ps-avg-char-width
))
1419 (to (car wrappoint
))
1420 (string (buffer-substring from to
)))
1421 (ps-output-string string
)
1422 (ps-output " S\n") ;
1425 (defun ps-basic-plot-whitespace (from to
&optional bg-color
)
1426 (let* ((wrappoint (ps-find-wrappoint from to ps-space-width
))
1427 (to (car wrappoint
)))
1429 (ps-output (format "%d W\n" (- to from
)))
1432 (defun ps-plot (plotfunc from to
&optional bg-color
)
1434 (let* ((wrappoint (funcall plotfunc from to bg-color
))
1435 (plotted-to (car wrappoint
))
1436 (plotted-width (cdr wrappoint
)))
1437 (setq from plotted-to
)
1438 (setq ps-width-remaining
(- ps-width-remaining plotted-width
))
1440 (ps-continue-line))))
1441 (if ps-razzle-dazzle
1442 (let* ((q-todo (- (point-max) (point-min)))
1443 (q-done (- (point) (point-min)))
1444 (chunkfrac (/ q-todo
8))
1445 (chunksize (if (> chunkfrac
1000) 1000 chunkfrac
)))
1446 (if (> (- q-done ps-razchunk
) chunksize
)
1448 (setq ps-razchunk q-done
)
1451 (/ (* 100 q-done
) q-todo
)
1452 (/ q-done
(/ q-todo
100))))
1453 (message "Formatting...%d%%" foo
))))))
1455 (defun ps-set-font (font)
1456 (setq ps-current-font font
)
1457 (ps-output (format "/f%d F\n" ps-current-font
)))
1459 (defvar ps-print-color-scale nil
)
1461 (defun ps-set-bg (color)
1462 (if (setq ps-current-bg color
)
1463 (ps-output (format ps-color-format
(nth 0 color
) (nth 1 color
)
1466 (ps-output "false BG\n")))
1468 (defun ps-set-color (color)
1469 (if (setq ps-current-color color
)
1471 (setq ps-current-color ps-default-fg
))
1472 (ps-output (format ps-color-format
(nth 0 ps-current-color
)
1473 (nth 1 ps-current-color
) (nth 2 ps-current-color
))
1476 (defun ps-set-underline (underline-p)
1477 (ps-output (if underline-p
"true" "false") " UL\n")
1478 (setq ps-current-underline-p underline-p
))
1480 (defun ps-plot-region (from to font fg-color
&optional bg-color underline-p
)
1482 (if (not (equal font ps-current-font
))
1485 ;; Specify a foreground color only if one's specified and it's
1486 ;; different than the current.
1487 (if (not (equal fg-color ps-current-color
))
1488 (ps-set-color fg-color
))
1490 (if (not (equal bg-color ps-current-bg
))
1491 (ps-set-bg bg-color
))
1493 ;; Toggle underlining if different.
1494 (if (not (equal underline-p ps-current-underline-p
))
1495 (ps-set-underline underline-p
))
1497 ;; Starting at the beginning of the specified region...
1501 ;; ...break the region up into chunks separated by tabs, linefeeds,
1502 ;; and pagefeeds, and plot each chunk.
1504 (if (re-search-forward "[\t\n\f]" to t
)
1505 (let ((match (char-after (match-beginning 0))))
1509 (save-excursion (beginning-of-line) (point))))
1510 (ps-plot 'ps-basic-plot-string from
(- (point) 1)
1513 (setq from
(+ linestart
(current-column)))
1514 (if (re-search-forward "[ \t]+" to t
)
1515 (ps-plot 'ps-basic-plot-whitespace
1516 from
(+ linestart
(current-column))
1520 (ps-plot 'ps-basic-plot-string from
(- (point) 1)
1526 (ps-plot 'ps-basic-plot-string from
(- (point) 1)
1529 (setq from
(point)))
1530 (ps-plot 'ps-basic-plot-string from to bg-color
)
1533 (defun ps-color-value (x-color-value)
1534 ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
1535 (/ x-color-value ps-print-color-scale
))
1537 (defun ps-color-values (x-color)
1538 (cond ((fboundp 'x-color-values
)
1539 (x-color-values x-color
))
1540 ((fboundp 'pixel-components
)
1541 (pixel-components x-color
))
1542 (t (error "No available function to determine X color values."))))
1544 (defun ps-face-attributes (face)
1545 (let ((differs (face-differs-from-default-p face
)))
1546 (list (memq face ps-ref-bold-faces
)
1547 (memq face ps-ref-italic-faces
)
1548 (memq face ps-ref-underlined-faces
)
1549 (and differs
(face-foreground face
))
1550 (and differs
(face-background face
)))))
1552 (defun ps-face-attribute-list (face-or-list)
1553 (if (listp face-or-list
)
1554 (let (bold-p italic-p underline-p foreground background face-attr face
)
1556 (setq face
(car face-or-list
))
1557 (setq face-attr
(ps-face-attributes face
))
1558 (setq bold-p
(or bold-p
(nth 0 face-attr
)))
1559 (setq italic-p
(or italic-p
(nth 1 face-attr
)))
1560 (setq underline-p
(or underline-p
(nth 2 face-attr
)))
1563 (setq foreground
(nth 3 face-attr
)))
1566 (setq background
(nth 4 face-attr
)))
1567 (setq face-or-list
(cdr face-or-list
)))
1568 (list bold-p italic-p underline-p foreground background
))
1570 (ps-face-attributes face-or-list
)))
1572 (defun ps-plot-with-face (from to face
)
1574 (let* ((face-attr (ps-face-attribute-list face
))
1575 (bold-p (nth 0 face-attr
))
1576 (italic-p (nth 1 face-attr
))
1577 (underline-p (nth 2 face-attr
))
1578 (foreground (nth 3 face-attr
))
1579 (background (nth 4 face-attr
))
1580 (fg-color (if (and ps-print-color-p foreground
)
1581 (mapcar 'ps-color-value
1582 (ps-color-values foreground
))
1584 (bg-color (if (and ps-print-color-p background
)
1585 (mapcar 'ps-color-value
1586 (ps-color-values background
)))))
1587 (ps-plot-region from to
1588 (cond ((and bold-p italic-p
) 3)
1592 ; (or fg-color '(0.0 0.0 0.0))
1594 bg-color underline-p
))
1598 (defun ps-emacs-face-kind-p (face kind kind-regex kind-list
)
1599 (let ((frame-font (face-font face
))
1600 (face-defaults (face-font face t
)))
1602 ;; Check FACE defaults:
1603 (and (listp face-defaults
)
1604 (memq kind face-defaults
))
1606 ;; Check the user's preferences
1607 (memq face kind-list
))))
1609 (defun ps-xemacs-face-kind-p (face kind kind-regex kind-list
)
1610 (let* ((frame-font (or (face-font face
) (face-font 'default
)))
1611 (kind-cons (assq kind
(x-font-properties frame-font
)))
1612 (kind-spec (cdr-safe kind-cons
))
1613 (case-fold-search t
))
1615 (or (and kind-spec
(string-match kind-regex kind-spec
))
1616 ;; Kludge-compatible:
1617 (memq face kind-list
))))
1619 (defun ps-face-bold-p (face)
1620 (if (eq ps-print-emacs-type
'emacs
)
1621 (ps-emacs-face-kind-p face
'bold
"-\\(bold\\|demibold\\)-"
1623 (ps-xemacs-face-kind-p face
'WEIGHT_NAME
"bold\\|demibold"
1626 (defun ps-face-italic-p (face)
1627 (if (eq ps-print-emacs-type
'emacs
)
1628 (ps-emacs-face-kind-p face
'italic
"-[io]-" ps-italic-faces
)
1630 (ps-xemacs-face-kind-p face
'ANGLE_NAME
"i\\|o" ps-italic-faces
)
1631 (ps-xemacs-face-kind-p face
'SLANT
"i\\|o" ps-italic-faces
))))
1633 (defun ps-face-underlined-p (face)
1634 (or (face-underline-p face
)
1635 (memq face ps-underlined-faces
)))
1637 ;; Ensure that face-list is fbound.
1638 (or (fboundp 'face-list
) (defalias 'face-list
'list-faces
))
1640 (defun ps-build-reference-face-lists ()
1641 (if ps-auto-font-detect
1642 (let ((faces (face-list))
1644 (setq ps-ref-bold-faces nil
1645 ps-ref-italic-faces nil
1646 ps-ref-underlined-faces nil
)
1648 (setq the-face
(car faces
))
1649 (if (ps-face-italic-p the-face
)
1650 (setq ps-ref-italic-faces
1651 (cons the-face ps-ref-italic-faces
)))
1652 (if (ps-face-bold-p the-face
)
1653 (setq ps-ref-bold-faces
1654 (cons the-face ps-ref-bold-faces
)))
1655 (if (ps-face-underlined-p the-face
)
1656 (setq ps-ref-underlined-faces
1657 (cons the-face ps-ref-underlined-faces
)))
1658 (setq faces
(cdr faces
))))
1659 (setq ps-ref-bold-faces ps-bold-faces
)
1660 (setq ps-ref-italic-faces ps-italic-faces
)
1661 (setq ps-ref-underlined-faces ps-underlined-faces
))
1662 (setq ps-build-face-reference nil
))
1664 (defun ps-mapper (extent list
)
1665 (nconc list
(list (list (extent-start-position extent
) 'push extent
)
1666 (list (extent-end-position extent
) 'pull extent
)))
1669 (defun ps-sorter (a b
)
1670 (< (car a
) (car b
)))
1672 (defun ps-extent-sorter (a b
)
1673 (< (extent-priority a
) (extent-priority b
)))
1675 (defun ps-print-ensure-fontified (start end
)
1676 (if (and (boundp 'lazy-lock-mode
) lazy-lock-mode
)
1677 (if (fboundp 'lazy-lock-fontify-region
)
1678 (lazy-lock-fontify-region start end
)
1679 (lazy-lock-fontify-buffer))))
1681 (defun ps-generate-postscript-with-faces (from to
)
1682 ;; Build the reference lists of faces if necessary.
1683 (if (or ps-always-build-face-reference
1684 ps-build-face-reference
)
1686 (message "Collecting face information...")
1687 (ps-build-reference-face-lists)))
1688 ;; Set the color scale. We do it here instead of in the defvar so
1689 ;; that ps-print can be dumped into emacs. This expression can't be
1690 ;; evaluated at dump-time because X isn't initialized.
1691 (setq ps-print-color-scale
1692 (if ps-print-color-p
1693 (float (car (ps-color-values "white")))
1695 ;; Generate some PostScript.
1697 (narrow-to-region from to
)
1698 (let ((face 'default
)
1700 (ps-print-ensure-fontified from to
)
1701 (cond ((or (eq ps-print-emacs-type
'lucid
) (eq ps-print-emacs-type
'xemacs
))
1702 ;; Build the list of extents...
1703 (let ((a (cons 'dummy nil
))
1704 record type extent extent-list
)
1705 (map-extents 'ps-mapper nil from to a
)
1707 (setq a
(sort a
'ps-sorter
))
1709 (setq extent-list nil
)
1711 ;; Loop through the extents...
1713 (setq record
(car a
))
1715 (setq position
(car record
))
1716 (setq record
(cdr record
))
1718 (setq type
(car record
))
1719 (setq record
(cdr record
))
1721 (setq extent
(car record
))
1723 ;; Plot up to this record.
1724 ;; XEmacs 19.12: for some reason, we're getting into a
1725 ;; situation in which some of the records have
1726 ;; positions less than 'from'. Since we've narrowed
1727 ;; the buffer, this'll generate errors. This is a
1728 ;; hack, but don't call ps-plot-with-face unless from >
1730 (if (and (>= from
(point-min))
1731 (<= position
(point-max)))
1732 (ps-plot-with-face from position face
))
1736 (if (extent-face extent
)
1737 (setq extent-list
(sort (cons extent extent-list
)
1738 'ps-extent-sorter
))))
1741 (setq extent-list
(sort (delq extent extent-list
)
1742 'ps-extent-sorter
))))
1746 (extent-face (car extent-list
))
1749 (setq from position
)
1752 ((eq ps-print-emacs-type
'emacs
)
1753 (let ((property-change from
)
1754 (overlay-change from
))
1756 (if (< property-change to
) ; Don't search for property change
1757 ; unless previous search succeeded.
1758 (setq property-change
1759 (next-property-change from nil to
)))
1760 (if (< overlay-change to
) ; Don't search for overlay change
1761 ; unless previous search succeeded.
1762 (setq overlay-change
1763 (min (next-overlay-change from
) to
)))
1765 (min property-change overlay-change
))
1766 ;; The code below is not quite correct,
1767 ;; because a non-nil overlay invisible property
1768 ;; which is inactive according to the current value
1769 ;; of buffer-invisibility-spec nonetheless overrides
1770 ;; a face text property.
1772 (cond ((let ((prop (get-text-property from
'invisible
)))
1773 ;; Decide whether this invisible property
1774 ;; really makes the text invisible.
1775 (if (eq buffer-invisibility-spec t
)
1777 (or (memq prop buffer-invisibility-spec
)
1778 (assq prop buffer-invisibility-spec
))))
1780 ((get-text-property from
'face
))
1782 (let ((overlays (overlays-at from
))
1783 (face-priority -
1)) ; text-property
1785 (let* ((overlay (car overlays
))
1786 (overlay-face (overlay-get overlay
'face
))
1787 (overlay-invisible (overlay-get overlay
'invisible
))
1788 (overlay-priority (or (overlay-get overlay
1791 (if (and (or overlay-invisible overlay-face
)
1792 (> overlay-priority face-priority
))
1793 (setq face
(cond ((if (eq buffer-invisibility-spec t
)
1794 (not (null overlay-invisible
))
1795 (or (memq overlay-invisible buffer-invisibility-spec
)
1796 (assq overlay-invisible buffer-invisibility-spec
)))
1798 ((and face overlay-face
)))
1799 face-priority overlay-priority
)))
1800 (setq overlays
(cdr overlays
))))
1801 ;; Plot up to this record.
1802 (ps-plot-with-face from position face
)
1803 (setq from position
)))))
1804 (ps-plot-with-face from to face
))))
1806 (defun ps-generate-postscript (from to
)
1807 (ps-plot-region from to
0 nil
))
1809 (defun ps-generate (buffer from to genfunc
)
1810 (let ((from (min to from
))
1812 ;; This avoids trouble if chars with read-only properties
1813 ;; are copied into ps-spool-buffer.
1814 (inhibit-read-only t
))
1816 (narrow-to-region from to
)
1817 (if ps-razzle-dazzle
1818 (message "Formatting...%d%%" (setq ps-razchunk
0)))
1820 (setq ps-source-buffer buffer
)
1821 (setq ps-spool-buffer
(get-buffer-create ps-spool-buffer-name
))
1822 (ps-init-output-queue)
1823 (let (safe-marker completed-safely needs-begin-file
)
1826 (set-buffer ps-spool-buffer
)
1828 ;; Get a marker and make it point to the current end of the
1829 ;; buffer, If an error occurs, we'll delete everything from
1830 ;; the end of this marker onwards.
1831 (setq safe-marker
(make-marker))
1832 (set-marker safe-marker
(point-max))
1834 (goto-char (point-min))
1835 (if (looking-at (regexp-quote "%!PS-Adobe-1.0"))
1837 (setq needs-begin-file t
))
1839 (set-buffer ps-source-buffer
)
1840 (if needs-begin-file
(ps-begin-file))
1843 (set-buffer ps-source-buffer
)
1844 (funcall genfunc from to
)
1847 (if (and ps-spool-duplex
1848 (= (mod ps-page-count
2) 1))
1852 ;; Back to the PS output buffer to set the page count
1853 (set-buffer ps-spool-buffer
)
1854 (goto-char (point-max))
1855 (while (re-search-backward "^/PageCount 0 def$" nil t
)
1856 (replace-match (format "/PageCount %d def" ps-page-count
) t
))
1858 ;; Setting this variable tells the unwind form that the
1859 ;; the postscript was generated without error.
1860 (setq completed-safely t
))
1862 ;; Unwind form: If some bad mojo occurred while generating
1863 ;; postscript, delete all the postscript that was generated.
1864 ;; This protects the previously spooled files from getting
1866 (if (and (markerp safe-marker
) (not completed-safely
))
1868 (set-buffer ps-spool-buffer
)
1869 (delete-region (marker-position safe-marker
) (point-max))))))
1871 (if ps-razzle-dazzle
1872 (message "Formatting...done")))))
1874 (defun ps-do-despool (filename)
1875 (if (or (not (boundp 'ps-spool-buffer
))
1876 (not ps-spool-buffer
))
1877 (message "No spooled PostScript to print")
1882 (if ps-razzle-dazzle
1883 (message "Saving..."))
1884 (set-buffer ps-spool-buffer
)
1885 (setq filename
(expand-file-name filename
))
1886 (write-region (point-min) (point-max) filename
)
1887 (if ps-razzle-dazzle
1888 (message "Wrote %s" filename
)))
1889 ;; Else, spool to the printer
1890 (if ps-razzle-dazzle
1891 (message "Printing..."))
1893 (set-buffer ps-spool-buffer
)
1894 (if (and (eq system-type
'ms-dos
) (stringp dos-ps-printer
))
1895 (write-region (point-min) (point-max) dos-ps-printer t
0)
1896 (let ((binary-process-input t
)) ; for MS-DOS
1897 (apply 'call-process-region
1898 (point-min) (point-max) ps-lpr-command nil
1899 (if (fboundp 'start-process
) 0 nil
)
1902 (if ps-razzle-dazzle
1903 (message "Printing...done")))
1904 (kill-buffer ps-spool-buffer
)))
1906 (defun ps-kill-emacs-check ()
1908 (if (and (setq ps-buffer
(get-buffer ps-spool-buffer-name
))
1909 (buffer-modified-p ps-buffer
))
1910 (if (y-or-n-p "Unprinted PostScript waiting; print now? ")
1912 (if (and (setq ps-buffer
(get-buffer ps-spool-buffer-name
))
1913 (buffer-modified-p ps-buffer
))
1914 (if (yes-or-no-p "Unprinted PostScript waiting; exit anyway? ")
1916 (error "Unprinted PostScript")))))
1918 (if (fboundp 'add-hook
)
1919 (add-hook 'kill-emacs-hook
'ps-kill-emacs-check
)
1921 (message "Won't override existing kill-emacs-hook")
1922 (setq kill-emacs-hook
'ps-kill-emacs-check
)))
1924 ;;; Sample Setup Code:
1926 ;; This stuff is for anybody that's brave enough to look this far,
1927 ;; and able to figure out how to use it. It isn't really part of ps-
1928 ;; print, but I'll leave it here in hopes it might be useful:
1930 ;; WARNING!!! The following code is *sample* code only. Don't use it
1931 ;; unless you understand what it does!
1933 (defmacro ps-prsc
() (list 'if
(list 'eq
'ps-print-emacs-type
''emacs
)
1935 (defmacro ps-c-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs)
1938 (defmacro ps-s-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs)
1942 ;; Look in an article or mail message for the Subject: line. To be
1943 ;; placed in ps-left-headers.
1944 (defun ps-article-subject ()
1946 (goto-char (point-min))
1947 (if (re-search-forward "^Subject:[ \t]+\\(.*\\)$")
1948 (buffer-substring (match-beginning 1) (match-end 1))
1951 ;; Look in an article or mail message for the From: line. Sorta-kinda
1952 ;; understands RFC-822 addresses and can pull the real name out where
1953 ;; it's provided. To be placed in ps-left-headers.
1954 (defun ps-article-author ()
1956 (goto-char (point-min))
1957 (if (re-search-forward "^From:[ \t]+\\(.*\\)$")
1958 (let ((fromstring (buffer-substring (match-beginning 1) (match-end 1))))
1961 ;; Try first to match addresses that look like
1962 ;; thompson@wg2.waii.com (Jim Thompson)
1963 ((string-match ".*[ \t]+(\\(.*\\))" fromstring)
1964 (substring fromstring (match-beginning 1) (match-end 1)))
1966 ;; Next try to match addresses that look like
1967 ;; Jim Thompson <thompson@wg2.waii.com>
1968 ((string-match "\\(.*\\)[ \t]+<.*>" fromstring)
1969 (substring fromstring (match-beginning 1) (match-end 1)))
1971 ;; Couldn't find a real name -- show the address instead.
1975 ;; A hook to bind to gnus-Article-prepare-hook. This will set the ps-
1976 ;; left-headers specially for gnus articles. Unfortunately, gnus-
1977 ;; article-mode-hook is called only once, the first time the *Article*
1978 ;; buffer enters that mode, so it would only work for the first time
1979 ;; we ran gnus. The second time, this hook wouldn't get set up. The
1980 ;; only alternative is gnus-article-prepare-hook.
1981 (defun ps-gnus-article-prepare-hook ()
1982 (setq ps-header-lines 3)
1983 (setq ps-left-header
1984 ;; The left headers will display the article's subject, its
1985 ;; author, and the newsgroup it was in.
1986 (list 'ps-article-subject 'ps-article-author 'gnus-newsgroup-name)))
1988 ;; A hook to bind to vm-mode-hook to locally bind prsc and set the ps-
1989 ;; left-headers specially for mail messages. This header setup would
1990 ;; also work, I think, for RMAIL.
1991 (defun ps-vm-mode-hook ()
1992 (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary)
1993 (setq ps-header-lines 3)
1994 (setq ps-left-header
1995 ;; The left headers will display the message's subject, its
1996 ;; author, and the name of the folder it was in.
1997 (list 'ps-article-subject 'ps-article-author 'buffer-name)))
1999 ;; Every now and then I forget to switch from the *Summary* buffer to
2000 ;; the *Article* before hitting prsc, and a nicely formatted list of
2001 ;; article subjects shows up at the printer. This function, bound to
2002 ;; prsc for the gnus *Summary* buffer means I don't have to switch
2004 (defun ps-gnus-print-article-from-summary ()
2006 (if (get-buffer "*Article*")
2008 (set-buffer "*Article*")
2009 (ps-spool-buffer-with-faces))))
2011 ;; See ps-gnus-print-article-from-summary. This function does the
2012 ;; same thing for vm.
2013 (defun ps-vm-print-message-from-summary ()
2017 (set-buffer vm-mail-buffer)
2018 (ps-spool-buffer-with-faces))))
2020 ;; A hook to bind to bind to gnus-summary-setup-buffer to locally bind
2022 (defun ps-gnus-summary-setup ()
2023 (local-set-key (ps-prsc) 'ps-gnus-print-article-from-summary))
2025 ;; Look in an article or mail message for the Subject: line. To be
2026 ;; placed in ps-left-headers.
2027 (defun ps-info-file ()
2029 (goto-char (point-min))
2030 (if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)")
2031 (buffer-substring (match-beginning 1) (match-end 1))
2034 ;; Look in an article or mail message for the Subject: line. To be
2035 ;; placed in ps-left-headers.
2036 (defun ps-info-node ()
2038 (goto-char (point-min))
2039 (if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)")
2040 (buffer-substring (match-beginning 1) (match-end 1))
2043 (defun ps-info-mode-hook ()
2044 (setq ps-left-header
2045 ;; The left headers will display the node name and file name.
2046 (list 'ps-info-node 'ps-info-file)))
2048 ;; WARNING! The following function is a *sample* only, and is *not*
2049 ;; meant to be used as a whole unless you understand what the effects
2050 ;; will be! (In fact, this is a copy if my setup for ps-print -- I'd
2051 ;; be very surprised if it was useful to *anybody*, without
2054 (defun ps-jts-ps-setup ()
2055 (global-set-key (ps-prsc) 'ps-spool-buffer-with-faces) ;f22 is prsc
2056 (global-set-key (ps-s-prsc) 'ps-spool-region-with-faces)
2057 (global-set-key (ps-c-prsc) 'ps-despool)
2058 (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook)
2059 (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup)
2060 (add-hook 'vm-mode-hook 'ps-vm-mode-hook)
2061 (add-hook 'vm-mode-hooks 'ps-vm-mode-hook)
2062 (add-hook 'Info-mode-hook 'ps-info-mode-hook)
2063 (setq ps-spool-duplex t)
2064 (setq ps-print-color-p nil)
2065 (setq ps-lpr-command "lpr")
2066 (setq ps-lpr-switches '("-Jjct,duplex_long")))
2070 ;;; ps-print.el ends here