X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/2a64315a111fb4da67e9c40c9b69045c4f63d619..f1e06f7bffc1407f7e597f714b2969fc6d1d8eed:/lisp/ps-print.el diff --git a/lisp/ps-print.el b/lisp/ps-print.el index 7c7397a52b..004bdce1f6 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -1,8 +1,6 @@ ;;; ps-print.el --- print text from the buffer as PostScript -;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, -;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 -;; Free Software Foundation, Inc. +;; Copyright (C) 1993-2014 Free Software Foundation, Inc. ;; Author: Jim Thompson (was ) ;; Jacques Duthen (was ) @@ -977,7 +975,7 @@ Please send all bug fixes and enhancements to ;; (setq ps-font-info-database '( )) ;; or, use `ps-print-hook' (see section Hooks): ;; (add-hook 'ps-print-hook -;; '(lambda () +;; (lambda () ;; (or (assq 'Helvetica ps-font-info-database) ;; (setq ps-font-info-database (append ...))))) ;; @@ -1044,7 +1042,7 @@ Please send all bug fixes and enhancements to ;; variables `ps-bold-faces', `ps-italic-faces' and `ps-underlined-faces'. ;; These variables contain lists of faces that ps-print should consider bold, ;; italic or underline; to set them, put code like the following into your -;; .emacs file: +;; init file: ;; ;; (setq ps-bold-faces '(my-blue-face)) ;; (setq ps-italic-faces '(my-red-face)) @@ -1466,25 +1464,16 @@ Please send all bug fixes and enhancements to (require 'lpr) -(or (featurep 'lisp-float-type) - (error "`ps-print' requires floating point support")) - - (if (featurep 'xemacs) - () + (or (featurep 'lisp-float-type) + (error "`ps-print' requires floating point support")) (unless (and (boundp 'emacs-major-version) (>= emacs-major-version 23)) (error "`ps-print' only supports Emacs 23 and higher"))) -(defconst ps-windows-system - (memq system-type '(ms-dos windows-nt))) -(defconst ps-lp-system - (memq system-type '(usg-unix-v hpux irix))) - - ;; Load XEmacs/Emacs definitions -(eval-and-compile (require 'ps-def)) +(require 'ps-def) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1681,8 +1670,7 @@ For more information about PostScript document comments, see: :version "20" :group 'ps-print-miscellany) -(defcustom ps-printer-name (and (boundp 'printer-name) - (symbol-value 'printer-name)) +(defcustom ps-printer-name nil "The name of a local printer for printing PostScript files. On Unix-like systems, a string value should be a name understood by lpr's -P @@ -1714,12 +1702,8 @@ See also `ps-printer-name-option' for documentation." :group 'ps-print-printer) (defcustom ps-printer-name-option - (cond (ps-windows-system - "/D:") - (ps-lp-system - "-d") - (t - "-P" )) + (cond (lpr-windows-system "/D:") + (t lpr-printer-switch)) "Option for `ps-printer-name' variable (see it). On Unix-like systems, if `lpr' is in use, this should be the string @@ -1734,8 +1718,6 @@ Set this to \"\" or nil, if the utility given by `ps-lpr-command' needs an empty printer name option--that is, pass the printer name with no special option preceding it. -Any value that is not a string is treated as nil. - This variable is used only when `ps-printer-name' is a non-empty string." :type '(choice :menu-tag "Printer Name Option" :tag "Printer Name Option" @@ -1787,11 +1769,14 @@ See `ps-lpr-command'." :version "20" :group 'ps-print-printer) -(defcustom ps-print-region-function nil +(defcustom ps-print-region-function + (if (memq system-type '(ms-dos windows-nt)) + #'w32-direct-ps-print-region-function + #'call-process-region) "Specify a function to print the region on a PostScript printer. See definition of `call-process-region' for calling conventions. The fourth and the sixth arguments are both nil." - :type '(choice (const nil) function) + :type 'function :version "20" :group 'ps-print-printer) @@ -1803,7 +1788,7 @@ If it's nil, automatic feeding takes place." :version "20" :group 'ps-print-printer) -(defcustom ps-end-with-control-d (and ps-windows-system t) +(defcustom ps-end-with-control-d (and lpr-windows-system t) "Non-nil means insert C-d at end of PostScript file generated." :version "21.1" :type 'boolean @@ -1964,13 +1949,13 @@ Valid values are: Any other value is treated as nil. -If you set `ps-selected-pages' (see it for documentation), first the pages are -filtered by `ps-selected-pages' and then by `ps-even-or-odd-pages'. For -example, if we have: +If you set option `ps-selected-pages', first the pages are +filtered by option `ps-selected-pages' and then by `ps-even-or-odd-pages'. +For example, if we have: (setq ps-selected-pages '(1 4 (6 . 10) (12 . 16) 20)) -Combining with `ps-even-or-odd-pages' and `ps-n-up-printing', we have: +Combining with `ps-even-or-odd-pages' and option `ps-n-up-printing', we have: `ps-n-up-printing' = 1: `ps-even-or-odd-pages' PAGES PRINTED @@ -2641,7 +2626,7 @@ NOTE: page numbers are displayed as part of headers, :group 'ps-print-headers) (defcustom ps-spool-config - (if ps-windows-system + (if lpr-windows-system nil 'lpr-switches) "Specify who is responsible for setting duplex and page size. @@ -3022,7 +3007,6 @@ Any other value is ignored and black color will be used. 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) (const :tag "Frame Foreground" frame-parameter) (number :tag "Gray Scale" :value 0.0) @@ -3030,7 +3014,8 @@ nor black-white." (list :tag "RGB Color" :value (0.0 0.0 0.0) (number :tag "Red") (number :tag "Green") - (number :tag "Blue"))) + (number :tag "Blue")) + (other :tag "Default Foreground Gray/Color" nil)) :version "20" :group 'ps-print-color) @@ -3068,7 +3053,6 @@ nor black-white. See also `ps-use-face-background'." :type '(choice :menu-tag "Default Background Gray/Color" - :tag "Default Background Gray/Color" (const :tag "Session Background" t) (const :tag "Frame Background" frame-parameter) (number :tag "Gray Scale" :value 1.0) @@ -3076,7 +3060,8 @@ See also `ps-use-face-background'." (list :tag "RGB Color" :value (1.0 1.0 1.0) (number :tag "Red") (number :tag "Green") - (number :tag "Blue"))) + (number :tag "Blue")) + (other :tag "Default Background Gray/Color" nil)) :version "20" :group 'ps-print-color) @@ -3394,15 +3379,12 @@ It's like the very first character of buffer (or region) is ^L (\\014)." :group 'ps-print-headers) (defcustom ps-postscript-code-directory - (or (if (featurep 'xemacs) - (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 - (error "`ps-postscript-code-directory' isn't set properly")) + (cond ((fboundp 'locate-data-directory) ; XEmacs + (locate-data-directory "ps-print")) + ((boundp 'data-directory) ; XEmacs and Emacs. + data-directory) + (t ; don't know what to do + (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'." :type 'directory @@ -3571,9 +3553,9 @@ Use the command `ps-despool' to send the spooled images to the printer." ;;;###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. This command works only if you are using a window system, -so it has a way to determine color values. +Like the command `ps-spool-buffer', 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. Use the command `ps-despool' to send the spooled images to the printer." (interactive) @@ -3651,8 +3633,7 @@ The table depends on the current ps-print setup." ") ps-print version " ps-print-version "\n") ";; internal vars" (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) + (ps-comment-string "lpr-windows-system" lpr-windows-system) nil '(25 . ps-print-color-p) '(25 . ps-lpr-command) @@ -4331,14 +4312,17 @@ Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head" (ps-header-font-size-internal (or ps-header-font-size-internal (ps-get-font-size 'ps-header-font-size))) + (ps-footer-font-size-internal + (or ps-footer-font-size-internal + (ps-get-font-size 'ps-footer-font-size))) (ps-header-title-font-size-internal (or ps-header-title-font-size-internal (ps-get-font-size 'ps-header-title-font-size))) (buf (get-buffer-create "*Line-lengths*")) (ifs ps-font-size-internal) ; initial font size - (icw (ps-avg-char-width 'ps-font-for-text)) ; initial character width (print-width (progn (ps-get-page-dimensions) ps-print-width)) + (icw (ps-avg-char-width 'ps-font-for-text)) ; initial character width (ps-setup (ps-setup)) ; setup for the current buffer (fs-min 5) ; minimum font size cw-min ; minimum character width @@ -4378,6 +4362,9 @@ and on the current ps-print setup." (ps-header-font-size-internal (or ps-header-font-size-internal (ps-get-font-size 'ps-header-font-size))) + (ps-footer-font-size-internal + (or ps-footer-font-size-internal + (ps-get-font-size 'ps-footer-font-size))) (ps-header-title-font-size-internal (or ps-header-title-font-size-internal (ps-get-font-size 'ps-header-title-font-size))) @@ -4387,9 +4374,9 @@ and on the current ps-print setup." (buf (get-buffer-create "*Nb-Pages*")) (ils ps-line-spacing-internal) ; initial line spacing (ifs ps-font-size-internal) ; initial font size - (ilh (ps-line-height 'ps-font-for-text)) ; initial line height (page-height (progn (ps-get-page-dimensions) ps-print-height)) + (ilh (ps-line-height 'ps-font-for-text)) ; initial line height (ps-setup (ps-setup)) ; setup for the current buffer (fs-min 4) ; minimum font size lh-min ; minimum line height @@ -4591,16 +4578,16 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th ps-print-height)))))) -(defun ps-print-preprint-region (prefix-arg) +(defun ps-print-preprint-region (prefix) (or (ps-mark-active-p) (error "The mark is not set now")) - (list (point) (mark) (ps-print-preprint prefix-arg))) + (list (point) (mark) (ps-print-preprint prefix))) -(defun ps-print-preprint (prefix-arg) - (and prefix-arg - (or (numberp prefix-arg) - (listp prefix-arg)) +(defun ps-print-preprint (prefix) + (and prefix + (or (numberp prefix) + (listp prefix)) (let* ((name (concat (file-name-nondirectory (or (buffer-file-name) (buffer-name))) ".ps")) @@ -5368,12 +5355,12 @@ Each element has the following form: (KIND XCOL YCOL XLIN YLIN REPEAT END XSTART YSTART) Where: -KIND is a valid value of `ps-n-up-filling'. +KIND is a valid value of the variable `ps-n-up-filling'. XCOL YCOL are the relative position for the next column. XLIN YLIN are the relative position for the beginning of next line. -REPEAT is the number of repetions for external loop. -END is the number of repetions for internal loop and also the number of pages in - a row. +REPEAT is the number of repetitions for external loop. +END is the number of repetitions for internal loop and also the number + of pages in a row. XSTART YSTART are the relative position for the first page in a sheet.") @@ -5425,8 +5412,8 @@ XSTART YSTART are the relative position for the first page in a sheet.") "%%Title: " (buffer-name) ; Take job name from name of ; first buffer printed "\n%%Creator: ps-print v" ps-print-version - "\n%%For: " (user-full-name) - "\n%%CreationDate: " (format-time-string "%T %b %d %Y") + "\n%%For: " (user-full-name) ;FIXME: may need encoding! + "\n%%CreationDate: " (format-time-string "%T %b %d %Y") ;FIXME: encoding! "\n%%Orientation: " (if ps-landscape-mode "Landscape" "Portrait") "\n%%DocumentNeededResources: font Times-Roman Times-Italic\n%%+ font " @@ -6019,7 +6006,7 @@ XSTART YSTART are the relative position for the first page in a sheet.") (ps-output " S\n") wrappoint)) -(defun ps-basic-plot-string (from to &optional bg-color) +(defun ps-basic-plot-string (from to &optional _bg-color) (let* ((wrappoint (ps-find-wrappoint from to (ps-avg-char-width 'ps-font-for-text))) (to (car wrappoint)) @@ -6028,7 +6015,7 @@ XSTART YSTART are the relative position for the first page in a sheet.") (ps-output " S\n") wrappoint)) -(defun ps-basic-plot-whitespace (from to &optional bg-color) +(defun ps-basic-plot-whitespace (from to &optional _bg-color) (let* ((wrappoint (ps-find-wrappoint from to (ps-space-width 'ps-font-for-text))) (to (car wrappoint))) @@ -6134,7 +6121,7 @@ to the equivalent Latin-1 characters.") (goto-char from) ;; ...break the region up into chunks separated by tabs, linefeeds, - ;; pagefeeds, control characters, and plot each chunk. + ;; formfeeds, control characters, and plot each chunk. (while (< from to) ;; skip lines between cut markers (and ps-begin-cut-regexp ps-end-cut-regexp @@ -6306,6 +6293,10 @@ If FACE is not a valid face name, use default face." ;; only background color, not a `real' face ((ps-face-background-color-p (car face-or-list)) (vector 0 nil (ps-face-extract-color face-or-list))) + ;; Anonymous face. + ((keywordp (car face-or-list)) + (vector 0 (plist-get face-or-list :foreground) + (plist-get face-or-list :background))) ;; list of faces (t (let ((effects 0) @@ -6438,6 +6429,7 @@ If FACE is not a valid face name, use default face." (save-restriction (narrow-to-region from to) (ps-print-ensure-fontified from to) + (deactivate-mark) ;bug#16866. (ps-generate-postscript-with-faces1 from to))) (defun ps-generate-postscript (from to) @@ -6568,95 +6560,36 @@ If FACE is not a valid face name, use default face." (write-region (point-min) (point-max) filename)) (and ps-razzle-dazzle (message "Wrote %s" filename))) ;; Else, spool to the printer - (and ps-razzle-dazzle (message "Printing...")) (with-current-buffer ps-spool-buffer (let* ((coding-system-for-write 'raw-text-unix) - (ps-printer-name (or ps-printer-name - (and (boundp 'printer-name) - (symbol-value 'printer-name)))) - (ps-lpr-switches - (append ps-lpr-switches - (and (stringp ps-printer-name) - (string< "" ps-printer-name) - (list (concat - (and (stringp ps-printer-name-option) - ps-printer-name-option) - ps-printer-name)))))) - (or (stringp ps-printer-name) - (setq ps-printer-name nil)) - (apply (or ps-print-region-function 'call-process-region) - (point-min) (point-max) ps-lpr-command nil - (and (fboundp 'start-process) 0) - nil - (ps-flatten-list ; dynamic evaluation - (ps-string-list - (mapcar 'ps-eval-switch ps-lpr-switches)))))) - (and ps-razzle-dazzle (message "Printing...done"))) + (printer-name (or ps-printer-name printer-name)) + (lpr-printer-switch ps-printer-name-option) + (print-region-function ps-print-region-function) + (lpr-command ps-lpr-command)) + (lpr-print-region (point-min) (point-max) ps-lpr-switches nil)))) (kill-buffer ps-spool-buffer))) -(defun ps-string-list (arg) - (let (lstr) - (dolist (elm arg) - (cond ((stringp elm) - (setq lstr (cons elm lstr))) - ((listp elm) - (let ((s (ps-string-list elm))) - (when s - (setq lstr (cons s lstr))))) - (t ))) ; ignore any other value - (nreverse lstr))) - -;; Dynamic evaluation -(defun ps-eval-switch (arg) - (cond ((stringp arg) arg) - ((functionp arg) (apply arg nil)) - ((symbolp arg) (symbol-value arg)) - ((consp arg) (apply (car arg) (cdr arg))) - (t nil))) - -;; `ps-flatten-list' is defined here (copied from "message.el" and -;; enhanced to handle dotted pairs as well) until we can get some -;; sensible autoloads, or `flatten-list' gets put somewhere decent. - -;; (ps-flatten-list '((a . b) c (d . e) (f g h) i . j)) -;; => (a b c d e f g h i j) - -(defun ps-flatten-list (&rest list) - (ps-flatten-list-1 list)) - -(defun ps-flatten-list-1 (list) - (cond ((null list) nil) - ((consp list) (append (ps-flatten-list-1 (car list)) - (ps-flatten-list-1 (cdr list)))) - (t (list list)))) - (defun ps-kill-emacs-check () - (let (ps-buffer) - (and (setq ps-buffer (get-buffer ps-spool-buffer-name)) - (buffer-name ps-buffer) ; check if it's not killed + (let ((ps-buffer (get-buffer ps-spool-buffer-name))) + (and (buffer-live-p ps-buffer) (buffer-modified-p ps-buffer) (y-or-n-p "Unprinted PostScript waiting; print now? ") - (ps-despool)) - (and (setq ps-buffer (get-buffer ps-spool-buffer-name)) - (buffer-name ps-buffer) ; check if it's not killed + (ps-despool))) + (let ((ps-buffer (get-buffer ps-spool-buffer-name))) + (and (buffer-live-p ps-buffer) (buffer-modified-p ps-buffer) (not (yes-or-no-p "Unprinted PostScript waiting; exit anyway? ")) (error "Unprinted PostScript")))) -(cond ((fboundp 'add-hook) - (funcall 'add-hook 'kill-emacs-hook 'ps-kill-emacs-check)) - (kill-emacs-hook - (message "Won't override existing `kill-emacs-hook'")) - (t - (setq kill-emacs-hook 'ps-kill-emacs-check))) +(unless noninteractive + (add-hook 'kill-emacs-hook #'ps-kill-emacs-check)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; To make this file smaller, some commands go in a separate file. ;; But autoload them here to make the separation invisible. -;;;### (autoloads (ps-mule-end-job ps-mule-begin-job ps-mule-initialize -;;;;;; ps-multibyte-buffer) "ps-mule" "ps-mule.el" "9187df3473401876e0df4937c311fbaf") +;;;### (autoloads nil "ps-mule" "ps-mule.el" "173235d6520575a877c25be437fb9e5f") ;;; Generated autoloads from ps-mule.el (defvar ps-multibyte-buffer nil "\ @@ -6726,5 +6659,4 @@ Finish printing job for multi-byte chars. (provide 'ps-print) -;; arch-tag: fb06a585-1112-4206-885d-a57d95d50579 ;;; ps-print.el ends here