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