comparison lisp/ps-print.el @ 19879:87952270ceeb

(ps-emacs-face-kind-p): Function deleted. (ps-face-bold-p, ps-face-italic-p): Check ps-bold-faces or ps-italic-faces. (ps-zebra-stripes, ps-zebra-stripe-height): Doc fixes. (ps-line-lengths, ps-nb-pages-buffer, ps-nb-pages-region, ps-setup): Doc fixes.

19878:a69ae37e6932

;; The spooling mechanism was designed for printing lots of small
;; files (mail messages or netnews articles) to save paper that would
;; otherwise be wasted on banner pages, and to make it easier to find
;; your output at the printer (it's easier to pick up one 50-page
;; printout than to find 50 single-page printouts).
;; 
;; Ps-print has a hook in the `kill-emacs-hooks' so that you won't
;; accidentally quit from Emacs while you have unprinted PostScript
;; waiting in the spool buffer.  If you do attempt to exit with
;; spooled PostScript, you'll be asked if you want to print it, and if
;; you decline, you'll be asked to confirm the exit; this is modeled

;; directory; on the right, the page number and date of printing.
;; The default headers look something like this:
;;
;;     ps-print.el                                         1/21
;;     /home/jct/emacs-lisp/ps/new                     94/12/31
;; 
;; When printing on duplex printers, left and right are reversed so
;; that the page numbers are toward the outside (cf. `ps-spool-duplex').
;;
;; Headers are configurable:
;; To turn them off completely, set `ps-print-header' to nil.
;; To turn off the header's gaudy framing box,
;; set `ps-print-header-frame' to nil.
;;
;; The font family and size of text in the header are determined
;; by the variables `ps-header-font-family', `ps-header-font-size' and 
;; `ps-header-title-font-size' (see below).
;;
;; The variable `ps-header-line-pad' determines the portion of a header
;; title line height to insert between the header frame and the text
;; it contains, both in the vertical and horizontal directions:

;; Ps-print will insert blank pages to make sure each buffer starts
;; on the correct side of the paper.
;; Don't forget to set `ps-lpr-switches' to select duplex printing
;; for your printer.
;;
;; 
;; Line Number
;; -----------
;;
;; 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).

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

;; for a list of font families (currently mainly `Courier' `Helvetica'
;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk').
;; Each font family contains the font names for standard, bold, italic
;; and bold-italic characters, a reference size (usually 10) and the
;; corresponding line height, width of a space and average character width.
;; 
;; The variable `ps-font-family' determines which font family
;; is to be used for ordinary text.
;; If its value does not correspond to a known font family,
;; an error message is printed into the `*Messages*' buffer,
;; which lists the currently available font families.

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

;;
;; Faces are always treated as opaque.
;;
;; Epoch and Emacs 18 not supported.  At all.
;;
;; Fixed-pitch fonts work better for line folding, but are not required.  
;;
;; `ps-nb-pages-buffer' and `ps-nb-pages-region' don't take care
;; of folding lines.
;;
;;

  :type 'number
  :group 'ps-print)

(defcustom ps-zebra-stripes nil
  "*Non-nil means print zebra stripes.
See also documentation for `ps-print-n-zebra'."
  :type 'boolean
  :group 'ps-print)

(defcustom ps-zebra-stripe-height 3
  "*Number of zebra stripe lines.
See also documentation for `ps-print-zebra'."
  :type 'number
  :group 'ps-print)

(defcustom ps-line-number nil
  "*Non-nil means print line number."

  (interactive (list (ps-print-preprint current-prefix-arg)))
  (ps-do-despool filename))

;;;###autoload
(defun ps-line-lengths ()
  "*Display the correspondence between a line length and a font size,
using the current ps-print setup.
Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"
  (interactive)
  (ps-line-lengths-internal))

;;;###autoload
(defun ps-nb-pages-buffer (nb-lines)
  "*Display an approximate correspondence between a font size and the number
of pages the current buffer would require to print
using the current ps-print setup."
  (interactive (list (count-lines (point-min) (point-max))))
  (ps-nb-pages nb-lines))

;;;###autoload
(defun ps-nb-pages-region (nb-lines)
  "*Display an approximate correspondence between a font size and the number
of pages the current region would require to print
using the current ps-print setup."
  (interactive (list (count-lines (mark) (point))))
  (ps-nb-pages nb-lines))

;;;###autoload
(defun ps-setup ()
  "*Return the current setup"
  (format
   "
\(setq ps-print-color-p  %s
      ps-lpr-command    \"%s\"
      ps-lpr-switches   %s

      (error "Could not read file `%s'" fname))
  (save-excursion
    (set-buffer ps-spool-buffer)
    (goto-char (point-max))
    (insert-file fname)))
    
;; These functions insert the arrays that define the contents of the
;; headers.

(defun ps-generate-header-line (fonttag &optional content)
  (ps-output "  [ " fonttag " ")

	  (setq count (+ count 1)))
	(ps-output "] def\n"))))

(defun ps-output-boolean (name bool)
  (ps-output (format "/%s %s def\n" name (if bool "true" "false"))))

(defun ps-background-pages (page-list func)
  (if page-list
      (mapcar
       '(lambda (pages)

  (ps-output (format "/BottomMargin %s def\n" ps-bottom-margin))
  (ps-output (format "/TopMargin    %s def\n" ps-top-margin)) ; not used
  (ps-output (format "/HeaderOffset %s def\n" ps-header-offset))
  (ps-output (format "/HeaderPad    %s def\n" ps-header-pad))
  
  (ps-output-boolean "PrintHeader"      ps-print-header)
  (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame)
  (ps-output-boolean "ShowNofN"         ps-show-n-of-n)
  (ps-output-boolean "Duplex"           ps-spool-duplex)

  (ps-header-page t)
  (ps-output "/PrintHeader false def
BeginPage
EndPage
EndDSCPage\n"))
	    
(defun ps-next-line ()
  (setq ps-showline-count (1+ ps-showline-count))
  (if (< ps-height-remaining ps-line-height)
      (ps-next-page)
    (setq ps-width-remaining  ps-print-width)

(defun ps-plot-region (from to font &optional fg-color bg-color effects)
  (if (not (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.
  (if (not (equal fg-color ps-current-color))
      (ps-set-color fg-color))
  
  (if (not (equal bg-color ps-current-bg))
      (ps-set-bg bg-color))
  
  ;; Specify effects (underline, overline, box, etc)
  (cond
   ((not (integerp effects))
    (ps-output "0 EF\n")
    (setq ps-current-effect 0))

			fg-color bg-color (lsh effect -2)))
    (ps-plot-region from to 0))
  (goto-char to))


(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
     ;; Check FACE defaults:
     (and (listp face-defaults)
	  (memq kind face-defaults))
     ;; Check the user's preferences
     (memq face kind-list))))

(defun ps-xemacs-face-kind-p (face kind kind-regex kind-list)
  (let* ((frame-font (or (face-font face) (face-font 'default)))
	 (kind-cons (assq kind (x-font-properties frame-font)))
	 (kind-spec (cdr-safe kind-cons))
	 (case-fold-search t))

	;; Kludge-compatible:
	(memq face kind-list))))

(defun ps-face-bold-p (face)
  (if (eq ps-print-emacs-type 'emacs)
      (face-bold-p face)
    (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold"
			   ps-bold-faces)))

(defun ps-face-italic-p (face)
  (if (eq ps-print-emacs-type 'emacs)
      (face-italic-p face)
    (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)

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

(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) ; the new
        (lazy-lock-fontify-buffer))))	       ; the old

(defun ps-generate-postscript-with-faces (from to)
  ;; Some initialization...
  (setq ps-current-effect 0)

19879:87952270ceeb

;; The spooling mechanism was designed for printing lots of small
;; files (mail messages or netnews articles) to save paper that would
;; otherwise be wasted on banner pages, and to make it easier to find
;; your output at the printer (it's easier to pick up one 50-page
;; printout than to find 50 single-page printouts).
;;
;; Ps-print has a hook in the `kill-emacs-hooks' so that you won't
;; accidentally quit from Emacs while you have unprinted PostScript
;; waiting in the spool buffer.  If you do attempt to exit with
;; spooled PostScript, you'll be asked if you want to print it, and if
;; you decline, you'll be asked to confirm the exit; this is modeled

;; directory; on the right, the page number and date of printing.
;; The default headers look something like this:
;;
;;     ps-print.el                                         1/21
;;     /home/jct/emacs-lisp/ps/new                     94/12/31
;;
;; When printing on duplex printers, left and right are reversed so
;; that the page numbers are toward the outside (cf. `ps-spool-duplex').
;;
;; Headers are configurable:
;; To turn them off completely, set `ps-print-header' to nil.
;; To turn off the header's gaudy framing box,
;; set `ps-print-header-frame' to nil.
;;
;; The font family and size of text in the header are determined
;; by the variables `ps-header-font-family', `ps-header-font-size' and
;; `ps-header-title-font-size' (see below).
;;
;; The variable `ps-header-line-pad' determines the portion of a header
;; title line height to insert between the header frame and the text
;; it contains, both in the vertical and horizontal directions:

;; Ps-print will insert blank pages to make sure each buffer starts
;; on the correct side of the paper.
;; Don't forget to set `ps-lpr-switches' to select duplex printing
;; for your printer.
;;
;;
;; Line Number
;; -----------
;;
;; 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).

;;
;; XXXXXXXXXXXXXXXXXXXXXXXX
;; XXXXXXXXXXXXXXXXXXXXXXXX
;; XXXXXXXXXXXXXXXXXXXXXXXX
;;
;; The blocks of X's 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.

;; for a list of font families (currently mainly `Courier' `Helvetica'
;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk').
;; Each font family contains the font names for standard, bold, italic
;; and bold-italic characters, a reference size (usually 10) and the
;; corresponding line height, width of a space and average character width.
;;
;; The variable `ps-font-family' determines which font family
;; is to be used for ordinary text.
;; If its value does not correspond to a known font family,
;; an error message is printed into the `*Messages*' buffer,
;; which lists the currently available font families.

;;   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   - print characters as hollow outlines.
;;
;; See the documentation for `ps-extend-face'.
;;
;; 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) '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.
;;
;;
;; How Ps-Print Has A Text And/Or Image On Background
;; --------------------------------------------------
;;

;;
;; Faces are always treated as opaque.
;;
;; Epoch and Emacs 18 not supported.  At all.
;;
;; Fixed-pitch fonts work better for line folding, but are not required.
;;
;; `ps-nb-pages-buffer' and `ps-nb-pages-region' don't take care
;; of folding lines.
;;
;;

  :type 'number
  :group 'ps-print)

(defcustom ps-zebra-stripes nil
  "*Non-nil means print zebra stripes.
See also documentation for `ps-zebra-stripe-height'."
  :type 'boolean
  :group 'ps-print)

(defcustom ps-zebra-stripe-height 3
  "*Number of zebra stripe lines.
See also documentation for `ps-zebra-stripes'."
  :type 'number
  :group 'ps-print)

(defcustom ps-line-number nil
  "*Non-nil means print line number."

  (interactive (list (ps-print-preprint current-prefix-arg)))
  (ps-do-despool filename))

;;;###autoload
(defun ps-line-lengths ()
  "Display the correspondence between a line length and a font size,
using the current ps-print setup.
Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head"
  (interactive)
  (ps-line-lengths-internal))

;;;###autoload
(defun ps-nb-pages-buffer (nb-lines)
  "Display number of pages to print this buffer, for various font heights.
The table depends on the current ps-print setup."
  (interactive (list (count-lines (point-min) (point-max))))
  (ps-nb-pages nb-lines))

;;;###autoload
(defun ps-nb-pages-region (nb-lines)
  "Display number of pages to print the region, for various font heights.
The table depends on the current ps-print setup."
  (interactive (list (count-lines (mark) (point))))
  (ps-nb-pages nb-lines))

;;;###autoload
(defun ps-setup ()
  "Return the current setup."
  (format
   "
\(setq ps-print-color-p  %s
      ps-lpr-command    \"%s\"
      ps-lpr-switches   %s

      (error "Could not read file `%s'" fname))
  (save-excursion
    (set-buffer ps-spool-buffer)
    (goto-char (point-max))
    (insert-file fname)))

;; These functions insert the arrays that define the contents of the
;; headers.

(defun ps-generate-header-line (fonttag &optional content)
  (ps-output "  [ " fonttag " ")

	  (setq count (+ count 1)))
	(ps-output "] def\n"))))

(defun ps-output-boolean (name bool)
  (ps-output (format "/%s %s def\n" name (if bool "true" "false"))))


(defun ps-background-pages (page-list func)
  (if page-list
      (mapcar
       '(lambda (pages)

  (ps-output (format "/BottomMargin %s def\n" ps-bottom-margin))
  (ps-output (format "/TopMargin    %s def\n" ps-top-margin)) ; not used
  (ps-output (format "/HeaderOffset %s def\n" ps-header-offset))
  (ps-output (format "/HeaderPad    %s def\n" ps-header-pad))

  (ps-output-boolean "PrintHeader"      ps-print-header)
  (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame)
  (ps-output-boolean "ShowNofN"         ps-show-n-of-n)
  (ps-output-boolean "Duplex"           ps-spool-duplex)

  (ps-header-page t)
  (ps-output "/PrintHeader false def
BeginPage
EndPage
EndDSCPage\n"))

(defun ps-next-line ()
  (setq ps-showline-count (1+ ps-showline-count))
  (if (< ps-height-remaining ps-line-height)
      (ps-next-page)
    (setq ps-width-remaining  ps-print-width)

(defun ps-plot-region (from to font &optional fg-color bg-color effects)
  (if (not (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.
  (if (not (equal fg-color ps-current-color))
      (ps-set-color fg-color))

  (if (not (equal bg-color ps-current-bg))
      (ps-set-bg bg-color))

  ;; Specify effects (underline, overline, box, etc)
  (cond
   ((not (integerp effects))
    (ps-output "0 EF\n")
    (setq ps-current-effect 0))

			fg-color bg-color (lsh effect -2)))
    (ps-plot-region from to 0))
  (goto-char to))


(defun ps-xemacs-face-kind-p (face kind kind-regex kind-list)
  (let* ((frame-font (or (face-font face) (face-font 'default)))
	 (kind-cons (assq kind (x-font-properties frame-font)))
	 (kind-spec (cdr-safe kind-cons))
	 (case-fold-search t))

	;; Kludge-compatible:
	(memq face kind-list))))

(defun ps-face-bold-p (face)
  (if (eq ps-print-emacs-type 'emacs)
      (or (face-bold-p face)
	  (memq face ps-bold-faces))
    (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold"
			   ps-bold-faces)))

(defun ps-face-italic-p (face)
  (if (eq ps-print-emacs-type 'emacs)
      (or (face-italic-p face)
	  (memq face 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)

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

(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) ; the new
	(lazy-lock-fontify-buffer))))	; the old

(defun ps-generate-postscript-with-faces (from to)
  ;; Some initialization...
  (setq ps-current-effect 0)