* 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.
This commit is contained in:
Stefan Monnier 2013-07-24 00:37:11 -04:00
parent 73600831f3
commit 2cdeb903c5
5 changed files with 123 additions and 173 deletions

View file

@ -1,3 +1,23 @@
2013-07-24 Stefan Monnier <monnier@iro.umontreal.ca>
* 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 <xfq.free@gmail.com>
* ansi-color.el: Fix old URL.

View file

@ -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"

View file

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

View file

@ -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

View file

@ -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 "\