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