Mercurial > hg > xemacs-beta

comparison lisp/packages/ps-print.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19.
2
3 ;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.
4
5 ;; Author: Jim Thompson <thompson@wg2.waii.com>
6 ;; Keywords: print, PostScript
7
8 ;; This file is part of XEmacs.
9
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
23
24 ;; LCD Archive Entry:
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|
28
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.)
33
34 ;;; Synched up with: FSF 19.30.
35
36 ;;; Commentary:
37
38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39 ;;
40 ;; About ps-print
41 ;; --------------
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.
47 ;;
48 ;; Using ps-print
49 ;; --------------
50 ;;
51 ;; The Commands
52 ;;
53 ;; Ps-print provides eight commands for generating PostScript images
54 ;; of Emacs buffers:
55 ;;
56 ;; ps-print-buffer
57 ;; ps-print-buffer-with-faces
58 ;; ps-print-region
59 ;; ps-print-region-with-faces
60 ;; ps-spool-buffer
61 ;; ps-spool-buffer-with-faces
62 ;; ps-spool-region
63 ;; ps-spool-region-with-faces
64 ;;
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".
69 ;;
70 ;; The word "print" or "spool" in the command name determines when the
71 ;; PostScript image is sent to the printer:
72 ;;
73 ;; print - The PostScript image is immediately sent to the
74 ;; printer;
75 ;;
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.
80 ;;
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).
86 ;;
87 ;; Ps-print has a hook in the kill-emacs-hooks so that you won't
88 ;; accidently 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.
93 ;;
94 ;; The word "buffer" or "region" in the command name determines how
95 ;; much of the buffer is printed:
96 ;;
97 ;; buffer - Print the entire buffer.
98 ;;
99 ;; region - Print just the current region.
100 ;;
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.
107 ;;
108 ;; Two ps-print- command examples:
109 ;;
110 ;; ps-print-buffer - print the entire buffer,
111 ;; without font, color, or
112 ;; underline information, and
113 ;; send it immediately to the
114 ;; printer.
115 ;;
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.
121 ;;
122 ;;
123 ;; Invoking Ps-Print
124 ;;
125 ;; To print your buffer, type
126 ;;
127 ;; M-x ps-print-buffer
128 ;;
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
132 ;;
133 ;; C-u M-x ps-print-buffer
134 ;;
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:
140 ;;
141 ;; C-u M-x ps-despool
142 ;;
143 ;; When invoked this way, ps-despool will prompt you for the name of
144 ;; the file to save to.
145 ;;
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:
149 ;;
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)
153 ;;
154 ;;
155 ;; The Printer Interface
156 ;;
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.
161 ;;
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.
167 ;;
168 ;;
169 ;; How Ps-Print Deals With Fonts
170 ;;
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.
175 ;;
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
181 ;; file:
182 ;;
183 ;; (setq ps-bold-faces '(my-blue-face))
184 ;; (setq ps-italic-faces '(my-red-face))
185 ;;
186 ;; Faces like bold-italic that are both bold and italic should go in
187 ;; *both* lists.
188 ;;
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.
195 ;;
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.
199 ;;
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 invokations of ps-print.
204 ;;
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.
210 ;;
211 ;;
212 ;; How Ps-Print Deals With Color
213 ;;
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.
220 ;;
221 ;;
222 ;; Headers
223 ;;
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:
229 ;;
230 ;; ps-print.el 1/21
231 ;; /home/jct/emacs-lisp/ps/new 94/12/31
232 ;;
233 ;; When printing on duplex printers, left and right are reversed so
234 ;; that the page numbers are toward the outside.
235 ;;
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.
241 ;;
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.
247 ;;
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
254 ;; ')'.
255 ;;
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 ;; strings delimeters are added by ps-print, and should not be part of
261 ;; the returned value.
262 ;;
263 ;; Here's an example: say we want the left header to display the text
264 ;;
265 ;; Moe
266 ;; Larry
267 ;; Curly
268 ;;
269 ;; where we have a function to return "Moe"
270 ;;
271 ;; (defun moe-func ()
272 ;; "Moe")
273 ;;
274 ;; a variable specifying "Larry"
275 ;;
276 ;; (setq larry-var "Larry")
277 ;;
278 ;; and a literal for "Curly". Here's how ps-left-header should be
279 ;; set:
280 ;;
281 ;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)"))
282 ;;
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
289 ;; warned.
290 ;;
291 ;;
292 ;; Duplex Printers
293 ;;
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.
299 ;;
300 ;;
301 ;; Paper Size
302 ;;
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.
306 ;;
307 ;;
308 ;; Installing ps-print
309 ;; -------------------
310 ;;
311 ;; 1. Place ps-print.el somewhere in your load-path and byte-compile
312 ;; it. You can ignore all byte-compiler warnings; they are the
313 ;; result of multi-Emacs support. This step is necessary only if
314 ;; you're installing your own ps-print; if ps-print came with your
315 ;; copy of Emacs, this been done already.
316 ;;
317 ;; 2. Place in your .emacs file the line
318 ;;
319 ;; (require 'ps-print)
320 ;;
321 ;; to load ps-print. Or you may cause any of the ps-print commands
322 ;; to be autoloaded with an autoload command such as:
323 ;;
324 ;; (autoload 'ps-print-buffer "ps-print"
325 ;; "Generate and print a PostScript image of the buffer..." t)
326 ;;
327 ;; 3. Make sure that the variables ps-lpr-command and ps-lpr-switches
328 ;; contain appropriate values for your system; see the usage notes
329 ;; below and the documentation of these variables.
330 ;;
331 ;; New since version 1.5
332 ;; ---------------------
333 ;; Color output capability.
334 ;;
335 ;; Automatic detection of font attributes (bold, italic).
336 ;;
337 ;; Configurable headers with page numbers.
338 ;;
339 ;; Slightly faster.
340 ;;
341 ;; Support for different paper sizes.
342 ;;
343 ;; Better conformance to PostScript Document Structure Conventions.
344 ;;
345 ;;
346 ;; Known bugs and limitations of ps-print:
347 ;; --------------------------------------
348 ;; Although color printing will work in XEmacs 19.12, it doesn't work
349 ;; well; in particular, bold or italic fonts don't print in the right
350 ;; background color.
351 ;;
352 ;; Invisible properties aren't correctly ignored in XEmacs 19.12.
353 ;;
354 ;; Automatic font-attribute detection doesn't work well, especially
355 ;; with hilit19 and older versions of get-create-face. Users having
356 ;; problems with auto-font detection should use the lists ps-italic-
357 ;; faces and ps-bold-faces and/or turn off automatic detection by
358 ;; setting ps-auto-font-detect to nil.
359 ;;
360 ;; Automatic font-attribute detection doesn't work with XEmacs 19.12
361 ;; in tty mode; use the lists ps-italic-faces and ps-bold-faces
362 ;; instead.
363 ;;
364 ;; Still too slow; could use some hand-optimization.
365 ;;
366 ;; ASCII Control characters other than tab, linefeed and pagefeed are
367 ;; not handled.
368 ;;
369 ;; Default background color isn't working.
370 ;;
371 ;; Faces are always treated as opaque.
372 ;;
373 ;; Epoch and Emacs 18 not supported. At all.
374 ;;
375 ;;
376 ;; Features to add:
377 ;; ---------------
378 ;; 2-up and 4-up capability.
379 ;;
380 ;; Line numbers.
381 ;;
382 ;; Wide-print (landscape) capability.
383 ;;
384 ;;
385 ;; Acknowledgements
386 ;; ----------------
387 ;; Thanks to Kevin Rodgers <kevinr@ihs.com> for adding support for
388 ;; color and the invisible property.
389 ;;
390 ;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing
391 ;; the initial port to Emacs 19. His code is no longer part of
392 ;; ps-print, but his work is still appreciated.
393 ;;
394 ;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org,
395 ;; for adding underline support. Their code also is no longer part of
396 ;; ps-print, but their efforts are not forgotten.
397 ;;
398 ;; Thanks also to all of you who mailed code to add features to
399 ;; ps-print; although I didn't use your code, I still appreciate your
400 ;; sharing it with me.
401 ;;
402 ;; Thanks to all who mailed comments, encouragement, and criticism.
403 ;; Thanks also to all who responded to my survey; I had too many
404 ;; responses to reply to them all, but I greatly appreciate your
405 ;; interest.
406 ;;
407 ;; Jim
408 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
409
410 ;;; Code:
411
412 (defconst ps-print-version "2.8"
413 "ps-print.el,v 2.8 1995/05/04 12:06:10 jct Exp
414
415 Jim's last change version -- this file may have been edited as part of
416 Emacs without changes to the version number. When reporting bugs,
417 please also report the version of Emacs, if any, that ps-print was
418 distributed with.
419
420 Please send all bug fixes and enhancements to
421 Jim Thompson <thompson@wg2.waii.com>.")
422
423 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
424 ;; User Variables:
425
426 (defvar ps-lpr-command lpr-command
427 "*The shell command for printing a PostScript file.")
428
429 (defvar ps-lpr-switches lpr-switches
430 "*A list of extra switches to pass to `ps-lpr-command'.")
431
432 (defvar ps-spool-duplex nil ; Not many people have duplex
433 ; printers, so default to nil.
434 "*Non-nil indicates spooling is for a two-sided printer.
435 For a duplex printer, the `ps-spool-*' commands will insert blank pages
436 as needed between print jobs so that the next buffer printed will
437 start on the right page. Also, if headers are turned on, the headers
438 will be reversed on duplex printers so that the page numbers fall to
439 the left on even-numbered pages.")
440
441 ;;;###autoload
442 (defvar ps-paper-type 'ps-letter
443 "*Specifies the size of paper to format for. Should be one of
444 `ps-letter', `ps-legal', or `ps-a4'.")
445
446 (defvar ps-print-header t
447 "*Non-nil means print a header at the top of each page.
448 By default, the header displays the buffer name, page number, and, if
449 the buffer is visiting a file, the file's directory. Headers are
450 customizable by changing variables `ps-header-left' and
451 `ps-header-right'.")
452
453 (defvar ps-print-header-frame t
454 "*Non-nil means draw a gaudy frame around the header.")
455
456 (defvar ps-show-n-of-n t
457 "*Non-nil means show page numbers as N/M, meaning page N of M.
458 Note: page numbers are displayed as part of headers, see variable
459 `ps-print-headers'.")
460
461 ;;;###autoload
462 (defvar ps-print-color-p (and (or (fboundp 'x-color-values) ; fsf
463 (fboundp 'color-instance-rgb-components))
464 ; xemacs
465 (fboundp 'float))
466 ; Printing color requires both floating point and x-color-values.
467 "*If non-nil, print the buffer's text in color.")
468
469 (defvar ps-default-fg '(0.0 0.0 0.0)
470 "*RGB values of the default foreground color. Defaults to black.")
471
472 (defvar ps-default-bg '(1.0 1.0 1.0)
473 "*RGB values of the default background color. Defaults to white.")
474
475 (defvar ps-font-size 10
476 "*Font size, in points, for generating Postscript.")
477
478 (defvar ps-font "Courier"
479 "*Font family name for ordinary text, when generating Postscript.")
480
481 (defvar ps-font-bold "Courier-Bold"
482 "*Font family name for bold text, when generating Postscript.")
483
484 (defvar ps-font-italic "Courier-Oblique"
485 "*Font family name for italic text, when generating Postscript.")
486
487 (defvar ps-font-bold-italic "Courier-BoldOblique"
488 "*Font family name for bold italic text, when generating Postscript.")
489
490 (defvar ps-avg-char-width (if (fboundp 'float) 5.6 6)
491 "*The average width, in points, of a character, for generating Postscript.
492 This is the value that ps-print uses to determine the length,
493 x-dimension, of the text it has printed, and thus affects the point at
494 which long lines wrap around. If you change the font or
495 font size, you will probably have to adjust this value to match.")
496
497 (defvar ps-space-width (if (fboundp 'float) 5.6 6)
498 "*The width of a space character, for generating Postscript.
499 This value is used in expanding tab characters.")
500
501 (defvar ps-line-height (if (fboundp 'float) 11.29 11)
502 "*The height of a line, for generating Postscript.
503 This is the value that ps-print uses to determine the height,
504 y-dimension, of the lines of text it has printed, and thus affects the
505 point at which page-breaks are placed. If you change the font or font
506 size, you will probably have to adjust this value to match. The
507 line-height is *not* the same as the point size of the font.")
508
509 (defvar ps-auto-font-detect t
510 "*Non-nil means automatically detect bold/italic face attributes.
511 nil means rely solely on the lists `ps-bold-faces', `ps-italic-faces',
512 and `ps-underlined-faces'.")
513
514 (defvar ps-bold-faces '()
515 "*A list of the \(non-bold\) faces that should be printed in bold font.
516 This applies to generating Postscript.")
517
518 (defvar ps-italic-faces '()
519 "*A list of the \(non-italic\) faces that should be printed in italic font.
520 This applies to generating Postscript.")
521
522 (defvar ps-underlined-faces '()
523 "*A list of the \(non-underlined\) faces that should be printed underlined.
524 This applies to generating Postscript.")
525
526 (defvar ps-header-lines 2
527 "*Number of lines to display in page header, when generating Postscript.")
528 (make-variable-buffer-local 'ps-header-lines)
529
530 (defvar ps-left-header
531 (list 'ps-get-buffer-name 'ps-header-dirpart)
532 "*The items to display on the right part of the page header.
533 This applies to generating Postscript.
534
535 The value should be a list of strings and symbols, each representing an
536 entry in the PostScript array HeaderLinesLeft.
537
538 Strings are inserted unchanged into the array; those representing
539 PostScript string literals should be delimited with PostScript string
540 delimiters '(' and ')'.
541
542 For symbols with bound functions, the function is called and should
543 return a string to be inserted into the array. For symbols with bound
544 values, the value should be a string to be inserted into the array.
545 In either case, function or variable, the string value has PostScript
546 string delimiters added to it.")
547 (make-variable-buffer-local 'ps-left-header)
548
549 (defvar ps-right-header
550 (list "/pagenumberstring load" 'time-stamp-yy/mm/dd 'time-stamp-hh:mm:ss)
551 "*The items to display on the left part of the page header.
552 This applies to generating Postscript.
553
554 See the variable `ps-left-header' for a description of the format of
555 this variable.")
556 (make-variable-buffer-local 'ps-right-header)
557
558 (defvar ps-razzle-dazzle t
559 "*Non-nil means report progress while formatting buffer.")
560
561 (defvar ps-adobe-tag "%!PS-Adobe-1.0\n"
562 "*Contains the header line identifying the output as PostScript.
563 By default, `ps-adobe-tag' contains the standard identifier. Some
564 printers require slightly different versions of this line.")
565
566 (defvar ps-build-face-reference t
567 "*Non-nil means build the reference face lists.
568
569 Ps-print sets this value to nil after it builds its internal reference
570 lists of bold and italic faces. By settings its value back to t, you
571 can force ps-print to rebuild the lists the next time you invoke one
572 of the ...-with-faces commands.
573
574 You should set this value back to t after you change the attributes of
575 any face, or create new faces. Most users shouldn't have to worry
576 about its setting, though.")
577
578 (defvar ps-always-build-face-reference nil
579 "*Non-nil means always rebuild the reference face lists.
580
581 If this variable is non-nil, ps-print will rebuild its internal
582 reference lists of bold and italic faces *every* time one of the
583 -with-faces commands is called. Most users shouldn't need to set this
584 variable.")
585
586 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
587 ;; User commands
588
589 ;;;###autoload
590 (defun ps-print-buffer (&optional filename)
591 "Generate and print a PostScript image of the buffer.
592
593 When called with a numeric prefix argument (C-u), prompts the user for
594 the name of a file to save the PostScript image in, instead of sending
595 it to the printer.
596
597 More specifically, the FILENAME argument is treated as follows: if it
598 is nil, send the image to the printer. If FILENAME is a string, save
599 the PostScript image in a file with that name. If FILENAME is a
600 number, prompt the user for the name of the file to save in."
601
602 (interactive (list (ps-print-preprint current-prefix-arg)))
603 (ps-generate (current-buffer) (point-min) (point-max)
604 'ps-generate-postscript)
605 (ps-do-despool filename))
606
607
608 ;;;###autoload
609 (defun ps-print-buffer-with-faces (&optional filename)
610 "Generate and print a PostScript image of the buffer.
611
612 Like `ps-print-buffer', but includes font, color, and underline
613 information in the generated image."
614 (interactive (list (ps-print-preprint current-prefix-arg)))
615 (ps-generate (current-buffer) (point-min) (point-max)
616 'ps-generate-postscript-with-faces)
617 (ps-do-despool filename))
618
619
620 ;;;###autoload
621 (defun ps-print-region (from to &optional filename)
622 "Generate and print a PostScript image of the region.
623
624 Like `ps-print-buffer', but prints just the current region."
625
626 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg)))
627 (ps-generate (current-buffer) from to
628 'ps-generate-postscript)
629 (ps-do-despool filename))
630
631
632 ;;;###autoload
633 (defun ps-print-region-with-faces (from to &optional filename)
634 "Generate and print a PostScript image of the region.
635
636 Like `ps-print-region', but includes font, color, and underline
637 information in the generated image."
638
639 (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg)))
640 (ps-generate (current-buffer) from to
641 'ps-generate-postscript-with-faces)
642 (ps-do-despool filename))
643
644
645 ;;;###autoload
646 (defun ps-spool-buffer ()
647 "Generate and spool a PostScript image of the buffer.
648
649 Like `ps-print-buffer' except that the PostScript image is saved in a
650 local buffer to be sent to the printer later.
651
652 Use the command `ps-despool' to send the spooled images to the printer."
653 (interactive)
654 (ps-generate (current-buffer) (point-min) (point-max)
655 'ps-generate-postscript))
656
657
658 ;;;###autoload
659 (defun ps-spool-buffer-with-faces ()
660 "Generate and spool a PostScript image of the buffer.
661
662 Like `ps-spool-buffer', but includes font, color, and underline
663 information in the generated image.
664
665 Use the command `ps-despool' to send the spooled images to the printer."
666
667 (interactive)
668 (ps-generate (current-buffer) (point-min) (point-max)
669 'ps-generate-postscript-with-faces))
670
671
672 ;;;###autoload
673 (defun ps-spool-region (from to)
674 "Generate a PostScript image of the region and spool locally.
675
676 Like `ps-spool-buffer', but spools just the current region.
677
678 Use the command `ps-despool' to send the spooled images to the printer."
679 (interactive "r")
680 (ps-generate (current-buffer) from to
681 'ps-generate-postscript))
682
683
684 ;;;###autoload
685 (defun ps-spool-region-with-faces (from to)
686 "Generate a PostScript image of the region and spool locally.
687
688 Like `ps-spool-region', but includes font, color, and underline
689 information in the generated image.
690
691 Use the command `ps-despool' to send the spooled images to the printer."
692 (interactive "r")
693 (ps-generate (current-buffer) from to
694 'ps-generate-postscript-with-faces))
695
696 ;;;###autoload
697 (defun ps-despool (&optional filename)
698 "Send the spooled PostScript to the printer.
699
700 When called with a numeric prefix argument (C-u), prompt the user for
701 the name of a file to save the spooled PostScript in, instead of sending
702 it to the printer.
703
704 More specifically, the FILENAME argument is treated as follows: if it
705 is nil, send the image to the printer. If FILENAME is a string, save
706 the PostScript image in a file with that name. If FILENAME is a
707 number, prompt the user for the name of the file to save in."
708 (interactive (list (ps-print-preprint current-prefix-arg)))
709 (ps-do-despool filename))
710
711 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
712 ;; Utility functions and variables:
713
714 (defvar ps-print-emacs-type
715 (cond ((string-match "XEmacs" emacs-version) 'xemacs)
716 ((string-match "Lucid" emacs-version) 'lucid)
717 ((string-match "Epoch" emacs-version) 'epoch)
718 (t 'emacs)))
719
720 (if (or (eq ps-print-emacs-type 'lucid)
721 (eq ps-print-emacs-type 'xemacs))
722 (if (< emacs-minor-version 12)
723 (setq ps-print-color-p nil))
724 (require 'faces)) ; face-font, face-underline-p,
725 ; x-font-regexp
726
727 (defun xemacs-color-device ()
728 (if (and (eq ps-print-emacs-type 'xemacs)
729 (>= emacs-minor-version 12))
730 (eq (device-class) 'color)
731 t))
732
733 (require 'time-stamp)
734
735 (defvar ps-print-prologue "% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4:
736 % If the ISOLatin1Encoding vector isn't known, define it.
737 /ISOLatin1Encoding where { pop } {
738 % Define the ISO Latin-1 encoding vector.
739 % The first half is the same as the standard encoding,
740 % except for minus instead of hyphen at code 055.
741 /ISOLatin1Encoding
742 StandardEncoding 0 45 getinterval aload pop
743 /minus
744 StandardEncoding 46 82 getinterval aload pop
745 %*** NOTE: the following are missing in the Adobe documentation,
746 %*** but appear in the displayed table:
747 %*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240.
748 % \20x
749 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
750 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
751 /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
752 /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron
753 % \24x
754 /space /exclamdown /cent /sterling
755 /currency /yen /brokenbar /section
756 /dieresis /copyright /ordfeminine /guillemotleft
757 /logicalnot /hyphen /registered /macron
758 /degree /plusminus /twosuperior /threesuperior
759 /acute /mu /paragraph /periodcentered
760 /cedilla /onesuperior /ordmasculine /guillemotright
761 /onequarter /onehalf /threequarters /questiondown
762 % \30x
763 /Agrave /Aacute /Acircumflex /Atilde
764 /Adieresis /Aring /AE /Ccedilla
765 /Egrave /Eacute /Ecircumflex /Edieresis
766 /Igrave /Iacute /Icircumflex /Idieresis
767 /Eth /Ntilde /Ograve /Oacute
768 /Ocircumflex /Otilde /Odieresis /multiply
769 /Oslash /Ugrave /Uacute /Ucircumflex
770 /Udieresis /Yacute /Thorn /germandbls
771 % \34x
772 /agrave /aacute /acircumflex /atilde
773 /adieresis /aring /ae /ccedilla
774 /egrave /eacute /ecircumflex /edieresis
775 /igrave /iacute /icircumflex /idieresis
776 /eth /ntilde /ograve /oacute
777 /ocircumflex /otilde /odieresis /divide
778 /oslash /ugrave /uacute /ucircumflex
779 /udieresis /yacute /thorn /ydieresis
780 256 packedarray def
781 } ifelse
782
783 /reencodeFontISO { %def
784 dup
785 length 5 add dict % Make a new font (a new dict
786 % the same size as the old
787 % one) with room for our new
788 % symbols.
789
790 begin % Make the new font the
791 % current dictionary.
792
793
794 { 1 index /FID ne
795 { def } { pop pop } ifelse
796 } forall % Copy each of the symbols
797 % from the old dictionary to
798 % the new except for the font
799 % ID.
800
801 /Encoding ISOLatin1Encoding def % Override the encoding with
802 % the ISOLatin1 encoding.
803
804 % Use the font's bounding box to determine the ascent, descent,
805 % and overall height; don't forget that these values have to be
806 % transformed using the font's matrix.
807 FontBBox
808 FontMatrix transform /Ascent exch def pop
809 FontMatrix transform /Descent exch def pop
810 /FontHeight Ascent Descent sub def
811
812 % Define these in case they're not in the FontInfo (also, here
813 % they're easier to get to.
814 /UnderlinePosition 1 def
815 /UnderlineThickness 1 def
816
817 % Get the underline position and thickness if they're defined.
818 currentdict /FontInfo known {
819 FontInfo
820
821 dup /UnderlinePosition known {
822 dup /UnderlinePosition get
823 0 exch FontMatrix transform exch pop
824 /UnderlinePosition exch def
825 } if
826
827 dup /UnderlineThickness known {
828 /UnderlineThickness get
829 0 exch FontMatrix transform exch pop
830 /UnderlineThickness exch def
831 } if
832
833 } if
834
835 currentdict % Leave the new font on the
836 % stack
837
838 end % Stop using the font as the
839 % current dictionary.
840
841 definefont % Put the font into the font
842 % dictionary
843
844 pop % Discard the returned font.
845 } bind def
846
847 /Font {
848 findfont exch scalefont reencodeFontISO
849 } def
850
851 /F { % Font select
852 findfont
853 dup /Ascent get /Ascent exch def
854 dup /Descent get /Descent exch def
855 dup /FontHeight get /FontHeight exch def
856 dup /UnderlinePosition get /UnderlinePosition exch def
857 dup /UnderlineThickness get /UnderlineThickness exch def
858 setfont
859 } def
860
861 /FG /setrgbcolor load def
862
863 /bg false def
864 /BG {
865 dup /bg exch def
866 { mark 4 1 roll ] /bgcolor exch def } if
867 } def
868
869 /dobackground { % width --
870 currentpoint
871 gsave
872 newpath
873 moveto
874 0 Ascent rmoveto
875 dup 0 rlineto
876 0 Descent Ascent sub rlineto
877 neg 0 rlineto
878 closepath
879 bgcolor aload pop setrgbcolor
880 fill
881 grestore
882 } def
883
884 /dobackgroundstring { % string --
885 stringwidth pop
886 dobackground
887 } def
888
889 /dounderline { % fromx fromy --
890 currentpoint
891 gsave
892 UnderlineThickness setlinewidth
893 4 2 roll
894 UnderlinePosition add moveto
895 UnderlinePosition add lineto
896 stroke
897 grestore
898 } def
899
900 /eolbg {
901 currentpoint pop
902 PrintWidth LeftMargin add exch sub dobackground
903 } def
904
905 /eolul {
906 currentpoint exch pop
907 PrintWidth LeftMargin add exch dounderline
908 } def
909
910 /SL { % Soft Linefeed
911 bg { eolbg } if
912 ul { eolul } if
913 currentpoint LineHeight sub LeftMargin exch moveto pop
914 } def
915
916 /HL /SL load def % Hard Linefeed
917
918 /sp1 { currentpoint 3 -1 roll } def
919
920 % Some debug
921 /dcp { currentpoint exch 40 string cvs print (, ) print = } def
922 /dp { print 2 copy
923 exch 40 string cvs print (, ) print = } def
924
925 /S {
926 bg { dup dobackgroundstring } if
927 ul { sp1 } if
928 show
929 ul { dounderline } if
930 } def
931
932 /W {
933 ul { sp1 } if
934 ( ) stringwidth % Get the width of a space
935 pop % Discard the Y component
936 mul % Multiply the width of a
937 % space by the number of
938 % spaces to plot
939 bg { dup dobackground } if
940 0 rmoveto
941 ul { dounderline } if
942 } def
943
944 /BeginDSCPage {
945 /vmstate save def
946 } def
947
948 /BeginPage {
949 PrintHeader {
950 PrintHeaderFrame { HeaderFrame } if
951 HeaderText
952 } if
953 LeftMargin
954 BottomMargin PrintHeight add
955 moveto % move to where printing will
956 % start.
957 } def
958
959 /EndPage {
960 bg { eolbg } if
961 ul { eolul } if
962 showpage % Spit out a page
963 } def
964
965 /EndDSCPage {
966 vmstate restore
967 } def
968
969 /ul false def
970
971 /UL { /ul exch def } def
972
973 /h0 14 /Helvetica-Bold Font
974 /h1 12 /Helvetica Font
975
976 /h1 F
977
978 /HeaderLineHeight FontHeight def
979 /HeaderDescent Descent def
980 /HeaderPad 2 def
981
982 /SetHeaderLines {
983 /HeaderOffset TopMargin 2 div def
984 /HeaderLines exch def
985 /HeaderHeight HeaderLines HeaderLineHeight mul HeaderPad 2 mul add def
986 /PrintHeight PrintHeight HeaderHeight sub def
987 } def
988
989 /HeaderFrameStart {
990 LeftMargin BottomMargin PrintHeight add HeaderOffset add
991 } def
992
993 /HeaderFramePath {
994 PrintWidth 0 rlineto
995 0 HeaderHeight rlineto
996 PrintWidth neg 0 rlineto
997 0 HeaderHeight neg rlineto
998 } def
999
1000 /HeaderFrame {
1001 gsave
1002 0.4 setlinewidth
1003 HeaderFrameStart moveto
1004 1 -1 rmoveto
1005 HeaderFramePath
1006 0 setgray fill
1007 HeaderFrameStart moveto
1008 HeaderFramePath
1009 gsave 0.9 setgray fill grestore
1010 gsave 0 setgray stroke grestore
1011 grestore
1012 } def
1013
1014 /HeaderStart {
1015 HeaderFrameStart
1016 exch HeaderPad add exch
1017 HeaderLineHeight HeaderLines 1 sub mul add HeaderDescent sub HeaderPad add
1018 } def
1019
1020 /strcat {
1021 dup length 3 -1 roll dup length dup 4 -1 roll add string dup
1022 0 5 -1 roll putinterval
1023 dup 4 2 roll exch putinterval
1024 } def
1025
1026 /pagenumberstring {
1027 PageNumber 32 string cvs
1028 ShowNofN {
1029 (/) strcat
1030 PageCount 32 string cvs strcat
1031 } if
1032 } def
1033
1034 /HeaderText {
1035 HeaderStart moveto
1036
1037 HeaderLinesRight HeaderLinesLeft
1038 Duplex PageNumber 1 and 0 eq and { exch } if
1039
1040 {
1041 aload pop
1042 exch F
1043 gsave
1044 dup xcheck { exec } if
1045 show
1046 grestore
1047 0 HeaderLineHeight neg rmoveto
1048 } forall
1049
1050 HeaderStart moveto
1051
1052 {
1053 aload pop
1054 exch F
1055 gsave
1056 dup xcheck { exec } if
1057 dup stringwidth pop
1058 PrintWidth exch sub HeaderPad 2 mul sub 0 rmoveto
1059 show
1060 grestore
1061 0 HeaderLineHeight neg rmoveto
1062 } forall
1063 } def
1064
1065 /ReportFontInfo {
1066 2 copy
1067 /t0 3 1 roll Font
1068 /t0 F
1069 /lh FontHeight def
1070 /sw ( ) stringwidth pop def
1071 /aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch
1072 stringwidth pop exch div def
1073 /t1 12 /Helvetica-Oblique Font
1074 /t1 F
1075 72 72 moveto
1076 gsave
1077 (For ) show
1078 128 string cvs show
1079 ( ) show
1080 32 string cvs show
1081 ( point, the line height is ) show
1082 lh 32 string cvs show
1083 (, the space width is ) show
1084 sw 32 string cvs show
1085 (,) show
1086 grestore
1087 0 FontHeight neg rmoveto
1088 (and a crude estimate of average character width is ) show
1089 aw 32 string cvs show
1090 (.) show
1091 showpage
1092 } def
1093
1094 % 10 /Courier ReportFontInfo
1095 ")
1096
1097 ;; Start Editing Here:
1098
1099 (defvar ps-source-buffer nil)
1100 (defvar ps-spool-buffer-name "*PostScript*")
1101 (defvar ps-spool-buffer nil)
1102
1103 (defvar ps-output-head nil)
1104 (defvar ps-output-tail nil)
1105
1106 (defvar ps-page-count 0)
1107 (defvar ps-showpage-count 0)
1108
1109 (defvar ps-current-font 0)
1110 (defvar ps-current-underline-p nil)
1111 (defvar ps-default-color (if ps-print-color-p ps-default-fg)) ; black
1112 (defvar ps-current-color ps-default-color)
1113 (defvar ps-current-bg nil)
1114
1115 (defvar ps-razchunk 0)
1116
1117 (defvar ps-color-format (if (eq ps-print-emacs-type 'emacs)
1118
1119 ;;Emacs understands the %f format; we'll
1120 ;;use it to limit color RGB values to
1121 ;;three decimals to cut down some on the
1122 ;;size of the PostScript output.
1123 "%0.3f %0.3f %0.3f"
1124
1125 ;; Lucid emacsen will have to make do with
1126 ;; %s (princ) for floats.
1127 "%s %s %s"))
1128
1129 ;; These values determine how much print-height to deduct when headers
1130 ;; are turned on. This is a pretty clumsy way of handling it, but
1131 ;; it'll do for now.
1132 (defvar ps-header-title-line-height (if (fboundp 'float) 16.0 16));Helvetica 14
1133 (defvar ps-header-line-height (if (fboundp 'float) 13.7 14));Helvetica 12
1134 (defvar ps-header-pad 2)
1135
1136 ;; LetterSmall 7.68 inch 10.16 inch
1137 ;; Tabloid 11.0 inch 17.0 inch
1138 ;; Ledger 17.0 inch 11.0 inch
1139 ;; Statement 5.5 inch 8.5 inch
1140 ;; Executive 7.5 inch 10.0 inch
1141 ;; A3 11.69 inch 16.5 inch
1142 ;; A4Small 7.47 inch 10.85 inch
1143 ;; B4 10.125 inch 14.33 inch
1144 ;; B5 7.16 inch 10.125 inch
1145
1146 ;; All page dimensions are in PostScript points.
1147
1148 (defvar ps-left-margin 72) ; 1 inch
1149 (defvar ps-right-margin 72) ; 1 inch
1150 (defvar ps-bottom-margin 36) ; 1/2 inch
1151 (defvar ps-top-margin 72) ; 1 inch
1152
1153 ;; Letter 8.5 inch x 11.0 inch
1154 (defvar ps-letter-page-height 792) ; 11 inches
1155 (defvar ps-letter-page-width 612) ; 8.5 inches
1156
1157 ;; Legal 8.5 inch x 14.0 inch
1158 (defvar ps-legal-page-height 1008) ; 14.0 inches
1159 (defvar ps-legal-page-width 612) ; 8.5 inches
1160
1161 ;; A4 8.26 inch x 11.69 inch
1162 (defvar ps-a4-page-height 842) ; 11.69 inches
1163 (defvar ps-a4-page-width 595) ; 8.26 inches
1164
1165 (defvar ps-pages-alist
1166 (list (list 'ps-letter ps-letter-page-width ps-letter-page-height)
1167 (list 'ps-legal ps-legal-page-width ps-legal-page-height)
1168 (list 'ps-a4 ps-a4-page-width ps-a4-page-height)))
1169
1170 ;; Define some constants to index into the page lists.
1171 (defvar ps-page-width-i 1)
1172 (defvar ps-page-height-i 2)
1173
1174 (defvar ps-page-dimensions nil)
1175 (defvar ps-print-width nil)
1176 (defvar ps-print-height nil)
1177
1178 (defvar ps-height-remaining)
1179 (defvar ps-width-remaining)
1180
1181 (defvar ps-ref-bold-faces nil)
1182 (defvar ps-ref-italic-faces nil)
1183 (defvar ps-ref-underlined-faces nil)
1184
1185 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1186 ;; Internal functions
1187
1188 (defun ps-get-page-dimensions ()
1189 (setq ps-page-dimensions (assq ps-paper-type ps-pages-alist))
1190 (let ((ps-page-width (nth ps-page-width-i ps-page-dimensions))
1191 (ps-page-height (nth ps-page-height-i ps-page-dimensions)))
1192 (setq ps-print-height (- ps-page-height ps-top-margin ps-bottom-margin))
1193 (setq ps-print-width (- ps-page-width ps-left-margin ps-right-margin))))
1194
1195 (defun ps-print-preprint (&optional filename)
1196 (if (and filename
1197 (or (numberp filename)
1198 (listp filename)))
1199 (let* ((name (concat (buffer-name) ".ps"))
1200 (prompt (format "Save PostScript to file: (default %s) "
1201 name)))
1202 (read-file-name prompt default-directory
1203 name nil))))
1204
1205 ;; The following functions implement a simple list-buffering scheme so
1206 ;; that ps-print doesn't have to repeatedly switch between buffers
1207 ;; while spooling. The functions ps-output and ps-output-string build
1208 ;; up the lists; the function ps-flush-output takes the lists and
1209 ;; insert its contents into the spool buffer (*PostScript*).
1210
1211 (defun ps-output-string-prim (string)
1212 (insert "(") ;insert start-string delimiter
1213 (save-excursion ;insert string
1214 (insert string))
1215
1216 ;; Find and quote special characters as necessary for PS
1217 (while (re-search-forward "[()\\]" nil t)
1218 (save-excursion
1219 (forward-char -1)
1220 (insert "\\")))
1221
1222 (goto-char (point-max))
1223 (insert ")")) ;insert end-string delimiter
1224
1225 (defun ps-init-output-queue ()
1226 (setq ps-output-head (list ""))
1227 (setq ps-output-tail ps-output-head))
1228
1229 (defun ps-output (&rest args)
1230 (setcdr ps-output-tail args)
1231 (while (cdr ps-output-tail)
1232 (setq ps-output-tail (cdr ps-output-tail))))
1233
1234 (defun ps-output-string (string)
1235 (ps-output t string))
1236
1237 (defun ps-flush-output ()
1238 (save-excursion
1239 (set-buffer ps-spool-buffer)
1240 (goto-char (point-max))
1241 (while ps-output-head
1242 (let ((it (car ps-output-head)))
1243 (if (not (eq t it))
1244 (insert it)
1245 (setq ps-output-head (cdr ps-output-head))
1246 (ps-output-string-prim (car ps-output-head))))
1247 (setq ps-output-head (cdr ps-output-head))))
1248 (ps-init-output-queue))
1249
1250 (defun ps-insert-file (fname)
1251 (ps-flush-output)
1252
1253 ;; Check to see that the file exists and is readable; if not, throw
1254 ;; and error.
1255 (if (not (file-readable-p fname))
1256 (error "Could not read file `%s'" fname))
1257
1258 (save-excursion
1259 (set-buffer ps-spool-buffer)
1260 (goto-char (point-max))
1261 (insert-file fname)))
1262
1263 ;; These functions insert the arrays that define the contents of the
1264 ;; headers.
1265
1266 (defun ps-generate-header-line (fonttag &optional content)
1267 (ps-output " [ " fonttag " ")
1268 (cond
1269 ;; Literal strings should be output as is -- the string must
1270 ;; contain its own PS string delimiters, '(' and ')', if necessary.
1271 ((stringp content)
1272 (ps-output content))
1273
1274 ;; Functions are called -- they should return strings; they will be
1275 ;; inserted as strings and the PS string delimiters added.
1276 ((and (symbolp content) (fboundp content))
1277 (ps-output-string (funcall content)))
1278
1279 ;; Variables will have their contents inserted. They should
1280 ;; contain strings, and will be inserted as strings.
1281 ((and (symbolp content) (boundp content))
1282 (ps-output-string (symbol-value content)))
1283
1284 ;; Anything else will get turned into an empty string.
1285 (t
1286 (ps-output-string "")))
1287 (ps-output " ]\n"))
1288
1289 (defun ps-generate-header (name contents)
1290 (ps-output "/" name " [\n")
1291 (if (> ps-header-lines 0)
1292 (let ((count 1))
1293 (ps-generate-header-line "/h0" (car contents))
1294 (while (and (< count ps-header-lines)
1295 (setq contents (cdr contents)))
1296 (ps-generate-header-line "/h1" (car contents))
1297 (setq count (+ count 1)))
1298 (ps-output "] def\n"))))
1299
1300 (defun ps-output-boolean (name bool)
1301 (ps-output (format "/%s %s def\n" name (if bool "true" "false"))))
1302
1303 (defun ps-begin-file ()
1304 (setq ps-showpage-count 0)
1305
1306 (ps-output ps-adobe-tag)
1307 (ps-output "%%Title: " (buffer-name) "\n") ;Take job name from name of
1308 ;first buffer printed
1309 (ps-output "%%Creator: " (user-full-name) "\n")
1310 (ps-output "%%CreationDate: "
1311 (time-stamp-hh:mm:ss) " " (time-stamp-mon-dd-yyyy) "\n")
1312 (ps-output "%% DocumentFonts: Helvetica Helvetica-Bold "
1313 ps-font " " ps-font-bold " " ps-font-italic " "
1314 ps-font-bold-italic "\n")
1315 (ps-output "%%Pages: (atend)\n")
1316 (ps-output "%%EndComments\n\n")
1317
1318 (ps-output-boolean "Duplex" ps-spool-duplex)
1319 (ps-output-boolean "PrintHeader" ps-print-header)
1320 (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame)
1321 (ps-output-boolean "ShowNofN" ps-show-n-of-n)
1322
1323 (ps-output (format "/LeftMargin %d def\n" ps-left-margin))
1324 (ps-output (format "/RightMargin %d def\n" ps-right-margin))
1325 (ps-output (format "/BottomMargin %d def\n" ps-bottom-margin))
1326 (ps-output (format "/TopMargin %d def\n" ps-top-margin))
1327
1328 (ps-get-page-dimensions)
1329 (ps-output (format "/PrintWidth %d def\n" ps-print-width))
1330 (ps-output (format "/PrintHeight %d def\n" ps-print-height))
1331
1332 (ps-output (format "/LineHeight %s def\n" ps-line-height))
1333
1334 (ps-output ps-print-prologue)
1335
1336 (ps-output (format "/f0 %d /%s Font\n" ps-font-size ps-font))
1337 (ps-output (format "/f1 %d /%s Font\n" ps-font-size ps-font-bold))
1338 (ps-output (format "/f2 %d /%s Font\n" ps-font-size ps-font-italic))
1339 (ps-output (format "/f3 %d /%s Font\n" ps-font-size
1340 ps-font-bold-italic))
1341
1342 (ps-output "%%EndPrologue\n"))
1343
1344 (defun ps-header-dirpart ()
1345 (let ((fname (buffer-file-name)))
1346 (if fname
1347 (if (string-equal (buffer-name) (file-name-nondirectory fname))
1348 (file-name-directory fname)
1349 fname)
1350 "")))
1351
1352 (defun ps-get-buffer-name ()
1353 ;; Indulge me this little easter egg:
1354 (if (string= (buffer-name) "ps-print.el")
1355 "Hey, Cool! It's ps-print.el!!!"
1356 (buffer-name)))
1357
1358 (defun ps-begin-job ()
1359 (setq ps-page-count 0))
1360
1361 (defun ps-end-file ()
1362 (ps-output "%%Trailer\n")
1363 (ps-output "%%Pages: " (format "%d\n" ps-showpage-count)))
1364
1365 (defun ps-next-page ()
1366 (ps-end-page)
1367 (ps-flush-output)
1368 (ps-begin-page))
1369
1370 (defun ps-begin-page (&optional dummypage)
1371 (ps-get-page-dimensions)
1372 (setq ps-width-remaining ps-print-width)
1373 (setq ps-height-remaining ps-print-height)
1374
1375 ;; If headers are turned on, deduct the height of the header from
1376 ;; the print height remaining. Clumsy clumsy clumsy.
1377 (if ps-print-header
1378 (setq ps-height-remaining
1379 (- ps-height-remaining
1380 ps-header-title-line-height
1381 (* ps-header-line-height (- ps-header-lines 1))
1382 (* 2 ps-header-pad))))
1383
1384 (setq ps-page-count (+ ps-page-count 1))
1385
1386 (ps-output "\n%%Page: "
1387 (format "%d %d\n" ps-page-count (+ 1 ps-showpage-count)))
1388 (ps-output "BeginDSCPage\n")
1389 (ps-output (format "/PageNumber %d def\n" ps-page-count))
1390 (ps-output "/PageCount 0 def\n")
1391
1392 (if ps-print-header
1393 (progn
1394 (ps-generate-header "HeaderLinesLeft" ps-left-header)
1395 (ps-generate-header "HeaderLinesRight" ps-right-header)
1396 (ps-output (format "%d SetHeaderLines\n" ps-header-lines))))
1397
1398 (ps-output "BeginPage\n")
1399 (ps-set-font ps-current-font)
1400 (ps-set-bg ps-current-bg)
1401 (ps-set-color ps-current-color)
1402 (ps-set-underline ps-current-underline-p))
1403
1404 (defun ps-end-page ()
1405 (setq ps-showpage-count (+ 1 ps-showpage-count))
1406 (ps-output "EndPage\n")
1407 (ps-output "EndDSCPage\n"))
1408
1409 (defun ps-dummy-page ()
1410 (setq ps-showpage-count (+ 1 ps-showpage-count))
1411 (ps-output "%%Page: " (format "- %d\n" ps-showpage-count)
1412 "BeginDSCPage
1413 /PrintHeader false def
1414 BeginPage
1415 EndPage
1416 EndDSCPage\n"))
1417
1418 (defun ps-next-line ()
1419 (if (< ps-height-remaining ps-line-height)
1420 (ps-next-page)
1421 (setq ps-width-remaining ps-print-width)
1422 (setq ps-height-remaining (- ps-height-remaining ps-line-height))
1423 (ps-hard-lf)))
1424
1425 (defun ps-continue-line ()
1426 (if (< ps-height-remaining ps-line-height)
1427 (ps-next-page)
1428 (setq ps-width-remaining ps-print-width)
1429 (setq ps-height-remaining (- ps-height-remaining ps-line-height))
1430 (ps-soft-lf)))
1431
1432 (defun ps-hard-lf ()
1433 (ps-output "HL\n"))
1434
1435 (defun ps-soft-lf ()
1436 (ps-output "SL\n"))
1437
1438 (defun ps-find-wrappoint (from to char-width)
1439 (let ((avail (truncate (/ ps-width-remaining char-width)))
1440 (todo (- to from)))
1441 (if (< todo avail)
1442 (cons to (* todo char-width))
1443 (cons (+ from avail) ps-width-remaining))))
1444
1445 (defun ps-basic-plot-string (from to &optional bg-color)
1446 (let* ((wrappoint (ps-find-wrappoint from to ps-avg-char-width))
1447 (to (car wrappoint))
1448 (string (buffer-substring from to)))
1449 (ps-output-string string)
1450 (ps-output " S\n") ;
1451 wrappoint))
1452
1453 (defun ps-basic-plot-whitespace (from to &optional bg-color)
1454 (let* ((wrappoint (ps-find-wrappoint from to ps-space-width))
1455 (to (car wrappoint)))
1456
1457 (ps-output (format "%d W\n" (- to from)))
1458 wrappoint))
1459
1460 (defun ps-plot (plotfunc from to &optional bg-color)
1461 (while (< from to)
1462 (let* ((wrappoint (funcall plotfunc from to bg-color))
1463 (plotted-to (car wrappoint))
1464 (plotted-width (cdr wrappoint)))
1465 (setq from plotted-to)
1466 (setq ps-width-remaining (- ps-width-remaining plotted-width))
1467 (if (< from to)
1468 (ps-continue-line))))
1469 (if ps-razzle-dazzle
1470 (let* ((q-todo (- (point-max) (point-min)))
1471 (q-done (- (point) (point-min)))
1472 (chunkfrac (/ q-todo 8))
1473 (chunksize (if (> chunkfrac 1000) 1000 chunkfrac)))
1474 (if (> (- q-done ps-razchunk) chunksize)
1475 (let (foo)
1476 (setq ps-razchunk q-done)
1477 (setq foo
1478 (if (< q-todo 100)
1479 (/ (* 100 q-done) q-todo)
1480 (/ q-done (/ q-todo 100))))
1481 (message "Formatting...%d%%" foo))))))
1482
1483 (defun ps-set-font (font)
1484 (setq ps-current-font font)
1485 (ps-output (format "/f%d F\n" ps-current-font)))
1486
1487 (defvar ps-print-color-scale nil)
1488
1489 (defun ps-set-bg (color)
1490 (if (setq ps-current-bg color)
1491 (ps-output (format ps-color-format (nth 0 color) (nth 1 color)
1492 (nth 2 color))
1493 " true BG\n")
1494 (ps-output "false BG\n")))
1495
1496 (defun ps-set-color (color)
1497 (if (setq ps-current-color color)
1498 nil
1499 (setq ps-current-color ps-default-fg))
1500 (ps-output (format ps-color-format (nth 0 ps-current-color)
1501 (nth 1 ps-current-color) (nth 2 ps-current-color))
1502 " FG\n"))
1503
1504 (defun ps-set-underline (underline-p)
1505 (ps-output (if underline-p "true" "false") " UL\n")
1506 (setq ps-current-underline-p underline-p))
1507
1508 (defun ps-plot-region (from to font fg-color &optional bg-color underline-p)
1509
1510 (if (not (equal font ps-current-font))
1511 (ps-set-font font))
1512
1513 ;; Specify a foreground color only if one's specified and it's
1514 ;; different than the current.
1515 (if (not (equal fg-color ps-current-color))
1516 (ps-set-color fg-color))
1517
1518 (if (not (equal bg-color ps-current-bg))
1519 (ps-set-bg bg-color))
1520
1521 ;; Toggle underlining if different.
1522 (if (not (equal underline-p ps-current-underline-p))
1523 (ps-set-underline underline-p))
1524
1525 ;; Starting at the beginning of the specified region...
1526 (save-excursion
1527 (goto-char from)
1528
1529 ;; ...break the region up into chunks separated by tabs, linefeeds,
1530 ;; and pagefeeds, and plot each chunk.
1531 (while (< from to)
1532 (if (re-search-forward "[\t\n\f]" to t)
1533 (let ((match (char-after (match-beginning 0))))
1534 (cond
1535 ((= match ?\t)
1536 (let ((linestart
1537 (save-excursion (beginning-of-line) (point))))
1538 (ps-plot 'ps-basic-plot-string from (- (point) 1)
1539 bg-color)
1540 (forward-char -1)
1541 (setq from (+ linestart (current-column)))
1542 (if (re-search-forward "[ \t]+" to t)
1543 (ps-plot 'ps-basic-plot-whitespace
1544 from (+ linestart (current-column))
1545 bg-color))))
1546
1547 ((= match ?\n)
1548 (ps-plot 'ps-basic-plot-string from (- (point) 1)
1549 bg-color)
1550 (ps-next-line)
1551 )
1552
1553 ((= match ?\f)
1554 (ps-plot 'ps-basic-plot-string from (- (point) 1)
1555 bg-color)
1556 (ps-next-page)))
1557 (setq from (point)))
1558 (ps-plot 'ps-basic-plot-string from to bg-color)
1559 (setq from to)))))
1560
1561 (defun ps-color-value (x-color-value)
1562 ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
1563 (/ x-color-value ps-print-color-scale))
1564
1565 (defun ps-color-values (x-color)
1566 (cond ((fboundp 'x-color-values)
1567 (x-color-values x-color))
1568 ((and (fboundp 'color-instance-rgb-components)
1569 (xemacs-color-device))
1570 (color-instance-rgb-components
1571 (if (color-instance-p x-color) x-color
1572 (if (color-specifier-p x-color)
1573 (make-color-instance (color-name x-color))
1574 (make-color-instance x-color)))))
1575 (t (error "No available function to determine X color values."))))
1576
1577 (defun ps-face-attributes (face)
1578 (let ((differs (face-differs-from-default-p face)))
1579 (list (memq face ps-ref-bold-faces)
1580 (memq face ps-ref-italic-faces)
1581 (memq face ps-ref-underlined-faces)
1582 (and differs (face-foreground face))
1583 (and differs (face-background face)))))
1584
1585 (defun ps-face-attribute-list (face-or-list)
1586 (if (listp face-or-list)
1587 (let (bold-p italic-p underline-p foreground background face-attr face)
1588 (while face-or-list
1589 (setq face (car face-or-list))
1590 (setq face-attr (ps-face-attributes face))
1591 (setq bold-p (or bold-p (nth 0 face-attr)))
1592 (setq italic-p (or italic-p (nth 1 face-attr)))
1593 (setq underline-p (or underline-p (nth 2 face-attr)))
1594 (if foreground
1595 nil
1596 (setq foreground (nth 3 face-attr)))
1597 (if background
1598 nil
1599 (setq background (nth 4 face-attr)))
1600 (setq face-or-list (cdr face-or-list)))
1601 (list bold-p italic-p underline-p foreground background))
1602
1603 (ps-face-attributes face-or-list)))
1604
1605 (defun ps-plot-with-face (from to face)
1606 (if face
1607 (let* ((face-attr (ps-face-attribute-list face))
1608 (bold-p (nth 0 face-attr))
1609 (italic-p (nth 1 face-attr))
1610 (underline-p (nth 2 face-attr))
1611 (foreground (nth 3 face-attr))
1612 (background (nth 4 face-attr))
1613 (fg-color (if (and ps-print-color-p
1614 (xemacs-color-device)
1615 foreground)
1616 (mapcar 'ps-color-value
1617 (ps-color-values foreground))
1618 ps-default-color))
1619 (bg-color (if (and ps-print-color-p
1620 (xemacs-color-device)
1621 background)
1622 (mapcar 'ps-color-value
1623 (ps-color-values background)))))
1624 (ps-plot-region from to
1625 (cond ((and bold-p italic-p) 3)
1626 (italic-p 2)
1627 (bold-p 1)
1628 (t 0))
1629 ; (or fg-color '(0.0 0.0 0.0))
1630 fg-color
1631 bg-color underline-p))
1632 (goto-char to)))
1633
1634
1635 (defun ps-emacs-face-kind-p (face kind kind-regex kind-list)
1636 (let ((frame-font (face-font face))
1637 (face-defaults (face-font face t)))
1638 (or
1639 ;; Check FACE defaults:
1640 (and (listp face-defaults)
1641 (memq kind face-defaults))
1642
1643 ;; Check the user's preferences
1644 (memq face kind-list))))
1645
1646 (defun ps-xemacs-face-kind-p (face kind kind-regex kind-list)
1647 (let* ((frame-font
1648 (or (face-font-instance face) (face-font-instance 'default)))
1649 (kind-cons (and frame-font
1650 (assq kind (font-instance-properties frame-font))))
1651 (kind-spec (cdr-safe kind-cons))
1652 (case-fold-search t))
1653
1654 (or (and kind-spec (string-match kind-regex kind-spec))
1655 ;; Kludge-compatible:
1656 (memq face kind-list))))
1657
1658 (defun ps-face-bold-p (face)
1659 (if (eq ps-print-emacs-type 'emacs)
1660 (ps-emacs-face-kind-p face 'bold "-\\(bold\\|demibold\\)-"
1661 ps-bold-faces)
1662 (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold"
1663 ps-bold-faces)))
1664
1665 (defun ps-face-italic-p (face)
1666 (if (eq ps-print-emacs-type 'emacs)
1667 (ps-emacs-face-kind-p face 'italic "-[io]-" ps-italic-faces)
1668 (or
1669 (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o" ps-italic-faces)
1670 (ps-xemacs-face-kind-p face 'SLANT "i\\|o" ps-italic-faces))))
1671
1672 (defun ps-face-underlined-p (face)
1673 (or (face-underline-p face)
1674 (memq face ps-underlined-faces)))
1675
1676 ;; Ensure that face-list is fbound.
1677 (or (fboundp 'face-list) (defalias 'face-list 'list-faces))
1678
1679 (defun ps-build-reference-face-lists ()
1680 (if ps-auto-font-detect
1681 (let ((faces (face-list))
1682 the-face)
1683 (setq ps-ref-bold-faces nil
1684 ps-ref-italic-faces nil
1685 ps-ref-underlined-faces nil)
1686 (while faces
1687 (setq the-face (car faces))
1688 (if (ps-face-italic-p the-face)
1689 (setq ps-ref-italic-faces
1690 (cons the-face ps-ref-italic-faces)))
1691 (if (ps-face-bold-p the-face)
1692 (setq ps-ref-bold-faces
1693 (cons the-face ps-ref-bold-faces)))
1694 (if (ps-face-underlined-p the-face)
1695 (setq ps-ref-underlined-faces
1696 (cons the-face ps-ref-underlined-faces)))
1697 (setq faces (cdr faces))))
1698 (setq ps-ref-bold-faces ps-bold-faces)
1699 (setq ps-ref-italic-faces ps-italic-faces)
1700 (setq ps-ref-underlined-faces ps-underlined-faces))
1701 (setq ps-build-face-reference nil))
1702
1703 (defun ps-mapper (extent list)
1704 (nconc list (list (list (extent-start-position extent) 'push extent)
1705 (list (extent-end-position extent) 'pull extent)))
1706 nil)
1707
1708 (defun ps-sorter (a b)
1709 (< (car a) (car b)))
1710
1711 (defun ps-extent-sorter (a b)
1712 (< (extent-priority a) (extent-priority b)))
1713
1714 (defun ps-print-ensure-fontified (start end)
1715 (if (and (boundp 'lazy-lock-mode) lazy-lock-mode)
1716 (if (fboundp 'lazy-lock-fontify-region)
1717 (lazy-lock-fontify-region start end)
1718 (lazy-lock-fontify-buffer))))
1719
1720 (defun ps-generate-postscript-with-faces (from to)
1721 ;; Build the reference lists of faces if necessary.
1722 (if (or ps-always-build-face-reference
1723 ps-build-face-reference)
1724 (progn
1725 (message "Collecting face information...")
1726 (ps-build-reference-face-lists)))
1727 ;; Set the color scale. We do it here instead of in the defvar so
1728 ;; that ps-print can be dumped into emacs. This expression can't be
1729 ;; evaluated at dump-time because X isn't initialized.
1730 (setq ps-print-color-scale
1731 (if (and ps-print-color-p (xemacs-color-device))
1732 (float (car (ps-color-values "white")))
1733 1.0))
1734 ;; Generate some PostScript.
1735 (save-restriction
1736 (narrow-to-region from to)
1737 (let ((face 'default)
1738 (position to))
1739 (ps-print-ensure-fontified from to)
1740 (cond ((or (eq ps-print-emacs-type 'lucid) (eq ps-print-emacs-type 'xemacs))
1741 ;; Build the list of extents...
1742 (let ((a (cons 'dummy nil))
1743 record type extent extent-list)
1744 (map-extents 'ps-mapper nil from to a)
1745 (setq a (cdr a))
1746 (setq a (sort a 'ps-sorter))
1747
1748 (setq extent-list nil)
1749
1750 ;; Loop through the extents...
1751 (while a
1752 (setq record (car a))
1753
1754 (setq position (car record))
1755 (setq record (cdr record))
1756
1757 (setq type (car record))
1758 (setq record (cdr record))
1759
1760 (setq extent (car record))
1761
1762 ;; Plot up to this record.
1763 ;; XEmacs 19.12: for some reason, we're getting into a
1764 ;; situation in which some of the records have
1765 ;; positions less than 'from'. Since we've narrowed
1766 ;; the buffer, this'll generate errors. This is a
1767 ;; hack, but don't call ps-plot-with-face unless from >
1768 ;; point-min.
1769 (if (and (>= from (point-min))
1770 (<= position (point-max)))
1771 (ps-plot-with-face from position face))
1772
1773 (cond
1774 ((eq type 'push)
1775 (if (extent-face extent)
1776 (setq extent-list (sort (cons extent extent-list)
1777 'ps-extent-sorter))))
1778
1779 ((eq type 'pull)
1780 (setq extent-list (sort (delq extent extent-list)
1781 'ps-extent-sorter))))
1782
1783 (setq face
1784 (if extent-list
1785 (extent-face (car extent-list))
1786 'default))
1787
1788 (setq from position)
1789 (setq a (cdr a)))))
1790
1791 ((eq ps-print-emacs-type 'emacs)
1792 (let ((property-change from)
1793 (overlay-change from))
1794 (while (< from to)
1795 (if (< property-change to) ; Don't search for property change
1796 ; unless previous search succeeded.
1797 (setq property-change
1798 (next-property-change from nil to)))
1799 (if (< overlay-change to) ; Don't search for overlay change
1800 ; unless previous search succeeded.
1801 (setq overlay-change
1802 (min (next-overlay-change from) to)))
1803 (setq position
1804 (min property-change overlay-change))
1805 (setq face
1806 (cond ((get-text-property from 'invisible) nil)
1807 ((get-text-property from 'face))
1808 (t 'default)))
1809 (let ((overlays (overlays-at from))
1810 (face-priority -1)) ; text-property
1811 (while overlays
1812 (let* ((overlay (car overlays))
1813 (overlay-face (overlay-get overlay 'face))
1814 (overlay-invisible (overlay-get overlay 'invisible))
1815 (overlay-priority (or (overlay-get overlay
1816 'priority)
1817 0)))
1818 (if (and (or overlay-invisible overlay-face)
1819 (> overlay-priority face-priority))
1820 (setq face (cond (overlay-invisible nil)
1821 ((and face overlay-face)))
1822 face-priority overlay-priority)))
1823 (setq overlays (cdr overlays))))
1824 ;; Plot up to this record.
1825 (ps-plot-with-face from position face)
1826 (setq from position)))))
1827 (ps-plot-with-face from to face))))
1828
1829 (defun ps-generate-postscript (from to)
1830 (ps-plot-region from to 0 nil))
1831
1832 (defun ps-generate (buffer from to genfunc)
1833 (let ((from (min to from))
1834 (to (max to from)))
1835 (save-restriction
1836 (narrow-to-region from to)
1837 (if ps-razzle-dazzle
1838 (message "Formatting...%d%%" (setq ps-razchunk 0)))
1839 (set-buffer buffer)
1840 (setq ps-source-buffer buffer)
1841 (setq ps-spool-buffer (get-buffer-create ps-spool-buffer-name))
1842 (ps-init-output-queue)
1843 (let (safe-marker completed-safely needs-begin-file)
1844 (unwind-protect
1845 (progn
1846 (set-buffer ps-spool-buffer)
1847
1848 ;; Get a marker and make it point to the current end of the
1849 ;; buffer, If an error occurs, we'll delete everything from
1850 ;; the end of this marker onwards.
1851 (setq safe-marker (make-marker))
1852 (set-marker safe-marker (point-max))
1853
1854 (goto-char (point-min))
1855 (if (looking-at (regexp-quote "%!PS-Adobe-1.0"))
1856 nil
1857 (setq needs-begin-file t))
1858 (save-excursion
1859 (set-buffer ps-source-buffer)
1860 (if needs-begin-file (ps-begin-file))
1861 (ps-begin-job)
1862 (ps-begin-page))
1863 (set-buffer ps-source-buffer)
1864 (funcall genfunc from to)
1865 (ps-end-page)
1866
1867 (if (and ps-spool-duplex
1868 (= (mod ps-page-count 2) 1))
1869 (ps-dummy-page))
1870 (ps-flush-output)
1871
1872 ;; Back to the PS output buffer to set the page count
1873 (set-buffer ps-spool-buffer)
1874 (goto-char (point-max))
1875 (while (re-search-backward "^/PageCount 0 def$" nil t)
1876 (replace-match (format "/PageCount %d def" ps-page-count) t))
1877
1878 ;; Setting this variable tells the unwind form that the
1879 ;; the postscript was generated without error.
1880 (setq completed-safely t))
1881
1882 ;; Unwind form: If some bad mojo ocurred while generating
1883 ;; postscript, delete all the postscript that was generated.
1884 ;; This protects the previously spooled files from getting
1885 ;; corrupted.
1886 (if (and (markerp safe-marker) (not completed-safely))
1887 (progn
1888 (set-buffer ps-spool-buffer)
1889 (delete-region (marker-position safe-marker) (point-max))))))
1890
1891 (if ps-razzle-dazzle
1892 (message "Formatting...done")))))
1893
1894 (defun ps-do-despool (filename)
1895 (if (or (not (boundp 'ps-spool-buffer))
1896 (not ps-spool-buffer))
1897 (message "No spooled PostScript to print")
1898 (ps-end-file)
1899 (ps-flush-output)
1900 (if filename
1901 (save-excursion
1902 (if ps-razzle-dazzle
1903 (message "Saving..."))
1904 (set-buffer ps-spool-buffer)
1905 (setq filename (expand-file-name filename))
1906 (write-region (point-min) (point-max) filename)
1907 (if ps-razzle-dazzle
1908 (message "Wrote %s" filename)))
1909 ;; Else, spool to the printer
1910 (if ps-razzle-dazzle
1911 (message "Printing..."))
1912 (save-excursion
1913 (set-buffer ps-spool-buffer)
1914 (apply 'call-process-region
1915 (point-min) (point-max) ps-lpr-command nil 0 nil
1916 ps-lpr-switches))
1917 (if ps-razzle-dazzle
1918 (message "Printing...done")))
1919 (kill-buffer ps-spool-buffer)))
1920
1921 (defun ps-kill-emacs-check ()
1922 (let (ps-buffer)
1923 (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
1924 (buffer-modified-p ps-buffer))
1925 (if (y-or-n-p "Unprinted PostScript waiting; print now? ")
1926 (ps-despool)))
1927 (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
1928 (buffer-modified-p ps-buffer))
1929 (if (yes-or-no-p "Unprinted PostScript waiting; exit anyway? ")
1930 nil
1931 (error "Unprinted PostScript")))))
1932
1933 (if (fboundp 'add-hook)
1934 (add-hook 'kill-emacs-hook 'ps-kill-emacs-check)
1935 (if kill-emacs-hook
1936 (message "Won't override existing kill-emacs-hook")
1937 (setq kill-emacs-hook 'ps-kill-emacs-check)))
1938
1939 ;;; Sample Setup Code:
1940
1941 ;; This stuff is for anybody that's brave enough to look this far,
1942 ;; and able to figure out how to use it. It isn't really part of ps-
1943 ;; print, but I'll leave it here in hopes it might be useful:
1944
1945 ;; WARNING!!! The following code is *sample* code only. Don't use it
1946 ;; unless you understand what it does!
1947
1948 (defmacro ps-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs)
1949 [f22] ''f22))
1950 (defmacro ps-c-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs)
1951 [C-f22]
1952 ''(control f22)))
1953 (defmacro ps-s-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs)
1954 [S-f22]
1955 ''(shift f22)))
1956
1957 ;; Look in an article or mail message for the Subject: line. To be
1958 ;; placed in ps-left-headers.
1959 (defun ps-article-subject ()
1960 (save-excursion
1961 (goto-char (point-min))
1962 (if (re-search-forward "^Subject:[ \t]+\\(.*\\)$")
1963 (buffer-substring (match-beginning 1) (match-end 1))
1964 "Subject ???")))
1965
1966 ;; Look in an article or mail message for the From: line. Sorta-kinda
1967 ;; understands RFC-822 addresses and can pull the real name out where
1968 ;; it's provided. To be placed in ps-left-headers.
1969 (defun ps-article-author ()
1970 (save-excursion
1971 (goto-char (point-min))
1972 (if (re-search-forward "^From:[ \t]+\\(.*\\)$")
1973 (let ((fromstring (buffer-substring (match-beginning 1) (match-end 1))))
1974 (cond
1975
1976 ;; Try first to match addresses that look like
1977 ;; thompson@wg2.waii.com (Jim Thompson)
1978 ((string-match ".*[ \t]+(\\(.*\\))" fromstring)
1979 (substring fromstring (match-beginning 1) (match-end 1)))
1980
1981 ;; Next try to match addresses that look like
1982 ;; Jim Thompson <thompson@wg2.waii.com>
1983 ((string-match "\\(.*\\)[ \t]+<.*>" fromstring)
1984 (substring fromstring (match-beginning 1) (match-end 1)))
1985
1986 ;; Couldn't find a real name -- show the address instead.
1987 (t fromstring)))
1988 "From ???")))
1989
1990 ;; A hook to bind to gnus-Article-prepare-hook. This will set the ps-
1991 ;; left-headers specially for gnus articles. Unfortunately, gnus-
1992 ;; article-mode-hook is called only once, the first time the *Article*
1993 ;; buffer enters that mode, so it would only work for the first time
1994 ;; we ran gnus. The second time, this hook wouldn't get set up. The
1995 ;; only alternative is gnus-article-prepare-hook.
1996 (defun ps-gnus-article-prepare-hook ()
1997 (setq ps-header-lines 3)
1998 (setq ps-left-header
1999 ;; The left headers will display the article's subject, its
2000 ;; author, and the newsgroup it was in.
2001 (list 'ps-article-subject 'ps-article-author 'gnus-newsgroup-name)))
2002
2003 ;; A hook to bind to vm-mode-hook to locally bind prsc and set the ps-
2004 ;; left-headers specially for mail messages. This header setup would
2005 ;; also work, I think, for RMAIL.
2006 (defun ps-vm-mode-hook ()
2007 (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary)
2008 (setq ps-header-lines 3)
2009 (setq ps-left-header
2010 ;; The left headers will display the message's subject, its
2011 ;; author, and the name of the folder it was in.
2012 (list 'ps-article-subject 'ps-article-author 'buffer-name)))
2013
2014 ;; Every now and then I forget to switch from the *Summary* buffer to
2015 ;; the *Article* before hitting prsc, and a nicely formatted list of
2016 ;; article subjects shows up at the printer. This function, bound to
2017 ;; prsc for the gnus *Summary* buffer means I don't have to switch
2018 ;; buffers first.
2019 (defun ps-gnus-print-article-from-summary ()
2020 (interactive)
2021 (if (get-buffer "*Article*")
2022 (save-excursion
2023 (set-buffer "*Article*")
2024 (ps-spool-buffer-with-faces))))
2025
2026 ;; See ps-gnus-print-article-from-summary. This function does the
2027 ;; same thing for vm.
2028 (defun ps-vm-print-message-from-summary ()
2029 (interactive)
2030 (if vm-mail-buffer
2031 (save-excursion
2032 (set-buffer vm-mail-buffer)
2033 (ps-spool-buffer-with-faces))))
2034
2035 ;; A hook to bind to bind to gnus-summary-setup-buffer to locally bind
2036 ;; prsc.
2037 (defun ps-gnus-summary-setup ()
2038 (local-set-key (ps-prsc) 'ps-gnus-print-article-from-summary))
2039
2040 ;; Look in an article or mail message for the Subject: line. To be
2041 ;; placed in ps-left-headers.
2042 (defun ps-info-file ()
2043 (save-excursion
2044 (goto-char (point-min))
2045 (if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)")
2046 (buffer-substring (match-beginning 1) (match-end 1))
2047 "File ???")))
2048
2049 ;; Look in an article or mail message for the Subject: line. To be
2050 ;; placed in ps-left-headers.
2051 (defun ps-info-node ()
2052 (save-excursion
2053 (goto-char (point-min))
2054 (if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)")
2055 (buffer-substring (match-beginning 1) (match-end 1))
2056 "Node ???")))
2057
2058 (defun ps-info-mode-hook ()
2059 (setq ps-left-header
2060 ;; The left headers will display the node name and file name.
2061 (list 'ps-info-node 'ps-info-file)))
2062
2063 ;; WARNING! The following function is a *sample* only, and is *not*
2064 ;; meant to be used as a whole unless you understand what the effects
2065 ;; will be! (In fact, this is a copy if my setup for ps-print -- I'd
2066 ;; be very surprised if it was useful to *anybody*, without
2067 ;; modification.)
2068
2069 (defun ps-jts-ps-setup ()
2070 (global-set-key (ps-prsc) 'ps-spool-buffer-with-faces) ;f22 is prsc
2071 (global-set-key (ps-s-prsc) 'ps-spool-region-with-faces)
2072 (global-set-key (ps-c-prsc) 'ps-despool)
2073 (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook)
2074 (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup)
2075 (add-hook 'vm-mode-hook 'ps-vm-mode-hook)
2076 (add-hook 'vm-mode-hooks 'ps-vm-mode-hook)
2077 (add-hook 'Info-mode-hook 'ps-info-mode-hook)
2078 (setq ps-spool-duplex t)
2079 (setq ps-print-color-p nil)
2080 (setq ps-lpr-command "lpr")
2081 (setq ps-lpr-switches '("-Jjct,duplex_long")))
2082
2083 (provide 'ps-print)
2084
2085 ;;; ps-print.el ends here