;;; ps-print.el --- print text from the buffer as PostScript
-;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+;; 2003 Free Software Foundation, Inc.
;; Author: Jim Thompson (was <thompson@wg2.waii.com>)
;; Jacques Duthen (was <duthen@cegelec-red.fr>)
-;; Vinicius Jose Latorre <vinicius@cpqd.com.br>
+;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
;; Maintainer: Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
-;; Vinicius Jose Latorre <vinicius@cpqd.com.br>
+;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, print, PostScript
-;; Time-stamp: <2002/09/11 15:52:39 vinicius>
-;; Version: 6.5.7
+;; Time-stamp: <2003/07/10 19:19:12 vinicius>
+;; Version: 6.6.2
;; X-URL: http://www.cpqd.com.br/~vinicius/emacs/
-(defconst ps-print-version "6.5.7"
- "ps-print.el, v 6.5.7 <2002/09/11 vinicius>
+(defconst ps-print-version "6.6.2"
+ "ps-print.el, v 6.6.2 <2003/07/10 vinicius>
Vinicius'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
- Vinicius Jose Latorre <vinicius@cpqd.com.br>.")
+ Vinicius Jose Latorre <viniciusjl@ig.com.br>.")
;; This file is part of GNU Emacs.
;;
;; 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 or Lucid Emacs, together
-;; with a fontifying package such as font-lock or hilit.
+;; output. ps-print is intended for use with Emacs or XEmacs, together with a
+;; fontifying package such as font-lock or hilit.
;;
;; ps-print uses the same face attributes defined through font-lock or hilit to
;; print a PostScript file, but some faces are better seeing on the screen than
;; 22 + 22 +
;; -------- ----------- --------- ----------------
;;
-;; Any other value is treated as `nil'.
+;; Any other value is treated as nil.
;;
;; See also section How Ps-Print Has A Text And/Or Image On Background.
;;
;; (face...) list of faces whose background color will be used.
;;
;; Any other value will be treated as t.
-;; The default value is t.
+;; The default value is nil.
;;
;;
;; How Ps-Print Deals With Color
;; New since version 2.8
;; ---------------------
;;
-;; [vinicius] Vinicius Jose Latorre <vinicius@cpqd.com.br>
+;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br>
;;
;; 20010619
;; `ps-time-stamp-locale-default'
;;
;; `ps-print-region-function'
;;
-;; [vinicius] Vinicius Jose Latorre <vinicius@cpqd.com.br>
+;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br>
;;
;; 19990301
;; PostScript tumble and setpagedevice.
;;
;; Multi-byte buffer handling.
;;
-;; [vinicius] Vinicius Jose Latorre <vinicius@cpqd.com.br>
+;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br>
;;
;; 19980306
;; Skip invisible text.
;;
;; Faces are always treated as opaque.
;;
-;; Epoch and Emacs 19 not supported. At all.
+;; Epoch, Lucid and Emacs 19 not supported. At all.
;;
;; Fixed-pitch fonts work better for line folding, but are not required.
;;
(error "`ps-print' requires floating point support"))
+ (defvar ps-print-emacs-type
+ (let ((case-fold-search t))
+ (cond ((string-match "XEmacs" emacs-version) 'xemacs)
+ ((string-match "Lucid" emacs-version)
+ (error "`ps-print' doesn't support Lucid"))
+ ((string-match "Epoch" emacs-version)
+ (error "`ps-print' doesn't support Epoch"))
+ (t
+ (unless (and (boundp 'emacs-major-version)
+ (> emacs-major-version 19))
+ (error "`ps-print' only supports Emacs 20 and higher"))
+ 'emacs))))
+
+
;; For Emacs 20.2 and the earlier version.
(or (fboundp 'set-buffer-multibyte)
(memq system-type '(usg-unix-v dgux hpux irix)))
- (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)))
-
- (or (memq ps-print-emacs-type '(lucid xemacs))
- (require 'faces)) ; face-font, face-underline-p,
- ; x-font-regexp
-
(defun ps-xemacs-color-name (color)
(if (ps-x-color-specifier-p color)
(ps-x-color-name color)
(defalias 'ps-face-foreground-name 'face-foreground)
(defalias 'ps-face-background-name 'face-background)
)
- (t ; xemacs, lucid, epoch
+ (t ; xemacs
(defalias 'ps-mark-active-p 'region-active-p)
(defun ps-face-foreground-name (face)
(ps-xemacs-color-name (face-foreground face)))
requirements and set %%LanguageLevel: to 2, do:
(setq ps-print-prologue-header
- \"%%+ numcopies(3) jog\\n%%LanguageLevel: 2\\n\")
+ \"%%+ numcopies(3) jog\\n%%LanguageLevel: 2\\n\")
The duplex requirement is inserted by ps-print (see `ps-spool-duplex').
If a list, the lists element may be an integer or a cons cell (FROM . TO)
designating FROM page to TO page; any invalid element is ignored, that is, an
-integer less than one or if FROM is greater than TO.
+integer lesser than one or if FROM is greater than TO.
Otherwise, it's treated as nil.
22 + 22 +
-------- ----------- --------- ----------------
-Any other value is treated as `nil'."
+Any other value is treated as nil."
:type '(choice :menu-tag "Zebra Stripe Follow"
:tag "Zebra Stripe Follow"
(const :tag "Always Restart" nil)
(const :tag "Print Black/White Color" black-white))
:group 'ps-print-color)
-(defcustom ps-default-fg (or (ps-face-foreground-name 'default)
- '(0.0 0.0 0.0)) ; black
- "*RGB values of the default foreground color. Defaults to black."
+(defcustom ps-default-fg '(0.0 0.0 0.0) ; black
+ "*RGB values of the default foreground color. Defaults to black.
+
+The `ps-default-fg' variable contains the default foreground color used by
+ps-print, that is, if there is a face in a text that doesn't have a foreground
+color, the `ps-default-fg' color should be used.
+
+Valid values are:
+
+ t The foreground color of Emacs session will be used.
+
+ NUMBER It's a real value between 0.0 (black) and 1.0 (white) that
+ indicate the gray color.
+
+ COLOR-NAME It's a string wich contains the color name. For example:
+ \"yellow\".
+
+ LIST It's a list of RGB values, that is a list of three real values
+ of the form:
+
+ (RED, GREEN, BLUE)
+
+ Where RED, GREEN and BLUE are reals between 0.0 (no color) and
+ 1.0 (full color).
+
+Any other value is ignored and it's used the black color.
+
+It's used only when `ps-print-color-p' is non-nil."
:type '(choice :menu-tag "Default Foreground Gray/Color"
:tag "Default Foreground Gray/Color"
+ (const :tag "Session Foreground" t)
(number :tag "Gray Scale" :value 0.0)
(string :tag "Color Name" :value "black")
(list :tag "RGB Color" :value (0.0 0.0 0.0)
(number :tag "Blue")))
:group 'ps-print-color)
-(defcustom ps-default-bg (or (ps-face-background-name 'default)
- '(1.0 1.0 1.0)) ; white
- "*RGB values of the default background color. Defaults to white."
+(defcustom ps-default-bg '(1.0 1.0 1.0) ; white
+ "*RGB values of the default background color. Defaults to white.
+
+The `ps-default-bg' variable contains the default background color used by
+ps-print, that is, if there is a face in a text that doesn't have a background
+color, the `ps-default-bg' color should be used.
+
+Valid values are:
+
+ t The background color of Emacs session will be used.
+
+ NUMBER It's a real value between 0.0 (black) and 1.0 (white) that
+ indicate the gray color.
+
+ COLOR-NAME It's a string wich contains the color name. For example:
+ \"yellow\".
+
+ LIST It's a list of RGB values, that is a list of three real values
+ of the form:
+
+ (RED, GREEN, BLUE)
+
+ Where RED, GREEN and BLUE are reals between 0.0 (no color) and
+ 1.0 (full color).
+
+Any other value is ignored and it's used the white color.
+
+It's used only when `ps-print-color-p' is non-nil.
+
+See also `ps-use-face-background'."
:type '(choice :menu-tag "Default Background Gray/Color"
:tag "Default Background Gray/Color"
+ (const :tag "Session Background" t)
(number :tag "Gray Scale" :value 1.0)
(string :tag "Color Name" :value "white")
(list :tag "RGB Color" :value (1.0 1.0 1.0)
(or (cond
((eq ps-print-emacs-type 'emacs) ; emacs
data-directory)
- ((fboundp 'locate-data-directory) ; emacsens (xemacs, etc.)
+ ((fboundp 'locate-data-directory) ; xemacs
(locate-data-directory "ps-print"))
- ((boundp 'data-directory) ; emacsens (xemacs, etc.)
+ ((boundp 'data-directory) ; xemacs
data-directory)
(t ; don't know what to do
nil))
- (error "ps-postscript-code-directory isn't set properly"))
+ (error "`ps-postscript-code-directory' isn't set properly"))
"*Directory where it's located the PostScript prologue file used by ps-print.
By default, this directory is the same as in the variable `data-directory'."
:type 'directory
(eval-and-compile
- (and (memq ps-print-emacs-type '(lucid xemacs))
+ (and (eq ps-print-emacs-type 'xemacs)
;; XEmacs change: Need to check for emacs-major-version too.
(or (< emacs-major-version 19)
(and (= emacs-major-version 19) (< emacs-minor-version 12)))
(memq face ps-italic-faces)))
)
- (t ; xemacs, lucid, epoch
+ (t ; xemacs
;; to avoid XEmacs compilation gripes
(defvar coding-system-for-write nil)
(defvar ps-current-font 0)
(defvar ps-default-foreground nil)
+(defvar ps-default-background nil)
(defvar ps-default-color nil)
(defvar ps-current-color nil)
(defvar ps-current-bg nil)
;; PostScript output.
"%0.3f %0.3f %0.3f"
- ;; Lucid emacsen will have to make do with %s (princ) for floats.
+ ;; XEmacs will have to make do with %s (princ) for floats.
"%s %s %s"))
;; These values determine how much print-height to deduct when headers/footers
(defun ps-spool-without-faces (from to &optional region-p)
(run-hooks 'ps-print-hook)
- (ps-printing-region region-p from)
+ (ps-printing-region region-p from to)
(ps-generate (current-buffer) from to 'ps-generate-postscript))
(defun ps-spool-with-faces (from to &optional region-p)
(run-hooks 'ps-print-hook)
- (ps-printing-region region-p from)
+ (ps-printing-region region-p from to)
(ps-generate (current-buffer) from to 'ps-generate-postscript-with-faces))
"Non-nil means ps-print is printing a region.")
-(defun ps-printing-region (region-p from)
+(defun ps-printing-region (region-p from to)
(setq ps-printing-region-p region-p
ps-printing-region
(cons (if region-p
- (ps-count-lines (point-min) from)
+ (ps-count-lines (point-min) (min from to))
1)
(ps-count-lines (point-min) (point-max)))))
(while (progn (skip-chars-forward " -'*-[]-~") (not (eobp)))
(let ((special (following-char)))
(delete-char 1)
- (insert (aref ps-string-escape-codes special))))
+ (insert
+ (if (and (<= 0 special) (<= special 255))
+ (aref ps-string-escape-codes special)
+ ;; insert hexadecimal representation if character code is out of range
+ (format "\\%04X" special)
+ ))))
(goto-char (point-max))
(insert ")")) ;insert end-string delimiter
(goto-char (point-max))
(insert-file fname)))
+;; These functions are used in `ps-mule' to get charset of header and footer.
+;; To avoid unnecessary calls to functions in `ps-left-header',
+;; `ps-right-header', `ps-left-footer' and `ps-right-footer'.
+
+(defun ps-generate-string-list (content)
+ (let (str)
+ (while content
+ (setq str (cons (cond
+ ((stringp (car content))
+ (car content))
+ ((and (symbolp (car content)) (fboundp (car content)))
+ (concat "(" (funcall (car content)) ")"))
+ ((and (symbolp (car content)) (boundp (car content)))
+ (concat "(" (symbol-value (car content)) ")"))
+ (t
+ ""))
+ str)
+ content (cdr content)))
+ (nreverse str)))
+
+(defvar ps-lh-cache nil)
+(defvar ps-rh-cache nil)
+(defvar ps-lf-cache nil)
+(defvar ps-rf-cache nil)
+
+(defun ps-header-footer-string ()
+ (and ps-print-header
+ (setq ps-lh-cache (ps-generate-string-list ps-left-header)
+ ps-rh-cache (ps-generate-string-list ps-right-header)))
+ (and ps-print-footer
+ (setq ps-lf-cache (ps-generate-string-list ps-left-footer)
+ ps-rf-cache (ps-generate-string-list ps-right-footer)))
+ (mapconcat 'identity
+ (append ps-lh-cache ps-rh-cache ps-lf-cache ps-rf-cache)
+ ""))
+
;; These functions insert the arrays that define the contents of the headers.
(defun ps-generate-header-line (fonttag &optional content)
;; 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.
-;; Lucid emacsen will have to make do with %s (princ) for floats.
+;; XEmacs will have to make do with %s (princ) for floats.
(defvar ps-float-format (if (eq ps-print-emacs-type 'emacs)
"%0.3f " ; emacs
- "%s ")) ; Lucid emacsen
+ "%s ")) ; xemacs
(defun ps-float-format (value &optional default)
"/ZebraColor "
(ps-format-color ps-zebra-color 0.95)
"def\n/BackgroundColor "
- (ps-format-color ps-default-bg 1.0)
+ (ps-format-color ps-default-background 1.0)
"def\n/UseSetpagedevice "
(if (eq ps-spool-config 'setpagedevice)
"/setpagedevice where{pop languagelevel 2 eq}{false}ifelse"
(ps-get-size (symbol-value font-sym) "font size" font-sym))
-(defsubst ps-rgb-color (color default)
- (cond ((and color (listp color)) color)
+(defun ps-rgb-color (color default)
+ (cond ((and color (listp color) (= (length color) 3)
+ (let ((cl color)
+ (ok t) e)
+ (while (and ok cl)
+ (setq e (car cl)
+ cl (cdr cl)
+ ok (and (floatp e) (<= 0.0 e) (<= e 1.0))))
+ ok))
+ color)
+ ((and (floatp color) (<= 0.0 color) (<= color 1.0))
+ (list color color color))
((stringp color) (ps-color-scale color))
- ((numberp color) (list color color color))
(t (list default default default))
))
((eq ps-print-control-characters 'control)
"[\000-\037\177]")
(t "[\t\n\f]"))
- ps-default-foreground (ps-rgb-color ps-default-fg 0.0)
+ ps-default-background (ps-rgb-color
+ (if (eq ps-default-bg t)
+ (ps-face-background-name 'default)
+ ps-default-bg)
+ 1.0)
+ ps-default-foreground (ps-rgb-color
+ (if (eq ps-default-fg t)
+ (ps-face-foreground-name 'default)
+ ps-default-fg)
+ 0.0)
ps-default-color (and (eq ps-print-color-p t) ps-default-foreground)
ps-current-color ps-default-color
;; Set the color scale. We do it here instead of in the defvar so
(float (car (ps-color-values "white")))
1.0))
;; initialize page dimensions
- (ps-get-page-dimensions))
+ (ps-get-page-dimensions)
+ ;; final check
+ (and ps-color-p
+ (equal ps-default-background ps-default-foreground)
+ (error
+ (concat
+ "`ps-default-fg' and `ps-default-bg' have the same color.\n"
+ "Text won't appear on page. Please, check these variables."))))
(defun ps-page-number ()
(format "/PageNumber %d def\n" (ps-page-number)))
(when ps-print-header
- (ps-generate-header "HeaderLinesLeft" "/h0" "/h1" ps-left-header)
- (ps-generate-header "HeaderLinesRight" "/h0" "/h1" ps-right-header)
- (ps-output (format "%d SetHeaderLines\n" ps-header-lines)))
+ (ps-generate-header "HeaderLinesLeft" "/h0" "/h1"
+ (or ps-lh-cache ps-left-header))
+ (ps-generate-header "HeaderLinesRight" "/h0" "/h1"
+ (or ps-rh-cache ps-right-header))
+ (ps-output (format "%d SetHeaderLines\n" ps-header-lines))
+ (setq ps-lh-cache nil
+ ps-rh-cache nil))
(when ps-print-footer
- (ps-generate-header "FooterLinesLeft" "/H0" "/H0" ps-left-footer)
- (ps-generate-header "FooterLinesRight" "/H0" "/H0" ps-right-footer)
- (ps-output (format "%d SetFooterLines\n" ps-footer-lines)))
+ (ps-generate-header "FooterLinesLeft" "/H0" "/H0"
+ (or ps-lf-cache ps-left-footer))
+ (ps-generate-header "FooterLinesRight" "/H0" "/H0"
+ (or ps-rf-cache ps-right-footer))
+ (ps-output (format "%d SetFooterLines\n" ps-footer-lines))
+ (setq ps-lf-cache nil
+ ps-rf-cache nil))
(ps-output (number-to-string ps-lines-printed) " BeginPage\n")
(ps-set-font ps-current-font)
(let ((face 'default)
(position to))
(cond
- ((memq ps-print-emacs-type '(xemacs lucid))
+ ((eq ps-print-emacs-type 'xemacs)
;; Build the list of extents...
(let ((a (cons 'dummy nil))
record type extent extent-list)
(provide 'ps-print)
+;;; arch-tag: fb06a585-1112-4206-885d-a57d95d50579
;;; ps-print.el ends here