comparison lisp/ps-print.el @ 11799:4a04c7799790

Miscellaneous fixes for better compatibility with XEmacs 19.12. (ps-plot-with-face): Added code to handle Emacs 19.29's new ability for the face attribute to hold a list of faces. Rolled in Chuck Thompson's changes to make color printing work in XEmacs 19.12. Fix error in comments. (ps-generate-postscript-with-faces): Add fix to handle extents without faces. (ps-faces-list): deleted. Added alias for list-faces if face-list isn't fbound. (ps-print-ensure-fontified) added to make sure ps-print works correctly in conjunction with lazy-lock. RMS's changes for Emacs.

11798:7646040d7383

;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;; LCD Archive Entry:
;; ps-print|James C. Thompson|[e-mail]|
;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print)|
;; 26-Feb-1994|2.0|~/packages/ps-print.el|

;; Baseline-version: 2.0.  (Jim's last change version -- this
;; file may have been edited as part of Emacs without changes to the
;; version number.  When reporting bugs, please also report the
;; version of Emacs, if any, that ps-print was distributed with.)

;;; Commentary:

;; contain lists of faces that ps-print should consider bold or
;; italic; to set them, put code like the following into your .emacs
;; file:
;;
;; 	(setq ps-bold-faces '(my-blue-face))
;;      (setq ps-red-faces '(my-red-face))
;;
;; Ps-print does not attempt to guess the sizes of fonts; all text is
;; rendered using the Courier font family, in 10 point size.  To
;; change the font family, change the variables ps-font, ps-font-bold,
;; ps-font-italic, and ps-font-bold-italic; fixed-pitch fonts work

;; Better conformance to PostScript Document Structure Conventions.
;;
;;
;; Known bugs and limitations of ps-print:
;; --------------------------------------
;; Automatic font-attribute detection doesn't work well, especially
;; with hilit19 and older versions of get-create-face.  Users having
;; problems with auto-font detection should use the lists ps-italic-
;; faces and ps-bold-faces and/or turn off automatic detection by
;; setting ps-auto-font-detect to nil.
;;
;; Color output doesn't yet work in XEmacs.
;;
;; Still too slow; could use some hand-optimization.
;;
;; ASCII Control characters other than tab, linefeed and pagefeed are
;; not handled.

;; Jim
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Code:

(defconst ps-print-version "2.0"
  "ps-print.el,v 2.0 1995/02/12 04:39:48 jct Exp

Jim's last change version -- this file may have been edited as part of
Emacs without changes to the version number.  When reporting bugs,
please also report the version of Emacs, if any, that ps-print was
distributed with.

(defvar ps-show-n-of-n t
  "*Non-nil means show page numbers as N/M, meaning page N of M.
Note: page numbers are displayed as part of headers, see variable
`ps-print-headers'.")

(defvar ps-print-color-p (and (fboundp 'x-color-values)
			      (fboundp 'float))
; Printing color requires both floating point and x-color-values.
  "*If non-nil, print the buffer's text in color.")

(defvar ps-default-fg '(0.0 0.0 0.0)

			   ((string-match "Epoch" emacs-version) 'epoch)
			   (t 'fsf))))

(if (or (eq emacs-type 'lucid)
	(eq emacs-type 'xemacs))
    (setq ps-print-color-p nil)
  (require 'faces))			; face-font, face-underline-p,
					; x-font-regexp

(require 'time-stamp)

		 " true BG\n")
    (ps-output "false BG\n")))

(defun ps-set-color (color)
  (if (setq ps-current-color color)
      (ps-output (format ps-color-format (nth 0 ps-current-color)
			 (nth 1 ps-current-color) (nth 2 ps-current-color))
		 " FG\n")))

(defun ps-set-underline (underline-p)
  (ps-output (if underline-p "true" "false") " UL\n")
  (setq ps-current-underline-p underline-p))

(defun ps-color-value (x-color-value)
  ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
  (/ x-color-value ps-print-color-scale))

(defun ps-plot-with-face (from to face)
  (if face
      (let* ((bold-p (memq face ps-ref-bold-faces))
	     (italic-p (memq face ps-ref-italic-faces))
	     (underline-p (memq face ps-ref-underlined-faces))
	     (foreground (face-foreground face))
	     (background (face-background face))
	     (fg-color (if (and ps-print-color-p foreground)
			   (mapcar 'ps-color-value
				   (x-color-values foreground))
			 ps-default-color))
	     (bg-color (if (and ps-print-color-p background)
			   (mapcar 'ps-color-value
				   (x-color-values background)))))
	(ps-plot-region from to
			(cond ((and bold-p italic-p) 3)
			      (italic-p 2)
			      (bold-p 1)
			      (t 0))

(defun ps-face-underlined-p (face)
  (or (face-underline-p face)
      (memq face ps-underlined-faces)))

(defun ps-faces-list ()
  (if (or (eq emacs-type 'lucid) (eq emacs-type 'xemacs))
      (list-faces)
    (face-list)))

(defun ps-build-reference-face-lists ()
  (if ps-auto-font-detect
      (let ((faces (ps-faces-list))
	    the-face)
	(setq ps-ref-bold-faces nil
	      ps-ref-italic-faces nil
	      ps-ref-underlined-faces nil)
	(while faces

(defun ps-sorter (a b)
  (< (car a) (car b)))

(defun ps-extent-sorter (a b)
  (< (extent-priority a) (extent-priority b)))
    
(defun ps-generate-postscript-with-faces (from to)
  ;; Build the reference lists of faces if necessary.
  (if (or ps-always-build-face-reference
	  ps-build-face-reference)
      (progn

  ;; Set the color scale.  We do it here instead of in the defvar so
  ;; that ps-print can be dumped into emacs.  This expression can't be
  ;; evaluated at dump-time because X isn't initialized.
  (setq ps-print-color-scale
	(if ps-print-color-p
	    (float (car (x-color-values "white")))
	  1.0))
  ;; Generate some PostScript.
  (save-restriction
    (narrow-to-region from to)
    (let ((face 'default)
	  (position to))
      (cond ((or (eq emacs-type 'lucid) (eq emacs-type 'xemacs))
	   ;; Build the list of extents...
	   (let ((a (cons 'dummy nil))
		 record type extent extent-list)
	     (map-extents 'ps-mapper nil from to a)

	       (setq record (cdr record))
	     
	       (setq extent (car record))
	     
	       ;; Plot up to this record.
	       (ps-plot-with-face from position face)
	     
	       (cond
		((eq type 'push)
		 (setq extent-list (sort (cons extent extent-list)
					 'ps-extent-sorter)))
	      
		((eq type 'pull)
		 (setq extent-list (sort (delq extent extent-list)
					 'ps-extent-sorter))))
	     

;; This stuff is for anybody that's brave enough to look this far,
;; and able to figure out how to use it.  It isn't really part of ps-
;; print, but I'll leave it here in hopes it might be useful:

(defmacro ps-prsc () (list 'if (list 'eq 'emacs-type ''fsf) [f22] ''f22))
(defmacro ps-c-prsc () (list 'if (list 'eq 'emacs-type ''fsf) [C-f22]
			     ''(control f22)))
(defmacro ps-s-prsc () (list 'if (list 'eq 'emacs-type ''fsf) [S-f22]
			     ''(shift f22)))

(defun ps-info-mode-hook ()
  (setq ps-left-header
	;; The left headers will display the node name and file name.
	(list 'ps-info-node 'ps-info-file)))

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

11799:4a04c7799790

;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;; LCD Archive Entry:
;; ps-print|James C. Thompson|[e-mail]|
;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print)|
;; 26-Feb-1994|2.8|~/packages/ps-print.el|

;; Baseline-version: 2.8.  (Jim's last change version -- this
;; file may have been edited as part of Emacs without changes to the
;; version number.  When reporting bugs, please also report the
;; version of Emacs, if any, that ps-print was distributed with.)

;;; Commentary:

;; contain lists of faces that ps-print should consider bold or
;; italic; to set them, put code like the following into your .emacs
;; file:
;;
;; 	(setq ps-bold-faces '(my-blue-face))
;;      (setq ps-italic-faces '(my-red-face))
;;
;; Faces like bold-italic that are both bold and italic should go in
;; *both* lists.
;;
;; Ps-print does not attempt to guess the sizes of fonts; all text is
;; rendered using the Courier font family, in 10 point size.  To
;; change the font family, change the variables ps-font, ps-font-bold,
;; ps-font-italic, and ps-font-bold-italic; fixed-pitch fonts work

;; Better conformance to PostScript Document Structure Conventions.
;;
;;
;; Known bugs and limitations of ps-print:
;; --------------------------------------
;; Although color printing will work in XEmacs 19.12, it doesn't work
;; well; in particular, bold or italic fonts don't print in the right
;; background color.
;;
;; Invisible properties aren't correctly ignored in XEmacs 19.12.
;;
;; Automatic font-attribute detection doesn't work well, especially
;; with hilit19 and older versions of get-create-face.  Users having
;; problems with auto-font detection should use the lists ps-italic-
;; faces and ps-bold-faces and/or turn off automatic detection by
;; setting ps-auto-font-detect to nil.
;;
;; Automatic font-attribute detection doesn't work with XEmacs 19.12
;; in tty mode; use the lists ps-italic-faces and ps-bold-faces
;; instead.
;;
;; Still too slow; could use some hand-optimization.
;;
;; ASCII Control characters other than tab, linefeed and pagefeed are
;; not handled.

;; Jim
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Code:

(defconst ps-print-version "2.8"
  "ps-print.el,v 2.8 1995/05/04 12:06:10 jct Exp

Jim's last change version -- this file may have been edited as part of
Emacs without changes to the version number.  When reporting bugs,
please also report the version of Emacs, if any, that ps-print was
distributed with.

(defvar ps-show-n-of-n t
  "*Non-nil means show page numbers as N/M, meaning page N of M.
Note: page numbers are displayed as part of headers, see variable
`ps-print-headers'.")

(defvar ps-print-color-p (and (or (fboundp 'x-color-values)   ; fsf
				(fboundp 'pixel-components))  ; xemacs
			      (fboundp 'float))
; Printing color requires both floating point and x-color-values.
  "*If non-nil, print the buffer's text in color.")

(defvar ps-default-fg '(0.0 0.0 0.0)

			   ((string-match "Epoch" emacs-version) 'epoch)
			   (t 'fsf))))

(if (or (eq emacs-type 'lucid)
	(eq emacs-type 'xemacs))
    (if (< emacs-minor-version 12)
	(setq ps-print-color-p nil))
  (require 'faces))			; face-font, face-underline-p,
					; x-font-regexp

(require 'time-stamp)

		 " true BG\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))
  (ps-output (format ps-color-format (nth 0 ps-current-color)
		     (nth 1 ps-current-color) (nth 2 ps-current-color))
	     " FG\n"))

(defun ps-set-underline (underline-p)
  (ps-output (if underline-p "true" "false") " UL\n")
  (setq ps-current-underline-p underline-p))

(defun ps-color-value (x-color-value)
  ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
  (/ x-color-value ps-print-color-scale))

(defun ps-color-values (x-color)
  (cond ((fboundp 'x-color-values)
	 (x-color-values x-color))
	((fboundp 'pixel-components)
	 (pixel-components x-color))
	(t (error "No available function to determine X color values."))))

(defun ps-face-attributes (face)
  (let ((differs (face-differs-from-default-p face)))
    (list (memq face ps-ref-bold-faces)
	  (memq face ps-ref-italic-faces)
	  (memq face ps-ref-underlined-faces)
	  (and differs (face-foreground face))
	  (and differs (face-background face)))))

(defun ps-face-attribute-list (face-or-list)
  (if (listp face-or-list)
      (let (bold-p italic-p underline-p foreground background face-attr face)
	(while face-or-list
	  (setq face (car face-or-list))
	  (setq face-attr (ps-face-attributes face))
	  (setq bold-p (or bold-p (nth 0 face-attr)))
	  (setq italic-p (or italic-p (nth 1 face-attr)))
	  (setq underline-p (or underline-p (nth 2 face-attr)))
	  (if foreground
	      nil
	    (setq foreground (nth 3 face-attr)))
	  (if background
	      nil
	    (setq background (nth 4 face-attr)))
	  (setq face-or-list (cdr face-or-list)))
	(list bold-p italic-p underline-p foreground background))

    (ps-face-attributes face-or-list)))

(defun ps-plot-with-face (from to face)
  (if face
      (let* ((face-attr (ps-face-attribute-list face))
	     (bold-p (nth 0 face-attr))
	     (italic-p (nth 1 face-attr))
	     (underline-p (nth 2 face-attr))
	     (foreground (nth 3 face-attr))
	     (background (nth 4 face-attr))
	     (fg-color (if (and ps-print-color-p foreground)
			   (mapcar 'ps-color-value
				   (ps-color-values foreground))
			 ps-default-color))
	     (bg-color (if (and ps-print-color-p background)
			   (mapcar 'ps-color-value
				   (ps-color-values background)))))
	(ps-plot-region from to
			(cond ((and bold-p italic-p) 3)
			      (italic-p 2)
			      (bold-p 1)
			      (t 0))

(defun ps-face-underlined-p (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 ()
  (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

(defun ps-sorter (a b)
  (< (car a) (car b)))

(defun ps-extent-sorter (a b)
  (< (extent-priority a) (extent-priority b)))

(defun ps-print-ensure-fontified (start end)
  (if (and (boundp 'lazy-lock-mode) lazy-lock-mode)
      (if (fboundp 'lazy-lock-fontify-region)
          (lazy-lock-fontify-region start end)
        (lazy-lock-fontify-buffer))))

(defun ps-generate-postscript-with-faces (from to)
  ;; Build the reference lists of faces if necessary.
  (if (or ps-always-build-face-reference
	  ps-build-face-reference)
      (progn

  ;; Set the color scale.  We do it here instead of in the defvar so
  ;; that ps-print can be dumped into emacs.  This expression can't be
  ;; evaluated at dump-time because X isn't initialized.
  (setq ps-print-color-scale
	(if ps-print-color-p
	    (float (car (ps-color-values "white")))
	  1.0))
  ;; Generate some PostScript.
  (save-restriction
    (narrow-to-region from to)
    (let ((face 'default)
	  (position to))
      (ps-print-ensure-fontified from to)
      (cond ((or (eq emacs-type 'lucid) (eq emacs-type 'xemacs))
	   ;; Build the list of extents...
	   (let ((a (cons 'dummy nil))
		 record type extent extent-list)
	     (map-extents 'ps-mapper nil from to a)

	       (setq record (cdr record))
	     
	       (setq extent (car record))
	     
	       ;; Plot up to this record.
	       ;; XEmacs 19.12: for some reason, we're getting into a
	       ;; situation in which some of the records have
	       ;; positions less than 'from'.  Since we've narrowed
	       ;; the buffer, this'll generate errors.  This is a
	       ;; hack, but don't call ps-plot-with-face unless from >
	       ;; point-min.
	       (if (and (>= from (point-min))
			(<= position (point-max)))
		   (ps-plot-with-face from position face))
	     
	       (cond
		((eq type 'push)
		 (if (extent-face extent)
		     (setq   extent-list (sort (cons extent extent-list)
					       'ps-extent-sorter))))
	      
		((eq type 'pull)
		 (setq extent-list (sort (delq extent extent-list)
					 'ps-extent-sorter))))
	     

;; This stuff is for anybody that's brave enough to look this far,
;; and able to figure out how to use it.  It isn't really part of ps-
;; print, but I'll leave it here in hopes it might be useful:

;; WARNING!!! The following code is *sample* code only. Don't use it
;; unless you understand what it does!

(defmacro ps-prsc () (list 'if (list 'eq 'emacs-type ''fsf) [f22] ''f22))
(defmacro ps-c-prsc () (list 'if (list 'eq 'emacs-type ''fsf) [C-f22]
			     ''(control f22)))
(defmacro ps-s-prsc () (list 'if (list 'eq 'emacs-type ''fsf) [S-f22]
			     ''(shift f22)))

(defun ps-info-mode-hook ()
  (setq ps-left-header
	;; The left headers will display the node name and file name.
	(list 'ps-info-node 'ps-info-file)))

;; WARNING! The following function is a *sample* only, and is *not*
;; meant to be used as a whole unless you understand what the effects
;; will be!  (In fact, this is a copy if my setup for ps-print -- I'd
;; be very surprised if it was useful to *anybody*, without
;; modification.)

(defun ps-jts-ps-setup ()
  (global-set-key (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)