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