xemacs-beta: lisp/packages/ps-print.el comparison

comparison lisp/packages/ps-print.el @ 2:ac2d302a0011 r19-15b2

Import from CVS: tag r19-15b2

author	cvs
date	Mon, 13 Aug 2007 08:46:35 +0200
parents	376386a54a3c
children	b82b59fe008d

comparison

equal deleted inserted replaced

-:c0c6a60d29db
+:ac2d302a0011
 ;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19.
-;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
 ;; Author: Jim Thompson <thompson@wg2.waii.com>
+;; Maintainer: duthen@cegelec-red.fr (Jacques Duthen Prestataire)
 ;; Keywords: print, PostScript
 ;; This file is part of XEmacs.
 ;; XEmacs is free software; you can redistribute it and/or modify it
 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 ;; General Public License for more details.
 ;; You should have received a copy of the GNU General Public License
 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
-;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
 ;; LCD Archive Entry:
 ;; ps-print|James C. Thompson|thompson@wg2.waii.com|
 ;; 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.)
-;;; Synched up with: FSF 19.30.
+;;; Synched up with: FSF 19.34.
 ;;; Commentary:
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;; 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
-;; accidently quit from Emacs while you have unprinted PostScript
+;; 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
 ;; on the confirmation that Emacs uses for modified buffers.
 ;;
 ;; ps-print cannot correctly place line and page breaks.
 ;;
 ;; Ps-print keeps internal lists of which fonts are bold and which are
 ;; italic; these lists are built the first time you invoke ps-print.
 ;; For the sake of efficiency, the lists are built only once; the same
-;; lists are referred in later invokations of ps-print.
+;; lists are referred in later invocations of ps-print.
 ;;
 ;; Because these lists are built only once, it's possible for them to
 ;; get out of sync, if a face changes, or if new faces are added.  To
 ;; get the lists back in sync, you can set the variable
 ;; ps-build-face-reference to t, and the lists will be rebuilt the
 ;;
 ;; Symbols in the header format lists can either represent functions
 ;; or variables.  Functions are called, and should return a string to
 ;; show in the header.  Variables should contain strings to display in
 ;; the header.  In either case, function or variable, the PostScript
-;; strings delimeters are added by ps-print, and should not be part of
+;; string delimeters are added by ps-print, and should not be part of
 ;; the returned value.
 ;;
 ;; Here's an example: say we want the left header to display the text
 ;;
 ;;     Moe
 ;;
 ;; The variable ps-paper-type determines the size of paper ps-print
 ;; formats for; it should contain one of the symbols ps-letter,
 ;; ps-legal, or ps-a4.  The default is ps-letter.
 ;;
-;;
+;; Make sure that the variables ps-lpr-command and ps-lpr-switches
-;; Installing ps-print
+;; contain appropriate values for your system; see the usage notes
-;; -------------------
+;; below and the documentation of these variables.
-;;
-;; 1. Place ps-print.el somewhere in your load-path and byte-compile
-;;    it.  You can ignore all byte-compiler warnings; they are the
-;;    result of multi-Emacs support.  This step is necessary only if
-;;    you're installing your own ps-print; if ps-print came with your
-;;    copy of Emacs, this been done already.
-;;
-;; 2. Place in your .emacs file the line
-;;
-;;        (require 'ps-print)
-;;
-;;    to load ps-print.  Or you may cause any of the ps-print commands
-;;    to be autoloaded with an autoload command such as:
-;;
-;;      (autoload 'ps-print-buffer "ps-print"
-;;        "Generate and print a PostScript image of the buffer..." t)
-;;
-;; 3. Make sure that the variables ps-lpr-command and ps-lpr-switches
-;;    contain appropriate values for your system; see the usage notes
-;;    below and the documentation of these variables.
 ;;
 ;; New since version 1.5
 ;; ---------------------
 ;; Color output capability.
 ;;
 "*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'.")
 ;;;###autoload
+;;; The 19.33 fsf version includes a test on pixel components instead
+;;;  of color-instance-rgb-components
 (defvar ps-print-color-p (and (or (fboundp 'x-color-values)	; fsf
 				  (fboundp 'color-instance-rgb-components))
 					; xemacs
 			      (fboundp 'float))
 ; Printing color requires both floating point and x-color-values.
 ;;;###autoload
 (defun ps-print-buffer-with-faces (&optional filename)
 "Generate and print a PostScript image of the buffer.
 Like `ps-print-buffer', but includes font, color, and underline
-information in the generated image."
+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 (ps-print-preprint current-prefix-arg)))
 (ps-generate (current-buffer) (point-min) (point-max)
 	       'ps-generate-postscript-with-faces)
 (ps-do-despool filename))
 ;;;###autoload
 (defun ps-print-region (from to &optional filename)
 "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-generate (current-buffer) from to
 	       'ps-generate-postscript)
 ;;;###autoload
 (defun ps-print-region-with-faces (from to &optional filename)
 "Generate and print a PostScript image of the region.
 Like `ps-print-region', but includes font, color, and underline
-information in the generated image."
+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-do-despool filename))
 ;;;###autoload
 (defun ps-spool-buffer ()
 "Generate and spool a PostScript image of the buffer.
 Like `ps-print-buffer' except that the PostScript image is saved in a
 local buffer to be sent to the printer later.
 Use the command `ps-despool' to send the spooled images to the printer."
 (interactive)
 ;;;###autoload
 (defun ps-spool-buffer-with-faces ()
 "Generate and spool a PostScript image of the buffer.
 Like `ps-spool-buffer', but includes font, color, and underline
-information in the generated image.
+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.
 Use the command `ps-despool' to send the spooled images to the printer."
 (interactive)
 (ps-generate (current-buffer) (point-min) (point-max)
 ;;;###autoload
 (defun ps-spool-region (from to)
 "Generate a PostScript image of the region and spool locally.
 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-generate (current-buffer) from to
 ;;;###autoload
 (defun ps-spool-region-with-faces (from to)
 "Generate a PostScript image of the region and spool locally.
 Like `ps-spool-region', but includes font, color, and underline
-information in the generated image.
+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.
 Use the command `ps-despool' to send the spooled images to the printer."
 (interactive "r")
 (ps-generate (current-buffer) from to
 	       'ps-generate-postscript-with-faces))
 /minus
 StandardEncoding 46 82 getinterval aload pop
 %*** NOTE: the following are missing in the Adobe documentation,
 %*** but appear in the displayed table:
 %*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240.
-% \20x
+% ^Px
 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
 /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef
 /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent
 /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron
-% \24x
+% ^Tx
 /space /exclamdown /cent /sterling
 	/currency /yen /brokenbar /section
 /dieresis /copyright /ordfeminine /guillemotleft
 	/logicalnot /hyphen /registered /macron
 /degree /plusminus /twosuperior /threesuperior
 	/acute /mu /paragraph /periodcentered
 /cedilla /onesuperior /ordmasculine /guillemotright
 	/onequarter /onehalf /threequarters /questiondown
-% \30x
+% ^Xx
 /Agrave /Aacute /Acircumflex /Atilde
 	/Adieresis /Aring /AE /Ccedilla
 /Egrave /Eacute /Ecircumflex /Edieresis
 	/Igrave /Iacute /Icircumflex /Idieresis
 /Eth /Ntilde /Ograve /Oacute
 	/Ocircumflex /Otilde /Odieresis /multiply
 /Oslash /Ugrave /Uacute /Ucircumflex
 	/Udieresis /Yacute /Thorn /germandbls
-% \34x
+% ^\\x
 /agrave /aacute /acircumflex /atilde
 	/adieresis /aring /ae /ccedilla
 /egrave /eacute /ecircumflex /edieresis
 	/igrave /iacute /icircumflex /idieresis
 /eth /ntilde /ograve /oacute
 (if (and filename
 	   (or (numberp filename)
 	       (listp filename)))
 (let* ((name (concat (buffer-name) ".ps"))
 	     (prompt (format "Save PostScript to file: (default %s) "
-			     name)))
+			     name))
-	(read-file-name prompt default-directory
+	     (res (read-file-name prompt default-directory name nil)))
-			name nil))))
+	(if (file-directory-p res)
+	    (expand-file-name name (file-name-as-directory res))
+	  res))))
 ;; The following functions implement a simple list-buffering scheme so
 ;; that ps-print doesn't have to repeatedly switch between buffers
 ;; while spooling.  The functions ps-output and ps-output-string build
 ;; up the lists; the function ps-flush-output takes the lists and
 (/ x-color-value ps-print-color-scale))
 (defun ps-color-values (x-color)
 (cond ((fboundp 'x-color-values)
 	 (x-color-values x-color))
+;; From fsf 19.33
+;; ((fboundp 'pixel-components)
+	;;  (pixel-components x-color))
 	((and (fboundp 'color-instance-rgb-components)
 	      (xemacs-color-device))
 	 (color-instance-rgb-components
 	  (if (color-instance-p x-color) x-color
 	    (if (color-specifier-p x-color)
 ;; Check the user's preferences
 (memq face kind-list))))
 (defun ps-xemacs-face-kind-p (face kind kind-regex kind-list)
+;; fsf 19.33:
+;; (let* ((frame-font (or (face-font face) (face-font 'default)))
+;;       (kind-cons (assq kind (x-font-properties frame-font)))
 (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))
 					; unless previous search succeeded.
 		     (setq overlay-change
 			   (min (next-overlay-change from) to)))
 		 (setq position
 		       (min property-change overlay-change))
+		 ;; The code below is not quite correct,
+		 ;; because a non-nil overlay invisible property
+		 ;; which is inactive according to the current value
+		 ;; of buffer-invisibility-spec nonetheless overrides
+		 ;; a face text property.
 		 (setq face
-		       (cond ((get-text-property from 'invisible) nil)
+		       (cond ((let ((prop (get-text-property from 'invisible)))
+				;; Decide whether this invisible property
+				;; really makes the text invisible.
+				(if (eq buffer-invisibility-spec t)
+				    (not (null prop))
+				  (or (memq prop buffer-invisibility-spec)
+				      (assq prop buffer-invisibility-spec))))
+			      nil)
 			     ((get-text-property from 'face))
 			     (t 'default)))
 		 (let ((overlays (overlays-at from))
 		       (face-priority -1)) ; text-property
 		   (while overlays
 			    (overlay-priority (or (overlay-get overlay
 							       'priority)
 						  0)))
 		       (if (and (or overlay-invisible overlay-face)
 				(> overlay-priority face-priority))
-			   (setq face (cond (overlay-invisible nil)
+			   (setq face (cond ((if (eq buffer-invisibility-spec t)
+						 (not (null overlay-invisible))
+					       (or (memq overlay-invisible buffer-invisibility-spec)
+						   (assq overlay-invisible buffer-invisibility-spec)))
+					     nil)
 					    ((and face overlay-face)))
 				 face-priority overlay-priority)))
 		     (setq overlays (cdr overlays))))
 		 ;; Plot up to this record.
 		 (ps-plot-with-face from position face)
 (defun ps-generate-postscript (from to)
 (ps-plot-region from to 0 nil))
 (defun ps-generate (buffer from to genfunc)
 (let ((from (min to from))
-	(to (max to from)))
+	(to (max to from))
+	;; This avoids trouble if chars with read-only properties
+	;; are copied into ps-spool-buffer.
+	(inhibit-read-only t))
 (save-restriction
 (narrow-to-region from to)
 (if ps-razzle-dazzle
 	  (message "Formatting...%d%%" (setq ps-razchunk 0)))
 (set-buffer buffer)
 	      (set-buffer ps-spool-buffer)
 	      (goto-char (point-max))
 	      (while (re-search-backward "^/PageCount 0 def$" nil t)
 		(replace-match (format "/PageCount %d def" ps-page-count) t))
-	      ;; Setting this variable tells the unwind form that the
+	      ;; Setting this variable tells the unwind form that
 	      ;; the postscript was generated without error.
 	      (setq completed-safely t))
-	  ;; Unwind form: If some bad mojo ocurred while generating
+	  ;; Unwind form: If some bad mojo occurred while generating
 	  ;; postscript, delete all the postscript that was generated.
 	  ;; This protects the previously spooled files from getting
 	  ;; corrupted.
 	  (if (and (markerp safe-marker) (not completed-safely))
 	      (progn
 ;; Else, spool to the printer
 (if ps-razzle-dazzle
 	  (message "Printing..."))
 (save-excursion
 	(set-buffer ps-spool-buffer)
-	(apply 'call-process-region
+	(if (and (eq system-type 'ms-dos) (stringp dos-ps-printer))
-	       (point-min) (point-max) ps-lpr-command nil 0 nil
+	    (write-region (point-min) (point-max) dos-ps-printer t 0)
-	       ps-lpr-switches))
+	  (let ((binary-process-input t)) ; for MS-DOS
+	    (apply 'call-process-region
+		   (point-min) (point-max) ps-lpr-command nil
+		   (if (fboundp 'start-process) 0 nil)
+		   nil
+		   ps-lpr-switches))))
 (if ps-razzle-dazzle
 	  (message "Printing...done")))
 (kill-buffer ps-spool-buffer)))
 (defun ps-kill-emacs-check ()
 ;; Look in an article or mail message for the Subject: line.  To be
 ;; placed in ps-left-headers.
 (defun ps-article-subject ()
 (save-excursion
 (goto-char (point-min))
-(if (re-search-forward "^Subject:[ \t]+\\(.*\\)$")
+(if (re-search-forward "^Subject:[ \t]+\\(.*\\)$" nil t)
 	(buffer-substring (match-beginning 1) (match-end 1))
 "Subject ???")))
 ;; Look in an article or mail message for the From: line.  Sorta-kinda
 ;; understands RFC-822 addresses and can pull the real name out where
 ;; it's provided.  To be placed in ps-left-headers.
 (defun ps-article-author ()
 (save-excursion
 (goto-char (point-min))
-(if (re-search-forward "^From:[ \t]+\\(.*\\)$")
+(if (re-search-forward "^From:[ \t]+\\(.*\\)$" nil t)
 	(let ((fromstring (buffer-substring (match-beginning 1) (match-end 1))))
 	  (cond
 	   ;; Try first to match addresses that look like
 	   ;; thompson@wg2.waii.com (Jim Thompson)
 ;; Look in an article or mail message for the Subject: line.  To be
 ;; placed in ps-left-headers.
 (defun ps-info-file ()
 (save-excursion
 (goto-char (point-min))
-(if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)")
+(if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)" nil t)
 	(buffer-substring (match-beginning 1) (match-end 1))
 "File ???")))
 ;; Look in an article or mail message for the Subject: line.  To be
 ;; placed in ps-left-headers.
 (defun ps-info-node ()
 (save-excursion
 (goto-char (point-min))
-(if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)")
+(if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)" nil t)
 	(buffer-substring (match-beginning 1) (match-end 1))
 "Node ???")))
 (defun ps-info-mode-hook ()
 (setq ps-left-header

Mercurial > hg > xemacs-beta

comparison lisp/packages/ps-print.el @ 2:ac2d302a0011 r19-15b2