comparison lisp/ps-print.el @ 7257:3759ad84023b

Initial revision
author Richard M. Stallman <rms@gnu.org>
date Sun, 01 May 1994 22:09:01 +0000
parents
children a0f38717d82d
comparison
equal deleted inserted replaced
7256:0f06f87f3c3b 7257:3759ad84023b
1 ;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print).
2 ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
3
4 ;; Author: James C. Thompson <thompson@wg2.waii.com>
5 ;; Keywords: faces, postscript, printing
6
7 ;; This file is part of GNU Emacs.
8
9 ;; 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
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
22
23 ;; Acknowledgements
24 ;; ----------------
25 ;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing
26 ;; the Emacs 19 port.
27 ;;
28 ;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org,
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
39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
40 ;;
41 ;; About ps-print:
42 ;; --------------
43 ;; This package provides printing of Emacs buffers on PostScript
44 ;; printers; the buffer's bold and italic text attributes are
45 ;; preserved in the printer output. Ps-print is intended for use with
46 ;; Emacs 19 (Lucid or FSF) and a fontifying package such as font-lock
47 ;; or hilit.
48 ;;
49 ;; Installing ps-print:
50 ;; -------------------
51 ;; Place ps-print somewhere in your load-path and byte-compile it.
52 ;; Load ps-print with (require 'ps-print).
53 ;;
54 ;; Using ps-print:
55 ;; --------------
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 ;;
63 ;; (setq ps-bold-faces (cons 'my-bold-face ps-bold-faces))
64 ;;
65 ;; Ps-print's printer interface is governed by the variables ps-lpr-
66 ;; command and ps-lpr-switches; these are analogous to the variables
67 ;; lpr-command and lpr-switches in the Emacs lpr package.
68 ;;
69 ;; To use ps-print, invoke the command ps-print-buffer-with-faces.
70 ;; This will generate a PostScript image of the current buffer and
71 ;; send it to the printer. Precede this command with a numeric prefix
72 ;; (C-u), and the PostScript output will be saved in a file; you will
73 ;; be prompted for a filename. Also see the functions ps-print-
74 ;; buffer, ps-print-region, and ps-print-region-with-faces.
75 ;;
76 ;; I recommend binding ps-print-buffer-with-faces to a key sequence;
77 ;; on a Sun 4 keyboard, for example, you can bind to the PrSc key (aka
78 ;; r22):
79 ;;
80 ;; (global-set-key 'f22 'ps-print-buffer-with-faces)
81 ;; (global-set-key '(shift f22) 'ps-print-region-with-faces)
82 ;;
83 ;; Or, as I now prefer, you can also bind the ps-spool- functions to
84 ;; keys; here's my bindings:
85 ;;
86 ;; (global-set-key 'f22 'ps-spool-buffer-with-faces)
87 ;; (global-set-key '(shift f22) 'ps-spool-region-with-faces)
88 ;; (global-set-key '(control f22) 'ps-despool)
89 ;;
90 ;; Using ps-print with other Emacses:
91 ;; ---------------------------------
92 ;; Although it was intended for use with Emacs 19, ps-print will also work
93 ;; with Emacs version 18; you won't get fancy fontified output, but it
94 ;; should work.
95 ;;
96 ;; A few words about support:
97 ;; -------------------------
98 ;; Despite its appearance, with comment blocks, usage instructions, and
99 ;; documentation strings, ps-print is not a supported package. That's all
100 ;; a masquerade. Ps-print is something I threw together in my spare time--
101 ;; an evening here, a Saturday there--to make my printouts look like my
102 ;; Emacs buffers. It works, but is not complete.
103 ;;
104 ;; Unfortunately, supporting elisp code is not my job and, now that I have
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 ;; ------------------
126 ;; Support for Emacs 19. Works with both overlays and text
127 ;; properties.
128 ;;
129 ;; Underlining.
130 ;;
131 ;; Local spooling; see function ps-spool-buffer.
132 ;;
133 ;; Support for ISO8859-1 character set.
134 ;;
135 ;; Page breaks are now handled correctly.
136 ;;
137 ;; Percentages reported while formatting are now correct.
138 ;;
139 ;; Known bugs and limitations of ps-print:
140 ;; --------------------------------------
141 ;; Slow. (Byte-compiling helps.)
142 ;;
143 ;; The PostScript needs review/cleanup/enhancing by a PS expert.
144 ;;
145 ;; ASCII Control characters other than tab, linefeed and pagefeed are
146 ;; not handled.
147 ;;
148 ;; The mechanism for determining whether a stretch of characters
149 ;; should be printed bold, italic, or plain is crude and extremely
150 ;; limited.
151 ;;
152 ;; Faces are always treated as opaque.
153 ;;
154 ;; Font names are hardcoded.
155 ;;
156 ;; Epoch not fully supported.
157 ;;
158 ;; Tested with only one PostScript printer.
159 ;;
160 ;; Features to add:
161 ;; ---------------
162 ;; Line numbers.
163 ;;
164 ;; Simple headers with date, filename, and page numbers.
165 ;;
166 ;; Gaudy headers a`la enscript and mp.
167 ;;
168 ;; 2-up and 4-up capability.
169 ;;
170 ;; Wide-print capability.
171 ;;
172
173 ;;; Code:
174
175 (defconst ps-print-version (substring "$Revision: 1.5 $" 11 -2)
176 "$Id: ps-print.el,v 1.5 1994/04/22 13:25:18 jct Exp $
177
178 Please send all bug fixes and enhancements to Jim Thompson,
179 thompson@wg2.waii.com.")
180
181 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
182 (defvar ps-lpr-command (if (memq system-type
183 '(usg-unix-v hpux silicon-graphics-unix))
184 "lp" "lpr")
185 "The shell command for printing a PostScript file.")
186
187 (defvar ps-lpr-switches nil
188 "A list of extra switches to pass to ps-lpr-command.")
189
190 (defvar ps-bold-faces
191 '(bold
192 bold-italic
193 font-lock-function-name-face
194 message-headers
195 )
196 "A list of the faces that should be printed italic.")
197
198 (defvar ps-italic-faces
199 '(italic
200 bold-italic
201 font-lock-function-name-face
202 font-lock-string-face
203 font-lock-comment-face
204 message-header-contents
205 message-highlighted-header-contents
206 message-cited-text
207 )
208 "A list of the faces that should be printed bold.")
209
210 (defvar ps-underline-faces
211 '(underline
212 font-lock-string-face)
213 "A list of the faces that should be printed underline.")
214
215 (defvar ps-razzle-dazzle t
216 "Non-nil means report progress while formatting buffer")
217
218 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
219
220 (defun ps-print-buffer (&optional filename)
221
222 "Generate and print a PostScript image of the buffer.
223
224 When called with a numeric prefix argument (C-u), prompt the user for
225 the name of a file to save the PostScript image in, instead of sending
226 it to the printer.
227
228 More specifically, the FILENAME argument is treated as follows: if it
229 is nil, send the image to the printer. If FILENAME is a string, save
230 the PostScript image in a file with that name. If FILENAME is a
231 number, prompt the user for the name of the file to save in.
232
233 The image is rendered using the PostScript font Courier.
234
235 See also: ps-print-buffer-with-faces
236 ps-spool-buffer
237 ps-spool-buffer-with-faces"
238
239 (interactive "P")
240 (setq filename (ps-preprint filename))
241 (ps-generate (current-buffer) (point-min) (point-max)
242 'ps-generate-postscript)
243 (ps-do-despool filename))
244
245
246 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
247
248 (defun ps-print-buffer-with-faces (&optional filename)
249
250 "Generate and print a PostScript image of the buffer.
251
252 This function works like ps-print-buffer, with the additional benefit
253 that any bold/italic formatting information present in the buffer
254 (contained in extents and faces) will be retained in the PostScript
255 image. In other words, WYSIAWYG -- What You See Is (Almost) What You
256 Get.
257
258 Ps-print uses three lists to determine which faces should be printed
259 bold, italic, and/or underlined; the lists are named ps-bold-faces, ps-
260 italic-faces, and ps-underline-faces. A given face should appear on as
261 many lists as are appropriate; for example, face bold-italic is in both
262 the lists ps-bold-faces and ps-italic-faces. The lists are pre-built
263 with the standard bold, italic, and bold-italic faces, with font-lock's
264 faces, and with the faces used by gnus and rmail.
265
266 The image is rendered using the PostScript fonts Courier, Courier-Bold,
267 Courier-Oblique, and Courier-BoldOblique.
268
269 See also: ps-print-buffer
270 ps-spool-buffer
271 ps-spool-buffer-with-faces."
272
273 (interactive "P")
274 (setq filename (ps-preprint filename))
275 (ps-generate (current-buffer) (point-min) (point-max)
276 'ps-generate-postscript-with-faces)
277 (ps-do-despool filename))
278
279 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
280
281 (defun ps-print-region (from to &optional filename)
282
283 "Generate and print a PostScript image of the region.
284
285 When called with a numeric prefix argument (C-u), prompt the user for
286 the name of a file to save the PostScript image in, instead of sending
287 it to the printer.
288
289 This function is essentially the same as ps-print-buffer except that it
290 prints just a region, and not the entire buffer. For more information,
291 see the function ps-print-buffer.
292
293 See also: ps-print-region-with-faces
294 ps-spool-region
295 ps-spool-region-with-faces"
296
297 (interactive "r\nP")
298 (setq filename (ps-preprint filename))
299 (ps-generate (current-buffer) from to
300 'ps-generate-postscript)
301 (ps-do-despool filename))
302
303 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
304
305 (defun ps-print-region-with-faces (from to &optional filename)
306
307 "Generate and print a PostScript image of the region.
308
309 This function is essentially the same as ps-print-buffer except that it
310 prints just a region, and not the entire buffer. See the functions
311 ps-print-region and ps-print-buffer-with-faces for
312 more information.
313
314 See also: ps-print-region
315 ps-spool-region
316 ps-spool-region-with-faces"
317
318 (interactive "r\nP")
319 (setq filename (ps-preprint filename))
320 (ps-generate (current-buffer) from to
321 'ps-generate-postscript-with-faces)
322 (ps-do-despool filename))
323
324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
325
326 (defun ps-spool-buffer ()
327
328 "Generate and spool a PostScript image of the buffer.
329
330 This function is essentially the same as function ps-print-buffer
331 except that the PostScript image is saved in a local buffer to be sent
332 to the printer later.
333
334 Each time you call one of the ps-spool- functions, the generated
335 PostScript is appended to a buffer named *PostScript*; to send the
336 spooled PostScript to the printer, or save it to a file, use the command
337 ps-despool.
338
339 If the variable ps-spool-duplex is non-nil, then the spooled PostScript
340 is padded with blank pages, when needed, so that each printed buffer
341 will start on a front page when printed on a duplex printer (a printer
342 that prints on both sides on the paper). Users of non-duplex printers
343 will want to leave ps-spool-duplex nil.
344
345 The spooling mechanism was designed for printing lots of small files
346 (mail messages or netnews articles) to save paper that would otherwise
347 be wasted on banner pages, and to make it easier to find your output at
348 the printer (it's easier to pick up one 50-page printout than to find 50
349 single-page printouts).
350
351 Ps-print has a hook in the kill-emacs-hook list so that you won't
352 accidently quit from Emacs while you have unprinted PostScript waiting
353 in the spool buffer. If you do attempt to exit with spooled PostScript,
354 you'll be asked if you want to print it, and if you decline, you'll be
355 asked to confirm the exit; this is modeled on the confirmation that
356 Emacs uses for modified buffers.
357
358 See also: ps-despool
359 ps-print-buffer
360 ps-print-buffer-with-faces
361 ps-spool-buffer-with-faces"
362
363 (interactive)
364 (ps-generate (current-buffer) (point-min) (point-max)
365 'ps-generate-postscript))
366
367 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
368
369 (defun ps-spool-buffer-with-faces ()
370
371 "Generate and spool PostScript image of the buffer.
372
373 This function is essentially the same as function ps-print-buffer-with-
374 faces except that the PostScript image is saved in a local buffer to be
375 sent to the printer later.
376
377 Use the function ps-despool to send the spooled images to the printer.
378 See the function ps-spool-buffer for a description of the spooling
379 mechanism.
380
381 See also: ps-despool
382 ps-spool-buffer
383 ps-print-buffer
384 ps-print-buffer-with-faces"
385
386 (interactive)
387 (ps-generate (current-buffer) (point-min) (point-max)
388 'ps-generate-postscript-with-faces))
389
390 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
391
392 (defun ps-spool-region (from to)
393
394 "Generate PostScript image of the region and spool locally.
395
396 This function is essentially the same as function ps-print-region except
397 that the PostScript image is saved in a local buffer to be sent to the
398 printer later.
399
400 Use the function ps-despool to send the spooled images to the printer.
401 See the function ps-spool-buffer for a description of the spooling
402 mechanism.
403
404 See also: ps-despool
405 ps-spool-buffer
406 ps-print-buffer
407 ps-print-buffer-with-faces"
408
409 (interactive "r")
410 (ps-generate (current-buffer) from to
411 'ps-generate-postscript))
412
413 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
414
415 (defun ps-spool-region-with-faces (from to)
416
417 "Generate PostScript image of the region and spool locally.
418
419 This function is essentially the same as function ps-print-region-with-
420 faces except that the PostScript image is saved in a local buffer to be
421 sent to the printer later.
422
423 Use the function ps-despool to send the spooled images to the printer.
424 See the function ps-spool-buffer for a description of the spooling
425 mechanism.
426
427 See also: ps-despool
428 ps-spool-buffer
429 ps-print-buffer
430 ps-print-buffer-with-faces"
431
432 (interactive "r")
433 (ps-generate (current-buffer) from to
434 'ps-generate-postscript-with-faces))
435
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.
441 For a duplex printer, the ps-spool functions will insert blank pages
442 as needed between print jobs so that the next buffer printed will
443 start on the right page.")
444
445 (defun ps-despool (&optional filename)
446 "Send the spooled PostScript to the printer.
447
448 When called with a numeric prefix argument (C-u), prompt the user for
449 the name of a file to save the spooled PostScript in, instead of sending
450 it to the printer.
451
452 More specifically, the FILENAME argument is treated as follows: if it
453 is nil, send the image to the printer. If FILENAME is a string, save
454 the PostScript image in a file with that name. If FILENAME is a
455 number, prompt the user for the name of the file to save in."
456
457 (interactive "P")
458
459 ;; If argument FILENAME is nil, send the image to the printer; if
460 ;; FILENAME is a string, save the PostScript image in that filename;
461 ;; if FILENAME is a number, prompt the user for the name of the file
462 ;; to save in.
463
464 (setq filename (ps-preprint filename))
465 (ps-do-despool filename))
466
467 ;; Here end the definitions that users need to know about; proceed
468 ;; further at your own risk!
469 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
470
471 (defun ps-kill-emacs-check ()
472 (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
473 (buffer-modified-p ps-buffer))
474 (if (y-or-n-p "Unprinted PostScript waiting... print now? ")
475 (ps-despool)))
476
477 (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name))
478 (buffer-modified-p ps-buffer))
479 (if (yes-or-no-p "Unprinted PostScript waiting; exit anyway? ")
480 nil
481 (error "Unprinted PostScript"))))
482
483 (if (fboundp 'add-hook)
484 (add-hook 'kill-emacs-hook 'ps-kill-emacs-check)
485 (if kill-emacs-hook
486 (message "Won't override existing kill-emacs-hook.")
487 (setq kill-emacs-hook 'ps-kill-emacs-check)))
488
489 (defun ps-preprint (&optional filename)
490 (if (and filename
491 (or (numberp filename)
492 (listp filename)))
493 (setq filename
494 (let* ((name (concat (buffer-name) ".ps"))
495 (prompt (format "Save PostScript to file: (default %s) "
496 name)))
497 (read-file-name prompt default-directory
498 name nil)))))
499
500 (defvar ps-spool-buffer-name "*PostScript*")
501
502 (defvar ps-col 0)
503 (defvar ps-row 0)
504 (defvar ps-xpos 0)
505 (defvar ps-ypos 0)
506
507 (defvar ps-chars-per-line 80)
508 (defvar ps-lines-per-page 66)
509
510 (defvar ps-page-start-ypos 745)
511 (defvar ps-line-start-xpos 40)
512
513 (defvar ps-char-xpos-inc 6)
514 (defvar ps-line-ypos-inc 11)
515
516 (defvar ps-current-font 0)
517
518 (defvar ps-multiple nil)
519 (defvar ps-virtual-page-number 0)
520
521 (defun ps-begin-file ()
522 (save-excursion
523 (set-buffer ps-output-buffer)
524 (goto-char (point-min))
525 (setq ps-real-page-number 1)
526 (insert
527 "%!PS-Adobe-1.0
528
529 /S /show load def
530 /M /moveto load def
531 /L { gsave newpath 3 1 roll 1 sub M 0 rlineto closepath stroke grestore } def
532
533 /F{$fd exch get setfont}def
534
535 /StartPage{/svpg save def}def
536 /EndPage{svpg restore showpage}def
537
538 /SetUpFonts
539 {dup/$fd exch array def{findfont exch scalefont $fd 3 1 roll put}repeat}def
540
541 % Define /ISOLatin1Encoding only if it's not already there.
542 /ISOLatin1Encoding where { pop save true }{ false } ifelse
543 /ISOLatin1Encoding [ StandardEncoding 0 45 getinterval aload pop /minus
544 StandardEncoding 46 98 getinterval aload pop /dotlessi /grave /acute
545 /circumflex /tilde /macron /breve /dotaccent /dieresis /.notdef /ring
546 /cedilla /.notdef /hungarumlaut /ogonek /caron /space /exclamdown /cent
547 /sterling /currency /yen /brokenbar /section /dieresis /copyright
548 /ordfeminine /guillemotleft /logicalnot /hyphen /registered /macron
549 /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph
550 /periodcentered /cedilla /onesuperior /ordmasculine /guillemotright
551 /onequarter /onehalf /threequarters /questiondown /Agrave /Aacute
552 /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla /Egrave /Eacute
553 /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex /Idieresis /Eth
554 /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply
555 /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn
556 /germandbls /agrave /aacute /acircumflex /atilde /adieresis /aring /ae
557 /ccedilla /egrave /eacute /ecircumflex /edieresis /igrave /iacute
558 /icircumflex /idieresis /eth /ntilde /ograve /oacute /ocircumflex
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
570 /CourierISO /Courier reencodeISO
571 /Courier-ObliqueISO /Courier-Oblique reencodeISO
572 /Courier-BoldISO /Courier-Bold reencodeISO
573 /Courier-BoldObliqueISO /Courier-BoldOblique reencodeISO
574
575 3 10 /Courier-BoldObliqueISO
576 2 10 /Courier-ObliqueISO
577 1 10 /Courier-BoldISO
578 0 10 /CourierISO
579 4 SetUpFonts
580
581 .4 setlinewidth
582 ")))
583
584 (defun ps-end-file ()
585 )
586
587 (defun ps-next-page ()
588 (ps-end-page)
589 (ps-begin-page)
590 (ps-set-font ps-current-font)
591 (ps-init-page))
592
593 (defun ps-top-of-page () (ps-next-page))
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
610 (defun ps-end-page ()
611 (save-excursion
612 (set-buffer ps-output-buffer)
613 (goto-char (point-max))
614 (insert "EndPage\n")))
615
616 (defun ps-next-line ()
617 (setq ps-row (+ ps-row 1))
618 (if (>= ps-row ps-lines-per-page)
619 (ps-next-page)
620 (setq ps-col 0)
621 (setq ps-xpos ps-line-start-xpos)
622 (setq ps-ypos (- ps-ypos ps-line-ypos-inc))))
623
624 (defun ps-continue-line ()
625 (ps-next-line))
626
627 (defvar ps-source-buffer nil)
628 (defvar ps-output-buffer nil)
629
630 (defun ps-basic-plot-string (from to &optional underline-p)
631 (setq text (buffer-substring from to))
632 (save-excursion
633 (set-buffer ps-output-buffer)
634 (goto-char (point-max))
635 (setq count (- to from))
636
637 (if underline-p
638 (insert (format "%d %d %d L\n" ps-xpos ps-ypos
639 (* count ps-char-xpos-inc))))
640
641 (insert (format "%d %d M (" ps-xpos ps-ypos))
642 (save-excursion
643 (insert text))
644
645 (while (re-search-forward "[()\\]" nil t)
646 (save-excursion
647 (forward-char -1)
648 (insert "\\")))
649
650 (end-of-line)
651 (insert ") S\n")
652
653 (setq ps-xpos (+ ps-xpos (* count ps-char-xpos-inc)))))
654
655 (defun ps-basic-plot-whitespace (from to underline-p)
656 (setq count (- to from))
657 (setq ps-xpos (+ ps-xpos (* count ps-char-xpos-inc))))
658
659 (defun ps-plot (plotfunc from to &optional underline-p)
660
661 (while (< from to)
662 (setq count (- to from))
663 ;; Test to see whether this region will fit on the current line
664 (if (<= (+ ps-col count) ps-chars-per-line)
665 (progn
666 ;; It fits; plot it.
667 (funcall plotfunc from to underline-p)
668 (setq from to))
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
679 (let* ((q-todo (- (point-max) (point-min)))
680 (q-done (- to (point-min)))
681 (chunkfrac (/ q-todo 8))
682 (chunksize (if (> chunkfrac 10000) 10000 chunkfrac)))
683 (if (> (- q-done ps-razchunk) chunksize)
684 (progn
685 (setq ps-razchunk q-done)
686 (setq foo
687 (if (< q-todo 100)
688 (* (/ q-done q-todo) 100)
689 (setq basis (/ q-todo 100))
690 (/ q-done basis)))
691
692 (message "Formatting... %d%%" foo))))))
693
694 (defun ps-set-font (&optional font)
695 (save-excursion
696 (set-buffer ps-output-buffer)
697 (goto-char (point-max))
698 (insert (format "%d F\n" (if font font ps-current-font))))
699 (if font
700 (setq ps-current-font font)))
701
702 (defun ps-plot-region (from to font &optional underline-p)
703
704 (ps-set-font font)
705
706 (save-excursion
707 (goto-char from)
708 (while (< from to)
709 (if (re-search-forward "[\t\n\014]" to t)
710 (let ((match (char-after (match-beginning 0))))
711 (cond
712 ((= match ?\n)
713 (ps-plot 'ps-basic-plot-string from (- (point) 1) underline-p)
714 (ps-next-line))
715
716 ((= match ?\t)
717 (ps-plot 'ps-basic-plot-string from (- (point) 1) underline-p)
718 (setq linestart (save-excursion (beginning-of-line) (point)))
719 (forward-char -1)
720 (setq from (+ linestart (current-column)))
721 (if (re-search-forward "[ \t]+" to t)
722 (ps-plot 'ps-basic-plot-whitespace from
723 (+ linestart (current-column)))))
724
725 ((= match ?\014)
726 (ps-plot 'ps-basic-plot-string from (- (point) 1) underline-p)
727 (ps-top-of-page)))
728 (setq from (point)))
729
730 (ps-plot 'ps-basic-plot-string from to underline-p)
731 (setq from to)))))
732
733 (defun ps-format-buffer ()
734 (interactive)
735
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
743 (ps-begin-file)
744 (ps-begin-page)
745 (ps-init-page)
746
747 (ps-plot-region (point-min) (point-max) 0)
748
749 (ps-end-page)
750 (ps-end-file)
751 )
752
753 (defun ps-mapper (extent list)
754 (nconc list (list (list (extent-start-position extent) 'push extent)
755 (list (extent-end-position extent) 'pull extent)))
756 nil)
757
758 (defun ps-sorter (a b)
759 (< (car a) (car b)))
760
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)
788
789 (save-restriction
790 (narrow-to-region from to)
791 (setq face 'default)
792
793 (cond ((string-match "Lucid" emacs-version)
794 ;; Build the list of extents...
795 (let ((a (cons 'dummy nil)))
796 (map-extents 'ps-mapper nil from to a)
797 (setq a (cdr a))
798 (setq a (sort a 'ps-sorter))
799
800 (setq extent-list nil)
801
802 ;; Loop through the extents...
803 (while a
804 (setq record (car a))
805
806 (setq position (car record))
807 (setq record (cdr record))
808
809 (setq type (car record))
810 (setq record (cdr record))
811
812 (setq extent (car record))
813
814 ;; Plot up to this record.
815 (ps-plot-with-face from position face)
816
817 (cond
818 ((eq type 'push)
819 (setq extent-list (sort (cons extent extent-list)
820 'ps-extent-sorter)))
821
822 ((eq type 'pull)
823 (setq extent-list (sort (delq extent extent-list)
824 'ps-extent-sorter))))
825
826 (setq face
827 (if extent-list
828 (extent-face (car extent-list))
829 'default))
830
831 (setq from position)
832 (setq a (cdr a)))))
833
834 ((string-match "^19" emacs-version)
835
836 (while (< from to)
837
838 (setq prop-position
839 (if (setq p (next-property-change from))
840 (if (> p to) to p)
841 to))
842
843 (setq over-position
844 (if (setq p (next-overlay-change from))
845 (if (> p to) to p)
846 to))
847
848 (setq position
849 (if (< prop-position over-position)
850 prop-position
851 over-position))
852
853 (setq face
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
860 (if (setq face (overlay-get (car overlays) 'face))
861 (setq overlays nil)
862 (setq overlays (cdr overlays))))))
863
864 ;; Plot up to this record.
865 (ps-plot-with-face from position face)
866
867 (setq from position))))
868
869 (ps-plot-with-face from to face)))
870
871 (defun ps-generate-postscript (from to)
872 (ps-plot-region from to 0))
873
874 (defun ps-generate (buffer from to genfunc)
875
876 (save-restriction
877 (narrow-to-region from to)
878 (if ps-razzle-dazzle
879 (message "Formatting... %d%%" (setq ps-razchunk 0)))
880
881 (set-buffer buffer)
882 (setq ps-source-buffer buffer)
883 (setq ps-output-buffer (get-buffer-create ps-spool-buffer-name))
884
885 (unwind-protect
886 (progn
887
888 (set-buffer ps-output-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
902 (set-buffer ps-source-buffer)
903 (funcall genfunc from to)
904
905 (ps-end-page)))
906
907 (if ps-razzle-dazzle
908 (message "Formatting... Done."))))
909
910 (defun ps-do-despool (filename)
911
912 (if (or (not (boundp 'ps-output-buffer))
913 (not ps-output-buffer))
914 (message "No spooled PostScript to print.")
915
916 (ps-end-file)
917
918 (if filename
919 (save-excursion
920 (if ps-razzle-dazzle
921 (message "Saving..."))
922
923 (set-buffer ps-output-buffer)
924 (setq filename (expand-file-name filename))
925 (write-region (point-min) (point-max) filename)
926
927 (if ps-razzle-dazzle
928 (message "Wrote %s" filename)))
929
930 ;; Else, spool to the printer
931 (if ps-razzle-dazzle
932 (message "Printing..."))
933
934 (save-excursion
935 (set-buffer ps-output-buffer)
936 (apply 'call-process-region
937 (point-min) (point-max) ps-lpr-command nil 0 nil
938 ps-lpr-switches))
939
940 (if ps-razzle-dazzle
941 (message "Printing... Done.")))
942
943 (kill-buffer ps-output-buffer)))
944
945 (defun ps-testpattern ()
946 (setq foo 1)
947 (while (< foo 60)
948 (insert "|" (make-string foo ?\ ) (format "%d\n" foo))
949 (setq foo (+ 1 foo))))
950
951 (defun pts (stuff)
952 (save-excursion
953 (set-buffer "*scratch*")
954 (goto-char (point-max))
955 (insert "---------------------------------\n"
956 (symbol-name stuff) ":\n"
957 (prin1-to-string (symbol-value stuff))
958 "\n")))
959
960 (provide 'ps-print)
961
962 ;; ps-print.el ends here