;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19.
-;; Copyright (C) 1993, 1994 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.
;; Author: Jim Thompson <thompson@wg2.waii.com>
-;; Version: 1.10
;; Keywords: print, PostScript
-;; This file is not yet part of GNU Emacs.
+;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; LCD Archive Entry:
;; ps-print|James C. Thompson|thompson@wg2.waii.com|
;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print)|
-;; 26-Feb-1994|1.6|~/packages/ps-print.el|
+;; 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:
;; 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.
+;; Emacs 19 or Lucid Emacs, together with a fontifying package such as
+;; font-lock or hilit.
;;
;; Using ps-print
;; --------------
;; 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
+;; then ps-print won't work properly. ps-lpr-command must name
;; a program that does not format the files it prints.
;;
;;
;; file:
;;
;; (setq ps-bold-faces '(my-blue-face))
-;; (setq ps-red-faces '(my-red-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
;; 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 in version 1.6
-;; ------------------
+;; New since version 1.5
+;; ---------------------
;; Color output capability.
;;
;; Automatic detection of font attributes (bold, italic).
;;
;; Known bugs and limitations of ps-print:
;; --------------------------------------
-;; Color output doesn't yet work in XEmacs.
+;; 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.
;;
-;; 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.
+;; 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.
;;
;; ASCII Control characters other than tab, linefeed and pagefeed are
;; not handled.
;;; Code:
-(defconst ps-print-version "1.10"
- "ps-print.el,v 1.10 1995/01/09 14:45:03 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>.")
(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.")
+`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'.")
+ "*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'.")
+ "*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)
+(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.")
"*RGB values of the default background color. Defaults to white.")
(defvar ps-font-size 10
- "*Specifies the size, in points, of the font to print text in.")
+ "*Font size, in points, for generating Postscript.")
(defvar ps-font "Courier"
- "*Specifies the name of the font family to print text in.")
+ "*Font family name for ordinary text, when generating Postscript.")
(defvar ps-font-bold "Courier-Bold"
- "*Specifies the name of the font family to print bold text in.")
+ "*Font family name for bold text, when generating Postscript.")
(defvar ps-font-italic "Courier-Oblique"
- "*Specifies the name of the font family to print italic text in.")
+ "*Font family name for italic text, when generating Postscript.")
(defvar ps-font-bold-italic "Courier-BoldOblique"
- "*Specifies the name of the font family to print bold-italic text in.")
+ "*Font family name for bold italic text, when generating Postscript.")
(defvar ps-avg-char-width (if (fboundp 'float) 5.6 6)
- "*Specifies the average width, in points, of a character. This is the
-value that ps-print uses to determine the length, x-dimension, of the
-text it has printed, and thus affects the point at which long lines
-wrap around. Note that if you change the font or font size, you will
-probably have to adjust this value to match.")
+ "*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)
- "*Specifies the width of a space character. This value is used in
-expanding tab characters.")
+ "*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)
- "*Specifies the height of a line. This is the value that ps-print
-uses to determine the height, y-dimension, of the lines of text it has
-printed, and thus affects the point at which page-breaks are placed.
-Note that if you change the font or font size, you will probably have
-to adjust this value to match. Note also that the line-height is
-*not* the same as the point size of the font.")
+ "*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',
+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.")
+ "*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.")
+ "*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.")
+ "*A list of the \(non-underlined\) faces that should be printed underlined.
+This applies to generating Postscript.")
(defvar ps-header-lines 2
- "*The number of lines to display in the page header.")
+ "*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.
-Should contain a list of strings and symbols, each representing an
+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
(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
+See the variable `ps-left-header' for a description of the format of
this variable.")
(make-variable-buffer-local 'ps-right-header)
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.
+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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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), 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.
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))
+ (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 "P")
- (setq filename (ps-print-preprint filename))
+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."
- (interactive "r\nP")
- (setq filename (ps-print-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."
+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 "r\nP")
- (setq filename (ps-print-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.
'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.
+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.
Use the command `ps-despool' to send the spooled images to the printer."
'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.
Use the command `ps-despool' to send the spooled images to the printer."
'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.
+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.
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.
is nil, send the image to the printer. If FILENAME is a string, save
the PostScript image in a file with that name. If FILENAME is a
number, prompt the user for the name of the file to save in."
- (interactive "P")
- (ps-do-despool (ps-print-preprint filename)))
+ (interactive (list (ps-print-preprint current-prefix-arg)))
+ (ps-do-despool filename))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Utility functions and variables:
-(if (featurep 'emacs-vers)
- nil
- (defvar emacs-type (cond ((string-match "XEmacs" emacs-version) 'xemacs)
- ((string-match "Lucid" emacs-version) 'lucid)
- ((string-match "Epoch" emacs-version) 'epoch)
- (t 'fsf))))
+(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 emacs-type 'lucid)
- (eq emacs-type 'xemacs))
- (setq ps-print-color-p nil)
+(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
findfont
dup /Ascent get /Ascent exch def
dup /Descent get /Descent exch def
- dup /FontHeight get /LineHeight exch def
+ dup /FontHeight get /FontHeight exch def
dup /UnderlinePosition get /UnderlinePosition exch def
dup /UnderlineThickness get /UnderlineThickness exch def
setfont
/h1 F
-/HeaderLineHeight LineHeight def
+/HeaderLineHeight FontHeight def
/HeaderDescent Descent def
/HeaderPad 2 def
2 copy
/t0 3 1 roll Font
/t0 F
- /lh LineHeight def
+ /lh FontHeight def
/sw ( ) stringwidth pop def
/aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch
stringwidth pop exch div def
sw 32 string cvs show
(,) show
grestore
- 0 LineHeight neg rmoveto
+ 0 FontHeight neg rmoveto
(and a crude estimate of average character width is ) show
aw 32 string cvs show
(.) show
(defvar ps-razchunk 0)
-(defvar ps-color-format (if (eq emacs-type 'fsf)
+(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
(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))
(chunkfrac (/ q-todo 8))
(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)
(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))
+(defvar ps-print-color-scale nil)
(defun ps-set-bg (color)
(if (setq ps-current-bg color)
(defun ps-set-color (color)
(if (setq ps-current-color color)
- (ps-output (format ps-color-format (nth 0 ps-current-color)
- (nth 1 ps-current-color) (nth 2 ps-current-color))
- " FG\n")))
+ 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")
;; 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)))
+
(defun ps-plot-with-face (from to face)
(if face
- (let* ((bold-p (memq face ps-ref-bold-faces))
- (italic-p (memq face ps-ref-italic-faces))
- (underline-p (memq face ps-ref-underlined-faces))
- (foreground (face-foreground face))
- (background (face-background face))
+ (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
- (x-color-values foreground))
+ (ps-color-values foreground))
ps-default-color))
(bg-color (if (and ps-print-color-p background)
(mapcar 'ps-color-value
- (x-color-values background)))))
+ (ps-color-values background)))))
(ps-plot-region from to
(cond ((and bold-p italic-p) 3)
(italic-p 2)
(goto-char to)))
-(defun ps-fsf-face-kind-p (face kind kind-regex kind-list)
+(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
(memq face kind-list))))
(defun ps-face-bold-p (face)
- (if (eq emacs-type 'fsf)
- (ps-fsf-face-kind-p face 'bold "-\\(bold\\|demibold\\)-"
+ (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 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)))
+ (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)))
-(defun ps-faces-list ()
- (if (or (eq emacs-type 'lucid) (eq emacs-type 'xemacs))
- (list-faces)
- (face-list)))
+;; 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 (ps-faces-list))
+ (let ((faces (face-list))
the-face)
(setq ps-ref-bold-faces nil
ps-ref-italic-faces nil
(defun ps-sorter (a b)
(< (car a) (car b)))
-
+
+(defun ps-extent-sorter (a b)
+ (< (extent-priority a) (extent-priority b)))
+
+(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)
(let ((face 'default)
(position to))
- (cond ((or (eq emacs-type 'lucid) (eq emacs-type 'xemacs))
+ (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))
record type extent extent-list)
(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)))))
- ((eq emacs-type 'fsf)
+ ((eq ps-print-emacs-type 'emacs)
(let ((property-change from)
(overlay-change from))
(while (< 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)
+ (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))
+ ;; 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
+ (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)
- (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)
+ (funcall genfunc from to)
+ (ps-end-page)
- (if (and ps-spool-duplex
- (= (mod ps-page-count 2) 1))
- (ps-dummy-page))
- (ps-flush-output)
+ (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
+ ;; Back to the PS output buffer to set the page count
(set-buffer ps-spool-buffer)
- (delete-region (marker-position safe-marker) (point-max))))))
+ (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"))))
+ (if ps-razzle-dazzle
+ (message "Formatting...done")))))
(defun ps-do-despool (filename)
(if (or (not (boundp 'ps-spool-buffer))
;; 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:
+;; WARNING!!! The following code is *sample* code only. Don't use it
+;; unless you understand what it does!
+
+(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 ()
;; 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)
+ (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
;; 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
+ (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.
;; 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 '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)
+ (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-switches '("-Jjct,duplex_long")))
(provide 'ps-print)
+
;;; ps-print.el ends here