From a18ed1290d36e933724c5e789328195f4f9c2aff Mon Sep 17 00:00:00 2001 From: "Richard M. Stallman" Date: Sat, 6 Sep 1997 02:52:00 +0000 Subject: [PATCH] Some comment and doc fixes. (ps-print-version): New version number (3.05.1). (ps-adobe-tag): Replace defvar by defcustom, and doc fix. (ps-print-with-faces, ps-print-without-faces) (ps-spool-with-faces, ps-spool-without-faces): Add arg REGION-P. (ps-print-region-with-faces, ps-print-region) (ps-spool-region, ps-spool-region-with-faces): Fix calls to the functions above. (ps-setup): Print value of ps-zebra-stripe, ps-number-of-zebra, ps-line-number, ps-print-background-image, and ps-print-background-text. (ps-print-prologue-1): Bug fix in PostScript programming: /BeginDSCPage, /BeginPage. (ps-showpage-count, ps-ref-bold-faces, ps-ref-italic-faces) (ps-ref-underlined-faces, font-lock-face-attributes) (ps-initialize-faces): Vars deleted. (ps-override-list, ps-extension-to-bit-face) (ps-extension-to-screen-face, ps-initialize-faces, ps-header-height) (ps-hard-lf, ps-soft-lf, ps-get-face, ps-map-font-lock): Fn deleted. (ps-extend-face-list, ps-extend-face): Doc fix. (ps-print-face-alist): New var to handle face alist. (ps-printing-region): New var and fn. (ps-header-page, ps-set-face-bold, ps-set-face-italic) (ps-set-face-underline, ps-set-face-attribute, ps-map-face): New fn. (ps-rmail-mode-hook, ps-rmail-print-message-from-summary) (ps-print-message-from-summary, ps-vm-print-message-from-summary): Fns moved. (ps-background): New argument PAGE-NUMBER. (ps-begin-file): Bug fix and print proper line number in a region. (ps-begin-page): Call ps-header-page. (ps-get-buffer-name): Indicates in the header when printing a region. (ps-end-page): Delete ps-showpage-count. (ps-dummy-page): Calls ps-header-page. (ps-set-color): Programming improvement. (ps-plot-region): Doc fix. (ps-face-attributes): Same functionality as deleted ps-get-face. (ps-build-reference-face-lists): Do the job by calling ps-set-face-bold and ps-bold-faces, and friends. --- lisp/ps-print.el | 535 +++++++++++++++++++++++------------------------ 1 file changed, 261 insertions(+), 274 deletions(-) diff --git a/lisp/ps-print.el b/lisp/ps-print.el index ced3288882d..80a52eb7702 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -6,11 +6,11 @@ ;; Author: Jacques Duthen ;; Maintainer: Vinicius Jose Latorre ;; Keywords: print, PostScript -;; Time-stamp: <97/08/09 1:30:17 vinicius> -;; Version: 3.05 +;; Time-stamp: <97/08/27 13:00:37 vinicius> +;; Version: 3.05.1 -(defconst ps-print-version "3.05" - "ps-print.el, v 3.05 <97/08/09 vinicius> +(defconst ps-print-version "3.05.1" + "ps-print.el, v 3.05.1 <97/08/24 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, @@ -365,16 +365,15 @@ Please send all bug fixes and enhancements to ;; Line Number ;; ----------- ;; -;; The variable `ps-line-number' determines if lines will be -;; numerated (non-nil value) or not (nil value). -;; The default is not numerated (nil value). +;; The variable `ps-line-number' specifies whether to number each line; +;; non-nil means do so. The default is nil (don't number each line). ;; ;; ;; Zebra Stripes ;; ------------- ;; -;; Zebra stripes are a kind of background which you can request -;; to appear "underneath" the text. They look like this: +;; Zebra stripes are a kind of background that appear "underneath" the text +;; and can make the text easier to read. They look like this: ;; ;; XXXXXXXXXXXXXXXXXXXXXXXX ;; XXXXXXXXXXXXXXXXXXXXXXXX @@ -386,14 +385,17 @@ Please send all bug fixes and enhancements to ;; XXXXXXXXXXXXXXXXXXXXXXXX ;; XXXXXXXXXXXXXXXXXXXXXXXX ;; -;; The X's here represent a rectangle area filled with a light gray color. -;; The height, in lines, of the gray area pis controlled by +;; The X's here represent rectangles filled with a light gray color. +;; Each rectangle extends all the way across the page. +;; +;; The height, in lines, of each rectangle is controlled by ;; the variable `ps-zebra-stripe-height', which is 3 by default. ;; The distance between stripes equals the height of a stripe. ;; -;; The variable `ps-zebra-stripe' determines if zebra stripe lines will be -;; printed (non-nil value) or not (nil value). -;; The default is not print zebra stripes (nil value). +;; The variable `ps-zebra-stripe' controls whether to print zebra stripes. +;; Non-nil means yes, nil means no. The default is nil. +;; +;; See also section How Ps-Print Has A Text And/Or Image On Background. ;; ;; ;; Font managing @@ -439,7 +441,7 @@ Please send all bug fixes and enhancements to ;; - generate the PostScript image to a file (C-u M-x ps-print-buffer) ;; - open this file and find the line: ;; `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage' -;; - delete the leading `%' (which is the Postscript comment character) +;; - delete the leading `%' (which is the PostScript comment character) ;; - replace in this line `Courier' by the new font (say `Helvetica') ;; to get the line: ;; `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage' @@ -480,8 +482,8 @@ Please send all bug fixes and enhancements to ;; by uncommenting the line: ;; % 3 cm 20 cm moveto ReportAllFontInfo showpage ;; -;; The postscript file should be sent to YOUR postscript printer. -;; If you send it to ghostscript or to another postscript printer, +;; The PostScript file should be sent to YOUR PostScript printer. +;; If you send it to ghostscript or to another PostScript printer, ;; you may get slightly different results. ;; Anyway, as ghostscript fonts are autoload, you won't get ;; much font info. @@ -542,21 +544,21 @@ Please send all bug fixes and enhancements to ;; overline - like underline, but the line is over the text. ;; shadow - text will have a shadow. ;; box - text will be surrounded by a box. -;; outline - only the contour of the characters will be printed. +;; outline - print characters as hollow outlines. ;; ;; See the documentation for `ps-extend-face' and `ps-extend-face-list'. ;; ;; Let's, for example, remap font-lock-keyword-face to another foreground color ;; and bold attribute: ;; -;; (ps-extend-face '(font-lock-keyword-face "RoyalBlue" nil bold)) -;; -;; Note: the only attributes that have effect on screen are: bold, italic and -;; underline. All other screen effect is ignored. +;; (ps-extend-face '(font-lock-keyword-face "RoyalBlue" nil bold) 'MERGE) ;; ;; If you want to use a new face, define it first with `defface', ;; and then call `ps-extend-face' to specify how to print it. ;; +;; NOTE: the only face attributes that have an effect are bold, italic and +;; underline. All other attributes are ignored. +;; ;; ;; How Ps-Print Has A Text And/Or Image On Background ;; -------------------------------------------------- @@ -609,7 +611,7 @@ Please send all bug fixes and enhancements to ;; 4. Print background texts only for current page (if any) ;; 5. Print background images only for current page (if any) ;; 6. Print header -;; 7. Print buffer text (with faces, if specified) with line number +;; 7. Print buffer text (with faces, if specified) and line number ;; ;; ;; Utilities @@ -631,8 +633,9 @@ Please send all bug fixes and enhancements to ;; the correspondence between a number of pages and the maximum font ;; size which allow the number of lines of the current buffer or of ;; its current region to fit in this number of pages. -;; Note: line folding is not taken into account in this process -;; and could change the results. +;; +;; NOTE: line folding is not taken into account in this process and could +;; change the results. ;; ;; ;; New since version 1.5 @@ -660,7 +663,7 @@ Please send all bug fixes and enhancements to ;; ;; [jack] 960517 Jacques Duthen ;; -;; Font familiy and float size for text and header. +;; Font family and float size for text and header. ;; Landscape mode. ;; Multiple columns. ;; Tools for page setup. @@ -704,7 +707,6 @@ Please send all bug fixes and enhancements to ;; ;; Add `ps-print-hook' (I don't know how to do that (yet!)). ;; Add 4-up capability (really needed?). -;; Add line numbers (should not be too hard). ;; Add `ps-non-bold-faces' and `ps-non-italic-faces' (should be easy). ;; Put one header per page over the columns (easy but needed?). ;; Improve the memory management for big files (hard?). @@ -1255,10 +1257,12 @@ this variable." :type 'boolean :group 'ps-print) -(defvar ps-adobe-tag "%!PS-Adobe-3.0\n" +(defcustom ps-adobe-tag "%!PS-Adobe-3.0\n" "*Contains the header line identifying the output as PostScript. By default, `ps-adobe-tag' contains the standard identifier. Some -printers require slightly different versions of this line.") +printers require slightly different versions of this line." + :type 'string + :group 'ps-print) (defcustom ps-build-face-reference t "*Non-nil means build the reference face lists. @@ -1318,7 +1322,7 @@ are using a window system, so it has a way to determine color values." "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-print-without-faces from to filename)) + (ps-print-without-faces from to filename t)) ;;;###autoload @@ -1328,9 +1332,7 @@ Like `ps-print-region', but includes font, color, and underline information in the generated image. This command works only if you are using a window system, so it has a way to determine color values." (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg))) - (ps-generate (current-buffer) from to - 'ps-generate-postscript-with-faces) - (ps-print-with-faces from to filename)) + (ps-print-with-faces from to filename t)) ;;;###autoload @@ -1363,7 +1365,7 @@ Like `ps-spool-buffer', but spools just the current region. Use the command `ps-despool' to send the spooled images to the printer." (interactive "r") - (ps-spool-without-faces from to)) + (ps-spool-without-faces from to t)) ;;;###autoload @@ -1375,7 +1377,7 @@ 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-spool-with-faces from to)) + (ps-spool-with-faces from to t)) ;;;###autoload (defun ps-despool (&optional filename) @@ -1419,21 +1421,30 @@ using the current ps-print setup." ;;;###autoload (defun ps-setup () "*Return the current setup" - (format " - (setq ps-print-color-p %s + (format + " +\(setq ps-print-color-p %s ps-lpr-command \"%s\" ps-lpr-switches %s - ps-paper-type '%s - ps-landscape-mode %s + ps-paper-type '%s + ps-landscape-mode %s ps-number-of-columns %s - ps-left-margin %s - ps-right-margin %s - ps-inter-column %s - ps-bottom-margin %s - ps-top-margin %s - ps-header-offset %s + ps-zebra-stripe %s + ps-number-of-zebra %s + ps-line-number %s + + ps-print-background-image %s + + ps-print-background-text %s + + ps-left-margin %s + ps-right-margin %s + ps-inter-column %s + ps-bottom-margin %s + ps-top-margin %s + ps-header-offset %s ps-header-line-pad %s ps-print-header %s ps-print-header-frame %s @@ -1441,35 +1452,40 @@ using the current ps-print setup." ps-show-n-of-n %s ps-spool-duplex %s - ps-font-family '%s - ps-font-size %s - ps-header-font-family '%s - ps-header-font-size %s - ps-header-title-font-size %s) + ps-font-family '%s + ps-font-size %s + ps-header-font-family '%s + ps-header-font-size %s + ps-header-title-font-size %s) " - ps-print-color-p - ps-lpr-command - ps-lpr-switches - ps-paper-type - ps-landscape-mode - ps-number-of-columns - ps-left-margin - ps-right-margin - ps-inter-column - ps-bottom-margin - ps-top-margin - ps-header-offset - ps-header-line-pad - ps-print-header - ps-print-header-frame - ps-header-lines - ps-show-n-of-n - ps-spool-duplex - ps-font-family - ps-font-size - ps-header-font-family - ps-header-font-size - ps-header-title-font-size)) + ps-print-color-p + ps-lpr-command + ps-lpr-switches + ps-paper-type + ps-landscape-mode + ps-number-of-columns + ps-zebra-stripe + ps-number-of-zebra + ps-line-number + ps-print-background-image + ps-print-background-text + ps-left-margin + ps-right-margin + ps-inter-column + ps-bottom-margin + ps-top-margin + ps-header-offset + ps-header-line-pad + ps-print-header + ps-print-header-frame + ps-header-lines + ps-show-n-of-n + ps-spool-duplex + ps-font-family + ps-font-size + ps-header-font-family + ps-header-font-size + ps-header-title-font-size)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Utility functions and variables: @@ -1920,17 +1936,19 @@ StandardEncoding 46 82 getinterval aload pop /BeginDSCPage { % ---- when 1st column, save the state of the page - ColumnIndex 1 eq { /pageState save def - 0 PrintStartY moveto % move to where printing will start - Zebra {printZebra}if - printGlobalBackground - printLocalBackground - } if + ColumnIndex 1 eq { /pageState save def } if % ---- save the state of the column /columnState save def } def /BeginPage { + % ---- when 1st column, print all background effects + ColumnIndex 1 eq { + 0 PrintStartY moveto % move to where printing will start + Zebra {printZebra}if + printGlobalBackground + printLocalBackground + } if PrintHeader { PrintHeaderFrame { HeaderFrame } if HeaderText @@ -2137,7 +2155,6 @@ StandardEncoding 46 82 getinterval aload pop (defvar ps-output-tail nil) (defvar ps-page-count 0) -(defvar ps-showpage-count 0) (defvar ps-showline-count 1) (defvar ps-background-pages nil) @@ -2191,10 +2208,6 @@ and the text it contains.") (defvar ps-height-remaining) (defvar ps-width-remaining) -(defvar ps-ref-bold-faces nil) -(defvar ps-ref-italic-faces nil) -(defvar ps-ref-underlined-faces nil) - (defvar ps-print-color-scale nil) @@ -2203,7 +2216,7 @@ and the text it contains.") (defvar ps-print-face-extension-alist nil - "Alist of symbolic faces with extension features (box, outline, etc). + "Alist of symbolic faces *WITH* extension features (box, outline, etc). An element of this list has the following form: (FACE . [BITS FG BG]) @@ -2215,10 +2228,19 @@ An element of this list has the following form: FG foreground color (string or nil) BG background color (string or nil) -Don't change this list directly; instead, use -`ps-extend-face' and `ps-extend-face-list' to change it. -See documentation for `ps-extend-face' for valid extension symbol. -See also `font-lock-face-attributes'.") +Don't change this list directly; instead, +use `ps-extend-face' and `ps-extend-face-list'. +See documentation for `ps-extend-face' for valid extension symbol.") + + +(defvar ps-print-face-alist nil + "Alist of symbolic faces *WITHOUT* extension features (box, outline, etc). + +An element of this list has the same form as an element of +`ps-print-face-extension-alist'. + +Don't change this list directly; this list is used by `ps-face-attributes', +`ps-map-face' and `ps-build-reference-face-lists'.") (defconst ps-print-face-map-alist @@ -2235,51 +2257,15 @@ Each symbol correspond to one bit in a bit vector.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Creating and Remapping Faces - - -(require 'font-lock) - - -;; The definition below is necessary because some emacs variant does not -;; define it on font-lock package. - -(defvar font-lock-face-attributes nil) - - - -(defun ps-override-list (sym-list element) - (let ((maplist (assq (car element) (symbol-value sym-list)))) - (if maplist - (setcdr maplist (cdr element)) - (set sym-list (cons element (symbol-value sym-list))) - ))) - - -(defun ps-extension-to-bit-face (face-extension) - (cons (nth 0 face-extension) - (vector (ps-extension-bit face-extension) - (nth 1 face-extension) - (nth 2 face-extension)))) - - -(defun ps-extension-to-screen-face (face) - (let ((face-name (nth 0 face)) - (face-foreground (nth 1 face)) - (face-background (nth 2 face)) - (face-attributes (nthcdr 3 face))) - (list face-name face-foreground face-background - (and (memq 'bold face-attributes) t) - (and (memq 'italic face-attributes) t) - (and (memq 'underline face-attributes) t)))) +;; Remapping Faces ;;;###autoload (defun ps-extend-face-list (face-extension-list &optional merge-p) "Extend face in `ps-print-face-extension-alist'. -If optional MERGE-P is non-nil, extensions in FACE-EXTENSION are merged with -face extension in `ps-print-face-extension-alist'; otherwise, overrides. +If optional MERGE-P is non-nil, extensions in FACE-EXTENSION-LIST are merged +with face extension in `ps-print-face-extension-alist'; otherwise, overrides. The elements in FACE-EXTENSION-LIST is like those for `ps-extend-face'. @@ -2293,8 +2279,8 @@ See `ps-extend-face' for documentation." (defun ps-extend-face (face-extension &optional merge-p) "Extend face in `ps-print-face-extension-alist'. -If optional MERGE-p is non-nil, extensions in FACE-EXTENSION are merged with -face extensions in `ps-print-face-extension-alist'; otherwise, overrides. +If optional MERGE-P is non-nil, extensions in FACE-EXTENSION-LIST are merged +with face extensions in `ps-print-face-extension-alist'; otherwise, overrides. The elements of FACE-EXTENSION list have the form: @@ -2313,7 +2299,7 @@ EXTENSION is one of the following symbols: overline - like underline, but the line is over the text. shadow - text will have a shadow. box - text will be surrounded by a box. - outline - only the text border font will be printed. + outline - print characters as hollow outlines. If EXTENSION is any other symbol, it is ignored." (let* ((face-name (nth 0 face-extension)) @@ -2351,60 +2337,48 @@ If EXTENSION is any other symbol, it is ignored." ;; Internal functions and variables -(defun ps-print-without-faces (from to &optional filename) +(defun ps-print-without-faces (from to &optional filename region-p) + (ps-printing-region region-p) (ps-generate (current-buffer) from to 'ps-generate-postscript) (ps-do-despool filename)) -(defun ps-spool-without-faces (from to) +(defun ps-spool-without-faces (from to &optional region-p) + (ps-printing-region region-p) (ps-generate (current-buffer) from to 'ps-generate-postscript)) -(defun ps-print-with-faces (from to &optional filename) - (ps-initialize-faces) +(defun ps-print-with-faces (from to &optional filename region-p) + (ps-printing-region region-p) (ps-generate (current-buffer) from to 'ps-generate-postscript-with-faces) (ps-do-despool filename)) -(defun ps-spool-with-faces (from to) - (ps-initialize-faces) +(defun ps-spool-with-faces (from to &optional region-p) + (ps-printing-region region-p) (ps-generate (current-buffer) from to 'ps-generate-postscript-with-faces)) -(defvar ps-initialize-faces nil) +(defsubst ps-count-lines (from to) + (+ (count-lines from to) + (save-excursion (goto-char to) + (if (= (current-column) 0) 1 0)))) -(defun ps-initialize-faces () - (or ps-initialize-faces - (progn - (setq ps-initialize-faces t) - (mapcar 'ps-map-font-lock font-lock-face-attributes)))) +(defvar ps-printing-region nil + "Variable used to indicate if it is printing a region. +If non-nil, it is a cons, the car of which is the line number +where the region begins, and its cdr is the total number of lines +in the buffer. Formatting functions can use this information +to print the original line number (and not the number of lines printed), +and to indicate in the header that the printout is of a partial file.") -(defun ps-map-font-lock (face) - (let* ((face-map (ps-screen-to-bit-face face)) - (ps-face-bit (cdr (assq (car face-map) - ps-print-face-extension-alist)))) - (if ps-face-bit - ;; if face exists, merge both - (let ((face-bit (cdr face-map))) - (aset ps-face-bit 0 (logior (aref ps-face-bit 0) (aref face-bit 0))) - (or (aref ps-face-bit 1) (aset ps-face-bit 1 (aref face-bit 1))) - (or (aref ps-face-bit 2) (aset ps-face-bit 2 (aref face-bit 2)))) - ;; if face does not exist, insert it - (setq ps-print-face-extension-alist - (cons face-map ps-print-face-extension-alist)) - ))) - - -(defun ps-screen-to-bit-face (face) - (let ((face-name (car face)) - (face-foreground (nth 1 face)) - (face-background (nth 2 face)) - (face-bit (logior (if (nth 3 face) 1 0) ; bold - (if (nth 4 face) 2 0) ; italic - (if (nth 5 face) 4 0)))) ; underline - (cons face-name (vector face-bit face-foreground face-background)))) +(defun ps-printing-region (region-p) + (setq ps-printing-region + (and region-p + (cons (ps-count-lines (point-min) (region-beginning)) + (ps-count-lines (point-min) (point-max)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -2750,12 +2724,6 @@ page-height == bm + print-height + tm - ho - hh (defun ps-output-boolean (name bool) (ps-output (format "/%s %s def\n" name (if bool "true" "false")))) -(defsubst ps-count-lines (from to) - (+ (count-lines from to) - (save-excursion (goto-char to) - (if (= (current-column) 0) 1 0)))) - - (defun ps-background-pages (page-list func) (if page-list (mapcar @@ -2868,11 +2836,11 @@ page-height == bm + print-height + tm - ho - hh ps-print-background-image)) -(defun ps-background () +(defun ps-background (page-number) (let (has-local-background) (mapcar '(lambda (range) - (and (<= (aref range 0) ps-page-count) - (<= ps-page-count (aref range 1)) + (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) @@ -2884,15 +2852,14 @@ page-height == bm + print-height + tm - ho - hh (defun ps-begin-file () (ps-get-page-dimensions) - (setq ps-showpage-count 0 - ps-showline-count 1 + (setq ps-showline-count (if ps-printing-region (car ps-printing-region) 1) ps-background-text-count 0 ps-background-image-count 0 ps-background-pages nil ps-background-all-pages nil) (ps-output ps-adobe-tag) - (ps-output "%%Title: " (buffer-name)) ;Take job name from name of + (ps-output "%%Title: " (buffer-name)) ;Take job name from name of ;first buffer printed (ps-output "\n%%Creator: " (user-full-name)) (ps-output "\n%%CreationDate: " @@ -2933,9 +2900,7 @@ page-height == bm + print-height + tm - ho - hh (ps-output (format "/LineHeight %s def\n" ps-line-height) (format "/LinesPerColumn %d def\n" - (round (/ (+ (if ps-print-header - (- ps-print-height (ps-header-height)) - ps-print-height) + (round (/ (+ ps-print-height (* ps-line-height 0.45)) ps-line-height)))) @@ -2943,7 +2908,10 @@ page-height == bm + print-height + tm - ho - hh (ps-output (format "/NumberOfZebra %d def\n" ps-zebra-stripe-height)) (ps-output-boolean "PrintLineNumber" ps-line-number) - (ps-output (format "/Lines %d def\n" (ps-count-lines (point-min) (point-max)))) + (ps-output (format "/Lines %d def\n" + (if ps-printing-region + (cdr ps-printing-region) + (ps-count-lines (point-min) (point-max))))) (ps-background-text) (ps-background-image) @@ -2990,6 +2958,7 @@ page-height == bm + print-height + tm - ho - hh ((string= (buffer-name) "sokoban.el") "Super! C'est sokoban.el!") (t (concat + (and ps-printing-region "Subset of: ") (buffer-name) (and (buffer-modified-p) " (unsaved)"))))) @@ -3003,29 +2972,29 @@ page-height == bm + print-height + tm - ho - hh (ps-output "\nEndDoc\n\n%%EOF\n")) -(defun ps-header-height () - (+ ps-header-title-line-height - (* ps-header-line-height (1- ps-header-lines)) - (* 2 ps-header-pad))) - - (defun ps-next-page () (ps-end-page) (ps-flush-output) (ps-begin-page)) +(defun ps-header-page (&optional inc-p) + (if (zerop (mod ps-page-count ps-number-of-columns)) + ;; Print only when a new real page begins. + (let ((page-number (1+ (/ ps-page-count ps-number-of-columns)))) + (ps-output (format "\n%%%%Page: %d %d\n" page-number page-number)) + (ps-output "BeginDSCPage\n") + (ps-background page-number) + (and inc-p (incf ps-page-count))) + ;; Print when any other page begins. + (ps-output "BeginDSCPage\n"))) + (defun ps-begin-page (&optional dummypage) (ps-get-page-dimensions) (setq ps-width-remaining ps-print-width) (setq ps-height-remaining ps-print-height) - ;; Print only when a new real page begins. - (when (zerop (mod ps-page-count ps-number-of-columns)) - (ps-output (format "\n%%%%Page: %d %d\n" - (1+ (/ ps-page-count ps-number-of-columns)) - (1+ (/ ps-page-count ps-number-of-columns))))) + (ps-header-page) - (ps-output "BeginDSCPage\n") (ps-output (format "/LineNumber %d def\n" ps-showline-count) (format "/PageNumber %d def\n" (incf ps-page-count))) (ps-output "/PageCount 0 def\n") @@ -3035,23 +3004,17 @@ page-height == bm + print-height + tm - ho - hh (ps-generate-header "HeaderLinesRight" ps-right-header) (ps-output (format "%d SetHeaderLines\n" ps-header-lines))) - (ps-background) - (ps-output "BeginPage\n") (ps-set-font ps-current-font) (ps-set-bg ps-current-bg) (ps-set-color ps-current-color)) (defun ps-end-page () - (setq ps-showpage-count (+ 1 ps-showpage-count)) - (ps-output "EndPage\n") - (ps-output "EndDSCPage\n")) + (ps-output "EndPage\nEndDSCPage\n")) (defun ps-dummy-page () - (setq ps-showpage-count (+ 1 ps-showpage-count)) - (ps-output "%%Page: " (format "- %d\n" ps-showpage-count) - "BeginDSCPage -/PrintHeader false def + (ps-header-page t) + (ps-output "/PrintHeader false def BeginPage EndPage EndDSCPage\n")) @@ -3135,9 +3098,7 @@ EndDSCPage\n")) (ps-output "false BG\n"))) (defun ps-set-color (color) - (if (setq ps-current-color color) - nil - (setq ps-current-color ps-default-fg)) + (setq ps-current-color (or 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")) @@ -3175,7 +3136,7 @@ EndDSCPage\n")) ;; pagefeeds, control characters, and plot each chunk. (while (< from to) (if (re-search-forward "[\000-\037\177-\377]" to t) - ;; region whith some control characters + ;; region with some control characters (let ((match (char-after (match-beginning 0)))) (if (= match ?\t) ; tab (let ((linestart @@ -3233,39 +3194,22 @@ EndDSCPage\n")) (t (error "No available function to determine X color values.")))) -(defun ps-get-face (face) - "Return face description on `ps-print-face-extension-alist'. +(defun ps-face-attributes (face) + "Return face attribute vector. -If FACE is not in `ps-print-face-extension-alist', -insert it and return the description. +If FACE is not in `ps-print-face-extension-alist' or in +`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." - (or (assq face ps-print-face-extension-alist) - (let* ((the-face (if (facep face) face 'default)) - (font (face-font the-face t)) - (new-face - (cons the-face - (vector - (logior (if (memq 'bold font) 1 0) - (if (memq 'italic font) 2 0) - (if (face-underline-p the-face) 4 0)) - (face-foreground the-face) - (face-background the-face))))) - (or (and (eq the-face 'default) - (assq the-face ps-print-face-extension-alist)) - (setq ps-print-face-extension-alist - (cons new-face - ps-print-face-extension-alist))) - new-face))) - - -(defun ps-face-attributes (face) - (let* ((face-vector (cdr (ps-get-face face))) - (effects (logior (aref face-vector 0) - (if (memq face ps-ref-bold-faces) 1 0) - (if (memq face ps-ref-italic-faces) 2 0) - (if (memq face ps-ref-underlined-faces) 4 0)))) - (vector effects (aref face-vector 1) (aref face-vector 2)))) + (cdr (or (assq face ps-print-face-extension-alist) + (assq face ps-print-face-alist) + (let* ((the-face (if (facep face) face 'default)) + (new-face (ps-screen-to-bit-face the-face))) + (or (and (eq the-face 'default) + (assq the-face ps-print-face-alist)) + (setq ps-print-face-alist (cons new-face ps-print-face-alist))) + new-face)))) (defun ps-face-attribute-list (face-or-list) @@ -3326,7 +3270,7 @@ If FACE is not a valid face name, it is used default face." (defun ps-face-bold-p (face) (if (eq ps-print-emacs-type 'emacs) (ps-emacs-face-kind-p face 'bold "-\\(bold\\|demibold\\)-" - ps-bold-faces) + ps-bold-faces) (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold" ps-bold-faces))) @@ -3341,33 +3285,59 @@ If FACE is not a valid face name, it is used default face." (or (face-underline-p face) (memq face ps-underlined-faces))) + ;; Ensure that face-list is fbound. (or (fboundp 'face-list) (defalias 'face-list 'list-faces)) + (defun ps-build-reference-face-lists () + (setq ps-print-face-alist nil) (if ps-auto-font-detect - (let ((faces (face-list)) - the-face) - (setq ps-ref-bold-faces nil - ps-ref-italic-faces nil - ps-ref-underlined-faces nil) - (while faces - (setq the-face (car faces)) - (if (ps-face-italic-p the-face) - (setq ps-ref-italic-faces - (cons the-face ps-ref-italic-faces))) - (if (ps-face-bold-p the-face) - (setq ps-ref-bold-faces - (cons the-face ps-ref-bold-faces))) - (if (ps-face-underlined-p the-face) - (setq ps-ref-underlined-faces - (cons the-face ps-ref-underlined-faces))) - (setq faces (cdr faces)))) - (setq ps-ref-bold-faces ps-bold-faces) - (setq ps-ref-italic-faces ps-italic-faces) - (setq ps-ref-underlined-faces ps-underlined-faces)) + (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)) (setq ps-build-face-reference nil)) + +(defun ps-set-face-bold (face) + (ps-set-face-attribute face 1)) + +(defun ps-set-face-italic (face) + (ps-set-face-attribute face 2)) + +(defun ps-set-face-underline (face) + (ps-set-face-attribute face 4)) + + +(defun ps-set-face-attribute (face effect) + (let ((face-bit (cdr (ps-map-face face)))) + (aset face-bit 0 (logior (aref face-bit 0) effect)))) + + +(defun ps-map-face (face) + (let* ((face-map (ps-screen-to-bit-face face)) + (ps-face-bit (cdr (assq (car face-map) ps-print-face-alist)))) + (if ps-face-bit + ;; if face exists, merge both + (let ((face-bit (cdr face-map))) + (aset ps-face-bit 0 (logior (aref ps-face-bit 0) (aref face-bit 0))) + (or (aref ps-face-bit 1) (aset ps-face-bit 1 (aref face-bit 1))) + (or (aref ps-face-bit 2) (aset ps-face-bit 2 (aref face-bit 2)))) + ;; if face does not exist, insert it + (setq ps-print-face-alist (cons face-map ps-print-face-alist))) + face-map)) + + +(defun ps-screen-to-bit-face (face) + (cons face + (vector (logior (if (ps-face-bold-p face) 1 0) ; bold + (if (ps-face-italic-p face) 2 0) ; italic + (if (ps-face-underlined-p face) 4 0)) ; underline + (face-foreground face) + (face-background face)))) + + (defun ps-mapper (extent list) (nconc list (list (list (extent-start-position extent) 'push extent) (list (extent-end-position extent) 'pull extent))) @@ -3650,6 +3620,33 @@ If FACE is not a valid face name, it is used default face." (defmacro ps-s-prsc () `(if (eq ps-print-emacs-type 'emacs) [S-f22] '(shift f22))) +;; 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) + (setq ps-header-lines 3 + ps-left-header + ;; The left headers will display the message's subject, its + ;; author, and the name of the folder it was in. + '(ps-article-subject ps-article-author buffer-name))) + +;; See `ps-gnus-print-article-from-summary'. This function does the +;; same thing for rmail. +(defun ps-rmail-print-message-from-summary () + (interactive) + (ps-print-message-from-summary 'rmail-summary-buffer "RMAIL")) + +;; Used in `ps-rmail-print-article-from-summary', +;; `ps-gnus-print-article-from-summary' and `ps-vm-print-message-from-summary'. +(defun ps-print-message-from-summary (summary-buffer summary-default) + (let ((ps-buf (or (and (boundp summary-buffer) + (symbol-value summary-buffer)) + summary-default))) + (and (get-buffer ps-buf) + (save-excursion + (set-buffer ps-buf) + (ps-spool-buffer-with-faces))))) + ;; Look in an article or mail message for the Subject: line. To be ;; placed in `ps-left-headers'. (defun ps-article-subject () @@ -3684,7 +3681,7 @@ If FACE is not a valid face name, it is used default face." (t fromstring))) "From ???"))) -;; A hook to bind to gnus-Article-prepare-hook. This will set the +;; A hook to bind to `gnus-article-prepare-hook'. This will set the ;; `ps-left-headers' specially for gnus articles. Unfortunately, ;; `gnus-article-mode-hook' is called only once, the first time the *Article* ;; buffer enters that mode, so it would only work for the first time @@ -3697,9 +3694,8 @@ If FACE is not a valid face name, it is used default face." ;; author, and the newsgroup it was in. (list 'ps-article-subject 'ps-article-author 'gnus-newsgroup-name))) -;; A hook to bind to vm-mode-hook to locally bind prsc and set the -;; ps-left-headers specially for mail messages. This header setup would -;; also work, I think, for RMAIL. +;; 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) (setq ps-header-lines 3) @@ -3716,22 +3712,13 @@ If FACE is not a valid face name, it is used default face." ;; sb: Updated for Gnus 5. (defun ps-gnus-print-article-from-summary () (interactive) - (let ((ps-buf (or (and (boundp 'gnus-article-buffer) - (symbol-value 'gnus-article-buffer)) - "*Article*"))) - (if (get-buffer ps-buf) - (save-excursion - (set-buffer ps-buf) - (ps-spool-buffer-with-faces))))) + (ps-print-message-from-summary 'gnus-article-buffer "*Article*")) ;; See `ps-gnus-print-article-from-summary'. This function does the ;; same thing for vm. (defun ps-vm-print-message-from-summary () (interactive) - (if (and (boundp 'vm-mail-buffer) (symbol-value 'vm-mail-buffer)) - (save-excursion - (set-buffer (symbol-value 'vm-mail-buffer)) - (ps-spool-buffer-with-faces)))) + (ps-print-message-from-summary 'vm-mail-buffer "")) ;; A hook to bind to bind to `gnus-summary-setup-buffer' to locally bind ;; prsc. -- 2.39.2