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