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