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