comparison lisp/ps-print.el @ 10683:64e6021d0ba0

Various changes.

10682:5659c0885145

;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19.

;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.

;; Author: Jim Thompson <[e-mail]>
;; Version: Jim's last version is 1.10
;; Keywords: print, PostScript

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify

;; 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.

;;; Commentary:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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
;; -------------------
;;
;; 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)
;;
;;    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 Commands

;; 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 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.
;;
;; 
;; New in version 1.6
;; ------------------
;; Color output capability.
;;
;; Automatic detection of font attributes (bold, italic).
;;
;; 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:
;; --------------------------------------
;; Color output doesn't yet work in XEmacs.
;;
;; 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.
;;
;; Default background color isn't working.

;; Jim
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Code:

(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 <[e-mail]>.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User Variables:

(defvar ps-lpr-command lpr-command

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

(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 (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.")

variable.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User commands

(defun ps-print-buffer (&optional filename)
  "Generate and print a PostScript image of the buffer.

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

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."

  (interactive "P")
  (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.

Like `ps-print-buffer', but includes font, color, and underline
information in the generated image."
  (interactive "P")
  (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.

Like `ps-print-buffer', but prints just the current region."

  (interactive "r\nP")
  (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.

Like `ps-print-region', but includes font, color, and underline
information in the generated image."

  (interactive "r\nP")
  (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.

Like `ps-print-buffer' except that the PostScript image is saved in a
local buffer to be sent to the printer later.

  (interactive)
  (ps-generate (current-buffer) (point-min) (point-max)
	       'ps-generate-postscript))


(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.

  (interactive)
  (ps-generate (current-buffer) (point-min) (point-max)
	       'ps-generate-postscript-with-faces))


(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.

  (interactive "r")
  (ps-generate (current-buffer) from to
	       'ps-generate-postscript))


(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.

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))

(defun ps-despool (&optional filename)
  "Send the spooled PostScript to the printer.

When called with a numeric prefix argument (C-u), prompt the user for
the name of a file to save the spooled PostScript in, instead of sending

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."
  (interactive "P")
  (ps-do-despool (ps-print-preprint filename)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utility functions and variables:

(if (featurep 'emacs-vers)

/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

/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

/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

    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

  (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 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))

      (let* ((q-todo (- (point-max) (point-min)))
	     (q-done (- (point) (point-min)))
	     (chunkfrac (/ q-todo 8))
	     (chunksize (if (> chunkfrac 1000) 1000 chunkfrac)))
	(if (> (- q-done ps-razchunk) chunksize)
	    (progn
	      (setq ps-razchunk q-done)
	      (setq foo
		    (if (< q-todo 100)
			(/ (* 100 q-done) q-todo)
		      (/ q-done (/ q-todo 100))))

(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 (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))

			   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)))

                    (list (extent-end-position extent) 'pull extent)))
  nil)

(defun ps-sorter (a b)
  (< (car a) (car b)))
    
(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)
    (let ((face 'default)
	  (position to))
      (cond ((or (eq emacs-type 'lucid) (eq emacs-type 'xemacs))

(defun ps-generate-postscript (from to)
  (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-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))

	    ;; 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 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"))))

(defun ps-do-despool (filename)
  (if (or (not (boundp 'ps-spool-buffer))
	  (not ps-spool-buffer))
      (message "No spooled PostScript to print")

;; 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))

;; 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)))

	(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))

;; 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

  (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")))

10683:64e6021d0ba0

;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19.

;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.

;; Author: Jim Thompson <[e-mail]>
;; Thompson's last version: 1.14
;; Keywords: print, PostScript

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify

;; 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.

;; LCD Archive Entry:
;; ps-print|James C. Thompson|[e-mail]|
;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print)|
;; 26-Feb-1994|1.6|~/packages/ps-print.el|

;;; Commentary:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; 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 or Lucid Emacs, together with a fontifying package such as
;; font-lock or hilit.
;; 
;; Installing ps-print
;; -------------------
;;
;; 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 Commands

;; 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 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.
;;
;;
;; Known bugs and limitations of ps-print:
;; --------------------------------------
;; Automatic font-attribute detection doesn't work will, 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.
;;
;; Color output doesn't yet work in XEmacs.
;;
;; Still too slow; could use some hand-optimization.
;;
;; ASCII Control characters other than tab, linefeed and pagefeed are
;; not handled.
;;
;; Default background color isn't working.

;; Jim
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Code:

(defconst ps-print-thompson-version "1.14"
  "Report bugs to [e-mail] and [e-mail].")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User Variables:

(defvar ps-lpr-command lpr-command

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

(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 (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.")

variable.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User commands

;;;###autoload
(defun ps-print-buffer (&optional filename)
  "Generate and print a PostScript image of the buffer.

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

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."

  (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.

Like `ps-print-buffer', but includes font, color, and underline
information in the generated image."
  (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."

  (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."

  (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.

  (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.

  (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.

  (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.

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))

;;;###autoload
(defun ps-despool (&optional filename)
  "Send the spooled PostScript to the printer.

When called with a numeric prefix argument (C-u), prompt the user for
the name of a file to save the spooled PostScript in, instead of sending

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."
  (interactive (list (ps-print-preprint current-prefix-arg)))
  (ps-do-despool filename))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utility functions and variables:

(if (featurep 'emacs-vers)

/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

/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

/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

    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

  (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 %d 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))

      (let* ((q-todo (- (point-max) (point-min)))
	     (q-done (- (point) (point-min)))
	     (chunkfrac (/ q-todo 8))
	     (chunksize (if (> chunkfrac 1000) 1000 chunkfrac)))
	(if (> (- q-done ps-razchunk) chunksize)
	    (let (foo)
	      (setq ps-razchunk q-done)
	      (setq foo
		    (if (< q-todo 100)
			(/ (* 100 q-done) q-todo)
		      (/ q-done (/ q-todo 100))))

(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))

			   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)
    (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)))

                    (list (extent-end-position extent) 'pull extent)))
  nil)

(defun ps-sorter (a b)
  (< (car a) (car b)))

(defun ps-extent-sorter (a b)
  (< (extent-priority a) (extent-priority b)))
    
(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 (x-color-values "white")))
	  1.0))
  ;; Generate some PostScript.
  (save-restriction
    (narrow-to-region from to)
    (let ((face 'default)
	  (position to))
      (cond ((or (eq emacs-type 'lucid) (eq emacs-type 'xemacs))

(defun ps-generate-postscript (from to)
  (ps-plot-region from to 0 nil))

(defun ps-generate (buffer from to genfunc)
  (let ((from (min to from))
	(to (max to from)))
    (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)
	    
	      ;; 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 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")))))

(defun ps-do-despool (filename)
  (if (or (not (boundp 'ps-spool-buffer))
	  (not ps-spool-buffer))
      (message "No spooled PostScript to print")

;; 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:

(defmacro ps-prsc () (list 'if (list 'eq 'emacs-type ''fsf) [f22] ''f22))
(defmacro ps-c-prsc () (list 'if (list 'eq 'emacs-type ''fsf) [C-f22]
			     ''(control f22)))
(defmacro ps-s-prsc () (list 'if (list 'eq 'emacs-type ''fsf) [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
    (goto-char (point-min))

;; 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)))

	(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

  (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 (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")))