-;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print).
-;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
+;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19.
-;; Author: James C. Thompson <thompson@wg2.waii.com>
-;; Keywords: faces, postscript, printing
+;; Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
+
+;; Author: Jim Thompson <thompson@wg2.waii.com>
+;; Maintainer: FSF
+;; Keywords: print, PostScript
;; This file is part of GNU Emacs.
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, 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|2.8|~/packages/ps-print.el|
+
+;; Baseline-version: 2.8. (Jim's last change version -- this
+;; file may have been edited as part of Emacs without changes to the
+;; version number. When reporting bugs, please also report the
+;; version of Emacs, if any, that ps-print was distributed with.)
+
+;;; 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
;; preserved in the printer output. Ps-print is intended for use with
-;; Emacs 19 (Lucid or FSF) and a fontifying package such as font-lock
-;; or hilit.
-;;
-;; Installing ps-print:
-;; -------------------
-;; Place ps-print somewhere in your load-path and byte-compile it.
-;; Load ps-print with (require 'ps-print).
+;; Emacs 19 or Lucid Emacs, together with a fontifying package such as
+;; font-lock or hilit.
;;
-;; Using ps-print:
+;; 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:
;;
-;; (setq ps-bold-faces (cons 'my-bold-face ps-bold-faces))
+;; 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
+;;
+;; 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.
+;;
+;; 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
+;; accidentally 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:
+;;
+;; 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.
+;;
+;; 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.
+;;
;;
-;; 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.
+;; Invoking Ps-Print
;;
-;; 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.
+;; To print your buffer, type
;;
-;; 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):
+;; M-x ps-print-buffer
;;
-;; (global-set-key 'f22 'ps-print-buffer-with-faces)
-;; (global-set-key '(shift f22) 'ps-print-region-with-faces)
+;; 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
;;
-;; Or, as I now prefer, you can also bind the ps-spool- functions to
-;; keys; here's my bindings:
+;; C-u M-x ps-print-buffer
;;
-;; (global-set-key 'f22 'ps-spool-buffer-with-faces)
+;; 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:
+;;
+;; C-u M-x ps-despool
+;;
+;; When invoked this way, ps-despool will prompt you for the name of
+;; the file to save to.
+;;
+;; 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-italic-faces '(my-red-face))
+;;
+;; Faces like bold-italic that are both bold and italic should go in
+;; *both* lists.
+;;
+;; 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 invocations 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.
+;; When printing on duplex printers, left and right are reversed so
+;; that the page numbers are toward the outside.
+;;
+;; 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
+;; ')'.
;;
-;; 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.
+;; 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
+;; string delimiters are added by ps-print, and should not be part of
+;; the returned value.
;;
-;; 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.
+;; Here's an example: say we want the left header to display the text
;;
-;; Please send all bug fixes and enhancements to me, thompson@wg2.waii.com.
+;; Moe
+;; Larry
+;; Curly
+;;
+;; where we have a function to return "Moe"
+;;
+;; (defun moe-func ()
+;; "Moe")
+;;
+;; a variable specifying "Larry"
+;;
+;; (setq larry-var "Larry")
+;;
+;; and a literal for "Curly". Here's how ps-left-header should be
+;; set:
+;;
+;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)"))
+;;
+;; 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
+;;
+;; 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.
+;;
+;;
+;; 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.
+;;
+;;
+;; 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.
+;;
+;;
+;; New since version 1.5
+;; ---------------------
+;; Color output capability.
;;
-;; New in version 1.5
-;; ------------------
-;; Support for Emacs 19. Works with both overlays and text
-;; properties.
+;; Automatic detection of font attributes (bold, italic).
;;
-;; Underlining.
+;; Configurable headers with page numbers.
;;
-;; Local spooling; see function ps-spool-buffer.
+;; Slightly faster.
;;
-;; Support for ISO8859-1 character set.
+;; Support for different paper sizes.
;;
-;; Page breaks are now handled correctly.
+;; Better conformance to PostScript Document Structure Conventions.
;;
-;; Percentages reported while formatting are now correct.
;;
;; Known bugs and limitations of ps-print:
;; --------------------------------------
-;; Slow. (Byte-compiling helps.)
+;; Although color printing will work in XEmacs 19.12, it doesn't work
+;; well; in particular, bold or italic fonts don't print in the right
+;; background color.
+;;
+;; Invisible properties aren't correctly ignored in XEmacs 19.12.
+;;
+;; Automatic font-attribute detection doesn't work well, especially
+;; with hilit19 and older versions of get-create-face. Users having
+;; problems with auto-font detection should use the lists ps-italic-
+;; faces and ps-bold-faces and/or turn off automatic detection by
+;; setting ps-auto-font-detect to nil.
+;;
+;; Automatic font-attribute detection doesn't work with XEmacs 19.12
+;; in tty mode; use the lists ps-italic-faces and ps-bold-faces
+;; instead.
+;;
+;; Still too slow; could use some hand-optimization.
;;
-;; The PostScript needs review/cleanup/enhancing by a PS expert.
-;;
;; 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.
;;
-;; 2-up and 4-up capability.
+;; Acknowledgements
+;; ----------------
+;; Thanks to Kevin Rodgers <kevinr@ihs.com> for adding support for
+;; color and the invisible property.
;;
-;; Wide-print capability.
+;; 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.
+;;
+;; 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.
+;;
+;; 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 "2.8"
+ "ps-print.el,v 2.8 1995/05/04 12:06:10 jct Exp
+
+Jim's last change version -- this file may have been edited as part of
+Emacs without changes to the version number. When reporting bugs,
+please also report the version of Emacs, if any, that ps-print was
+distributed with.
-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.")
-
-(defvar ps-lpr-switches nil
- "A list of extra switches to pass to ps-lpr-command.")
-
-(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-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-underline-faces
- '(underline
- font-lock-string-face)
- "A list of the faces that should be printed underline.")
+;; 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-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-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 (or (fboundp 'x-color-values) ; Emacs
+ (fboundp 'pixel-components)) ; XEmacs
+ (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
+ "*Font size, in points, for generating Postscript.")
+
+(defvar ps-font "Courier"
+ "*Font family name for ordinary text, when generating Postscript.")
+
+(defvar ps-font-bold "Courier-Bold"
+ "*Font family name for bold text, when generating Postscript.")
+
+(defvar ps-font-italic "Courier-Oblique"
+ "*Font family name for italic text, when generating Postscript.")
+
+(defvar ps-font-bold-italic "Courier-BoldOblique"
+ "*Font family name for bold italic text, when generating Postscript.")
+
+(defvar ps-avg-char-width (if (fboundp 'float) 5.6 6)
+ "*The average width, in points, of a character, for generating Postscript.
+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. 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)
+ "*The width of a space character, for generating Postscript.
+This value is used in expanding tab characters.")
+
+(defvar ps-line-height (if (fboundp 'float) 11.29 11)
+ "*The height of a line, for generating Postscript.
+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. If you change the font or font
+size, you will probably have to adjust this value to match. 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.
+This applies to generating Postscript.")
+
+(defvar ps-italic-faces '()
+ "*A list of the \(non-italic\) faces that should be printed in italic font.
+This applies to generating Postscript.")
+
+(defvar ps-underlined-faces '()
+ "*A list of the \(non-underlined\) faces that should be printed underlined.
+This applies to generating Postscript.")
+
+(defvar ps-header-lines 2
+ "*Number of lines to display in page header, when generating Postscript.")
+(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.
+This applies to generating Postscript.
+
+The value should be 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.
+This applies to generating Postscript.
+
+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
+;;;###autoload
(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
+When called with a numeric prefix argument (C-u), prompts the user for
the name of a file to save the PostScript image in, instead of sending
it to the printer.
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))
+ (interactive (list (ps-print-preprint current-prefix-arg)))
(ps-generate (current-buffer) (point-min) (point-max)
'ps-generate-postscript)
(ps-do-despool filename))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
+;;;###autoload
(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.
-
-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."
-
- (interactive "P")
- (setq filename (ps-preprint filename))
+ "Generate and print a PostScript image of the buffer.
+Like `ps-print-buffer', but includes font, color, and underline
+information in the generated image. This command works only if you
+are using a window system, so it has a way to determine color values."
+ (interactive (list (ps-print-preprint current-prefix-arg)))
(ps-generate (current-buffer) (point-min) (point-max)
'ps-generate-postscript-with-faces)
(ps-do-despool filename))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;###autoload
(defun ps-print-region (from to &optional filename)
+ "Generate and print a PostScript image of the region.
+Like `ps-print-buffer', but prints just the current region."
-"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.
-
-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.
-
-See also: ps-print-region-with-faces
- ps-spool-region
- ps-spool-region-with-faces"
-
- (interactive "r\nP")
- (setq filename (ps-preprint filename))
+ (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg)))
(ps-generate (current-buffer) from to
'ps-generate-postscript)
(ps-do-despool filename))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;###autoload
(defun ps-print-region-with-faces (from to &optional filename)
+ "Generate and print a PostScript image of the region.
+Like `ps-print-region', but includes font, color, and underline
+information in the generated image. This command works only if you
+are using a window system, so it has a way to determine color values."
-"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.
-
-See also: ps-print-region
- ps-spool-region
- ps-spool-region-with-faces"
-
- (interactive "r\nP")
- (setq filename (ps-preprint filename))
+ (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg)))
(ps-generate (current-buffer) from to
'ps-generate-postscript-with-faces)
(ps-do-despool filename))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;###autoload
(defun ps-spool-buffer ()
+ "Generate and spool a PostScript image of the buffer.
+Like `ps-print-buffer' 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.
-
-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.
-
-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-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))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;###autoload
(defun ps-spool-buffer-with-faces ()
+ "Generate and spool a PostScript image of the buffer.
+Like `ps-spool-buffer', but includes font, color, and underline
+information in the generated image. This command works only if you
+are using a window system, so it has a way to determine color values.
-"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.
-
-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.
-
-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))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;###autoload
(defun ps-spool-region (from to)
+ "Generate a PostScript image of the region and spool locally.
+Like `ps-spool-buffer', but spools just the current region.
-"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.
-
-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.
-
-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))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;###autoload
(defun ps-spool-region-with-faces (from to)
+ "Generate a PostScript image of the region and spool locally.
+Like `ps-spool-region', but includes font, color, and underline
+information in the generated image. This command works only if you
+are using a window system, so it has a way to determine color values.
-"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.
-
-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.
-
-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.")
-
+;;;###autoload
(defun ps-despool (&optional filename)
"Send the spooled PostScript to the printer.
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 (list (ps-print-preprint current-prefix-arg)))
+ (ps-do-despool filename))
- (interactive "P")
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utility functions and variables:
+
+(defvar ps-print-emacs-type
+ (cond ((string-match "XEmacs" emacs-version) 'xemacs)
+ ((string-match "Lucid" emacs-version) 'lucid)
+ ((string-match "Epoch" emacs-version) 'epoch)
+ (t 'emacs)))
+
+(if (or (eq ps-print-emacs-type 'lucid)
+ (eq ps-print-emacs-type 'xemacs))
+ (if (< emacs-minor-version 12)
+ (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
+
+ 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
-;; 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.
+/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 /FontHeight 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
+
+/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
+
+/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
+
+/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 FontHeight 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
+
+/ReportFontInfo {
+ 2 copy
+ /t0 3 1 roll Font
+ /t0 F
+ /lh FontHeight 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 FontHeight 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:
- (setq filename (ps-preprint filename))
- (ps-do-despool filename))
+(defvar ps-source-buffer nil)
+(defvar ps-spool-buffer-name "*PostScript*")
+(defvar ps-spool-buffer nil)
-;; Here end the definitions that users need to know about; proceed
-;; further at your own risk!
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar ps-output-head nil)
+(defvar ps-output-tail nil)
-(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)))
+(defvar ps-page-count 0)
+(defvar ps-showpage-count 0)
- (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"))))
+(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 ps-print-emacs-type 'emacs)
+
+ ;;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"))
+
+;; 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
+
+;; 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)
-(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)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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-preprint (&optional filename)
+(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))
+ (res (read-file-name prompt default-directory name nil)))
+ (if (file-directory-p res)
+ (expand-file-name name (file-name-as-directory res))
+ res))))
+
+;; 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
-(defvar ps-col 0)
-(defvar ps-row 0)
-(defvar ps-xpos 0)
-(defvar ps-ypos 0)
+(defun ps-init-output-queue ()
+ (setq ps-output-head (list ""))
+ (setq ps-output-tail ps-output-head))
-(defvar ps-chars-per-line 80)
-(defvar ps-lines-per-page 66)
+(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-page-start-ypos 745)
-(defvar ps-line-start-xpos 40)
+(defun ps-output-string (string)
+ (ps-output t string))
-(defvar ps-char-xpos-inc 6)
-(defvar ps-line-ypos-inc 11)
+(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))
+
+(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-current-font 0)
+ (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.
-(defvar ps-multiple nil)
-(defvar ps-virtual-page-number 0)
+(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))
+
+ ;; 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)))
+
+ ;; Anything else will get turned into an empty string.
+ (t
+ (ps-output-string "")))
+ (ps-output " ]\n"))
+
+(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
-
-/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
-
-/StartPage{/svpg save def}def
-/EndPage{svpg restore showpage}def
-
-/SetUpFonts
- {dup/$fd exch array def{findfont exch scalefont $fd 3 1 roll put}repeat}def
-
-% 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
-
-/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
+ (setq ps-showpage-count 0)
+
+ (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")
+
+ (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)
+
+ (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))
+
+ (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 (format "/LineHeight %s def\n" ps-line-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))
-/CourierISO /Courier reencodeISO
-/Courier-ObliqueISO /Courier-Oblique reencodeISO
-/Courier-BoldISO /Courier-Bold reencodeISO
-/Courier-BoldObliqueISO /Courier-BoldOblique reencodeISO
+ (ps-output "%%EndPrologue\n"))
-3 10 /Courier-BoldObliqueISO
-2 10 /Courier-ObliqueISO
-1 10 /Courier-BoldISO
-0 10 /CourierISO
-4 SetUpFonts
+(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)
+ "")))
-.4 setlinewidth
-")))
+(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)))
+
+(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-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)
+
+ ;; 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))))
+
+ (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")
+
+ (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-init-page))
-
-(defun ps-top-of-page () (ps-next-page))
-
-(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))
-
-(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")))
+ (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))
-
-(defvar ps-source-buffer nil)
-(defvar ps-output-buffer nil)
-
-(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))
-
- (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))
-
- (while (re-search-forward "[()\\]" nil t)
- (save-excursion
- (forward-char -1)
- (insert "\\")))
-
- (end-of-line)
- (insert ") S\n")
-
- (setq ps-xpos (+ ps-xpos (* count ps-char-xpos-inc)))))
-
-(defun ps-basic-plot-whitespace (from to underline-p)
- (setq count (- to from))
- (setq ps-xpos (+ ps-xpos (* count ps-char-xpos-inc))))
-
-(defun ps-plot (plotfunc from to &optional underline-p)
-
+ (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)))
+
+(defun ps-hard-lf ()
+ (ps-output "HL\n"))
+
+(defun ps-soft-lf ()
+ (ps-output "SL\n"))
+
+(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))))
+
+(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))
+
+(defun ps-basic-plot-whitespace (from to &optional bg-color)
+ (let* ((wrappoint (ps-find-wrappoint from to ps-space-width))
+ (to (car wrappoint)))
+
+ (ps-output (format "%d W\n" (- to from)))
+ wrappoint))
+
+(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
+ (let (foo)
(setq ps-razchunk q-done)
(setq foo
(if (< q-todo 100)
- (* (/ q-done q-todo) 100)
- (setq basis (/ q-todo 100))
- (/ q-done basis)))
-
- (message "Formatting... %d%%" foo))))))
-
-(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-plot-region (from to font &optional underline-p)
-
- (ps-set-font font)
+ (/ (* 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)))
+
+(defvar ps-print-color-scale nil)
+
+(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-color (color)
+ (if (setq ps-current-color color)
+ nil
+ (setq ps-current-color ps-default-fg))
+ (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)
+
+ (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))
+ ;; 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)
- (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 ?\014)
- (ps-plot 'ps-basic-plot-string from (- (point) 1) underline-p)
- (ps-top-of-page)))
+ ((= 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 ?\n)
+ (ps-plot 'ps-basic-plot-string from (- (point) 1)
+ bg-color)
+ (ps-next-line)
+ )
+
+ ((= 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)
-
- (setq ps-source-buffer (current-buffer))
- (setq ps-output-buffer (get-buffer-create "%PostScript%"))
-
- (save-excursion
- (set-buffer ps-output-buffer)
- (delete-region (point-max) (point-min)))
-
- (ps-begin-file)
- (ps-begin-page)
- (ps-init-page)
-
- (ps-plot-region (point-min) (point-max) 0)
+(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))
+
+(defun ps-color-values (x-color)
+ (cond ((fboundp 'x-color-values)
+ (x-color-values x-color))
+ ((fboundp 'pixel-components)
+ (pixel-components x-color))
+ (t (error "No available function to determine X color values."))))
+
+(defun ps-face-attributes (face)
+ (let ((differs (face-differs-from-default-p face)))
+ (list (memq face ps-ref-bold-faces)
+ (memq face ps-ref-italic-faces)
+ (memq face ps-ref-underlined-faces)
+ (and differs (face-foreground face))
+ (and differs (face-background face)))))
+
+(defun ps-face-attribute-list (face-or-list)
+ (if (listp face-or-list)
+ (let (bold-p italic-p underline-p foreground background face-attr face)
+ (while face-or-list
+ (setq face (car face-or-list))
+ (setq face-attr (ps-face-attributes face))
+ (setq bold-p (or bold-p (nth 0 face-attr)))
+ (setq italic-p (or italic-p (nth 1 face-attr)))
+ (setq underline-p (or underline-p (nth 2 face-attr)))
+ (if foreground
+ nil
+ (setq foreground (nth 3 face-attr)))
+ (if background
+ nil
+ (setq background (nth 4 face-attr)))
+ (setq face-or-list (cdr face-or-list)))
+ (list bold-p italic-p underline-p foreground background))
+
+ (ps-face-attributes face-or-list)))
- (ps-end-page)
- (ps-end-file)
- )
+(defun ps-plot-with-face (from to face)
+ (if face
+ (let* ((face-attr (ps-face-attribute-list face))
+ (bold-p (nth 0 face-attr))
+ (italic-p (nth 1 face-attr))
+ (underline-p (nth 2 face-attr))
+ (foreground (nth 3 face-attr))
+ (background (nth 4 face-attr))
+ (fg-color (if (and ps-print-color-p foreground)
+ (mapcar 'ps-color-value
+ (ps-color-values foreground))
+ ps-default-color))
+ (bg-color (if (and ps-print-color-p background)
+ (mapcar 'ps-color-value
+ (ps-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)))
+
+
+(defun ps-emacs-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))
+
+ (or (and kind-spec (string-match kind-regex kind-spec))
+ ;; Kludge-compatible:
+ (memq face kind-list))))
+
+(defun ps-face-bold-p (face)
+ (if (eq ps-print-emacs-type 'emacs)
+ (ps-emacs-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 ps-print-emacs-type 'emacs)
+ (ps-emacs-face-kind-p face 'italic "-[io]-" ps-italic-faces)
+ (or
+ (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o" ps-italic-faces)
+ (ps-xemacs-face-kind-p face 'SLANT "i\\|o" ps-italic-faces))))
+
+(defun ps-face-underlined-p (face)
+ (or (face-underline-p face)
+ (memq face ps-underlined-faces)))
+
+;; Ensure that face-list is fbound.
+(or (fboundp 'face-list) (defalias 'face-list 'list-faces))
+
+(defun ps-build-reference-face-lists ()
+ (if ps-auto-font-detect
+ (let ((faces (face-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)
(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-print-ensure-fontified (start end)
+ (if (and (boundp 'lazy-lock-mode) lazy-lock-mode)
+ (if (fboundp 'lazy-lock-fontify-region)
+ (lazy-lock-fontify-region start end)
+ (lazy-lock-fontify-buffer))))
(defun ps-generate-postscript-with-faces (from to)
-
+ ;; Build the reference lists of faces if necessary.
+ (if (or ps-always-build-face-reference
+ ps-build-face-reference)
+ (progn
+ (message "Collecting face information...")
+ (ps-build-reference-face-lists)))
+ ;; Set the color scale. We do it here instead of in the defvar so
+ ;; that ps-print can be dumped into emacs. This expression can't be
+ ;; evaluated at dump-time because X isn't initialized.
+ (setq ps-print-color-scale
+ (if ps-print-color-p
+ (float (car (ps-color-values "white")))
+ 1.0))
+ ;; Generate some PostScript.
(save-restriction
(narrow-to-region from to)
- (setq face 'default)
-
- (cond ((string-match "Lucid" emacs-version)
+ (let ((face 'default)
+ (position to))
+ (ps-print-ensure-fontified from to)
+ (cond ((or (eq ps-print-emacs-type 'lucid) (eq ps-print-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))
(setq extent (car record))
;; Plot up to this record.
- (ps-plot-with-face from position face)
+ ;; XEmacs 19.12: for some reason, we're getting into a
+ ;; situation in which some of the records have
+ ;; positions less than 'from'. Since we've narrowed
+ ;; the buffer, this'll generate errors. This is a
+ ;; hack, but don't call ps-plot-with-face unless from >
+ ;; point-min.
+ (if (and (>= from (point-min))
+ (<= position (point-max)))
+ (ps-plot-with-face from position face))
(cond
((eq type 'push)
- (setq extent-list (sort (cons extent extent-list)
- 'ps-extent-sorter)))
+ (if (extent-face extent)
+ (setq extent-list (sort (cons extent extent-list)
+ 'ps-extent-sorter))))
((eq type 'pull)
(setq extent-list (sort (delq extent extent-list)
(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 ps-print-emacs-type 'emacs)
+ (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))
+ ;; The code below is not quite correct,
+ ;; because a non-nil overlay invisible property
+ ;; which is inactive according to the current value
+ ;; of buffer-invisibility-spec nonetheless overrides
+ ;; a face text property.
+ (setq face
+ (cond ((let ((prop (get-text-property from 'invisible)))
+ ;; Decide whether this invisible property
+ ;; really makes the text invisible.
+ (if (eq buffer-invisibility-spec t)
+ (not (null prop))
+ (or (memq prop buffer-invisibility-spec)
+ (assq prop buffer-invisibility-spec))))
+ 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 ((if (eq buffer-invisibility-spec t)
+ (not (null overlay-invisible))
+ (or (memq overlay-invisible buffer-invisibility-spec)
+ (assq overlay-invisible buffer-invisibility-spec)))
+ 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)))
-
- (set-buffer buffer)
- (setq ps-source-buffer buffer)
- (setq ps-output-buffer (get-buffer-create ps-spool-buffer-name))
-
- (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))
+ (let ((from (min to from))
+ (to (max to from))
+ ;; This avoids trouble if chars with read-only properties
+ ;; are copied into ps-spool-buffer.
+ (inhibit-read-only t))
+ (save-restriction
+ (narrow-to-region from to)
+ (if ps-razzle-dazzle
+ (message "Formatting...%d%%" (setq ps-razchunk 0)))
+ (set-buffer buffer)
+ (setq ps-source-buffer buffer)
+ (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)
- (set-buffer ps-source-buffer)
- (funcall genfunc from to)
-
- (ps-end-page)))
+ ;; 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))
+
+ ;; Setting this variable tells the unwind form that the
+ ;; the postscript was generated without error.
+ (setq completed-safely t))
+
+ ;; Unwind form: If some bad mojo occurred 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."))))
+ (if ps-razzle-dazzle
+ (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)
- (apply 'call-process-region
- (point-min) (point-max) ps-lpr-command nil 0 nil
- ps-lpr-switches))
-
+ (set-buffer ps-spool-buffer)
+ (if (and (eq system-type 'ms-dos) (stringp dos-ps-printer))
+ (write-region (point-min) (point-max) dos-ps-printer t 0)
+ (let ((binary-process-input t)) ; for MS-DOS
+ (apply 'call-process-region
+ (point-min) (point-max) ps-lpr-command nil
+ (if (fboundp 'start-process) 0 nil)
+ nil
+ ps-lpr-switches))))
(if ps-razzle-dazzle
- (message "Printing... Done.")))
+ (message "Printing...done")))
+ (kill-buffer ps-spool-buffer)))
+
+(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:
- (kill-buffer ps-output-buffer)))
+;; 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:
-(defun ps-testpattern ()
- (setq foo 1)
- (while (< foo 60)
- (insert "|" (make-string foo ?\ ) (format "%d\n" foo))
- (setq foo (+ 1 foo))))
+;; WARNING!!! The following code is *sample* code only. Don't use it
+;; unless you understand what it does!
-(defun pts (stuff)
+(defmacro ps-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs)
+ [f22] ''f22))
+(defmacro ps-c-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs)
+ [C-f22]
+ ''(control f22)))
+(defmacro ps-s-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs)
+ [S-f22]
+ ''(shift f22)))
+
+;; Look in an article or mail message for the Subject: line. To be
+;; placed in ps-left-headers.
+(defun ps-article-subject ()
(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 "^Subject:[ \t]+\\(.*\\)$")
+ (buffer-substring (match-beginning 1) (match-end 1))
+ "Subject ???")))
+
+;; 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)))
+
+;; 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 (ps-prsc) '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 (ps-prsc) 'ps-gnus-print-article-from-summary))
+
+;; 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
+ (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)))
+
+;; WARNING! The following function is a *sample* only, and is *not*
+;; meant to be used as a whole unless you understand what the effects
+;; will be! (In fact, this is a copy if my setup for ps-print -- I'd
+;; be very surprised if it was useful to *anybody*, without
+;; modification.)
+
+(defun ps-jts-ps-setup ()
+ (global-set-key (ps-prsc) 'ps-spool-buffer-with-faces) ;f22 is prsc
+ (global-set-key (ps-s-prsc) 'ps-spool-region-with-faces)
+ (global-set-key (ps-c-prsc) '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 'vm-mode-hooks '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