|
442
|
1 ;;; printer.el --- support for hard-copy printing in XEmacs
|
|
|
2
|
|
|
3 ;; Copyright (C) 2000 Ben Wing.
|
|
|
4 ;; Copyright (C) 2000 Kirill Katsnelson.
|
|
|
5
|
|
|
6 ;; Maintainer: XEmacs Development Team
|
|
|
7 ;; Keywords: printer, printing, internal, dumped
|
|
|
8
|
|
|
9 ;; This file is part of XEmacs.
|
|
|
10
|
|
|
11 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
12 ;; under the terms of the GNU General Public License as published by
|
|
|
13 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
14 ;; any later version.
|
|
|
15
|
|
|
16 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
19 ;; General Public License for more details.
|
|
|
20
|
|
|
21 ;; You should have received a copy of the GNU General Public License
|
|
|
22 ;; along with XEmacs; see the file COPYING. If not, write to the Free
|
|
|
23 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
|
|
|
24 ;; 02111-1307, USA.
|
|
|
25
|
|
|
26 ;;; Synched up with: Not in FSF.
|
|
|
27
|
|
|
28 ;;; Authorship:
|
|
|
29
|
|
|
30 ;; Created 2000 by Ben Wing, to provide the high-level interface onto the
|
|
|
31 ;; print support implemented by Kirill Katsnelson.
|
|
|
32
|
|
|
33 ;;; Commentary:
|
|
|
34
|
|
|
35 ;; This file is dumped with XEmacs.
|
|
|
36
|
|
|
37
|
|
|
38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
39 ;; generic printing code ;;
|
|
|
40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
41
|
|
|
42 ;; #### should be named print-buffer, but that's currently in
|
|
|
43 ;; lpr-buffer with some horrible definition: print-buffer == "print with
|
|
|
44 ;; headings", lpr-buffer == "print without headings", and the headings are
|
|
|
45 ;; generated by calling the external program "pr"! This is major stone-age
|
|
|
46 ;; here!
|
|
|
47 ;;
|
|
|
48 ;; I propose junking that package entirely and creating a unified,
|
|
|
49 ;; modern API here that will work well with modern GUI's on top of it,
|
|
|
50 ;; and with various different actual implementations (e.g. lpr or the
|
|
|
51 ;; pretty-print package on Unix, built-in msprinter support on
|
|
|
52 ;; Windows), where the workings of a particular implementation is
|
|
|
53 ;; hidden from the user and there is a consistent set of options to
|
|
|
54 ;; control how to print, which works across all implementations.
|
|
|
55 ;;
|
|
|
56 ;; The code here is just a start and needs a huge amount of work. Probably
|
|
|
57 ;; the interfaces below will change and the functions renamed.
|
|
|
58
|
|
|
59 (defgroup printing nil
|
|
|
60 "Generic printing support."
|
|
|
61 :group 'wp)
|
|
|
62
|
|
|
63 (defcustom printer-name nil
|
|
|
64 "*Name of printer to print to.
|
|
|
65 If nil, use default.
|
|
|
66 Under Windows, use `mswindows-printer-list' to get names of installed
|
|
|
67 printers."
|
|
|
68 :type 'string
|
|
|
69 :group 'printing)
|
|
|
70
|
|
491
|
71 (defstruct Print-context pageno window start-time printer-name)
|
|
|
72
|
|
|
73 (defcustom printer-page-header '((face bold date) nil (face bold buffer-name))
|
|
442
|
74 "*Controls printed page header.
|
|
|
75
|
|
|
76 This can be:
|
|
|
77 - nil. Header is not printed.
|
|
|
78 - An fbound symbol or lambda expression. The function is called with
|
|
|
79 one parameter, a print-context object, every time the headers need
|
|
|
80 to be set up. It can use the function `print-context-property' to
|
|
|
81 query the properties of this object. The return value is treated as
|
|
491
|
82 if it was literally specified: i.e. it will be reprocessed.
|
|
442
|
83 - A list of up to three elements, for left, center and right portions
|
|
|
84 of the header. Each of these can be
|
|
|
85 - nil, not to print the portion
|
|
|
86 - A string, which will be printed literally.
|
|
|
87 - A predefined symbol, on of the following:
|
|
491
|
88 printer-name Name of printer being printed to
|
|
442
|
89 short-file-name File name only, no path
|
|
|
90 long-file-name File name with its path
|
|
|
91 buffer-name Buffer name
|
|
|
92 date Date current when printing started
|
|
|
93 time Time current when printing started
|
|
|
94 page Current printout page number, 1-based
|
|
|
95 user-id User logon id
|
|
|
96 user-name User full name
|
|
491
|
97 - A list of three elements: (face FACE-NAME EXPR). EXPR is any of the
|
|
|
98 items given here. The item will be displayed in the given face.
|
|
442
|
99 - A cons of an extent and any of the items given here. The item will
|
|
|
100 be displayed using the extent's face, begin-glyph and end-glyph
|
|
|
101 properties.
|
|
|
102 - A list, each element of which is any of the items given here.
|
|
|
103 Each element of the list is rendered in sequence. For example,
|
|
|
104 '(\"Page \" page) is rendered as \"Page 5\" on the fifth page.
|
|
|
105 - An fbound symbol or lambda expression, called with one parameter,
|
|
|
106 a print-context object, as above. The return value is treated as
|
|
|
107 if it was literally specified: i.e. it will be reprocessed."
|
|
|
108 :type 'sexp
|
|
|
109 :group 'printing)
|
|
|
110
|
|
491
|
111 (defcustom printer-page-footer '(nil (face bold ("Page " page)))
|
|
442
|
112 "*Controls printed page footer.
|
|
|
113
|
|
|
114 Format is the same as `printer-page-header'."
|
|
|
115 :type 'sexp
|
|
|
116 :group 'printing)
|
|
|
117
|
|
491
|
118 (defun generate-header-element (element context)
|
|
|
119 (cond ((null element) nil)
|
|
|
120 ((stringp element) (insert element))
|
|
|
121 ((memq element '(printer-name
|
|
|
122 short-file-name long-file-name buffer-name
|
|
|
123 date time page user-id user-name))
|
|
|
124 (insert (print-context-property context element)))
|
|
|
125 ((and (consp element) (eq 'face (car element)))
|
|
|
126 (let ((p (point)))
|
|
|
127 (generate-header-element (third element) context)
|
|
|
128 (let ((x (make-extent p (point))))
|
|
|
129 (set-extent-face x (second element)))))
|
|
|
130 ((and (consp element) (extentp (car element)))
|
|
|
131 (let ((p (point)))
|
|
|
132 (generate-header-element (cdr element) context)
|
|
|
133 (let ((x (make-extent p (point))))
|
|
|
134 (set-extent-face x (extent-face (car element)))
|
|
|
135 (set-extent-begin-glyph x (extent-begin-glyph (car element)))
|
|
|
136 (set-extent-end-glyph x (extent-end-glyph (car element))))))
|
|
|
137 ((listp element)
|
|
|
138 (mapcar #'(lambda (el) (generate-header-element el context))
|
|
|
139 element))
|
|
|
140 ((functionp element)
|
|
|
141 (generate-header-element (funcall element context) context))
|
|
|
142 (t (error 'invalid-argument "Unknown header element" element))))
|
|
|
143
|
|
|
144 (defun generate-header-line (spec context)
|
|
|
145 (let* ((left (first spec))
|
|
|
146 (middle (second spec))
|
|
|
147 (right (third spec))
|
|
|
148 (left-start (point))
|
|
|
149 (middle-start (progn (generate-header-element left context)
|
|
|
150 (point)))
|
|
|
151 (right-start (progn (generate-header-element middle context)
|
|
|
152 (point)))
|
|
|
153 (right-end (progn (generate-header-element right context)
|
|
|
154 (point)))
|
|
|
155 (left-width (- middle-start left-start))
|
|
|
156 (middle-width (- right-start middle-start))
|
|
|
157 (right-width (- right-end right-start))
|
|
|
158 (winwidth (- (window-width (Print-context-window context)) 1))
|
|
|
159 (spaces1 (max (- (/ (- winwidth middle-width) 2) left-width) 0))
|
|
|
160 (spaces2 (max (- (- winwidth right-width)
|
|
|
161 (+ left-width spaces1 middle-width))
|
|
|
162 0)))
|
|
|
163 (goto-char right-start)
|
|
|
164 (insert-char ?\ spaces2)
|
|
|
165 (goto-char middle-start)
|
|
|
166 (insert-char ?\ spaces1)))
|
|
|
167
|
|
442
|
168 (defun print-context-property (print-context prop)
|
|
|
169 "Return property PROP of PRINT-CONTEXT.
|
|
|
170
|
|
|
171 Valid properties are
|
|
|
172
|
|
491
|
173 print-buffer Buffer being printed
|
|
|
174 print-window Window on printer device containing print buffer
|
|
|
175 print-frame Frame on printer device corresponding to current page
|
|
|
176 print-device Device referring to printer
|
|
|
177 print-start-time Time current when printing started (`current-time' format)
|
|
|
178 print-page Current printout page number, 1-based
|
|
|
179 printer-name Name of printer being printed to
|
|
442
|
180 short-file-name File name only, no path
|
|
|
181 long-file-name File name with its path
|
|
|
182 buffer-name Buffer name
|
|
491
|
183 date Date current when printing started (as a string)
|
|
|
184 time Time current when printing started (as a string)
|
|
|
185 page Current printout page number, 1-based (as a string)
|
|
|
186 user-id User logon id (as a string)
|
|
442
|
187 user-name User full name"
|
|
491
|
188 (let* ((window (Print-context-window print-context))
|
|
|
189 (pageno (Print-context-pageno print-context))
|
|
|
190 (start-time (Print-context-start-time print-context))
|
|
|
191 (printer-name (Print-context-printer-name print-context))
|
|
|
192 (buffer (window-buffer window)))
|
|
|
193 (case prop
|
|
|
194 (print-buffer buffer)
|
|
|
195 (print-window window)
|
|
|
196 (print-frame (window-frame window))
|
|
|
197 (print-device (frame-device (window-frame window)))
|
|
|
198 (print-start-time start-time)
|
|
|
199 (print-page pageno)
|
|
|
200 (printer-name printer-name)
|
|
|
201 (short-file-name (let ((name (buffer-file-name buffer)))
|
|
|
202 (if name (file-name-nondirectory name) "")))
|
|
|
203 (long-file-name (let ((name (buffer-file-name buffer)))
|
|
|
204 (or name "")))
|
|
|
205 (buffer-name (buffer-name buffer))
|
|
|
206 (date (format-time-string "%x" start-time))
|
|
|
207 (time (format-time-string "%X" start-time))
|
|
|
208 (page (format "%d" pageno))
|
|
|
209 (user-id (format "%d" (user-uid)))
|
|
|
210 (user-name (format "%d" (user-login-name)))
|
|
|
211 (t (error 'invalid-argument "Unrecognized print-context property"
|
|
|
212 prop)))))
|
|
442
|
213
|
|
491
|
214 (defun generic-print-buffer (&optional buffer display-print-dialog)
|
|
444
|
215 "Print buffer BUFFER using a printing method appropriate to the O.S. being run.
|
|
442
|
216 Under Unix, `lpr' is normally used to spool out a no-frills version of the
|
|
|
217 buffer, or the `ps-print' package is used to pretty-print the buffer to a
|
|
|
218 PostScript printer. Under MS Windows, the built-in printing support is used.
|
|
|
219
|
|
491
|
220 If DISPLAY-PRINT-DIALOG is t, the print dialog will first be
|
|
|
221 displayed, allowing the user to select various printing settings
|
|
|
222 \(e.g. which printer to print to, the range of pages, number of copies,
|
|
|
223 modes such landscape/portrait/2-up/4-up [2 or 4 (small!) logical pages
|
|
|
224 per physical page], etc.). At this point the user can cancel the printing
|
|
|
225 operation using the dialog box, and `generic-print-buffer' will not print
|
|
|
226 anything. When called interactively, use a prefix arg to suppress the
|
|
|
227 display of the print dialog box.
|
|
|
228
|
|
444
|
229 If BUFFER is nil or omitted, the current buffer is used."
|
|
491
|
230 ;; #### for some reason, displaying a dialog box makes the printing
|
|
|
231 ;; fail unless y-or-n-p is called (see below). when this is fixed,
|
|
|
232 ;; remove one of the calls to `not' in the following line.
|
|
|
233 (interactive (list nil (not (not current-prefix-arg))))
|
|
|
234 (if (or (not (valid-specifier-tag-p 'msprinter))
|
|
|
235 (not display-print-dialog))
|
|
|
236 (generic-print-region (point-min buffer) (point-max buffer) buffer)
|
|
|
237 (let* ((d (make-device 'msprinter printer-name))
|
|
|
238 (props (make-dialog-box 'print :device d)))
|
|
|
239 (and props (generic-print-region (point-min buffer)
|
|
|
240 (point-max buffer) buffer
|
|
|
241 d props)))))
|
|
442
|
242
|
|
491
|
243 (defun generic-print-region (start end &optional buffer print-device props)
|
|
442
|
244 "Print region using a printing method appropriate to the O.S. being run.
|
|
444
|
245 The region between START and END of BUFFER (defaults to the current
|
|
|
246 buffer) is printed.
|
|
442
|
247
|
|
|
248 Under Unix, `lpr' is normally used to spool out a no-frills version of the
|
|
|
249 buffer, or the `ps-print' package is used to pretty-print the buffer to a
|
|
491
|
250 PostScript printer. Under MS Windows, the built-in printing support is used.
|
|
|
251
|
|
|
252 Optional PRINT-DEVICE is a device, already created, to use to do the
|
|
|
253 printing. This is typically used when this function was invoked from
|
|
|
254 `generic-print-buffer' and it displayed a dialog box. That function created
|
|
|
255 the device, and then the dialog box stuffed it with the user's selections
|
|
|
256 of how the buffer should be printed.
|
|
|
257
|
|
|
258 PROPS, if given, is typically the plist returned from the call to
|
|
|
259 `make-dialog-box' that displayed the Print box. It contains properties
|
|
|
260 relevant to us when we print.
|
|
|
261
|
|
|
262 Recognized properties are the same as those in `make-dialog-box':
|
|
|
263
|
|
|
264 name Printer device name. If omitted, the current system-selected
|
|
|
265 printer will be used.
|
|
|
266 from-page First page to print, 1-based. If omitted, printing starts from
|
|
|
267 the beginning.
|
|
|
268 to-page Last page to print, inclusive, If omitted, printing ends at
|
|
|
269 the end.
|
|
|
270 copies Number of copies to print. If omitted, one copy is printed."
|
|
442
|
271 (cond ((valid-specifier-tag-p 'msprinter)
|
|
491
|
272 (let (d f header-buffer footer-buffer)
|
|
444
|
273 (setq buffer (decode-buffer buffer))
|
|
442
|
274 (unwind-protect
|
|
|
275 (progn
|
|
491
|
276 (setq d (or print-device
|
|
|
277 (make-device 'msprinter printer-name)))
|
|
442
|
278 (setq f (make-frame
|
|
491
|
279 (list* 'name (concat
|
|
|
280 (substitute ?_ ?. (buffer-name buffer))
|
|
|
281 " - XEmacs")
|
|
|
282 '(menubar-visible-p
|
|
|
283 nil
|
|
442
|
284 has-modeline-p nil
|
|
|
285 default-toolbar-visible-p nil
|
|
|
286 default-gutter-visible-p nil
|
|
|
287 minibuffer none
|
|
|
288 modeline-shadow-thickness 0
|
|
|
289 vertical-scrollbar-visible-p nil
|
|
|
290 horizontal-scrollbar-visible-p nil))
|
|
|
291 d))
|
|
|
292 (let* ((w (frame-root-window f))
|
|
|
293 (vertdpi (cdr (device-system-metric d 'device-dpi)))
|
|
|
294 (pixel-vertical-clip-threshold (/ vertdpi 2))
|
|
491
|
295 (from-page (plist-get props 'from-page 1))
|
|
|
296 (to-page (plist-get props 'to-page))
|
|
|
297 (copies (plist-get props 'copies 1))
|
|
|
298 (context (make-Print-context
|
|
|
299 :start-time (current-time)
|
|
|
300 ;; #### bogus! we need accessors for
|
|
|
301 ;; print-settings objects.
|
|
|
302 :printer-name
|
|
|
303 (or (plist-get props 'name)
|
|
|
304 printer-name
|
|
|
305 (mswindows-get-default-printer))))
|
|
|
306 header-window
|
|
|
307 footer-window)
|
|
|
308
|
|
|
309 (when printer-page-header
|
|
|
310 (let ((window-min-height 2))
|
|
|
311 (setq header-window w)
|
|
|
312 (setq w (split-window w 2)))
|
|
|
313 (setq header-buffer (generate-new-buffer " *header*"))
|
|
|
314 (set-window-buffer header-window header-buffer))
|
|
|
315
|
|
|
316 (when printer-page-footer
|
|
|
317 (let ((window-min-height 2))
|
|
|
318 (setq footer-window
|
|
|
319 (split-window w (- (window-height w) 2))))
|
|
|
320 (setq footer-buffer (generate-new-buffer " *footer*"))
|
|
|
321 (set-window-buffer footer-window footer-buffer))
|
|
|
322
|
|
|
323 (setf (Print-context-window context) w)
|
|
|
324
|
|
|
325 ;; loop, printing one copy of document per loop
|
|
|
326 (while (> copies 0)
|
|
|
327 (let ((last-end 0) ; bufpos at end of previous page
|
|
|
328 reached-end ; t if we've reached the end of the
|
|
|
329 ; text we're printing
|
|
|
330 (pageno 1))
|
|
|
331 (set-window-buffer w buffer)
|
|
|
332 (set-window-start w start)
|
|
|
333
|
|
|
334 ;; loop, printing one page per loop
|
|
|
335 (while (and (not reached-end)
|
|
|
336 ;; stop at end of region of text or
|
|
|
337 ;; outside of ranges of pages given
|
|
|
338 (or (not to-page) (<= pageno to-page)))
|
|
|
339
|
|
|
340 (setf (Print-context-pageno context) pageno)
|
|
|
341
|
|
|
342 ;; only actually print the page if it's in the
|
|
|
343 ;; range.
|
|
|
344 (when (>= pageno from-page)
|
|
|
345 ;; none of these work.
|
|
|
346 ; (mapcar #'(lambda (foo)
|
|
|
347 ; (redisplay-device foo t))
|
|
|
348 ; (delete-if #'(lambda (foo)
|
|
|
349 ; (eq (device-type foo)
|
|
|
350 ; 'msprinter))
|
|
|
351 ; (device-list)))
|
|
|
352 ; (mapcar #'(lambda (foo)
|
|
|
353 ; (redraw-device foo t))
|
|
|
354 ; (delete-if #'(lambda (foo)
|
|
|
355 ; (eq (device-type foo)
|
|
|
356 ; 'msprinter))
|
|
|
357 ; (device-list)))
|
|
|
358 ; (sit-for 0.01)
|
|
|
359 ;; but this one sure as hell does.
|
|
|
360 ; (y-or-n-p "continue")
|
|
|
361 (when printer-page-header
|
|
|
362 (with-current-buffer header-buffer
|
|
|
363 (erase-buffer)
|
|
|
364 (generate-header-line printer-page-header
|
|
|
365 context)
|
|
|
366 (goto-char (point-min))
|
|
|
367 (set-window-start header-window (point-min))))
|
|
|
368
|
|
|
369 (when printer-page-footer
|
|
|
370 (with-current-buffer footer-buffer
|
|
|
371 (erase-buffer)
|
|
|
372 (insert "\n")
|
|
|
373 (generate-header-line printer-page-footer
|
|
|
374 context)
|
|
|
375 (goto-char (point-min))
|
|
|
376 (set-window-start footer-window (point-min))))
|
|
|
377
|
|
|
378 (redisplay-frame f)
|
|
|
379 (print-job-eject-page f)
|
|
|
380 )
|
|
|
381 ;; but use the GUARANTEE argument to `window-end'
|
|
|
382 ;; so that we get the right value even if we
|
|
|
383 ;; didn't do a redisplay.
|
|
|
384 (let ((this-end (window-end w t))
|
|
|
385 (pixvis (window-last-line-visible-height w)))
|
|
|
386 ;; in case we get stuck somewhere, bow out
|
|
|
387 ;; rather than printing an infinite number of
|
|
|
388 ;; pages. #### this will fail with an image
|
|
|
389 ;; bigger than an entire page. but we really
|
|
|
390 ;; need this check here. we should be more
|
|
|
391 ;; clever in our check, to deal with this case.
|
|
|
392 (if (or (= this-end last-end)
|
|
|
393 ;; #### fuckme! window-end returns a value
|
|
|
394 ;; outside of the valid range of buffer
|
|
|
395 ;; positions!!!
|
|
|
396 (>= this-end end))
|
|
|
397 (setq reached-end t)
|
|
|
398 (setq last-end this-end)
|
|
|
399 (set-window-start w this-end)
|
|
|
400 (if pixvis
|
|
|
401 (save-selected-window
|
|
|
402 (select-window w)
|
|
|
403 ;; #### scroll-down should take a
|
|
|
404 ;; window arg.
|
|
|
405 (let ((window-pixel-scroll-increment
|
|
|
406 pixvis))
|
|
|
407 (scroll-down 1))))))
|
|
|
408 (setq pageno (1+ pageno))))
|
|
|
409 (setq copies (1- copies)))))
|
|
442
|
410 (and f (delete-frame f))
|
|
|
411 (and d (delete-device d))
|
|
491
|
412 (and header-buffer (kill-buffer header-buffer))
|
|
|
413 (and footer-buffer (kill-buffer footer-buffer))
|
|
442
|
414 )))
|
|
|
415 ((and (not (eq system-type 'windows-nt))
|
|
|
416 (fboundp 'lpr-buffer))
|
|
444
|
417 (lpr-region buffer))
|
|
442
|
418 (t (error "No print support available"))))
|
