;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters)
;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, print, PostScript
-;; Version: 6.7.1
+;; Version: 6.8.1
;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
-(defconst ps-print-version "6.7.1"
- "ps-print.el, v 6.7.1 <2007/01/21 vinicius>
+(defconst ps-print-version "6.8.1"
+ "ps-print.el, v 6.8.1 <2007/11/09 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
;; 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 the Free
-;; Software Foundation; either version 2, or (at your option) any later
+;; Software Foundation; either version 3, or (at your option) any later
;; version.
;; GNU Emacs is distributed in the hope that it will be useful, but WITHOUT ANY
;; You can also set `ps-print-color-p' to 'black-white to have a better looking
;; on black/white printers. See also `ps-black-white-faces' for documentation.
;;
+;; ps-print also detects if the text foreground and background colors are
+;; equals when `ps-fg-validate-p' is non-nil. In this case, if these colors
+;; are used, no text will appear. You can use `ps-fg-list' to give a list of
+;; foreground colors to be used when text foreground and background colors are
+;; equals. It'll be used the first foreground color in `ps-fg-list' which is
+;; different from the background color. If `ps-fg-list' is nil, the default
+;; foreground color is used.
+;;
;;
;; How Ps-Print Maps Faces
;; -----------------------
;;
;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br>
;;
-;; 20040229
+;; 2007-10-27
+;; `ps-fg-validate-p', `ps-fg-list'
+;;
+;; 2004-02-29
;; `ps-time-stamp-yyyy-mm-dd', `ps-time-stamp-iso8601'
;;
-;; 20010619
+;; 2001-06-19
;; `ps-time-stamp-locale-default'
;;
-;; 20010530
+;; 2001-05-30
;; Handle before-string and after-string overlay properties.
;;
-;; 20010407
+;; 2001-04-07
;; `ps-line-number-color', `ps-print-footer', `ps-footer-offset',
;; `ps-print-footer-frame', `ps-footer-font-family',
;; `ps-footer-font-size', `ps-footer-line-pad', `ps-footer-lines',
;; `ps-left-footer', `ps-right-footer', `ps-footer-frame-alist' and
;; `ps-header-frame-alist'.
;;
-;; 20010328
+;; 2001-03-28
;; `ps-line-spacing', `ps-paragraph-spacing', `ps-paragraph-regexp',
;; `ps-begin-cut-regexp' and `ps-end-cut-regexp'.
;;
-;; 20001122
+;; 2000-11-22
;; `ps-line-number-font', `ps-line-number-font-size' and
;; `ps-end-with-control-d'.
;;
-;; 20000821
+;; 2000-08-21
;; `ps-even-or-odd-pages'
;;
-;; 20000617
+;; 2000-06-17
;; `ps-manual-feed', `ps-warn-paper-type', `ps-print-upside-down',
;; `ps-selected-pages', `ps-last-selected-pages',
;; `ps-restore-selected-pages', `ps-switch-header',
;; `ps-line-number-step', `ps-line-number-start',
;; `ps-zebra-stripe-follow' and `ps-use-face-background'.
;;
-;; 20000310
+;; 2000-03-10
;; PostScript error handler.
;; `ps-user-defined-prologue' and `ps-error-handler-message'.
;;
-;; 19991211
+;; 1999-12-11
;; `ps-print-customize'.
;;
-;; 19990703
+;; 1999-07-03
;; Better customization.
;; `ps-banner-page-when-duplexing' and `ps-zebra-color'.
;;
-;; 19990513
+;; 1999-05-13
;; N-up printing.
;; Hook: `ps-print-begin-sheet-hook'.
;;
-;; [kenichi] 19990509 Ken'ichi Handa <handa@m17n.org>
+;; [kenichi] 1999-05-09 Ken'ichi Handa <handa@m17n.org>
;;
;; `ps-print-region-function'
;;
;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br>
;;
-;; 19990301
+;; 1999-03-01
;; PostScript tumble and setpagedevice.
;;
-;; 19980922
+;; 1998-09-22
;; PostScript prologue header comment insertion.
;; Skip invisible text better.
;;
-;; [kenichi] 19980819 Ken'ichi Handa <handa@m17n.org>
+;; [kenichi] 1998-08-19 Ken'ichi Handa <handa@m17n.org>
;;
;; Multi-byte buffer handling.
;;
;; [vinicius] Vinicius Jose Latorre <viniciusjl@ig.com.br>
;;
-;; 19980306
+;; 1998-03-06
;; Skip invisible text.
;;
-;; 19971130
+;; 1997-11-30
;; Hooks: `ps-print-hook', `ps-print-begin-page-hook' and
;; `ps-print-begin-column-hook'.
;; Put one header per page over the columns.
;; Better database font management.
;; Better control characters handling.
;;
-;; 19971121
+;; 1997-11-21
;; Dynamic evaluation at print time of `ps-lpr-switches'.
;; Handle control characters.
;; Face remapping.
;; Zebra stripes.
;; Text and/or image on background.
;;
-;; [jack] 19960517 Jacques Duthen <duthen@cegelec-red.fr>
+;; [jack] 1996-05-17 Jacques Duthen <duthen@cegelec-red.fr>
;;
-;; Font family and float size for text and header.
-;; Landscape mode.
-;; Multiple columns.
-;; Tools for page setup.
+;; Font family and float size for text and header.
+;; Landscape mode.
+;; Multiple columns.
+;; Tools for page setup.
;;
;;
;; Known bugs and limitations of ps-print
;; ----------------
;;
;; Avoid page break inside a paragraph.
+;;
;; Add `ps-non-bold-faces' and `ps-non-italic-faces' (should be easy).
+;;
;; Improve the memory management for big files (hard?).
+;;
;; `ps-nb-pages-buffer' and `ps-nb-pages-region' should take care of folding
;; lines.
;;
(or (featurep 'lisp-float-type)
(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 22))
- (error "`ps-print' only supports Emacs 22 and higher"))
- 'emacs))))
+(if (featurep 'xemacs)
+ ()
+ (unless (and (boundp 'emacs-major-version)
+ (>= emacs-major-version 22))
+ (error "`ps-print' only supports Emacs 22 and higher")))
;; GNU Emacs
;; to avoid compilation gripes
-;; XEmacs
-(defalias 'ps-x-color-instance-p 'color-instance-p)
-(defalias 'ps-x-color-instance-rgb-components 'color-instance-rgb-components)
-(defalias 'ps-x-color-name 'color-name)
-(defalias 'ps-x-color-specifier-p 'color-specifier-p)
-(defalias 'ps-x-copy-coding-system 'copy-coding-system)
-(defalias 'ps-x-device-class 'device-class)
-(defalias 'ps-x-extent-end-position 'extent-end-position)
-(defalias 'ps-x-extent-face 'extent-face)
-(defalias 'ps-x-extent-priority 'extent-priority)
-(defalias 'ps-x-extent-start-position 'extent-start-position)
-(defalias 'ps-x-face-font-instance 'face-font-instance)
-(defalias 'ps-x-find-coding-system 'find-coding-system)
-(defalias 'ps-x-font-instance-properties 'font-instance-properties)
-(defalias 'ps-x-make-color-instance 'make-color-instance)
-(defalias 'ps-x-map-extents 'map-extents)
-(defalias 'ps-x-frame-property 'frame-property)
-
;; GNU Emacs
-(defalias 'ps-e-face-bold-p 'face-bold-p)
-(defalias 'ps-e-face-italic-p 'face-italic-p)
-(defalias 'ps-e-next-overlay-change 'next-overlay-change)
-(defalias 'ps-e-overlays-at 'overlays-at)
-(defalias 'ps-e-overlay-get 'overlay-get)
-(defalias 'ps-e-overlay-end 'overlay-end)
-(defalias 'ps-e-x-color-values 'x-color-values)
-(defalias 'ps-e-color-values 'color-values)
-(defalias 'ps-e-frame-parameter 'frame-parameter)
-(if (fboundp 'find-composition)
- (defalias 'ps-e-find-composition 'find-composition)
- (defalias 'ps-e-find-composition 'ignore))
+(defalias 'ps-e-find-composition (if (fboundp 'find-composition)
+ 'find-composition
+ 'ignore))
(defconst ps-windows-system
(defun ps-xemacs-color-name (color)
- (if (ps-x-color-specifier-p color)
- (ps-x-color-name color)
- color))
-
-
-(cond ((featurep 'xemacs) ; xemacs
- (defalias 'ps-mark-active-p 'region-active-p)
- (defun ps-face-foreground-name (face)
- (ps-xemacs-color-name (face-foreground face)))
- (defun ps-face-background-name (face)
- (ps-xemacs-color-name (face-background face)))
- (defun ps-frame-parameter (param)
- (ps-x-frame-property nil param))
- )
- (t ; emacs 22 or higher
- (defvar mark-active nil)
- (defun ps-mark-active-p ()
- mark-active)
- (defun ps-face-foreground-name (face)
- (face-foreground face nil t))
- (defun ps-face-background-name (face)
- (face-background face nil t))
- (defun ps-frame-parameter (param)
- (ps-e-frame-parameter nil param))
- ))
+ (when (featurep 'xemacs)
+ (if (color-specifier-p color)
+ (color-name color)
+ color)))
+
+(defalias 'ps-frame-parameter
+ (if (fboundp 'frame-parameter) 'frame-parameter 'frame-property))
+
+(defalias 'ps-mark-active-p
+ (if (fboundp 'region-active-p)
+ 'region-active-p ; XEmacs
+ (defvar mark-active) ; To shup up XEmacs's byte compiler.
+ (lambda () mark-active))) ; Emacs
+
+(defun ps-face-foreground-name (face)
+ (if (featurep 'xemacs)
+ (ps-xemacs-color-name (face-foreground face))
+ (face-foreground face nil t)))
+(defun ps-face-background-name (face)
+ (if (featurep 'xemacs)
+ (ps-xemacs-color-name (face-background face))
+ (face-background face nil t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User Variables:
:group 'ps-print-font)
(defcustom ps-font-size '(7 . 8.5)
- "*Font size, in points, for ordinary text, when generating PostScript."
+ "*Font size, in points, for ordinary text, when generating PostScript.
+Either a float or a cons of floats (LANDSCAPE-SIZE . PORTRAIT-SIZE)."
:type '(choice :menu-tag "Ordinary Text Font Size"
:tag "Ordinary Text Font Size"
(number :tag "Text Size")
:group 'ps-print-font)
(defcustom ps-header-font-size '(10 . 12)
- "*Font size, in points, for text in the header, when generating PostScript."
+ "*Font size, in points, for text in the header, when generating PostScript.
+Either a float or a cons of floats (LANDSCAPE-SIZE . PORTRAIT-SIZE)."
:type '(choice :menu-tag "Header Font Size"
:tag "Header Font Size"
(number :tag "Header Size")
:group 'ps-print-font)
(defcustom ps-header-title-font-size '(12 . 14)
- "*Font size, in points, for the top line of text in header, in PostScript."
+ "*Font size, in points, for the top line of text in header, in PostScript.
+Either a float or a cons of floats (LANDSCAPE-SIZE . PORTRAIT-SIZE)."
:type '(choice :menu-tag "Header Title Font Size"
:tag "Header Title Font Size"
(number :tag "Header Title Size")
:group 'ps-print-font)
(defcustom ps-footer-font-size '(10 . 12)
- "*Font size, in points, for text in the footer, when generating PostScript."
+ "*Font size, in points, for text in the footer, when generating PostScript.
+Either a float or a cons of floats (LANDSCAPE-SIZE . PORTRAIT-SIZE)."
:type '(choice :menu-tag "Footer Font Size"
:tag "Footer Font Size"
(number :tag "Footer Size")
:group 'ps-print-miscellany)
(defcustom ps-line-number-font-size 6
- "*Font size, in points, for line number, when generating PostScript."
+ "*Font size, in points, for line number, when generating PostScript.
+Either a float or a cons of floats (LANDSCAPE-SIZE . PORTRAIT-SIZE)."
:type '(choice :menu-tag "Line Number Font Size"
:tag "Line Number Font Size"
(number :tag "Font Size")
:version "20"
:group 'ps-print-color)
-(defcustom ps-default-fg 'frame-parameter
+(defcustom ps-default-fg nil
"*RGB values of the default foreground color.
The `ps-default-fg' variable contains the default foreground color used by
LIST It's a list of RGB values, that is a list of three real values
of the form:
- (RED, GREEN, BLUE)
+ (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 black color will be used.
-It's used only when `ps-print-color-p' is non-nil."
+This variable is used only when `ps-print-color-p' (which see) is neither nil
+nor black-white."
:type '(choice :menu-tag "Default Foreground Gray/Color"
:tag "Default Foreground Gray/Color"
(const :tag "Session Foreground" t)
:version "20"
:group 'ps-print-color)
-(defcustom ps-default-bg 'frame-parameter
+(defcustom ps-default-bg nil
"*RGB values of the default background color.
The `ps-default-bg' variable contains the default background color used by
LIST It's a list of RGB values, that is a list of three real values
of the form:
- (RED, GREEN, BLUE)
+ (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 white color will be used.
-It's used only when `ps-print-color-p' is non-nil.
+This variable is used only when `ps-print-color-p' (which see) is neither nil
+nor black-white.
See also `ps-use-face-background'."
:type '(choice :menu-tag "Default Background Gray/Color"
:version "20"
:group 'ps-print-color)
+(defcustom ps-fg-list nil
+ "*Specify foreground color list.
+
+This list is used to chose a text foreground color which is different than the
+background color. It'll be used the first foreground color in `ps-fg-list'
+which is different from the background color.
+
+If this list is nil, the default foreground color is used. See
+`ps-default-fg'.
+
+The list element valid values are:
+
+ 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 which 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 black color will be used.
+
+This variable is used only when `ps-fg-validate-p' (which see) is non-nil and
+when `ps-print-color-p' (which see) is neither nil nor black-white."
+ :type '(repeat
+ (choice :menu-tag "Foreground Gray/Color"
+ :tag "Foreground Gray/Color"
+ (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 "Red")
+ (number :tag "Green")
+ (number :tag "Blue"))))
+ :version "22"
+ :group 'ps-print-color)
+
+(defcustom ps-fg-validate-p t
+ "*Non-nil means validate if foreground color is different than background.
+
+If text foreground and background colors are equals, no text will appear.
+
+See also `ps-fg-list'."
+ :type 'boolean
+ :version "22"
+ :group 'ps-print-color)
+
(defcustom ps-auto-font-detect t
"*Non-nil means automatically detect bold/italic/underline face attributes.
If nil, we rely solely on the lists `ps-bold-faces', `ps-italic-faces', and
"*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
+bold and italic faces. By setting 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.
(defcustom ps-postscript-code-directory
(or (if (featurep 'xemacs)
- (cond ((fboundp 'locate-data-directory) ; xemacs
- (locate-data-directory "ps-print"))
- ((boundp 'data-directory) ; xemacs
- data-directory)
+ (cond ((fboundp 'locate-data-directory) ; XEmacs
+ (funcall 'locate-data-directory "ps-print"))
+ ((boundp 'data-directory) ; XEmacs
+ (symbol-value 'data-directory))
(t ; don't know what to do
nil))
- data-directory) ; emacs
+ data-directory) ; Emacs
(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'."
(defcustom ps-line-spacing 0
"*Specify line spacing, in points, for ordinary text.
+Either a float or a cons of floats (LANDSCAPE-SIZE . PORTRAIT-SIZE).
+
See also `ps-paragraph-spacing' and `ps-paragraph-regexp'.
To get all lines with some spacing set both `ps-line-spacing' and
(defcustom ps-paragraph-spacing 0
"*Specify paragraph spacing, in points, for ordinary text.
+Either a float or a cons of floats (LANDSCAPE-SIZE . PORTRAIT-SIZE).
+
See also `ps-line-spacing' and `ps-paragraph-regexp'.
To get all lines with some spacing set both `ps-line-spacing' and
(mapconcat
#'ps-print-quote
(list
- (concat "\n;;; ps-print version " ps-print-version "\n")
+ (concat "\n;;; (" (if (featurep 'xemacs) "XEmacs" "Emacs")
+ ") ps-print version " ps-print-version "\n")
";; internal vars"
- (ps-comment-string "emacs-version " emacs-version)
- (ps-comment-string "ps-print-emacs-type" ps-print-emacs-type)
- (ps-comment-string "ps-windows-system " ps-windows-system)
- (ps-comment-string "ps-lp-system " ps-lp-system)
+ (ps-comment-string "emacs-version " emacs-version)
+ (ps-comment-string "ps-windows-system " ps-windows-system)
+ (ps-comment-string "ps-lp-system " ps-lp-system)
nil
'(25 . ps-print-color-p)
'(25 . ps-lpr-command)
'(23 . ps-line-number-step)
'(23 . ps-line-number-start)
nil
- '(17 . ps-default-fg)
- '(17 . ps-default-bg)
'(17 . ps-razzle-dazzle)
+ '(17 . ps-default-bg)
+ '(17 . ps-default-fg)
+ '(17 . ps-fg-validate-p)
+ '(17 . ps-fg-list)
nil
'(23 . ps-use-face-background)
nil
'(20 . ps-underlined-faces)
'(20 . ps-black-white-faces)
" )\n
-;; The following customized variables have long lists and are seldom modified:
-;; ps-page-dimensions-database
-;; ps-font-info-database
+\;; The following customized variables have long lists and are seldom modified:
+\;; ps-page-dimensions-database
+\;; ps-font-info-database
-;;; ps-print - end of settings\n")
+\;;; ps-print - end of settings\n")
"\n")))
;; Return t if the device (which can be changed during an emacs session)
;; can handle colors.
;; This function is not yet implemented for GNU emacs.
-(cond ((and (featurep '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)))) ; xemacs >= 19.12
- (defun ps-color-device ()
- (eq (ps-x-device-class) 'color)))
-
- (t ; emacs
- (defun ps-color-device ()
- (if (fboundp 'color-values)
- (ps-e-color-values "Green")
- t))))
-
-
-(defun ps-mapper (extent list)
- (nconc list
- (list (list (ps-x-extent-start-position extent) 'push extent)
- (list (ps-x-extent-end-position extent) 'pull extent)))
+(defalias 'ps-color-device
+ (cond ((and (featurep '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)))) ; XEmacs >= 19.12
+ (lambda ()
+ (eq (device-class) 'color)))
+
+ (t ; Emacs
+ (lambda ()
+ (if (fboundp 'color-values)
+ (color-values "Green")
+ t)))))
+
+
+(defun ps-xemacs-mapper (extent list)
+ (when (featurep 'xemacs)
+ (nconc list
+ (list (list (extent-start-position extent) 'push extent)
+ (list (extent-end-position extent) 'pull extent))))
nil)
-(defun ps-extent-sorter (a b)
- (< (ps-x-extent-priority a) (ps-x-extent-priority b)))
+(defun ps-xemacs-extent-sorter (a b)
+ (when (featurep 'xemacs)
+ (< (extent-priority a) (extent-priority b))))
(defun ps-xemacs-face-kind-p (face kind kind-regex)
- (let* ((frame-font (or (ps-x-face-font-instance face)
- (ps-x-face-font-instance 'default)))
- (kind-cons
- (and frame-font
- (assq kind
- (ps-x-font-instance-properties frame-font))))
- (kind-spec (cdr-safe kind-cons))
- (case-fold-search t))
- (and kind-spec (string-match kind-regex kind-spec))))
-
-(cond ((featurep 'xemacs) ; xemacs
-
- ;; to avoid XEmacs compilation gripes
- (defvar coding-system-for-write nil)
- (defvar coding-system-for-read nil)
- (defvar buffer-file-coding-system nil)
-
- (and (fboundp 'find-coding-system)
- (or (ps-x-find-coding-system 'raw-text-unix)
- (ps-x-copy-coding-system 'no-conversion-unix 'raw-text-unix)))
-
- (defun ps-color-values (x-color)
- (let ((color (ps-xemacs-color-name x-color)))
- (cond
- ((fboundp 'x-color-values)
- (ps-e-x-color-values color))
- ((and (fboundp 'color-instance-rgb-components)
- (ps-color-device))
- (ps-x-color-instance-rgb-components
- (if (ps-x-color-instance-p x-color)
- x-color
- (ps-x-make-color-instance color))))
- (t
- (error "No available function to determine X color values")))))
-
- (defun ps-face-bold-p (face)
- (or (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold")
- (memq face ps-bold-faces))) ; Kludge-compatible
-
- (defun ps-face-italic-p (face)
- (or (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o")
- (ps-xemacs-face-kind-p face 'SLANT "i\\|o")
- (memq face ps-italic-faces))) ; Kludge-compatible
- )
-
- (t ; emacs
-
- (defun ps-color-values (x-color)
- (cond
- ((fboundp 'color-values)
- (ps-e-color-values x-color))
- ((fboundp 'x-color-values)
- (ps-e-x-color-values x-color))
- (t
- (error "No available function to determine X color values"))))
-
- (defun ps-face-bold-p (face)
- (or (ps-e-face-bold-p face)
- (memq face ps-bold-faces)))
-
- (defun ps-face-italic-p (face)
- (or (ps-e-face-italic-p face)
- (memq face ps-italic-faces)))
- ))
+ (when (featurep 'xemacs)
+ (let* ((frame-font (or (face-font-instance face)
+ (face-font-instance 'default)))
+ (kind-cons
+ (and frame-font
+ (assq kind
+ (font-instance-properties frame-font))))
+ (kind-spec (cdr-safe kind-cons))
+ (case-fold-search t))
+ (and kind-spec (string-match kind-regex kind-spec)))))
+
+(when (featurep 'xemacs)
+ ;; to avoid XEmacs compilation gripes
+ (defvar coding-system-for-write)
+ (defvar coding-system-for-read)
+ (defvar buffer-file-coding-system)
+
+ (and (fboundp 'find-coding-system)
+ (or (find-coding-system 'raw-text-unix)
+ (copy-coding-system 'no-conversion-unix 'raw-text-unix))))
+
+(defun ps-color-values (x-color)
+ (if (featurep 'xemacs)
+ (let ((color (ps-xemacs-color-name x-color)))
+ (cond
+ ((fboundp 'x-color-values)
+ (x-color-values color))
+ ((and (fboundp 'color-instance-rgb-components)
+ (ps-color-device))
+ (color-instance-rgb-components
+ (if (color-instance-p x-color)
+ x-color
+ (make-color-instance color))))
+ (t
+ (error "No available function to determine X color values"))))
+ (cond
+ ((fboundp 'color-values)
+ (color-values x-color))
+ ((fboundp 'x-color-values)
+ (x-color-values x-color))
+ (t
+ (error "No available function to determine X color values")))))
+
+(defun ps-face-bold-p (face)
+ (if (featurep 'xemacs)
+ (or (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold")
+ (memq face ps-bold-faces)) ; Kludge-compatible
+ (or (face-bold-p face)
+ (memq face ps-bold-faces))))
+(defun ps-face-italic-p (face)
+ (if (featurep 'xemacs)
+ (or (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o")
+ (ps-xemacs-face-kind-p face 'SLANT "i\\|o")
+ (memq face ps-italic-faces)) ; Kludge-compatible
+ (or (face-italic-p face)
+ (memq face ps-italic-faces))))
(defvar ps-print-color-scale 1.0)
(defvar ps-default-color nil)
(defvar ps-current-color nil)
(defvar ps-current-bg nil)
+(defvar ps-foreground-list nil)
(defvar ps-zebra-stripe-full-p nil)
(defvar ps-razchunk 0)
;; XEmacs will have to make do with %s (princ) for floats.
(defvar ps-float-format (if (featurep 'xemacs)
- "%s " ; xemacs
- "%0.3f ")) ; emacs
+ "%s " ; XEmacs
+ "%0.3f ")) ; Emacs
(defun ps-float-format (value &optional default)
(defun ps-background (page-number)
(let (has-local-background)
- (mapcar #'(lambda (range)
- (and (<= (aref range 0) page-number)
- (<= page-number (aref range 1))
- (if has-local-background
- (ps-output (aref range 2))
- (setq has-local-background t)
- (ps-output "/printLocalBackground{\n"
- (aref range 2)))))
- ps-background-pages)
+ (mapc #'(lambda (range)
+ (and (<= (aref range 0) page-number)
+ (<= page-number (aref range 1))
+ (if has-local-background
+ (ps-output (aref range 2))
+ (setq has-local-background t)
+ (ps-output "/printLocalBackground{\n"
+ (aref range 2)))))
+ ps-background-pages)
(and has-local-background (ps-output "}def\n"))))
ps-zebra-stripe-height)
"/ZebraColor "
(ps-format-color ps-zebra-color 0.95)
- "def\n/BackgroundColor "
+ "def\n")
+ (ps-output "/BackgroundColor "
(ps-format-color ps-default-background 1.0)
- "def\n/UseSetpagedevice "
+ "def\n")
+ (ps-output "/UseSetpagedevice "
(if (eq ps-spool-config 'setpagedevice)
"/setpagedevice where{pop languagelevel 2 eq}{false}ifelse"
"false")
(ps-output "\n" ps-print-prologue-1
"\n/printGlobalBackground{\n")
- (mapcar 'ps-output ps-background-all-pages)
+ (mapc 'ps-output ps-background-all-pages)
(ps-output
"}def\n/printLocalBackground{\n}def\n"
"\n%%EndProlog\n\n%%BeginSetup\n"
(ps-get-size (symbol-value font-sym) "font size" font-sym))
-(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))
- (t (list default default default))
- ))
-
-
-(defun ps-begin-job ()
+(defun ps-rgb-color (color unspecified default)
+ (cond
+ ;; (float float float) ==> (R G B)
+ ((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)
+ ;; float ==> 0.0 = black .. 1.0 = white
+ ((and (floatp color) (<= 0.0 color) (<= color 1.0))
+ (list color color color))
+ ;; "colorName" but different from "unspecified-[bf]g"
+ ((and (stringp color) (not (string= color unspecified)))
+ (ps-color-scale color))
+ ;; ok, use the default
+ (t
+ (list default default default))))
+
+
+(defun ps-begin-job (genfunc)
;; prologue files
(or (equal ps-mark-code-directory ps-postscript-code-directory)
(setq ps-print-prologue-0 (ps-prologue-file 0)
((eq ps-print-control-characters 'control)
"[\000-\037\177]")
(t "[\t\n\f]"))
+ ;; 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.
+ ps-color-p (and ps-print-color-p (ps-color-device))
+ ps-print-color-scale (if ps-color-p
+ (float (car (ps-color-values "white")))
+ 1.0)
ps-default-background (ps-rgb-color
(cond
+ ((or (member ps-print-color-p
+ '(nil back-white))
+ (eq genfunc 'ps-generate-postscript))
+ nil)
((eq ps-default-bg 'frame-parameter)
- (ps-frame-parameter 'background-color))
+ (ps-frame-parameter nil 'background-color))
((eq ps-default-bg t)
(ps-face-background-name 'default))
(t
ps-default-bg))
+ "unspecified-bg"
1.0)
ps-default-foreground (ps-rgb-color
(cond
+ ((or (member ps-print-color-p
+ '(nil back-white))
+ (eq genfunc 'ps-generate-postscript))
+ nil)
((eq ps-default-fg 'frame-parameter)
- (ps-frame-parameter 'foreground-color))
+ (ps-frame-parameter nil 'foreground-color))
((eq ps-default-fg t)
(ps-face-foreground-name 'default))
(t
ps-default-fg))
+ "unspecified-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
- ;; that ps-print can be dumped into emacs. This expression can't be
- ;; evaluated at dump-time because X isn't initialized.
- ps-color-p (and ps-print-color-p (ps-color-device))
- ps-print-color-scale (if ps-color-p
- (float (car (ps-color-values "white")))
- 1.0))
+ ps-foreground-list (mapcar
+ #'(lambda (arg)
+ (ps-rgb-color arg "unspecified-fg" 0.0))
+ (append (and (not (member ps-print-color-p
+ '(nil back-white)))
+ ps-fg-list)
+ (list ps-default-foreground
+ "black")))
+ ps-default-color (and (not (member ps-print-color-p
+ '(nil back-white)))
+ ps-default-foreground)
+ ps-current-color ps-default-color)
;; initialize page dimensions
(ps-get-page-dimensions)
;; final check
+ (unless (listp ps-lpr-switches)
+ (error "`ps-lpr-switches' value should be a list."))
(and ps-color-p
(equal ps-default-background ps-default-foreground)
(error
(or (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.
+ ;; Specify a foreground color only if:
+ ;; one's specified,
+ ;; it's different than the background (if `ps-fg-validate-p' is non-nil)
+ ;; and it's different than the current.
(let ((fg (or fg-color ps-default-foreground)))
+ (if ps-fg-validate-p
+ (let ((bg (or bg-color ps-default-background))
+ (el ps-foreground-list))
+ (while (and el (equal fg bg))
+ (setq fg (car el)
+ el (cdr el)))))
(or (equal fg ps-current-color)
(ps-set-color fg)))
(or (equal bg-color ps-current-bg)
(ps-set-bg bg-color))
- ;; Specify effects (underline, overline, box, etc)
+ ;; Specify effects (underline, overline, box, etc.)
(cond
((not (integerp effects))
(ps-output "0 EF\n")
(ps-output " S\n")))
+(defsubst ps-face-foreground-color-p (attr)
+ (memq attr '(foreground-color :foreground)))
+
+
+(defsubst ps-face-background-color-p (attr)
+ (memq attr '(background-color :background)))
+
+
+(defsubst ps-face-color-p (attr)
+ (memq attr '(foreground-color :foreground background-color :background)))
+
+
(defun ps-face-attributes (face)
"Return face attribute vector.
`ps-print-face-alist', insert it on `ps-print-face-alist' and
return the attribute vector.
-If FACE is not a valid face name, it is used default face."
+If FACE is not a valid face name, use default face."
(cond
(ps-black-white-faces-alist
(or (and (symbolp face)
(setq ps-print-face-alist
(cons new-face ps-print-face-alist)))
new-face))))
- ((eq (car face) 'foreground-color)
+ ((ps-face-foreground-color-p (car face))
(vector 0 (cdr face) nil))
- ((eq (car face) 'background-color)
+ ((ps-face-background-color-p (car face))
(vector 0 nil (cdr face)))
(t
(vector 0 nil nil))))
(defun ps-face-background (face background)
- (and (or (eq ps-use-face-background t)
- (cond ((symbolp face)
- (memq face ps-use-face-background))
- ((listp face)
- (or (memq (car face) '(foreground-color background-color))
- (let (ok)
- (while face
- (if (or (memq (car face) ps-use-face-background)
- (memq (car face)
- '(foreground-color background-color)))
- (setq face nil
- ok t)
- (setq face (cdr face))))
- ok)))
- (t
- nil)
- ))
+ (and (cond ((eq ps-use-face-background t)) ; always
+ ((null ps-use-face-background) nil) ; never
+ ;; ps-user-face-background is a symbol face list
+ ((symbolp face)
+ (memq face ps-use-face-background))
+ ((listp face)
+ (or (ps-face-color-p (car face))
+ (let (ok)
+ (while face
+ (if (or (memq (car face) ps-use-face-background)
+ (ps-face-color-p (car face)))
+ (setq face nil
+ ok t)
+ (setq face (cdr face))))
+ ok)))
+ (t
+ nil)
+ )
background))
((not (listp face-or-list))
(ps-face-attributes face-or-list))
;; only foreground color, not a `real' face
- ((eq (car face-or-list) 'foreground-color)
+ ((ps-face-foreground-color-p (car face-or-list))
(vector 0 (cdr face-or-list) nil))
;; only background color, not a `real' face
- ((eq (car face-or-list) 'background-color)
+ ((ps-face-background-color-p (car face-or-list))
(vector 0 nil (cdr face-or-list)))
;; list of faces
(t
;; Now, rebuild reference face lists
(setq ps-print-face-alist nil)
(if ps-auto-font-detect
- (mapcar 'ps-map-face (face-list))
- (mapcar 'ps-set-face-bold ps-bold-faces)
- (mapcar 'ps-set-face-italic ps-italic-faces)
- (mapcar 'ps-set-face-underline ps-underlined-faces))
+ (mapc 'ps-map-face (face-list))
+ (mapc 'ps-set-face-bold ps-bold-faces)
+ (mapc 'ps-set-face-italic ps-italic-faces)
+ (mapc 'ps-set-face-underline ps-underlined-faces))
(setq ps-build-face-reference nil))
(let ((face 'default)
(position to))
(cond
- ((featurep 'xemacs) ; xemacs
+ ((featurep 'xemacs) ; XEmacs
;; Build the list of extents...
(let ((a (cons 'dummy nil))
record type extent extent-list)
- (ps-x-map-extents 'ps-mapper nil from to a)
+ (map-extents 'ps-xemacs-mapper nil from to a)
(setq a (sort (cdr a) 'car-less-than-car)
extent-list nil)
(cond
((eq type 'push)
- (and (ps-x-extent-face extent)
+ (and (extent-face extent)
(setq extent-list (sort (cons extent extent-list)
- 'ps-extent-sorter))))
+ 'ps-xemacs-extent-sorter))))
((eq type 'pull)
(setq extent-list (sort (delq extent extent-list)
- 'ps-extent-sorter))))
+ 'ps-xemacs-extent-sorter))))
(setq face (if extent-list
- (ps-x-extent-face (car extent-list))
+ (extent-face (car extent-list))
'default)
from position
a (cdr a)))))
- (t ; emacs
+ (t ; Emacs
(let ((property-change from)
(overlay-change from)
(save-buffer-invisibility-spec buffer-invisibility-spec)
(setq property-change (next-property-change from nil to)))
(and (< overlay-change to) ; Don't search for overlay change
; unless previous search succeeded.
- (setq overlay-change (min (ps-e-next-overlay-change from)
+ (setq overlay-change (min (next-overlay-change from)
to)))
(setq position (min property-change overlay-change)
before-string nil
'emacs--invisible--face)
((get-text-property from 'face))
(t 'default)))
- (let ((overlays (ps-e-overlays-at from))
+ (let ((overlays (overlays-at from))
(face-priority -1)) ; text-property
(while (and overlays
(not (eq face 'emacs--invisible--face)))
(let* ((overlay (car overlays))
(overlay-invisible
- (ps-e-overlay-get overlay 'invisible))
+ (overlay-get overlay 'invisible))
(overlay-priority
- (or (ps-e-overlay-get overlay 'priority) 0)))
+ (or (overlay-get overlay 'priority) 0)))
(and (> overlay-priority face-priority)
(setq before-string
- (or (ps-e-overlay-get overlay 'before-string)
+ (or (overlay-get overlay 'before-string)
before-string)
after-string
- (or (and (<= (ps-e-overlay-end overlay) position)
- (ps-e-overlay-get overlay 'after-string))
+ (or (and (<= (overlay-end overlay) position)
+ (overlay-get overlay 'after-string))
after-string)
face-priority overlay-priority
face
(assq overlay-invisible
save-buffer-invisibility-spec)))
'emacs--invisible--face)
- ((ps-e-overlay-get overlay 'face))
+ ((overlay-get overlay 'face))
(t face)
))))
(setq overlays (cdr overlays))))
(ps-plot-with-face from to face))))
(defun ps-generate-postscript (from to)
- (ps-plot-region from to 0 nil))
+ (ps-plot-region from to 0))
(defun ps-generate (buffer from to genfunc)
(save-excursion
(save-excursion
(let ((ps-print-page-p t)
ps-even-or-odd-pages)
- (ps-begin-job)
+ (ps-begin-job genfunc)
(when needs-begin-file
(ps-begin-file)
(ps-mule-initialize))
;; WARNING!!! The following code is *sample* code only.
;; Don't use it unless you understand what it does!
-(defmacro ps-prsc ()
- `(if (featurep 'xemacs) 'f22 [f22]))
-(defmacro ps-c-prsc ()
- `(if (featurep 'xemacs) '(control f22) [C-f22]))
-(defmacro ps-s-prsc ()
- `(if (featurep 'xemacs) '(shift f22) [S-f22]))
+;; The key `f22' should probably be replaced by `print'. --Stef
;; A hook to bind to `rmail-mode-hook' to locally bind prsc and set the
;; `ps-left-headers' specially for mail messages.
(defun ps-rmail-mode-hook ()
- (local-set-key (ps-prsc) 'ps-rmail-print-message-from-summary)
+ (local-set-key [(f22)] 'ps-rmail-print-message-from-summary)
(setq ps-header-lines 3
ps-left-header
;; The left headers will display the message's subject, its
;; A hook to bind to `vm-mode-hook' to locally bind prsc and set the
;; `ps-left-headers' specially for mail messages.
(defun ps-vm-mode-hook ()
- (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary)
+ (local-set-key [(f22)] 'ps-vm-print-message-from-summary)
(setq ps-header-lines 3
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 (ps-prsc) 'ps-gnus-print-article-from-summary))
+ (local-set-key [(f22)] 'ps-gnus-print-article-from-summary))
;; Look in an article or mail message for the Subject: line. To be
;; placed in `ps-left-headers'.
;; 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)
+ (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)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To make this file smaller, some commands go in a separate file.
;; But autoload them here to make the separation invisible.
+\f
+;;;### (autoloads (ps-mule-begin-page ps-mule-begin-job ps-mule-encode-header-string
+;;;;;; ps-mule-initialize ps-mule-plot-composition ps-mule-plot-string
+;;;;;; ps-mule-set-ascii-font ps-mule-prepare-ascii-font ps-multibyte-buffer)
+;;;;;; "ps-mule" "ps-mule.el" "586d0a4deeb89be9b80cc01def34481c")
+;;; Generated autoloads from ps-mule.el
-(autoload 'ps-mule-prepare-ascii-font "ps-mule"
- "Setup special ASCII font for STRING.
-STRING should contain only ASCII characters.")
+(defvar ps-multibyte-buffer nil "\
+*Specifies the multi-byte buffer handling.
-(autoload 'ps-mule-set-ascii-font "ps-mule"
- "Adjust current font if current charset is not ASCII.")
+Valid values are:
-(autoload 'ps-mule-plot-string "ps-mule"
- "Generate PostScript code for plotting characters in the region FROM and TO.
+ nil This is the value to use the default settings;
+ by default, this only works to print buffers with
+ only ASCII and Latin characters. But this default
+ setting can be changed by setting the variable
+ `ps-mule-font-info-database-default' differently.
+ The initial value of this variable is
+ `ps-mule-font-info-database-latin' (see
+ documentation).
+
+ `non-latin-printer' This is the value to use when you have a Japanese
+ or Korean PostScript printer and want to print
+ buffer with ASCII, Latin-1, Japanese (JISX0208 and
+ JISX0201-Kana) and Korean characters. At present,
+ it was not tested with the Korean characters
+ printing. If you have a korean PostScript printer,
+ please, test it.
+
+ `bdf-font' This is the value to use when you want to print
+ buffer with BDF fonts. BDF fonts include both latin
+ and non-latin fonts. BDF (Bitmap Distribution
+ Format) is a format used for distributing X's font
+ source file. BDF fonts are included in
+ `intlfonts-1.2' which is a collection of X11 fonts
+ for all characters supported by Emacs. In order to
+ use this value, be sure to have installed
+ `intlfonts-1.2' and set the variable
+ `bdf-directory-list' appropriately (see ps-bdf.el for
+ documentation of this variable).
+
+ `bdf-font-except-latin' This is like `bdf-font' except that it uses
+ PostScript default fonts to print ASCII and Latin-1
+ characters. This is convenient when you want or
+ need to use both latin and non-latin characters on
+ the same buffer. See `ps-font-family',
+ `ps-header-font-family' and `ps-font-info-database'.
+
+Any other value is treated as nil.")
+
+(custom-autoload 'ps-multibyte-buffer "ps-mule" t)
+
+(autoload 'ps-mule-prepare-ascii-font "ps-mule" "\
+Setup special ASCII font for STRING.
+STRING should contain only ASCII characters.
+
+\(fn STRING)" nil nil)
+
+(autoload 'ps-mule-set-ascii-font "ps-mule" "\
+Not documented
+
+\(fn)" nil nil)
+
+(autoload 'ps-mule-plot-string "ps-mule" "\
+Generate PostScript code for plotting characters in the region FROM and TO.
It is assumed that all characters in this region belong to the same charset.
(ENDPOS . RUN-WIDTH)
Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
-the sequence.")
+the sequence.
+
+\(fn FROM TO &optional BG-COLOR)" nil nil)
+
+(autoload 'ps-mule-plot-composition "ps-mule" "\
+Generate PostScript code for plotting composition in the region FROM and TO.
+
+It is assumed that all characters in this region belong to the same
+composition.
+
+Optional argument BG-COLOR specifies background color.
+
+Returns the value:
+
+ (ENDPOS . RUN-WIDTH)
+
+Where ENDPOS is the end position of the sequence and RUN-WIDTH is the width of
+the sequence.
+
+\(fn FROM TO &optional BG-COLOR)" nil nil)
+
+(autoload 'ps-mule-initialize "ps-mule" "\
+Initialize global data for printing multi-byte characters.
+
+\(fn)" nil nil)
+
+(autoload 'ps-mule-encode-header-string "ps-mule" "\
+Generate PostScript code for ploting STRING by font FONTTAG.
+FONTTAG should be a string \"/h0\" or \"/h1\".
-(autoload 'ps-mule-initialize "ps-mule"
- "Initialize global data for printing multi-byte characters.")
+\(fn STRING FONTTAG)" nil nil)
-(autoload 'ps-mule-begin-job "ps-mule"
- "Start printing job for multi-byte chars between FROM and TO.
-This checks if all multi-byte characters in the region are printable or not.")
+(autoload 'ps-mule-begin-job "ps-mule" "\
+Start printing job for multi-byte chars between FROM and TO.
+It checks if all multi-byte characters in the region are printable or not.
-(autoload 'ps-mule-begin-page "ps-mule"
- "Initialize multi-byte charset for printing current page.")
+\(fn FROM TO)" nil nil)
-(autoload 'ps-mule-encode-header-string "ps-mule"
- "Generate PostScript code for plotting characters in header STRING.
+(autoload 'ps-mule-begin-page "ps-mule" "\
+Not documented
-It is assumed that the length of STRING is not zero.")
+\(fn)" nil nil)
+;;;***
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'ps-print)
-;;; arch-tag: fb06a585-1112-4206-885d-a57d95d50579
+;; arch-tag: fb06a585-1112-4206-885d-a57d95d50579
;;; ps-print.el ends here
HCoop / bpt / emacs.git / blobdiff