From 2cdeb903c57126d3ad5f0cbd72e182584b76ee29 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 24 Jul 2013 00:37:11 -0400 Subject: [PATCH] * lisp/lpr.el: Signal print errors more prominently. (print-region-function): Don't default to nil. (lpr-print-region): New function, extracted from print-region-1. Check lpr's return value and signal an error in case of problem. (print-region-1): Use it. * lisp/ps-print.el (ps-windows-system, ps-lp-system): Remove. Use the lpr-* versions instead. (ps-printer-name): Default to nil. (ps-printer-name-option): Default to lpr-printer-switch. (ps-print-region-function): Don't default to nil. (ps-postscript-code-directory): Simplify default. (ps-do-despool): Use lpr-print-region to properly check the outcome. (ps-string-list, ps-eval-switch, ps-flatten-list) (ps-flatten-list-1): Remove. (ps-multibyte-buffer): Avoid setq. * lisp/dos-w32.el (direct-print-region-helper): Use proper regexp operators. (print-region-function, ps-print-region-function): Don't set them here. --- lisp/ChangeLog | 20 +++++++ lisp/dos-w32.el | 21 ++++---- lisp/lpr.el | 116 ++++++++++++++++++++------------------- lisp/ps-mule.el | 1 + lisp/ps-print.el | 138 +++++++++++------------------------------------ 5 files changed, 123 insertions(+), 173 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 141c3fc6344..4c115d8435a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,23 @@ +2013-07-24 Stefan Monnier + + * lpr.el: Signal print errors more prominently. + (print-region-function): Don't default to nil. + (lpr-print-region): New function, extracted from print-region-1. + Check lpr's return value and signal an error in case of problem. + (print-region-1): Use it. + * ps-print.el (ps-windows-system, ps-lp-system): Remove. Use the lpr-* + versions instead. + (ps-printer-name): Default to nil. + (ps-printer-name-option): Default to lpr-printer-switch. + (ps-print-region-function): Don't default to nil. + (ps-postscript-code-directory): Simplify default. + (ps-do-despool): Use lpr-print-region to properly check the outcome. + (ps-string-list, ps-eval-switch, ps-flatten-list) + (ps-flatten-list-1): Remove. + (ps-multibyte-buffer): Avoid setq. + * dos-w32.el (direct-print-region-helper): Use proper regexp operators. + (print-region-function, ps-print-region-function): Don't set them here. + 2013-07-24 Xue Fuqiao * ansi-color.el: Fix old URL. diff --git a/lisp/dos-w32.el b/lisp/dos-w32.el index ff4a3ad66f0..0573caa6c23 100644 --- a/lisp/dos-w32.el +++ b/lisp/dos-w32.el @@ -257,10 +257,10 @@ filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"." ;; Function to actually send data to the printer port. ;; Supports writing directly, and using various programs. (defun direct-print-region-helper (printer - start end - lpr-prog - _delete-text _buf _display - rest) + start end + lpr-prog + _delete-text _buf _display + rest) (let* (;; Ignore case when matching known external program names. (case-fold-search t) ;; Convert / to \ in printer name, for sake of external programs. @@ -295,12 +295,14 @@ filesystem mounted on drive Z:, FILESYSTEM could be \"Z:\"." (unwind-protect (cond ;; nprint.exe is the standard print command on Netware - ((string-match-p "^nprint\\(\\.exe\\)?$" (file-name-nondirectory lpr-prog)) + ((string-match-p "\\`nprint\\(\\.exe\\)?\\'" + (file-name-nondirectory lpr-prog)) (write-region start end tempfile nil 0) (call-process lpr-prog nil errbuf nil tempfile (concat "P=" printer))) ;; print.exe is a standard command on NT - ((string-match-p "^print\\(\\.exe\\)?$" (file-name-nondirectory lpr-prog)) + ((string-match-p "\\`print\\(\\.exe\\)?\\'" + (file-name-nondirectory lpr-prog)) ;; Be careful not to invoke print.exe on MS-DOS or Windows 9x ;; though, because it is a TSR program there (hangs Emacs). (or (and (eq system-type 'windows-nt) @@ -369,7 +371,7 @@ indicates a specific program should be invoked." (write-region-annotate-functions (cons (lambda (_start end) - (if (not (char-equal (char-before end) ?\C-l)) + (if (not (char-equal (char-before end) ?\f)) `((,end . "\f")))) write-region-annotate-functions)) (printer (or (and (boundp 'dos-printer) @@ -383,9 +385,7 @@ indicates a specific program should be invoked." (direct-print-region-helper printer start end lpr-prog delete-text buf display rest))) -(defvar print-region-function) (defvar lpr-headers-switches) -(setq print-region-function 'direct-print-region-function) ;; Set this to nil if you have a port of the `pr' program ;; (e.g., from GNU Textutils), or if you have an `lpr' @@ -416,9 +416,6 @@ indicates a specific program should be invoked." (direct-print-region-helper printer start end lpr-prog delete-text buf display rest))) -(defvar ps-print-region-function) -(setq ps-print-region-function 'direct-ps-print-region-function) - ;(setq ps-lpr-command "gs") ;(setq ps-lpr-switches '("-q" "-dNOPAUSE" "-sDEVICE=epson" "-r240x60" diff --git a/lisp/lpr.el b/lisp/lpr.el index 0b860ed07f1..5aed3bcc484 100644 --- a/lisp/lpr.el +++ b/lisp/lpr.el @@ -130,10 +130,13 @@ and print the result." (repeat :tag "Multiple arguments" (string :tag "Argument"))) :group 'lpr) -(defcustom print-region-function nil +(defcustom print-region-function + (if (memq system-type '(ms-dos windows-nt)) + #'direct-print-region-function + #'call-process-region) "Function to call to print the region on a printer. See definition of `print-region-1' for calling conventions." - :type '(choice (const nil) function) + :type 'function :group 'lpr) (defcustom lpr-page-header-program "pr" @@ -212,35 +215,24 @@ for further customization of the printer command." (print-region-1 start end lpr-switches t)) (defun print-region-1 (start end switches page-headers) + (and page-headers lpr-headers-switches + ;; It's possible to use an lpr option to get page headers. + (setq switches (append (if (stringp lpr-headers-switches) + (list lpr-headers-switches) + lpr-headers-switches) + switches))) ;; On some MIPS system, having a space in the job name ;; crashes the printer demon. But using dashes looks ugly ;; and it seems to annoying to do for that MIPS system. - (let ((name (concat (buffer-name) " Emacs buffer")) - (title (concat (buffer-name) " Emacs buffer")) - ;; Make pipes use the same coding system as - ;; writing the buffer to a file would. - (coding-system-for-write (or coding-system-for-write - buffer-file-coding-system)) - (coding-system-for-read (or coding-system-for-read - buffer-file-coding-system)) - (width tab-width) - nswitches - switch-string) - (save-excursion - (and page-headers lpr-headers-switches - ;; It's possible to use an lpr option to get page headers. - (setq switches (append (if (stringp lpr-headers-switches) - (list lpr-headers-switches) - lpr-headers-switches) - switches))) - (setq nswitches (lpr-flatten-list - (mapcar 'lpr-eval-switch ; Dynamic evaluation - switches)) - switch-string (if switches - (concat " with options " - (mapconcat 'identity switches " ")) - "")) - (message "Spooling%s..." switch-string) + (save-excursion + (let ((name (concat (buffer-name) " Emacs buffer")) + ;; Make pipes use the same coding system as + ;; writing the buffer to a file would. + (coding-system-for-write (or coding-system-for-write + buffer-file-coding-system)) + (coding-system-for-read (or coding-system-for-read + buffer-file-coding-system)) + (width tab-width)) (if (/= tab-width 8) (let ((new-coords (print-region-new-buffer start end))) (setq start (car new-coords) @@ -258,34 +250,48 @@ for further customization of the printer command." (let ((new-coords (print-region-new-buffer start end))) (apply 'call-process-region (car new-coords) (cdr new-coords) lpr-page-header-program t t nil - (mapcar (lambda (e) (format e title)) + (mapcar (lambda (e) (format e name)) lpr-page-header-switches))) (setq start (point-min) end (point-max)))) - (let ((buf (current-buffer))) - (with-temp-buffer - (let ((tempbuf (current-buffer))) - (with-current-buffer buf - (apply (or print-region-function 'call-process-region) - (nconc (list start end lpr-command - nil tempbuf nil) - (and lpr-add-switches - (list "-J" name)) - ;; These belong in pr if we are using that. - (and lpr-add-switches lpr-headers-switches - (list "-T" title)) - (and (stringp printer-name) - (list (concat lpr-printer-switch - printer-name))) - nswitches)))) - (if (markerp end) - (set-marker end nil)) - (message "Spooling%s...done%s%s" switch-string - (pcase (count-lines (point-min) (point-max)) - (0 "") - (1 ": ") - (_ ":\n")) - (buffer-string))))))) + (lpr-print-region start end switches name)))) + +(defun lpr-print-region (start end switches name) + (let ((buf (current-buffer)) + (nswitches (lpr-flatten-list + (mapcar #'lpr-eval-switch ; Dynamic evaluation + switches))) + (switch-string (if switches + (concat " with options " + (mapconcat #'identity switches " ")) + ""))) + (message "Spooling%s..." switch-string) + (with-temp-buffer + (let ((retval + (let ((tempbuf (current-buffer))) + (with-current-buffer buf + (apply (or print-region-function 'call-process-region) + start end lpr-command + nil tempbuf nil + (nconc (and name lpr-add-switches + (list "-J" name)) + ;; These belong in pr if we are using that. + (and name lpr-add-switches lpr-headers-switches + (list "-T" name)) + (and (stringp printer-name) + (string< "" printer-name) + (list (concat lpr-printer-switch + printer-name))) + nswitches)))))) + (if (markerp end) + (set-marker end nil)) + (funcall (if (memq retval '(nil 0)) #'message #'user-error) + "Spooling%s...done%s%s" switch-string + (pcase (count-lines (point-min) (point-max)) + (0 "") + (1 ": ") + (_ ":\n")) + (buffer-string)))))) ;; This function copies the text between start and end ;; into a new buffer, makes that buffer current. @@ -325,7 +331,7 @@ The characters tab, linefeed, space, return and formfeed are not affected." ;; Dynamic evaluation (defun lpr-eval-switch (arg) (cond ((stringp arg) arg) - ((functionp arg) (apply arg nil)) + ((functionp arg) (funcall arg)) ((symbolp arg) (symbol-value arg)) ((consp arg) (apply (car arg) (cdr arg))) (t nil))) @@ -342,7 +348,7 @@ The characters tab, linefeed, space, return and formfeed are not affected." (defun lpr-flatten-list-1 (list) (cond - ((null list) (list)) + ((null list) nil) ((consp list) (append (lpr-flatten-list-1 (car list)) (lpr-flatten-list-1 (cdr list)))) diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el index 059261ac0ac..7f30700bee8 100644 --- a/lisp/ps-mule.el +++ b/lisp/ps-mule.el @@ -1058,6 +1058,7 @@ It checks if all multi-byte characters in the region are printable or not." (= (skip-chars-forward "\x00-\x7F" to) to))) ;; All characters can be printed by normal PostScript fonts. (setq ps-basic-plot-string-function 'ps-basic-plot-string + ;; FIXME: Doesn't ps-encode-header-string-function take 2 args? ps-encode-header-string-function 'identity) (setq ps-basic-plot-string-function 'ps-mule-plot-string ps-encode-header-string-function 'ps-mule-encode-header-string diff --git a/lisp/ps-print.el b/lisp/ps-print.el index b5961064cb4..8369afcbbc7 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -1472,12 +1472,6 @@ Please send all bug fixes and enhancements to (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 (require 'ps-def) @@ -1676,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 @@ -1709,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 @@ -1729,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" @@ -1782,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)) + #'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) @@ -1798,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 @@ -2636,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. @@ -3389,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 @@ -3646,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) @@ -5426,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 " @@ -6569,96 +6555,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) - (unless noninteractive - (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" "b39f881d3a029049994ef6aa3de93c89") +;;;### (autoloads nil "ps-mule" "ps-mule.el" "a90e8414a27ac8fdf093251ac648d761") ;;; Generated autoloads from ps-mule.el (defvar ps-multibyte-buffer nil "\ -- 2.39.2