Mercurial > emacs
changeset 10492:a0f38717d82d
*** empty log message ***
| author | Richard M. Stallman <rms@gnu.org> |
|---|---|
| date | Fri, 20 Jan 1995 06:09:03 +0000 |
| parents | dfc0d2c81c56 |
| children | ed52763e77d6 |
| files | lisp/ps-print.el |
| diffstat | 1 files changed, 1606 insertions(+), 626 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ps-print.el Fri Jan 20 06:04:56 1995 +0000 +++ b/lisp/ps-print.el Fri Jan 20 06:09:03 1995 +0000 @@ -1,10 +1,12 @@ -;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print). +;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19. + ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. -;; Author: James C. Thompson <thompson@wg2.waii.com> -;; Keywords: faces, postscript, printing +;; Author: Jim Thompson <thompson@wg2.waii.com> +;; Version: 1.10 +;; Keywords: print, PostScript -;; This file is part of GNU Emacs. +;; This file is not yet part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -20,25 +22,16 @@ ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. -;; Acknowledgements -;; ---------------- -;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing -;; the Emacs 19 port. -;; -;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org, -;; for adding underline support and title code. (Titling will appear -;; in the next release.) -;; -;; Thanks to Heiko Muenkel, muenkel@tnt.uni-hannover.de, for showing -;; me how to handle ISO-8859/1 characters. -;; -;; Code to handle ISO-8859/1 characters borrowed from the mp prologue -;; file mp.pro.ps, used with permission of Rich Burridge of Sun -;; Microsystems (Rich.Burridge@eng.sun.com). +;; LCD Archive Entry: +;; ps-print|James C. Thompson|thompson@wg2.waii.com| +;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print)| +;; 26-Feb-1994|1.6|~/packages/ps-print.el| + +;;; Commentary: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; -;; About ps-print: +;; About ps-print ;; -------------- ;; This package provides printing of Emacs buffers on PostScript ;; printers; the buffer's bold and italic text attributes are @@ -46,180 +39,520 @@ ;; Emacs 19 (Lucid or FSF) and a fontifying package such as font-lock ;; or hilit. ;; -;; Installing ps-print: +;; Installing ps-print ;; ------------------- -;; Place ps-print somewhere in your load-path and byte-compile it. -;; Load ps-print with (require 'ps-print). +;; +;; 1. Place ps-print.el somewhere in your load-path and byte-compile +;; it. You can ignore all byte-compiler warnings; they are the +;; result of multi-Emacs support. This step is necessary only if +;; you're installing your own ps-print; if ps-print came with your +;; copy of Emacs, this been done already. +;; +;; 2. Place in your .emacs file the line +;; +;; (require 'ps-print) ;; -;; Using ps-print: +;; to load ps-print. Or you may cause any of the ps-print commands +;; to be autoloaded with an autoload command such as: +;; +;; (autoload 'ps-print-buffer "ps-print" +;; "Generate and print a PostScript image of the buffer..." t) +;; +;; 3. Make sure that the variables ps-lpr-command and ps-lpr-switches +;; contain appropriate values for your system; see the usage notes +;; below and the documentation of these variables. +;; +;; Using ps-print ;; -------------- -;; The variables ps-bold-faces and ps-italic-faces *must* contain -;; lists of the faces that you wish to print in bold or italic font. -;; These variables already contain some default values, but most users -;; will probably have to add some of their own. To add a face to one -;; of these lists, put code something like the following into your -;; .emacs startup file: +;; +;; The Commands +;; +;; Ps-print provides eight commands for generating PostScript images +;; of Emacs buffers: +;; +;; ps-print-buffer +;; ps-print-buffer-with-faces +;; ps-print-region +;; ps-print-region-with-faces +;; ps-spool-buffer +;; ps-spool-buffer-with-faces +;; ps-spool-region +;; ps-spool-region-with-faces ;; -;; (setq ps-bold-faces (cons 'my-bold-face ps-bold-faces)) +;; These commands all perform essentially the same function: they +;; generate PostScript images suitable for printing on a PostScript +;; printer or displaying with GhostScript. These commands are +;; collectively referred to as "ps-print- commands". +;; +;; The word "print" or "spool" in the command name determines when the +;; PostScript image is sent to the printer: +;; +;; print - The PostScript image is immediately sent to the +;; printer; +;; +;; spool - The PostScript image is saved temporarily in an +;; Emacs buffer. Many images may be spooled locally +;; before printing them. To send the spooled images +;; to the printer, use the command ps-despool. ;; -;; Ps-print's printer interface is governed by the variables ps-lpr- -;; command and ps-lpr-switches; these are analogous to the variables -;; lpr-command and lpr-switches in the Emacs lpr package. +;; The spooling mechanism was designed for printing lots of small +;; files (mail messages or netnews articles) to save paper that would +;; otherwise be wasted on banner pages, and to make it easier to find +;; your output at the printer (it's easier to pick up one 50-page +;; printout than to find 50 single-page printouts). +;; +;; Ps-print has a hook in the kill-emacs-hooks so that you won't +;; accidently quit from Emacs while you have unprinted PostScript +;; waiting in the spool buffer. If you do attempt to exit with +;; spooled PostScript, you'll be asked if you want to print it, and if +;; you decline, you'll be asked to confirm the exit; this is modeled +;; on the confirmation that Emacs uses for modified buffers. +;; +;; The word "buffer" or "region" in the command name determines how +;; much of the buffer is printed: ;; -;; To use ps-print, invoke the command ps-print-buffer-with-faces. -;; This will generate a PostScript image of the current buffer and -;; send it to the printer. Precede this command with a numeric prefix -;; (C-u), and the PostScript output will be saved in a file; you will -;; be prompted for a filename. Also see the functions ps-print- -;; buffer, ps-print-region, and ps-print-region-with-faces. +;; buffer - Print the entire buffer. +;; +;; region - Print just the current region. +;; +;; The -with-faces suffix on the command name means that the command +;; will include font, color, and underline information in the +;; PostScript image, so the printed image can look as pretty as the +;; buffer. The ps-print- commands without the -with-faces suffix +;; don't include font, color, or underline information; images printed +;; with these commands aren't as pretty, but are faster to generate. +;; +;; Two ps-print- command examples: +;; +;; ps-print-buffer - print the entire buffer, +;; without font, color, or +;; underline information, and +;; send it immediately to the +;; printer. ;; -;; I recommend binding ps-print-buffer-with-faces to a key sequence; -;; on a Sun 4 keyboard, for example, you can bind to the PrSc key (aka -;; r22): +;; ps-spool-region-with-faces - print just the current region; +;; include font, color, and +;; underline information, and +;; spool the image in Emacs to +;; send to the printer later. +;; +;; +;; Invoking Ps-Print +;; +;; To print your buffer, type +;; +;; M-x ps-print-buffer +;; +;; or substitute one of the other seven ps-print- commands. The +;; command will generate the PostScript image and print or spool it as +;; specified. By giving the command a prefix argument ;; -;; (global-set-key 'f22 'ps-print-buffer-with-faces) -;; (global-set-key '(shift f22) 'ps-print-region-with-faces) +;; C-u M-x ps-print-buffer +;; +;; it will save the PostScript image to a file instead of sending it +;; to the printer; you will be prompted for the name of the file to +;; save the image to. The prefix argument is ignored by the commands +;; that spool their images, but you may save the spooled images to a +;; file by giving a prefix argument to ps-despool: ;; -;; Or, as I now prefer, you can also bind the ps-spool- functions to -;; keys; here's my bindings: +;; C-u M-x ps-despool +;; +;; When invoked this way, ps-despool will prompt you for the name of +;; the file to save to. ;; -;; (global-set-key 'f22 'ps-spool-buffer-with-faces) +;; Any of the ps-print- commands can be bound to keys; I recommend +;; binding ps-spool-buffer-with-faces, ps-spool-region-with-faces, and +;; ps-despool. Here are the bindings I use on my Sun 4 keyboard: +;; +;; (global-set-key 'f22 'ps-spool-buffer-with-faces) ;f22 is prsc ;; (global-set-key '(shift f22) 'ps-spool-region-with-faces) ;; (global-set-key '(control f22) 'ps-despool) ;; -;; Using ps-print with other Emacses: -;; --------------------------------- -;; Although it was intended for use with Emacs 19, ps-print will also work -;; with Emacs version 18; you won't get fancy fontified output, but it -;; should work. +;; +;; The Printer Interface +;; +;; The variables ps-lpr-command and ps-lpr-switches determine what +;; command is used to send the PostScript images to the printer, and +;; what arguments to give the command. These are analogous to lpr- +;; command and lpr-switches. +;; +;; NOTE: ps-lpr-command and ps-lpr-switches take their initial values +;; from the variables lpr-command and lpr-switches. If you have +;; lpr-command set to invoke a pretty-printer such as enscript, +;; then ps-print won't work properly. Ps-lpr-command must name +;; a program that does not format the files it prints. +;; +;; +;; How Ps-Print Deals With Fonts +;; +;; The ps-print-*-with-faces commands attempt to determine which faces +;; should be printed in bold or italic, but their guesses aren't +;; always right. For example, you might want to map colors into faces +;; so that blue faces print in bold, and red faces in italic. +;; +;; It is possible to force ps-print to consider specific faces bold or +;; italic, no matter what font they are displayed in, by setting the +;; variables ps-bold-faces and ps-italic-faces. These variables +;; contain lists of faces that ps-print should consider bold or +;; italic; to set them, put code like the following into your .emacs +;; file: +;; +;; (setq ps-bold-faces '(my-blue-face)) +;; (setq ps-red-faces '(my-red-face)) +;; +;; Ps-print does not attempt to guess the sizes of fonts; all text is +;; rendered using the Courier font family, in 10 point size. To +;; change the font family, change the variables ps-font, ps-font-bold, +;; ps-font-italic, and ps-font-bold-italic; fixed-pitch fonts work +;; best, but are not required. To change the font size, change the +;; variable ps-font-size. +;; +;; If you change the font family or size, you MUST also change the +;; variables ps-line-height, ps-avg-char-width, and ps-space-width, or +;; ps-print cannot correctly place line and page breaks. +;; +;; Ps-print keeps internal lists of which fonts are bold and which are +;; italic; these lists are built the first time you invoke ps-print. +;; For the sake of efficiency, the lists are built only once; the same +;; lists are referred in later invokations of ps-print. +;; +;; Because these lists are built only once, it's possible for them to +;; get out of sync, if a face changes, or if new faces are added. To +;; get the lists back in sync, you can set the variable +;; ps-build-face-reference to t, and the lists will be rebuilt the +;; next time ps-print is invoked. +;; +;; +;; How Ps-Print Deals With Color +;; +;; Ps-print detects faces with foreground and background colors +;; defined and embeds color information in the PostScript image. The +;; default foreground and background colors are defined by the +;; variables ps-default-fg and ps-default-bg. On black-and-white +;; printers, colors are displayed in grayscale. To turn off color +;; output, set ps-print-color-p to nil. +;; +;; +;; Headers +;; +;; Ps-print can print headers at the top of each page; the default +;; headers contain the following four items: on the left, the name of +;; the buffer and, if the buffer is visiting a file, the file's +;; directory; on the right, the page number and date of printing. The +;; default headers look something like this: +;; +;; ps-print.el 1/21 +;; /home/jct/emacs-lisp/ps/new 94/12/31 ;; -;; A few words about support: -;; ------------------------- -;; Despite its appearance, with comment blocks, usage instructions, and -;; documentation strings, ps-print is not a supported package. That's all -;; a masquerade. Ps-print is something I threw together in my spare time-- -;; an evening here, a Saturday there--to make my printouts look like my -;; Emacs buffers. It works, but is not complete. -;; -;; Unfortunately, supporting elisp code is not my job and, now that I have -;; what I need out of ps-print, additional support is going to be up to -;; you, the user. But that's the spirit of Emacs, isn't it? I call on -;; all who use this package to help in developing it further. If you -;; notice a bug, fix it and send me the patches. If you add a feature, -;; again, send me the patches. I will collect all such contributions and -;; periodically post the updates to the appropriate places. +;; When printing on duplex printers, left and right are reversed so +;; that the page numbers are toward the outside. ;; -;; A few more words about support: -;; ------------------------------ -;; The response to my call for public support of ps-print has been -;; terrific. With the exception of the spooling mechanism, all the new -;; features in this version of ps-print were contributed by users. I have -;; some contributed code for printing headers that I'll add to the next -;; release of ps-print, but there are still other features that users can -;; write. See the "Features to Add" list a little further on, and keep -;; that elisp rolling in. +;; Headers are configurable. To turn them off completely, set +;; ps-print-header to nil. To turn off the header's gaudy framing +;; box, set ps-print-header-frame to nil. Page numbers are printed in +;; "n/m" format, indicating page n of m pages; to omit the total page +;; count and just print the page number, set ps-show-n-of-n to nil. +;; +;; The amount of information in the header can be changed by changing +;; the number of lines. To show less, set ps-header-lines to 1, and +;; the header will show only the buffer name and page number. To show +;; more, set ps-header-lines to 3, and the header will show the time of +;; printing below the date. +;; +;; To change the content of the headers, change the variables +;; ps-left-header and ps-right-header. These variables are lists, +;; specifying top-to-bottom the text to display on the left or right +;; side of the header. Each element of the list should be a string or +;; a symbol. Strings are inserted directly into the PostScript +;; arrays, and should contain the PostScript string delimiters '(' and +;; ')'. ;; -;; Please send all bug fixes and enhancements to me, thompson@wg2.waii.com. +;; Symbols in the header format lists can either represent functions +;; or variables. Functions are called, and should return a string to +;; show in the header. Variables should contain strings to display in +;; the header. In either case, function or variable, the PostScript +;; strings delimeters are added by ps-print, and should not be part of +;; the returned value. +;; +;; Here's an example: say we want the left header to display the text +;; +;; Moe +;; Larry +;; Curly +;; +;; where we have a function to return "Moe" +;; +;; (defun moe-func () +;; "Moe") +;; +;; a variable specifying "Larry" +;; +;; (setq larry-var "Larry") ;; -;; New in version 1.5 -;; ------------------ -;; Support for Emacs 19. Works with both overlays and text -;; properties. +;; and a literal for "Curly". Here's how ps-left-header should be +;; set: +;; +;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)")) ;; -;; Underlining. +;; Note that Curly has the PostScript string delimiters inside his +;; quotes -- those aren't misplaced lisp delimiters! Without them, +;; PostScript would attempt to call the undefined function Curly, +;; which would result in a PostScript error. Since most printers +;; don't report PostScript errors except by aborting the print job, +;; this kind of error can be hard to track down. Consider yourself +;; warned. +;; +;; +;; Duplex Printers ;; -;; Local spooling; see function ps-spool-buffer. +;; If you have a duplex-capable printer (one that prints both sides of +;; the paper), set ps-spool-duplex to t. Ps-print will insert blank +;; pages to make sure each buffer starts on the correct side of the +;; paper. Don't forget to set ps-lpr-switches to select duplex +;; printing for your printer. +;; ;; -;; Support for ISO8859-1 character set. +;; Paper Size +;; +;; The variable ps-paper-type determines the size of paper ps-print +;; formats for; it should contain one of the symbols ps-letter, +;; ps-legal, or ps-a4. The default is ps-letter. ;; -;; Page breaks are now handled correctly. +;; +;; New in version 1.6 +;; ------------------ +;; Color output capability. +;; +;; Automatic detection of font attributes (bold, italic). ;; -;; Percentages reported while formatting are now correct. +;; Configurable headers with page numbers. +;; +;; Slightly faster. +;; +;; Support for different paper sizes. +;; +;; Better conformance to PostScript Document Structure Conventions. +;; ;; ;; Known bugs and limitations of ps-print: ;; -------------------------------------- -;; Slow. (Byte-compiling helps.) +;; Color output doesn't yet work in XEmacs. ;; -;; The PostScript needs review/cleanup/enhancing by a PS expert. -;; +;; Slow. Because XEmacs implements certain functions, such as +;; next-property-change, in lisp, printing with faces is several times +;; slower in XEmacs. In Emacs, these functions are implemented in C, +;; so Emacs is somewhat faster. +;; ;; ASCII Control characters other than tab, linefeed and pagefeed are ;; not handled. ;; -;; The mechanism for determining whether a stretch of characters -;; should be printed bold, italic, or plain is crude and extremely -;; limited. +;; Default background color isn't working. ;; ;; Faces are always treated as opaque. ;; -;; Font names are hardcoded. +;; Epoch and Emacs 18 not supported. At all. ;; -;; Epoch not fully supported. -;; -;; Tested with only one PostScript printer. ;; ;; Features to add: ;; --------------- +;; 2-up and 4-up capability. +;; ;; Line numbers. ;; -;; Simple headers with date, filename, and page numbers. +;; Wide-print (landscape) capability. +;; ;; -;; Gaudy headers a`la enscript and mp. +;; Acknowledgements +;; ---------------- +;; Thanks to Kevin Rodgers <kevinr@ihs.com> for adding support for +;; color and the invisible property. +;; +;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing +;; the initial port to Emacs 19. His code is no longer part of +;; ps-print, but his work is still appreciated. ;; -;; 2-up and 4-up capability. +;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org, +;; for adding underline support. Their code also is no longer part of +;; ps-print, but their efforts are not forgotten. +;; +;; Thanks also to all of you who mailed code to add features to +;; ps-print; although I didn't use your code, I still appreciate your +;; sharing it with me. ;; -;; Wide-print capability. +;; Thanks to all who mailed comments, encouragement, and criticism. +;; Thanks also to all who responded to my survey; I had too many +;; responses to reply to them all, but I greatly appreciate your +;; interest. ;; +;; Jim +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Code: -(defconst ps-print-version (substring "$Revision: 1.5 $" 11 -2) - "$Id: ps-print.el,v 1.5 1994/04/22 13:25:18 jct Exp $ +(defconst ps-print-version "1.10" + "ps-print.el,v 1.10 1995/01/09 14:45:03 jct Exp -Please send all bug fixes and enhancements to Jim Thompson, -thompson@wg2.waii.com.") +Please send all bug fixes and enhancements to + Jim Thompson <thompson@wg2.waii.com>.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar ps-lpr-command (if (memq system-type - '(usg-unix-v hpux silicon-graphics-unix)) - "lp" "lpr") - "The shell command for printing a PostScript file.") +;; User Variables: + +(defvar ps-lpr-command lpr-command + "*The shell command for printing a PostScript file.") + +(defvar ps-lpr-switches lpr-switches + "*A list of extra switches to pass to `ps-lpr-command'.") -(defvar ps-lpr-switches nil - "A list of extra switches to pass to ps-lpr-command.") +(defvar ps-spool-duplex nil ; Not many people have duplex + ; printers, so default to nil. + "*Non-nil indicates spooling is for a two-sided printer. +For a duplex printer, the `ps-spool-*' commands will insert blank pages +as needed between print jobs so that the next buffer printed will +start on the right page. Also, if headers are turned on, the headers +will be reversed on duplex printers so that the page numbers fall to +the left on even-numbered pages.") + +(defvar ps-paper-type 'ps-letter + "*Specifies the size of paper to format for. Should be one of +'ps-letter, 'ps-legal, or 'ps-a4.") + +(defvar ps-print-header t + "*Non-nil means print a header at the top of each page. By default, +the header displays the buffer name, page number, and, if the buffer +is visiting a file, the file's directory. Headers are customizable by +changing variables `ps-header-left' and `ps-header-right'.") + +(defvar ps-print-header-frame t + "*Non-nil means draw a gaudy frame around the header.") -(defvar ps-bold-faces - '(bold - bold-italic - font-lock-function-name-face - message-headers - ) - "A list of the faces that should be printed italic.") +(defvar ps-show-n-of-n t + "*Non-nil means show page numbers as \"n/m\", meaning page n of m. +Note: page numbers are displayed as part of headers, see variable `ps- +print-headers'.") + +(defvar ps-print-color-p (and (fboundp 'x-color-values) + (fboundp 'float)) +; Printing color requires both floating point and x-color-values. + "*If non-nil, print the buffer's text in color.") + +(defvar ps-default-fg '(0.0 0.0 0.0) + "*RGB values of the default foreground color. Defaults to black.") + +(defvar ps-default-bg '(1.0 1.0 1.0) + "*RGB values of the default background color. Defaults to white.") + +(defvar ps-font-size 10 + "*Specifies the size, in points, of the font to print text in.") + +(defvar ps-font "Courier" + "*Specifies the name of the font family to print text in.") + +(defvar ps-font-bold "Courier-Bold" + "*Specifies the name of the font family to print bold text in.") + +(defvar ps-font-italic "Courier-Oblique" + "*Specifies the name of the font family to print italic text in.") + +(defvar ps-font-bold-italic "Courier-BoldOblique" + "*Specifies the name of the font family to print bold-italic text in.") -(defvar ps-italic-faces - '(italic - bold-italic - font-lock-function-name-face - font-lock-string-face - font-lock-comment-face - message-header-contents - message-highlighted-header-contents - message-cited-text - ) - "A list of the faces that should be printed bold.") +(defvar ps-avg-char-width (if (fboundp 'float) 5.6 6) + "*Specifies the average width, in points, of a character. This is the +value that ps-print uses to determine the length, x-dimension, of the +text it has printed, and thus affects the point at which long lines +wrap around. Note that if you change the font or font size, you will +probably have to adjust this value to match.") + +(defvar ps-space-width (if (fboundp 'float) 5.6 6) + "*Specifies the width of a space character. This value is used in +expanding tab characters.") + +(defvar ps-line-height (if (fboundp 'float) 11.29 11) + "*Specifies the height of a line. This is the value that ps-print +uses to determine the height, y-dimension, of the lines of text it has +printed, and thus affects the point at which page-breaks are placed. +Note that if you change the font or font size, you will probably have +to adjust this value to match. Note also that the line-height is +*not* the same as the point size of the font.") + +(defvar ps-auto-font-detect t + "*Non-nil means automatically detect bold/italic face attributes. +Nil means rely solely on the lists `ps-bold-faces', `ps-italic-faces', +and `ps-underlined-faces'.") + +(defvar ps-bold-faces '() + "*A list of the \(non-bold\) faces that should be printed in bold font.") + +(defvar ps-italic-faces '() + "*A list of the \(non-italic\) faces that should be printed in italic font.") -(defvar ps-underline-faces - '(underline - font-lock-string-face) - "A list of the faces that should be printed underline.") +(defvar ps-underlined-faces '() + "*A list of the \(non-underlined\) faces that should be printed underlined.") + +(defvar ps-header-lines 2 + "*The number of lines to display in the page header.") +(make-variable-buffer-local 'ps-header-lines) + +(defvar ps-left-header + (list 'ps-get-buffer-name 'ps-header-dirpart) + "*The items to display on the right part of the page header. + +Should contain a list of strings and symbols, each representing an +entry in the PostScript array HeaderLinesLeft. + +Strings are inserted unchanged into the array; those representing +PostScript string literals should be delimited with PostScript string +delimiters '(' and ')'. + +For symbols with bound functions, the function is called and should +return a string to be inserted into the array. For symbols with bound +values, the value should be a string to be inserted into the array. +In either case, function or variable, the string value has PostScript +string delimiters added to it.") +(make-variable-buffer-local 'ps-left-header) + +(defvar ps-right-header + (list "/pagenumberstring load" 'time-stamp-yy/mm/dd 'time-stamp-hh:mm:ss) + "*The items to display on the left part of the page header. + +See the variable ps-left-header for a description of the format of +this variable.") +(make-variable-buffer-local 'ps-right-header) (defvar ps-razzle-dazzle t - "Non-nil means report progress while formatting buffer") + "*Non-nil means report progress while formatting buffer.") + +(defvar ps-adobe-tag "%!PS-Adobe-1.0\n" + "*Contains the header line identifying the output as PostScript. +By default, `ps-adobe-tag' contains the standard identifier. Some +printers require slightly different versions of this line.") + +(defvar ps-build-face-reference t + "*Non-nil means build the reference face lists. + +Ps-print sets this value to nil after it builds its internal reference +lists of bold and italic faces. By settings its value back to t, you +can force ps-print to rebuild the lists the next time you invoke one +of the -with-faces commands. + +You should set this value back to t after you change the attributes of +any face, or create new faces. Most users shouldn't have to worry +about its setting, though.") + +(defvar ps-always-build-face-reference nil + "*Non-nil means always rebuild the reference face lists. + +If this variable is non-nil, ps-print will rebuild its internal +reference lists of bold and italic faces *every* time one of the +-with-faces commands is called. Most users shouldn't need to set this +variable.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; User commands (defun ps-print-buffer (&optional filename) - -"Generate and print a PostScript image of the buffer. + "Generate and print a PostScript image of the buffer. When called with a numeric prefix argument (C-u), prompt the user for the name of a file to save the PostScript image in, instead of sending @@ -228,220 +561,99 @@ More specifically, the FILENAME argument is treated as follows: if it is nil, send the image to the printer. If FILENAME is a string, save the PostScript image in a file with that name. If FILENAME is a -number, prompt the user for the name of the file to save in. - -The image is rendered using the PostScript font Courier. - -See also: ps-print-buffer-with-faces - ps-spool-buffer - ps-spool-buffer-with-faces" +number, prompt the user for the name of the file to save in." (interactive "P") - (setq filename (ps-preprint filename)) + (setq filename (ps-print-preprint filename)) (ps-generate (current-buffer) (point-min) (point-max) 'ps-generate-postscript) (ps-do-despool filename)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (defun ps-print-buffer-with-faces (&optional filename) - -"Generate and print a PostScript image of the buffer. - -This function works like ps-print-buffer, with the additional benefit -that any bold/italic formatting information present in the buffer -(contained in extents and faces) will be retained in the PostScript -image. In other words, WYSIAWYG -- What You See Is (Almost) What You -Get. + "Generate and print a PostScript image of the buffer. -Ps-print uses three lists to determine which faces should be printed -bold, italic, and/or underlined; the lists are named ps-bold-faces, ps- -italic-faces, and ps-underline-faces. A given face should appear on as -many lists as are appropriate; for example, face bold-italic is in both -the lists ps-bold-faces and ps-italic-faces. The lists are pre-built -with the standard bold, italic, and bold-italic faces, with font-lock's -faces, and with the faces used by gnus and rmail. - -The image is rendered using the PostScript fonts Courier, Courier-Bold, -Courier-Oblique, and Courier-BoldOblique. - -See also: ps-print-buffer - ps-spool-buffer - ps-spool-buffer-with-faces." - +Like `ps-print-buffer', but includes font, color, and underline +information in the generated image." (interactive "P") - (setq filename (ps-preprint filename)) + (setq filename (ps-print-preprint filename)) (ps-generate (current-buffer) (point-min) (point-max) 'ps-generate-postscript-with-faces) (ps-do-despool filename)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ps-print-region (from to &optional filename) - -"Generate and print a PostScript image of the region. - -When called with a numeric prefix argument (C-u), prompt the user for -the name of a file to save the PostScript image in, instead of sending -it to the printer. + "Generate and print a PostScript image of the region. -This function is essentially the same as ps-print-buffer except that it -prints just a region, and not the entire buffer. For more information, -see the function ps-print-buffer. +Like `ps-print-buffer', but prints just the current region." -See also: ps-print-region-with-faces - ps-spool-region - ps-spool-region-with-faces" - (interactive "r\nP") - (setq filename (ps-preprint filename)) + (setq filename (ps-print-preprint filename)) (ps-generate (current-buffer) from to 'ps-generate-postscript) (ps-do-despool filename)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ps-print-region-with-faces (from to &optional filename) - -"Generate and print a PostScript image of the region. + "Generate and print a PostScript image of the region. -This function is essentially the same as ps-print-buffer except that it -prints just a region, and not the entire buffer. See the functions -ps-print-region and ps-print-buffer-with-faces for -more information. +Like `ps-print-region', but includes font, color, and underline +information in the generated image." -See also: ps-print-region - ps-spool-region - ps-spool-region-with-faces" - (interactive "r\nP") - (setq filename (ps-preprint filename)) + (setq filename (ps-print-preprint filename)) (ps-generate (current-buffer) from to 'ps-generate-postscript-with-faces) (ps-do-despool filename)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ps-spool-buffer () - -"Generate and spool a PostScript image of the buffer. - -This function is essentially the same as function ps-print-buffer -except that the PostScript image is saved in a local buffer to be sent -to the printer later. - -Each time you call one of the ps-spool- functions, the generated -PostScript is appended to a buffer named *PostScript*; to send the -spooled PostScript to the printer, or save it to a file, use the command -ps-despool. - -If the variable ps-spool-duplex is non-nil, then the spooled PostScript -is padded with blank pages, when needed, so that each printed buffer -will start on a front page when printed on a duplex printer (a printer -that prints on both sides on the paper). Users of non-duplex printers -will want to leave ps-spool-duplex nil. + "Generate and spool a PostScript image of the buffer. -The spooling mechanism was designed for printing lots of small files -(mail messages or netnews articles) to save paper that would otherwise -be wasted on banner pages, and to make it easier to find your output at -the printer (it's easier to pick up one 50-page printout than to find 50 -single-page printouts). +Like `ps-print-buffer' except that the PostScript image is saved in a +local buffer to be sent to the printer later. -Ps-print has a hook in the kill-emacs-hook list so that you won't -accidently quit from Emacs while you have unprinted PostScript waiting -in the spool buffer. If you do attempt to exit with spooled PostScript, -you'll be asked if you want to print it, and if you decline, you'll be -asked to confirm the exit; this is modeled on the confirmation that -Emacs uses for modified buffers. - -See also: ps-despool - ps-print-buffer - ps-print-buffer-with-faces - ps-spool-buffer-with-faces" - +Use the command `ps-despool' to send the spooled images to the printer." (interactive) (ps-generate (current-buffer) (point-min) (point-max) 'ps-generate-postscript)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ps-spool-buffer-with-faces () - -"Generate and spool PostScript image of the buffer. - -This function is essentially the same as function ps-print-buffer-with- -faces except that the PostScript image is saved in a local buffer to be -sent to the printer later. + "Generate and spool a PostScript image of the buffer. -Use the function ps-despool to send the spooled images to the printer. -See the function ps-spool-buffer for a description of the spooling -mechanism. +Like `ps-spool-buffer', but includes font, color, and underline +information in the generated image. -See also: ps-despool - ps-spool-buffer - ps-print-buffer - ps-print-buffer-with-faces" +Use the command `ps-despool' to send the spooled images to the printer." (interactive) (ps-generate (current-buffer) (point-min) (point-max) 'ps-generate-postscript-with-faces)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ps-spool-region (from to) - -"Generate PostScript image of the region and spool locally. - -This function is essentially the same as function ps-print-region except -that the PostScript image is saved in a local buffer to be sent to the -printer later. + "Generate a PostScript image of the region and spool locally. -Use the function ps-despool to send the spooled images to the printer. -See the function ps-spool-buffer for a description of the spooling -mechanism. +Like `ps-spool-buffer', but spools just the current region. -See also: ps-despool - ps-spool-buffer - ps-print-buffer - ps-print-buffer-with-faces" - +Use the command `ps-despool' to send the spooled images to the printer." (interactive "r") (ps-generate (current-buffer) from to 'ps-generate-postscript)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ps-spool-region-with-faces (from to) - -"Generate PostScript image of the region and spool locally. - -This function is essentially the same as function ps-print-region-with- -faces except that the PostScript image is saved in a local buffer to be -sent to the printer later. + "Generate a PostScript image of the region and spool locally. -Use the function ps-despool to send the spooled images to the printer. -See the function ps-spool-buffer for a description of the spooling -mechanism. +Like `ps-spool-region', but includes font, color, and underline +information in the generated image. -See also: ps-despool - ps-spool-buffer - ps-print-buffer - ps-print-buffer-with-faces" - +Use the command `ps-despool' to send the spooled images to the printer." (interactive "r") (ps-generate (current-buffer) from to 'ps-generate-postscript-with-faces)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defvar ps-spool-duplex nil ; Not many people have duplex - ; printers, so default to nil. - "*Non-nil indicates spooling is for a two-sided printer. -For a duplex printer, the ps-spool functions will insert blank pages -as needed between print jobs so that the next buffer printed will -start on the right page.") - (defun ps-despool (&optional filename) "Send the spooled PostScript to the printer. @@ -453,302 +665,945 @@ is nil, send the image to the printer. If FILENAME is a string, save the PostScript image in a file with that name. If FILENAME is a number, prompt the user for the name of the file to save in." + (interactive "P") + (ps-do-despool (ps-print-preprint filename))) - (interactive "P") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Utility functions and variables: + +(if (featurep 'emacs-vers) + nil + (defvar emacs-type (cond ((string-match "XEmacs" emacs-version) 'xemacs) + ((string-match "Lucid" emacs-version) 'lucid) + ((string-match "Epoch" emacs-version) 'epoch) + (t 'fsf)))) + +(if (or (eq emacs-type 'lucid) + (eq emacs-type 'xemacs)) + (setq ps-print-color-p nil) + (require 'faces)) ; face-font, face-underline-p, + ; x-font-regexp + +(require 'time-stamp) + +(defvar ps-print-prologue "% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4: +% If the ISOLatin1Encoding vector isn't known, define it. +/ISOLatin1Encoding where { pop } { +% Define the ISO Latin-1 encoding vector. +% The first half is the same as the standard encoding, +% except for minus instead of hyphen at code 055. +/ISOLatin1Encoding +StandardEncoding 0 45 getinterval aload pop + /minus +StandardEncoding 46 82 getinterval aload pop +%*** NOTE: the following are missing in the Adobe documentation, +%*** but appear in the displayed table: +%*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240. +% \20x + /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef + /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef + /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent + /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron +% \24x + /space /exclamdown /cent /sterling + /currency /yen /brokenbar /section + /dieresis /copyright /ordfeminine /guillemotleft + /logicalnot /hyphen /registered /macron + /degree /plusminus /twosuperior /threesuperior + /acute /mu /paragraph /periodcentered + /cedilla /onesuperior /ordmasculine /guillemotright + /onequarter /onehalf /threequarters /questiondown +% \30x + /Agrave /Aacute /Acircumflex /Atilde + /Adieresis /Aring /AE /Ccedilla + /Egrave /Eacute /Ecircumflex /Edieresis + /Igrave /Iacute /Icircumflex /Idieresis + /Eth /Ntilde /Ograve /Oacute + /Ocircumflex /Otilde /Odieresis /multiply + /Oslash /Ugrave /Uacute /Ucircumflex + /Udieresis /Yacute /Thorn /germandbls +% \34x + /agrave /aacute /acircumflex /atilde + /adieresis /aring /ae /ccedilla + /egrave /eacute /ecircumflex /edieresis + /igrave /iacute /icircumflex /idieresis + /eth /ntilde /ograve /oacute + /ocircumflex /otilde /odieresis /divide + /oslash /ugrave /uacute /ucircumflex + /udieresis /yacute /thorn /ydieresis +256 packedarray def +} ifelse + +/reencodeFontISO { %def + dup + length 5 add dict % Make a new font (a new dict + % the same size as the old + % one) with room for our new + % symbols. + + begin % Make the new font the + % current dictionary. + + + { 1 index /FID ne + { def } { pop pop } ifelse + } forall % Copy each of the symbols + % from the old dictionary to + % the new except for the font + % ID. + + /Encoding ISOLatin1Encoding def % Override the encoding with + % the ISOLatin1 encoding. + + % Use the font's bounding box to determine the ascent, descent, + % and overall height; don't forget that these values have to be + % transformed using the font's matrix. + FontBBox + FontMatrix transform /Ascent exch def pop + FontMatrix transform /Descent exch def pop + /FontHeight Ascent Descent sub def + + % Define these in case they're not in the FontInfo (also, here + % they're easier to get to. + /UnderlinePosition 1 def + /UnderlineThickness 1 def + + % Get the underline position and thickness if they're defined. + currentdict /FontInfo known { + FontInfo + + dup /UnderlinePosition known { + dup /UnderlinePosition get + 0 exch FontMatrix transform exch pop + /UnderlinePosition exch def + } if -;; If argument FILENAME is nil, send the image to the printer; if -;; FILENAME is a string, save the PostScript image in that filename; -;; if FILENAME is a number, prompt the user for the name of the file -;; to save in. + dup /UnderlineThickness known { + /UnderlineThickness get + 0 exch FontMatrix transform exch pop + /UnderlineThickness exch def + } if + + } if + + currentdict % Leave the new font on the + % stack + + end % Stop using the font as the + % current dictionary. + + definefont % Put the font into the font + % dictionary + + pop % Discard the returned font. +} bind def + +/Font { + findfont exch scalefont reencodeFontISO +} def + +/F { % Font select + findfont + dup /Ascent get /Ascent exch def + dup /Descent get /Descent exch def + dup /FontHeight get /LineHeight exch def + dup /UnderlinePosition get /UnderlinePosition exch def + dup /UnderlineThickness get /UnderlineThickness exch def + setfont +} def + +/FG /setrgbcolor load def + +/bg false def +/BG { + dup /bg exch def + { mark 4 1 roll ] /bgcolor exch def } if +} def + +/dobackground { % width -- + currentpoint + gsave + newpath + moveto + 0 Ascent rmoveto + dup 0 rlineto + 0 Descent Ascent sub rlineto + neg 0 rlineto + closepath + bgcolor aload pop setrgbcolor + fill + grestore +} def - (setq filename (ps-preprint filename)) - (ps-do-despool filename)) +/dobackgroundstring { % string -- + stringwidth pop + dobackground +} def + +/dounderline { % fromx fromy -- + currentpoint + gsave + UnderlineThickness setlinewidth + 4 2 roll + UnderlinePosition add moveto + UnderlinePosition add lineto + stroke + grestore +} def + +/eolbg { + currentpoint pop + PrintWidth LeftMargin add exch sub dobackground +} def + +/eolul { + currentpoint exch pop + PrintWidth LeftMargin add exch dounderline +} def + +/SL { % Soft Linefeed + bg { eolbg } if + ul { eolul } if + currentpoint LineHeight sub LeftMargin exch moveto pop +} def -;; Here end the definitions that users need to know about; proceed -;; further at your own risk! -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +/HL /SL load def % Hard Linefeed + +/sp1 { currentpoint 3 -1 roll } def + +% Some debug +/dcp { currentpoint exch 40 string cvs print (, ) print = } def +/dp { print 2 copy + exch 40 string cvs print (, ) print = } def + +/S { + bg { dup dobackgroundstring } if + ul { sp1 } if + show + ul { dounderline } if +} def + +/W { + ul { sp1 } if + ( ) stringwidth % Get the width of a space + pop % Discard the Y component + mul % Multiply the width of a + % space by the number of + % spaces to plot + bg { dup dobackground } if + 0 rmoveto + ul { dounderline } if +} def + +/BeginDSCPage { + /vmstate save def +} def -(defun ps-kill-emacs-check () - (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name)) - (buffer-modified-p ps-buffer)) - (if (y-or-n-p "Unprinted PostScript waiting... print now? ") - (ps-despool))) +/BeginPage { + PrintHeader { + PrintHeaderFrame { HeaderFrame } if + HeaderText + } if + LeftMargin + BottomMargin PrintHeight add + moveto % move to where printing will + % start. +} def + +/EndPage { + bg { eolbg } if + ul { eolul } if + showpage % Spit out a page +} def + +/EndDSCPage { + vmstate restore +} def + +/ul false def + +/UL { /ul exch def } def + +/h0 14 /Helvetica-Bold Font +/h1 12 /Helvetica Font + +/h1 F + +/HeaderLineHeight LineHeight def +/HeaderDescent Descent def +/HeaderPad 2 def + +/SetHeaderLines { + /HeaderOffset TopMargin 2 div def + /HeaderLines exch def + /HeaderHeight HeaderLines HeaderLineHeight mul HeaderPad 2 mul add def + /PrintHeight PrintHeight HeaderHeight sub def +} def + +/HeaderFrameStart { + LeftMargin BottomMargin PrintHeight add HeaderOffset add +} def + +/HeaderFramePath { + PrintWidth 0 rlineto + 0 HeaderHeight rlineto + PrintWidth neg 0 rlineto + 0 HeaderHeight neg rlineto +} def + +/HeaderFrame { + gsave + 0.4 setlinewidth + HeaderFrameStart moveto + 1 -1 rmoveto + HeaderFramePath + 0 setgray fill + HeaderFrameStart moveto + HeaderFramePath + gsave 0.9 setgray fill grestore + gsave 0 setgray stroke grestore + grestore +} def + +/HeaderStart { + HeaderFrameStart + exch HeaderPad add exch + HeaderLineHeight HeaderLines 1 sub mul add HeaderDescent sub HeaderPad add +} def + +/strcat { + dup length 3 -1 roll dup length dup 4 -1 roll add string dup + 0 5 -1 roll putinterval + dup 4 2 roll exch putinterval +} def + +/pagenumberstring { + PageNumber 32 string cvs + ShowNofN { + (/) strcat + PageCount 32 string cvs strcat + } if +} def + +/HeaderText { + HeaderStart moveto + + HeaderLinesRight HeaderLinesLeft + Duplex PageNumber 1 and 0 eq and { exch } if + + { + aload pop + exch F + gsave + dup xcheck { exec } if + show + grestore + 0 HeaderLineHeight neg rmoveto + } forall + + HeaderStart moveto + + { + aload pop + exch F + gsave + dup xcheck { exec } if + dup stringwidth pop + PrintWidth exch sub HeaderPad 2 mul sub 0 rmoveto + show + grestore + 0 HeaderLineHeight neg rmoveto + } forall +} def - (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name)) - (buffer-modified-p ps-buffer)) - (if (yes-or-no-p "Unprinted PostScript waiting; exit anyway? ") - nil - (error "Unprinted PostScript")))) +/ReportFontInfo { + 2 copy + /t0 3 1 roll Font + /t0 F + /lh LineHeight def + /sw ( ) stringwidth pop def + /aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch + stringwidth pop exch div def + /t1 12 /Helvetica-Oblique Font + /t1 F + 72 72 moveto + gsave + (For ) show + 128 string cvs show + ( ) show + 32 string cvs show + ( point, the line height is ) show + lh 32 string cvs show + (, the space width is ) show + sw 32 string cvs show + (,) show + grestore + 0 LineHeight neg rmoveto + (and a crude estimate of average character width is ) show + aw 32 string cvs show + (.) show + showpage +} def + +% 10 /Courier ReportFontInfo +") + +;; Start Editing Here: + +(defvar ps-source-buffer nil) +(defvar ps-spool-buffer-name "*PostScript*") +(defvar ps-spool-buffer nil) + +(defvar ps-output-head nil) +(defvar ps-output-tail nil) + +(defvar ps-page-count 0) +(defvar ps-showpage-count 0) + +(defvar ps-current-font 0) +(defvar ps-current-underline-p nil) +(defvar ps-default-color (if ps-print-color-p ps-default-fg)) ; black +(defvar ps-current-color ps-default-color) +(defvar ps-current-bg nil) + +(defvar ps-razchunk 0) + +(defvar ps-color-format (if (eq emacs-type 'fsf) + + ;;Emacs understands the %f format; we'll + ;;use it to limit color RGB values to + ;;three decimals to cut down some on the + ;;size of the PostScript output. + "%0.3f %0.3f %0.3f" + + ;; Lucid emacsen will have to make do with + ;; %s (princ) for floats. + "%s %s %s")) -(if (fboundp 'add-hook) - (add-hook 'kill-emacs-hook 'ps-kill-emacs-check) - (if kill-emacs-hook - (message "Won't override existing kill-emacs-hook.") - (setq kill-emacs-hook 'ps-kill-emacs-check))) +;; These values determine how much print-height to deduct when headers +;; are turned on. This is a pretty clumsy way of handling it, but +;; it'll do for now. +(defvar ps-header-title-line-height (if (fboundp 'float) 16.0 16));Helvetica 14 +(defvar ps-header-line-height (if (fboundp 'float) 13.7 14));Helvetica 12 +(defvar ps-header-pad 2) + +;; LetterSmall 7.68 inch 10.16 inch +;; Tabloid 11.0 inch 17.0 inch +;; Ledger 17.0 inch 11.0 inch +;; Statement 5.5 inch 8.5 inch +;; Executive 7.5 inch 10.0 inch +;; A3 11.69 inch 16.5 inch +;; A4Small 7.47 inch 10.85 inch +;; B4 10.125 inch 14.33 inch +;; B5 7.16 inch 10.125 inch + +;; All page dimensions are in PostScript points. + +(defvar ps-left-margin 72) ; 1 inch +(defvar ps-right-margin 72) ; 1 inch +(defvar ps-bottom-margin 36) ; 1/2 inch +(defvar ps-top-margin 72) ; 1 inch + +;; Letter 8.5 inch x 11.0 inch +(defvar ps-letter-page-height 792) ; 11 inches +(defvar ps-letter-page-width 612) ; 8.5 inches + +;; Legal 8.5 inch x 14.0 inch +(defvar ps-legal-page-height 1008) ; 14.0 inches +(defvar ps-legal-page-width 612) ; 8.5 inches -(defun ps-preprint (&optional filename) +;; A4 8.26 inch x 11.69 inch +(defvar ps-a4-page-height 842) ; 11.69 inches +(defvar ps-a4-page-width 595) ; 8.26 inches + +(defvar ps-pages-alist + (list (list 'ps-letter ps-letter-page-width ps-letter-page-height) + (list 'ps-legal ps-legal-page-width ps-legal-page-height) + (list 'ps-a4 ps-a4-page-width ps-a4-page-height))) + +;; Define some constants to index into the page lists. +(defvar ps-page-width-i 1) +(defvar ps-page-height-i 2) + +(defvar ps-page-dimensions nil) +(defvar ps-print-width nil) +(defvar ps-print-height nil) + +(defvar ps-height-remaining) +(defvar ps-width-remaining) + +(defvar ps-ref-bold-faces nil) +(defvar ps-ref-italic-faces nil) +(defvar ps-ref-underlined-faces nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Internal functions + +(defun ps-get-page-dimensions () + (setq ps-page-dimensions (assq ps-paper-type ps-pages-alist)) + (let ((ps-page-width (nth ps-page-width-i ps-page-dimensions)) + (ps-page-height (nth ps-page-height-i ps-page-dimensions))) + (setq ps-print-height (- ps-page-height ps-top-margin ps-bottom-margin)) + (setq ps-print-width (- ps-page-width ps-left-margin ps-right-margin)))) + +(defun ps-print-preprint (&optional filename) (if (and filename (or (numberp filename) (listp filename))) - (setq filename - (let* ((name (concat (buffer-name) ".ps")) - (prompt (format "Save PostScript to file: (default %s) " - name))) - (read-file-name prompt default-directory - name nil))))) + (let* ((name (concat (buffer-name) ".ps")) + (prompt (format "Save PostScript to file: (default %s) " + name))) + (read-file-name prompt default-directory + name nil)))) + +;; The following functions implement a simple list-buffering scheme so +;; that ps-print doesn't have to repeatedly switch between buffers +;; while spooling. The functions ps-output and ps-output-string build +;; up the lists; the function ps-flush-output takes the lists and +;; insert its contents into the spool buffer (*PostScript*). + +(defun ps-output-string-prim (string) + (insert "(") ;insert start-string delimiter + (save-excursion ;insert string + (insert string)) + + ;; Find and quote special characters as necessary for PS + (while (re-search-forward "[()\\]" nil t) + (save-excursion + (forward-char -1) + (insert "\\"))) -(defvar ps-spool-buffer-name "*PostScript*") + (goto-char (point-max)) + (insert ")")) ;insert end-string delimiter + +(defun ps-init-output-queue () + (setq ps-output-head (list "")) + (setq ps-output-tail ps-output-head)) + +(defun ps-output (&rest args) + (setcdr ps-output-tail args) + (while (cdr ps-output-tail) + (setq ps-output-tail (cdr ps-output-tail)))) -(defvar ps-col 0) -(defvar ps-row 0) -(defvar ps-xpos 0) -(defvar ps-ypos 0) +(defun ps-output-string (string) + (ps-output t string)) + +(defun ps-flush-output () + (save-excursion + (set-buffer ps-spool-buffer) + (goto-char (point-max)) + (while ps-output-head + (let ((it (car ps-output-head))) + (if (not (eq t it)) + (insert it) + (setq ps-output-head (cdr ps-output-head)) + (ps-output-string-prim (car ps-output-head)))) + (setq ps-output-head (cdr ps-output-head)))) + (ps-init-output-queue)) -(defvar ps-chars-per-line 80) -(defvar ps-lines-per-page 66) +(defun ps-insert-file (fname) + (ps-flush-output) + + ;; Check to see that the file exists and is readable; if not, throw + ;; and error. + (if (not (file-readable-p fname)) + (error "Could not read file `%s'" fname)) -(defvar ps-page-start-ypos 745) -(defvar ps-line-start-xpos 40) + (save-excursion + (set-buffer ps-spool-buffer) + (goto-char (point-max)) + (insert-file fname))) + +;; These functions insert the arrays that define the contents of the +;; headers. + +(defun ps-generate-header-line (fonttag &optional content) + (ps-output " [ " fonttag " ") + (cond + ;; Literal strings should be output as is -- the string must + ;; contain its own PS string delimiters, '(' and ')', if necessary. + ((stringp content) + (ps-output content)) -(defvar ps-char-xpos-inc 6) -(defvar ps-line-ypos-inc 11) + ;; Functions are called -- they should return strings; they will be + ;; inserted as strings and the PS string delimiters added. + ((and (symbolp content) (fboundp content)) + (ps-output-string (funcall content))) + + ;; Variables will have their contents inserted. They should + ;; contain strings, and will be inserted as strings. + ((and (symbolp content) (boundp content)) + (ps-output-string (symbol-value content))) -(defvar ps-current-font 0) + ;; Anything else will get turned into an empty string. + (t + (ps-output-string ""))) + (ps-output " ]\n")) -(defvar ps-multiple nil) -(defvar ps-virtual-page-number 0) +(defun ps-generate-header (name contents) + (ps-output "/" name " [\n") + (if (> ps-header-lines 0) + (let ((count 1)) + (ps-generate-header-line "/h0" (car contents)) + (while (and (< count ps-header-lines) + (setq contents (cdr contents))) + (ps-generate-header-line "/h1" (car contents)) + (setq count (+ count 1))) + (ps-output "] def\n")))) + +(defun ps-output-boolean (name bool) + (ps-output (format "/%s %s def\n" name (if bool "true" "false")))) (defun ps-begin-file () - (save-excursion - (set-buffer ps-output-buffer) - (goto-char (point-min)) - (setq ps-real-page-number 1) - (insert -"%!PS-Adobe-1.0 + (setq ps-showpage-count 0) -/S /show load def -/M /moveto load def -/L { gsave newpath 3 1 roll 1 sub M 0 rlineto closepath stroke grestore } def - -/F{$fd exch get setfont}def + (ps-output ps-adobe-tag) + (ps-output "%%Title: " (buffer-name) "\n") ;Take job name from name of + ;first buffer printed + (ps-output "%%Creator: " (user-full-name) "\n") + (ps-output "%%CreationDate: " + (time-stamp-hh:mm:ss) " " (time-stamp-mon-dd-yyyy) "\n") + (ps-output "%% DocumentFonts: Helvetica Helvetica-Bold " + ps-font " " ps-font-bold " " ps-font-italic " " + ps-font-bold-italic "\n") + (ps-output "%%Pages: (atend)\n") + (ps-output "%%EndComments\n\n") -/StartPage{/svpg save def}def -/EndPage{svpg restore showpage}def + (ps-output-boolean "Duplex" ps-spool-duplex) + (ps-output-boolean "PrintHeader" ps-print-header) + (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame) + (ps-output-boolean "ShowNofN" ps-show-n-of-n) -/SetUpFonts - {dup/$fd exch array def{findfont exch scalefont $fd 3 1 roll put}repeat}def + (ps-output (format "/LeftMargin %d def\n" ps-left-margin)) + (ps-output (format "/RightMargin %d def\n" ps-right-margin)) + (ps-output (format "/BottomMargin %d def\n" ps-bottom-margin)) + (ps-output (format "/TopMargin %d def\n" ps-top-margin)) -% Define /ISOLatin1Encoding only if it's not already there. -/ISOLatin1Encoding where { pop save true }{ false } ifelse -/ISOLatin1Encoding [ StandardEncoding 0 45 getinterval aload pop /minus - StandardEncoding 46 98 getinterval aload pop /dotlessi /grave /acute - /circumflex /tilde /macron /breve /dotaccent /dieresis /.notdef /ring - /cedilla /.notdef /hungarumlaut /ogonek /caron /space /exclamdown /cent - /sterling /currency /yen /brokenbar /section /dieresis /copyright - /ordfeminine /guillemotleft /logicalnot /hyphen /registered /macron - /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph - /periodcentered /cedilla /onesuperior /ordmasculine /guillemotright - /onequarter /onehalf /threequarters /questiondown /Agrave /Aacute - /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla /Egrave /Eacute - /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex /Idieresis /Eth - /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply - /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn - /germandbls /agrave /aacute /acircumflex /atilde /adieresis /aring /ae - /ccedilla /egrave /eacute /ecircumflex /edieresis /igrave /iacute - /icircumflex /idieresis /eth /ntilde /ograve /oacute /ocircumflex - /otilde /odieresis /divide /oslash /ugrave /uacute /ucircumflex - /udieresis /yacute /thorn /ydieresis ] def -{ restore } if + (ps-get-page-dimensions) + (ps-output (format "/PrintWidth %d def\n" ps-print-width)) + (ps-output (format "/PrintHeight %d def\n" ps-print-height)) + + (ps-output ps-print-prologue) + + (ps-output (format "/f0 %d /%s Font\n" ps-font-size ps-font)) + (ps-output (format "/f1 %d /%s Font\n" ps-font-size ps-font-bold)) + (ps-output (format "/f2 %d /%s Font\n" ps-font-size ps-font-italic)) + (ps-output (format "/f3 %d /%s Font\n" ps-font-size + ps-font-bold-italic)) + + (ps-output "%%EndPrologue\n")) -/reencodeISO { %def - findfont dup length dict begin - { 1 index /FID ne { def }{ pop pop } ifelse } forall - /Encoding ISOLatin1Encoding def - currentdict end definefont pop -} bind def +(defun ps-header-dirpart () + (let ((fname (buffer-file-name))) + (if fname + (if (string-equal (buffer-name) (file-name-nondirectory fname)) + (file-name-directory fname) + fname) + ""))) -/CourierISO /Courier reencodeISO -/Courier-ObliqueISO /Courier-Oblique reencodeISO -/Courier-BoldISO /Courier-Bold reencodeISO -/Courier-BoldObliqueISO /Courier-BoldOblique reencodeISO +(defun ps-get-buffer-name () + ;; Indulge me this little easter egg: + (if (string= (buffer-name) "ps-print.el") + "Hey, Cool! It's ps-print.el!!!" + (buffer-name))) -3 10 /Courier-BoldObliqueISO -2 10 /Courier-ObliqueISO -1 10 /Courier-BoldISO -0 10 /CourierISO -4 SetUpFonts - -.4 setlinewidth -"))) +(defun ps-begin-job () + (setq ps-page-count 0)) (defun ps-end-file () - ) + (ps-output "%%Trailer\n") + (ps-output "%%Pages: " (format "%d\n" ps-showpage-count))) (defun ps-next-page () (ps-end-page) - (ps-begin-page) - (ps-set-font ps-current-font) - (ps-init-page)) + (ps-flush-output) + (ps-begin-page)) + +(defun ps-begin-page (&optional dummypage) + (ps-get-page-dimensions) + (setq ps-width-remaining ps-print-width) + (setq ps-height-remaining ps-print-height) -(defun ps-top-of-page () (ps-next-page)) + ;; If headers are turned on, deduct the height of the header from + ;; the print height remaining. Clumsy clumsy clumsy. + (if ps-print-header + (setq ps-height-remaining + (- ps-height-remaining + ps-header-title-line-height + (* ps-header-line-height (- ps-header-lines 1)) + (* 2 ps-header-pad)))) -(defun ps-init-page () - (setq ps-row 0) - (setq ps-col 0) - (setq ps-ypos ps-page-start-ypos) - (setq ps-xpos ps-line-start-xpos) - (ps-set-font)) + (setq ps-page-count (+ ps-page-count 1)) + + (ps-output "\n%%Page: " + (format "%d %d\n" ps-page-count (+ 1 ps-showpage-count))) + (ps-output "BeginDSCPage\n") + (ps-output (format "/PageNumber %d def\n" ps-page-count)) + (ps-output "/PageCount 0 def\n") -(defun ps-begin-page () - (save-excursion - (set-buffer ps-output-buffer) - (goto-char (point-max)) - (insert (format "%%%%Page: ? %d\n" ps-real-page-number)) - (setq ps-real-page-number (+ 1 ps-real-page-number)) - (insert "StartPage\n0.4 setlinewidth\n"))) + (if ps-print-header + (progn + (ps-generate-header "HeaderLinesLeft" ps-left-header) + (ps-generate-header "HeaderLinesRight" ps-right-header) + (ps-output (format "%d SetHeaderLines\n" ps-header-lines)))) + + (ps-output "BeginPage\n") + (ps-set-font ps-current-font) + (ps-set-bg ps-current-bg) + (ps-set-color ps-current-color) + (ps-set-underline ps-current-underline-p)) (defun ps-end-page () - (save-excursion - (set-buffer ps-output-buffer) - (goto-char (point-max)) - (insert "EndPage\n"))) + (setq ps-showpage-count (+ 1 ps-showpage-count)) + (ps-output "EndPage\n") + (ps-output "EndDSCPage\n")) +(defun ps-dummy-page () + (setq ps-showpage-count (+ 1 ps-showpage-count)) + (ps-output "%%Page: " (format "- %d\n" ps-showpage-count) + "BeginDSCPage +/PrintHeader false def +BeginPage +EndPage +EndDSCPage\n")) + (defun ps-next-line () - (setq ps-row (+ ps-row 1)) - (if (>= ps-row ps-lines-per-page) + (if (< ps-height-remaining ps-line-height) (ps-next-page) - (setq ps-col 0) - (setq ps-xpos ps-line-start-xpos) - (setq ps-ypos (- ps-ypos ps-line-ypos-inc)))) + (setq ps-width-remaining ps-print-width) + (setq ps-height-remaining (- ps-height-remaining ps-line-height)) + (ps-hard-lf))) (defun ps-continue-line () - (ps-next-line)) + (if (< ps-height-remaining ps-line-height) + (ps-next-page) + (setq ps-width-remaining ps-print-width) + (setq ps-height-remaining (- ps-height-remaining ps-line-height)) + (ps-soft-lf))) -(defvar ps-source-buffer nil) -(defvar ps-output-buffer nil) +(defun ps-hard-lf () + (ps-output "HL\n")) -(defun ps-basic-plot-string (from to &optional underline-p) - (setq text (buffer-substring from to)) - (save-excursion - (set-buffer ps-output-buffer) - (goto-char (point-max)) - (setq count (- to from)) +(defun ps-soft-lf () + (ps-output "SL\n")) - (if underline-p - (insert (format "%d %d %d L\n" ps-xpos ps-ypos - (* count ps-char-xpos-inc)))) - - (insert (format "%d %d M (" ps-xpos ps-ypos)) - (save-excursion - (insert text)) +(defun ps-find-wrappoint (from to char-width) + (let ((avail (truncate (/ ps-width-remaining char-width))) + (todo (- to from))) + (if (< todo avail) + (cons to (* todo char-width)) + (cons (+ from avail) ps-width-remaining)))) - (while (re-search-forward "[()\\]" nil t) - (save-excursion - (forward-char -1) - (insert "\\"))) - - (end-of-line) - (insert ") S\n") +(defun ps-basic-plot-string (from to &optional bg-color) + (let* ((wrappoint (ps-find-wrappoint from to ps-avg-char-width)) + (to (car wrappoint)) + (string (buffer-substring from to))) + (ps-output-string string) + (ps-output " S\n") ; + wrappoint)) - (setq ps-xpos (+ ps-xpos (* count ps-char-xpos-inc))))) +(defun ps-basic-plot-whitespace (from to &optional bg-color) + (let* ((wrappoint (ps-find-wrappoint from to ps-space-width)) + (to (car wrappoint))) -(defun ps-basic-plot-whitespace (from to underline-p) - (setq count (- to from)) - (setq ps-xpos (+ ps-xpos (* count ps-char-xpos-inc)))) + (ps-output (format "%d W\n" (- to from))) + wrappoint)) -(defun ps-plot (plotfunc from to &optional underline-p) - +(defun ps-plot (plotfunc from to &optional bg-color) (while (< from to) - (setq count (- to from)) - ;; Test to see whether this region will fit on the current line - (if (<= (+ ps-col count) ps-chars-per-line) - (progn - ;; It fits; plot it. - (funcall plotfunc from to underline-p) - (setq from to)) - - ;; It needs to be wrapped; plot part of it, then loop - (setq chars-that-will-fit (- ps-chars-per-line ps-col)) - (funcall plotfunc from (+ from chars-that-will-fit)) - - (ps-continue-line) - - (setq from (+ from chars-that-will-fit)))) - + (let* ((wrappoint (funcall plotfunc from to bg-color)) + (plotted-to (car wrappoint)) + (plotted-width (cdr wrappoint))) + (setq from plotted-to) + (setq ps-width-remaining (- ps-width-remaining plotted-width)) + (if (< from to) + (ps-continue-line)))) (if ps-razzle-dazzle (let* ((q-todo (- (point-max) (point-min))) - (q-done (- to (point-min))) + (q-done (- (point) (point-min))) (chunkfrac (/ q-todo 8)) - (chunksize (if (> chunkfrac 10000) 10000 chunkfrac))) + (chunksize (if (> chunkfrac 1000) 1000 chunkfrac))) (if (> (- q-done ps-razchunk) chunksize) (progn (setq ps-razchunk q-done) (setq foo (if (< q-todo 100) - (* (/ q-done q-todo) 100) - (setq basis (/ q-todo 100)) - (/ q-done basis))) + (/ (* 100 q-done) q-todo) + (/ q-done (/ q-todo 100)))) + (message "Formatting...%d%%" foo)))))) + +(defun ps-set-font (font) + (setq ps-current-font font) + (ps-output (format "/f%d F\n" ps-current-font))) - (message "Formatting... %d%%" foo)))))) +(defvar ps-print-color-scale (if ps-print-color-p + (float (car (x-color-values "white"))) + 1.0)) + +(defun ps-set-bg (color) + (if (setq ps-current-bg color) + (ps-output (format ps-color-format (nth 0 color) (nth 1 color) + (nth 2 color)) + " true BG\n") + (ps-output "false BG\n"))) -(defun ps-set-font (&optional font) - (save-excursion - (set-buffer ps-output-buffer) - (goto-char (point-max)) - (insert (format "%d F\n" (if font font ps-current-font)))) - (if font - (setq ps-current-font font))) +(defun ps-set-color (color) + (if (setq ps-current-color color) + (ps-output (format ps-color-format (nth 0 ps-current-color) + (nth 1 ps-current-color) (nth 2 ps-current-color)) + " FG\n"))) + +(defun ps-set-underline (underline-p) + (ps-output (if underline-p "true" "false") " UL\n") + (setq ps-current-underline-p underline-p)) + +(defun ps-plot-region (from to font fg-color &optional bg-color underline-p) -(defun ps-plot-region (from to font &optional underline-p) + (if (not (equal font ps-current-font)) + (ps-set-font font)) + + ;; Specify a foreground color only if one's specified and it's + ;; different than the current. + (if (not (equal fg-color ps-current-color)) + (ps-set-color fg-color)) + + (if (not (equal bg-color ps-current-bg)) + (ps-set-bg bg-color)) + + ;; Toggle underlining if different. + (if (not (equal underline-p ps-current-underline-p)) + (ps-set-underline underline-p)) - (ps-set-font font) - + ;; Starting at the beginning of the specified region... (save-excursion (goto-char from) + + ;; ...break the region up into chunks separated by tabs, linefeeds, + ;; and pagefeeds, and plot each chunk. (while (< from to) - (if (re-search-forward "[\t\n\014]" to t) + (if (re-search-forward "[\t\n\f]" to t) (let ((match (char-after (match-beginning 0)))) (cond - ((= match ?\n) - (ps-plot 'ps-basic-plot-string from (- (point) 1) underline-p) - (ps-next-line)) + ((= match ?\t) + (let ((linestart + (save-excursion (beginning-of-line) (point)))) + (ps-plot 'ps-basic-plot-string from (- (point) 1) + bg-color) + (forward-char -1) + (setq from (+ linestart (current-column))) + (if (re-search-forward "[ \t]+" to t) + (ps-plot 'ps-basic-plot-whitespace + from (+ linestart (current-column)) + bg-color)))) - ((= match ?\t) - (ps-plot 'ps-basic-plot-string from (- (point) 1) underline-p) - (setq linestart (save-excursion (beginning-of-line) (point))) - (forward-char -1) - (setq from (+ linestart (current-column))) - (if (re-search-forward "[ \t]+" to t) - (ps-plot 'ps-basic-plot-whitespace from - (+ linestart (current-column))))) + ((= match ?\n) + (ps-plot 'ps-basic-plot-string from (- (point) 1) + bg-color) + (ps-next-line) + ) - ((= match ?\014) - (ps-plot 'ps-basic-plot-string from (- (point) 1) underline-p) - (ps-top-of-page))) + ((= match ?\f) + (ps-plot 'ps-basic-plot-string from (- (point) 1) + bg-color) + (ps-next-page))) (setq from (point))) - - (ps-plot 'ps-basic-plot-string from to underline-p) + (ps-plot 'ps-basic-plot-string from to bg-color) (setq from to))))) -(defun ps-format-buffer () - (interactive) +(defun ps-color-value (x-color-value) + ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval. + (/ x-color-value ps-print-color-scale)) - (setq ps-source-buffer (current-buffer)) - (setq ps-output-buffer (get-buffer-create "%PostScript%")) +(defun ps-plot-with-face (from to face) + (if face + (let* ((bold-p (memq face ps-ref-bold-faces)) + (italic-p (memq face ps-ref-italic-faces)) + (underline-p (memq face ps-ref-underlined-faces)) + (foreground (face-foreground face)) + (background (face-background face)) + (fg-color (if (and ps-print-color-p foreground) + (mapcar 'ps-color-value + (x-color-values foreground)) + ps-default-color)) + (bg-color (if (and ps-print-color-p background) + (mapcar 'ps-color-value + (x-color-values background))))) + (ps-plot-region from to + (cond ((and bold-p italic-p) 3) + (italic-p 2) + (bold-p 1) + (t 0)) +; (or fg-color '(0.0 0.0 0.0)) + fg-color + bg-color underline-p)) + (goto-char to))) - (save-excursion - (set-buffer ps-output-buffer) - (delete-region (point-max) (point-min))) + +(defun ps-fsf-face-kind-p (face kind kind-regex kind-list) + (let ((frame-font (face-font face)) + (face-defaults (face-font face t))) + (or + ;; Check FACE defaults: + (and (listp face-defaults) + (memq kind face-defaults)) + + ;; Check the user's preferences + (memq face kind-list)))) + +(defun ps-xemacs-face-kind-p (face kind kind-regex kind-list) + (let* ((frame-font (or (face-font face) (face-font 'default))) + (kind-cons (assq kind (x-font-properties frame-font))) + (kind-spec (cdr-safe kind-cons)) + (case-fold-search t)) - (ps-begin-file) - (ps-begin-page) - (ps-init-page) + (or (and kind-spec (string-match kind-regex kind-spec)) + ;; Kludge-compatible: + (memq face kind-list)))) + +(defun ps-face-bold-p (face) + (if (eq emacs-type 'fsf) + (ps-fsf-face-kind-p face 'bold "-\\(bold\\|demibold\\)-" + ps-bold-faces) + (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold" + ps-bold-faces))) + +(defun ps-face-italic-p (face) + (if (eq emacs-type 'fsf) + (ps-fsf-face-kind-p face 'italic "-[io]-" ps-italic-faces) + (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o" ps-italic-faces))) + +(defun ps-face-underlined-p (face) + (or (face-underline-p face) + (memq face ps-underlined-faces))) - (ps-plot-region (point-min) (point-max) 0) +(defun ps-faces-list () + (if (or (eq emacs-type 'lucid) (eq emacs-type 'xemacs)) + (list-faces) + (face-list))) - (ps-end-page) - (ps-end-file) - ) +(defun ps-build-reference-face-lists () + (if ps-auto-font-detect + (let ((faces (ps-faces-list)) + the-face) + (setq ps-ref-bold-faces nil + ps-ref-italic-faces nil + ps-ref-underlined-faces nil) + (while faces + (setq the-face (car faces)) + (if (ps-face-italic-p the-face) + (setq ps-ref-italic-faces + (cons the-face ps-ref-italic-faces))) + (if (ps-face-bold-p the-face) + (setq ps-ref-bold-faces + (cons the-face ps-ref-bold-faces))) + (if (ps-face-underlined-p the-face) + (setq ps-ref-underlined-faces + (cons the-face ps-ref-underlined-faces))) + (setq faces (cdr faces)))) + (setq ps-ref-bold-faces ps-bold-faces) + (setq ps-ref-italic-faces ps-italic-faces) + (setq ps-ref-underlined-faces ps-underlined-faces)) + (setq ps-build-face-reference nil)) (defun ps-mapper (extent list) (nconc list (list (list (extent-start-position extent) 'push extent) @@ -757,42 +1612,21 @@ (defun ps-sorter (a b) (< (car a) (car b))) - -(defun ps-extent-sorter (a b) - (< (extent-priority a) (extent-priority b))) - -(defun overlay-priority (p) - (if (setq priority (overlay-get p 'priority)) priority 0)) - -(defun ps-overlay-sorter (a b) - (> (overlay-priority a) (overlay-priority b))) - -(defun ps-plot-with-face (from to face) - - (setq bold-p (memq face ps-bold-faces)) - (setq italic-p (memq face ps-italic-faces)) - (setq underline-p (memq face ps-underline-faces)) - - (cond - ((and bold-p italic-p) - (ps-plot-region from to 3 underline-p)) - (italic-p - (ps-plot-region from to 2 underline-p)) - (bold-p - (ps-plot-region from to 1 underline-p)) - (t - (ps-plot-region from to 0 underline-p)))) - - + (defun ps-generate-postscript-with-faces (from to) - + (if (or ps-always-build-face-reference + ps-build-face-reference) + (progn + (message "Collecting face information...") + (ps-build-reference-face-lists))) (save-restriction (narrow-to-region from to) - (setq face 'default) - - (cond ((string-match "Lucid" emacs-version) + (let ((face 'default) + (position to)) + (cond ((or (eq emacs-type 'lucid) (eq emacs-type 'xemacs)) ;; Build the list of extents... - (let ((a (cons 'dummy nil))) + (let ((a (cons 'dummy nil)) + record type extent extent-list) (map-extents 'ps-mapper nil from to a) (setq a (cdr a)) (setq a (sort a 'ps-sorter)) @@ -831,132 +1665,278 @@ (setq from position) (setq a (cdr a))))) - ((string-match "^19" emacs-version) - - (while (< from to) - - (setq prop-position - (if (setq p (next-property-change from)) - (if (> p to) to p) - to)) - - (setq over-position - (if (setq p (next-overlay-change from)) - (if (> p to) to p) - to)) - - (setq position - (if (< prop-position over-position) - prop-position - over-position)) - - (setq face - (if (setq f (get-text-property from 'face)) f 'default)) - - (if (setq overlays (overlays-at from)) - (progn - (setq overlays (sort overlays 'ps-overlay-sorter)) + ((eq emacs-type 'fsf) + (let ((property-change from) + (overlay-change from)) + (while (< from to) + (if (< property-change to) ; Don't search for property change + ; unless previous search succeeded. + (setq property-change + (next-property-change from nil to))) + (if (< overlay-change to) ; Don't search for overlay change + ; unless previous search succeeded. + (setq overlay-change + (min (next-overlay-change from) to))) + (setq position + (min property-change overlay-change)) + (setq face + (cond ((get-text-property from 'invisible) nil) + ((get-text-property from 'face)) + (t 'default))) + (let ((overlays (overlays-at from)) + (face-priority -1)) ; text-property (while overlays - (if (setq face (overlay-get (car overlays) 'face)) - (setq overlays nil) - (setq overlays (cdr overlays)))))) - - ;; Plot up to this record. - (ps-plot-with-face from position face) - - (setq from position)))) - - (ps-plot-with-face from to face))) + (let* ((overlay (car overlays)) + (overlay-face (overlay-get overlay 'face)) + (overlay-invisible (overlay-get overlay 'invisible)) + (overlay-priority (or (overlay-get overlay + 'priority) + 0))) + (if (and (or overlay-invisible overlay-face) + (> overlay-priority face-priority)) + (setq face (cond (overlay-invisible nil) + ((and face overlay-face))) + face-priority overlay-priority))) + (setq overlays (cdr overlays)))) + ;; Plot up to this record. + (ps-plot-with-face from position face) + (setq from position))))) + (ps-plot-with-face from to face)))) (defun ps-generate-postscript (from to) - (ps-plot-region from to 0)) + (ps-plot-region from to 0 nil)) (defun ps-generate (buffer from to genfunc) - (save-restriction (narrow-to-region from to) (if ps-razzle-dazzle - (message "Formatting... %d%%" (setq ps-razchunk 0))) - + (message "Formatting...%d%%" (setq ps-razchunk 0))) (set-buffer buffer) (setq ps-source-buffer buffer) - (setq ps-output-buffer (get-buffer-create ps-spool-buffer-name)) + (setq ps-spool-buffer (get-buffer-create ps-spool-buffer-name)) + (ps-init-output-queue) + (let (safe-marker completed-safely needs-begin-file) + (unwind-protect + (progn + (set-buffer ps-spool-buffer) + + ;; Get a marker and make it point to the current end of the + ;; buffer, If an error occurs, we'll delete everything from + ;; the end of this marker onwards. + (setq safe-marker (make-marker)) + (set-marker safe-marker (point-max)) + + (goto-char (point-min)) + (if (looking-at (regexp-quote "%!PS-Adobe-1.0")) + nil + (setq needs-begin-file t)) + (save-excursion + (set-buffer ps-source-buffer) + (if needs-begin-file (ps-begin-file)) + (ps-begin-job) + (ps-begin-page)) + (set-buffer ps-source-buffer) + (funcall genfunc from to) + (ps-end-page) + + (if (and ps-spool-duplex + (= (mod ps-page-count 2) 1)) + (ps-dummy-page)) + (ps-flush-output) + + ;; Back to the PS output buffer to set the page count + (set-buffer ps-spool-buffer) + (goto-char (point-max)) + (while (re-search-backward "^/PageCount 0 def$" nil t) + (replace-match (format "/PageCount %d def" ps-page-count) t)) - (unwind-protect - (progn - - (set-buffer ps-output-buffer) - (goto-char (point-min)) - (if (looking-at (regexp-quote "%!PS-Adobe-1.0")) - (ps-set-font ps-current-font) - (ps-begin-file)) - (ps-begin-page) - (ps-init-page) - - (goto-char (point-max)) - (if (and ps-spool-duplex - (re-search-backward "^%%Page") - (looking-at "^%%Page.*[24680]$")) - (ps-next-page)) - - (set-buffer ps-source-buffer) - (funcall genfunc from to) + ;; Setting this variable tells the unwind form that the + ;; the postscript was generated without error. + (setq completed-safely t)) - (ps-end-page))) + ;; Unwind form: If some bad mojo ocurred while generating + ;; postscript, delete all the postscript that was generated. + ;; This protects the previously spooled files from getting + ;; corrupted. + (if (and (markerp safe-marker) (not completed-safely)) + (progn + (set-buffer ps-spool-buffer) + (delete-region (marker-position safe-marker) (point-max)))))) (if ps-razzle-dazzle - (message "Formatting... Done.")))) + (message "Formatting...done")))) (defun ps-do-despool (filename) - - (if (or (not (boundp 'ps-output-buffer)) - (not ps-output-buffer)) - (message "No spooled PostScript to print.") - + (if (or (not (boundp 'ps-spool-buffer)) + (not ps-spool-buffer)) + (message "No spooled PostScript to print") (ps-end-file) - + (ps-flush-output) (if filename (save-excursion (if ps-razzle-dazzle (message "Saving...")) - - (set-buffer ps-output-buffer) + (set-buffer ps-spool-buffer) (setq filename (expand-file-name filename)) (write-region (point-min) (point-max) filename) - (if ps-razzle-dazzle (message "Wrote %s" filename))) - ;; Else, spool to the printer (if ps-razzle-dazzle (message "Printing...")) - (save-excursion - (set-buffer ps-output-buffer) + (set-buffer ps-spool-buffer) (apply 'call-process-region (point-min) (point-max) ps-lpr-command nil 0 nil ps-lpr-switches)) + (if ps-razzle-dazzle + (message "Printing...done"))) + (kill-buffer ps-spool-buffer))) - (if ps-razzle-dazzle - (message "Printing... Done."))) +(defun ps-kill-emacs-check () + (let (ps-buffer) + (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name)) + (buffer-modified-p ps-buffer)) + (if (y-or-n-p "Unprinted PostScript waiting; print now? ") + (ps-despool))) + (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name)) + (buffer-modified-p ps-buffer)) + (if (yes-or-no-p "Unprinted PostScript waiting; exit anyway? ") + nil + (error "Unprinted PostScript"))))) + +(if (fboundp 'add-hook) + (add-hook 'kill-emacs-hook 'ps-kill-emacs-check) + (if kill-emacs-hook + (message "Won't override existing kill-emacs-hook") + (setq kill-emacs-hook 'ps-kill-emacs-check))) + +;;; Sample Setup Code: + +;; This stuff is for anybody that's brave enough to look this far, +;; and able to figure out how to use it. It isn't really part of ps- +;; print, but I'll leave it here in hopes it might be useful: + +;; Look in an article or mail message for the Subject: line. To be +;; placed in ps-left-headers. +(defun ps-article-subject () + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^Subject:[ \t]+\\(.*\\)$") + (buffer-substring (match-beginning 1) (match-end 1)) + "Subject ???"))) - (kill-buffer ps-output-buffer))) +;; Look in an article or mail message for the From: line. Sorta-kinda +;; understands RFC-822 addresses and can pull the real name out where +;; it's provided. To be placed in ps-left-headers. +(defun ps-article-author () + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "^From:[ \t]+\\(.*\\)$") + (let ((fromstring (buffer-substring (match-beginning 1) (match-end 1)))) + (cond + + ;; Try first to match addresses that look like + ;; thompson@wg2.waii.com (Jim Thompson) + ((string-match ".*[ \t]+(\\(.*\\))" fromstring) + (substring fromstring (match-beginning 1) (match-end 1))) + + ;; Next try to match addresses that look like + ;; Jim Thompson <thompson@wg2.waii.com> + ((string-match "\\(.*\\)[ \t]+<.*>" fromstring) + (substring fromstring (match-beginning 1) (match-end 1))) + + ;; Couldn't find a real name -- show the address instead. + (t fromstring))) + "From ???"))) + +;; A hook to bind to gnus-Article-prepare-hook. This will set the ps- +;; left-headers specially for gnus articles. Unfortunately, gnus- +;; article-mode-hook is called only once, the first time the *Article* +;; buffer enters that mode, so it would only work for the first time +;; we ran gnus. The second time, this hook wouldn't get set up. The +;; only alternative is gnus-article-prepare-hook. +(defun ps-gnus-article-prepare-hook () + (setq ps-header-lines 3) + (setq ps-left-header + ;; The left headers will display the article's subject, its + ;; author, and the newsgroup it was in. + (list 'ps-article-subject 'ps-article-author 'gnus-newsgroup-name))) -(defun ps-testpattern () - (setq foo 1) - (while (< foo 60) - (insert "|" (make-string foo ?\ ) (format "%d\n" foo)) - (setq foo (+ 1 foo)))) +;; A hook to bind to vm-mode-hook to locally bind prsc and set the ps- +;; left-headers specially for mail messages. This header setup would +;; also work, I think, for RMAIL. +(defun ps-vm-mode-hook () + (local-set-key 'f22 'ps-vm-print-message-from-summary) + (setq ps-header-lines 3) + (setq ps-left-header + ;; The left headers will display the message's subject, its + ;; author, and the name of the folder it was in. + (list 'ps-article-subject 'ps-article-author 'buffer-name))) + +;; Every now and then I forget to switch from the *Summary* buffer to +;; the *Article* before hitting prsc, and a nicely formatted list of +;; article subjects shows up at the printer. This function, bound to +;; prsc for the gnus *Summary* buffer means I don't have to switch +;; buffers first. +(defun ps-gnus-print-article-from-summary () + (interactive) + (if (get-buffer "*Article*") + (save-excursion + (set-buffer "*Article*") + (ps-spool-buffer-with-faces)))) + +;; See ps-gnus-print-article-from-summary. This function does the +;; same thing for vm. +(defun ps-vm-print-message-from-summary () + (interactive) + (if vm-mail-buffer + (save-excursion + (set-buffer vm-mail-buffer) + (ps-spool-buffer-with-faces)))) + +;; A hook to bind to bind to gnus-summary-setup-buffer to locally bind +;; prsc. +(defun ps-gnus-summary-setup () + (local-set-key 'f22 'ps-gnus-print-article-from-summary)) -(defun pts (stuff) +;; File: lispref.info, Node: Standard Errors + +;; Look in an article or mail message for the Subject: line. To be +;; placed in ps-left-headers. +(defun ps-info-file () + (save-excursion + (goto-char (point-min)) + (if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)") + (buffer-substring (match-beginning 1) (match-end 1)) + "File ???"))) + +;; Look in an article or mail message for the Subject: line. To be +;; placed in ps-left-headers. +(defun ps-info-node () (save-excursion - (set-buffer "*scratch*") - (goto-char (point-max)) - (insert "---------------------------------\n" - (symbol-name stuff) ":\n" - (prin1-to-string (symbol-value stuff)) - "\n"))) + (goto-char (point-min)) + (if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)") + (buffer-substring (match-beginning 1) (match-end 1)) + "Node ???"))) + +(defun ps-info-mode-hook () + (setq ps-left-header + ;; The left headers will display the node name and file name. + (list 'ps-info-node 'ps-info-file))) + +(defun ps-jts-ps-setup () + (global-set-key 'f22 'ps-spool-buffer-with-faces) ;f22 is prsc + (global-set-key '(shift f22) 'ps-spool-region-with-faces) + (global-set-key '(control f22) 'ps-despool) + (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook) + (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup) + (add-hook 'vm-mode-hook 'ps-vm-mode-hook) + (add-hook 'Info-mode-hook 'ps-info-mode-hook) + (setq ps-spool-duplex t) + (setq ps-print-color-p nil) + (setq ps-lpr-command "lpr") + (setq ps-lpr-switches '("-Jjct,duplex_long"))) (provide 'ps-print) - -;; ps-print.el ends here +;;; ps-print.el ends here