Mercurial > hg > xemacs-beta

comparison lisp/packages/lpr.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; lpr.el --- print Emacs buffer on line printer.
2
3 ;; Copyright (C) 1985, 1988, 1992, 1994 Free Software Foundation, Inc.
4
5 ;; Maintainer: FSF
6 ;; Keywords: unix
7
8 ;; This file is part of XEmacs.
9
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
23
24 ;;; Synched up with: FSF 19.30.
25
26 ;;; Commentary:
27
28 ;; Commands to send the region or a buffer your printer. Entry points
29 ;; are `lpr-buffer', `print-buffer', lpr-region', or `print-region'; option
30 ;; variables include `lpr-switches' and `lpr-command'.
31
32 ;;; Code:
33
34 ;;;###autoload
35 (defvar lpr-switches nil
36 "*List of strings to pass as extra switch args to `lpr' when it is invoked.")
37
38 (defvar lpr-add-switches (eq system-type 'berkeley-unix)
39 "*Non-nil means construct -T and -J options for the `lpr'.")
40
41 ;;;###autoload
42 (defvar lpr-command
43 (if (memq system-type '(usg-unix-v dgux hpux irix))
44 "lp" "lpr")
45 "*Name of program for printing a file.")
46
47 ;; Default is nil, because that enables us to use pr -f
48 ;; which is more reliable than pr with no args, which is what lpr -p does.
49 (defvar lpr-headers-switches nil
50 "*List of strings to use as options for `lpr' to request page headings.
51 If nil, we run `lpr-page-header-program' to make page headings
52 and print the result.")
53
54 (defvar print-region-function nil
55 "Function to call to print the region on a printer.
56 See definition of `print-region-1' for calling conventions.")
57
58 (defvar lpr-page-header-program "pr"
59 "*Name of program for adding page headers to a file.")
60
61 (defvar lpr-page-header-switches '("-f")
62 "*List of strings to use as options for `lpr-page-header-program'.")
63
64 ;;;###autoload
65 (defun lpr-buffer ()
66 "Print buffer contents as with Unix command `lpr'.
67 `lpr-switches' is a list of extra switches (strings) to pass to lpr."
68 (interactive)
69 (print-region-1 (point-min) (point-max) lpr-switches nil))
70
71 ;;;###autoload
72 (defun print-buffer ()
73 "Print buffer contents as with Unix command `lpr -p'.
74 `lpr-switches' is a list of extra switches (strings) to pass to lpr."
75 (interactive)
76 (print-region-1 (point-min) (point-max) lpr-switches t))
77
78 ;;;###autoload
79 (defun lpr-region (start end)
80 "Print region contents as with Unix command `lpr'.
81 `lpr-switches' is a list of extra switches (strings) to pass to lpr."
82 (interactive "r")
83 (print-region-1 start end lpr-switches nil))
84
85 ;;;###autoload
86 (defun print-region (start end)
87 "Print region contents as with Unix command `lpr -p'.
88 `lpr-switches' is a list of extra switches (strings) to pass to lpr."
89 (interactive "r")
90 (print-region-1 start end lpr-switches t))
91
92 (defun print-region-1 (start end switches page-headers)
93 ;; On some MIPS system, having a space in the job name
94 ;; crashes the printer demon. But using dashes looks ugly
95 ;; and it seems to annoying to do for that MIPS system.
96 (let ((name (concat (buffer-name) " Emacs buffer"))
97 (title (concat (buffer-name) " Emacs buffer"))
98 (width tab-width)
99 switch-string)
100 (save-excursion
101 (if page-headers
102 (if lpr-headers-switches
103 ;; It is possible to use an lpr option
104 ;; to get page headers.
105 (setq switches (append (if (stringp lpr-headers-switches)
106 (list lpr-headers-switches)
107 lpr-headers-switches)
108 switches))))
109 (setq switch-string
110 (if switches (concat " with options "
111 (mapconcat 'identity switches " "))
112 ""))
113 (message "Spooling%s..." switch-string)
114 (if (/= tab-width 8)
115 (let ((new-coords (print-region-new-buffer start end)))
116 (setq start (car new-coords) end (cdr new-coords))
117 (setq tab-width width)
118 (save-excursion
119 (goto-char end)
120 (setq end (point-marker)))
121 (untabify (point-min) (point-max))))
122 (if page-headers
123 (if lpr-headers-switches
124 ;; We handled this above by modifying SWITCHES.
125 nil
126 ;; Run a separate program to get page headers.
127 (let ((new-coords (print-region-new-buffer start end)))
128 (setq start (car new-coords) end (cdr new-coords)))
129 (apply 'call-process-region start end lpr-page-header-program
130 t t nil
131 (nconc (and lpr-add-switches
132 (list "-h" title))
133 lpr-page-header-switches))
134 (setq start (point-min) end (point-max))))
135 (apply (or print-region-function 'call-process-region)
136 (nconc (list start end lpr-command
137 nil nil nil)
138 (nconc (and lpr-add-switches
139 (list "-J" name))
140 ;; These belong in pr if we are using that.
141 (and lpr-add-switches lpr-headers-switches
142 (list "-T" title))
143 switches)))
144 (if (markerp end)
145 (set-marker end nil))
146 (message "Spooling%s...done" switch-string))))
147
148 ;; This function copies the text between start and end
149 ;; into a new buffer, makes that buffer current.
150 ;; It returns the new range to print from the new current buffer
151 ;; as (START . END).
152
153 (defun print-region-new-buffer (ostart oend)
154 (if (string= (buffer-name) " *spool temp*")
155 (cons ostart oend)
156 (let ((oldbuf (current-buffer)))
157 (set-buffer (get-buffer-create " *spool temp*"))
158 (widen) (erase-buffer)
159 (insert-buffer-substring oldbuf ostart oend)
160 (cons (point-min) (point-max)))))
161
162 (defun printify-region (begin end)
163 "Turn nonprinting characters (other than TAB, LF, SPC, RET, and FF)
164 in the current buffer into printable representations as control or
165 hexadecimal escapes."
166 (interactive "r")
167 (save-excursion
168 (goto-char begin)
169 (let (c)
170 (while (re-search-forward "[\^@-\^h\^k\^n-\^_\177-\377]" end t)
171 (setq c (preceding-char))
172 (delete-backward-char 1)
173 (insert
174 (if (< c ?\ )
175 (format "\\^%c" (+ c ?@))
176 (format "\\%02x" c)))))))
177
178 (provide 'lpr)
179
180 ;;; lpr.el ends here