|
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 ;;
|
|
506
|
56 ;; The code here currently only really supports Windows.
|
|
442
|
57
|
|
|
58 (defgroup printing nil
|
|
|
59 "Generic printing support."
|
|
|
60 :group 'wp)
|
|
|
61
|
|
|
62 (defcustom printer-name nil
|
|
|
63 "*Name of printer to print to.
|
|
|
64 If nil, use default.
|
|
|
65 Under Windows, use `mswindows-printer-list' to get names of installed
|
|
|
66 printers."
|
|
|
67 :type 'string
|
|
|
68 :group 'printing)
|
|
|
69
|
|
491
|
70 (defstruct Print-context pageno window start-time printer-name)
|
|
|
71
|
|
506
|
72 (defvar printer-current-device nil)
|
|
|
73
|
|
|
74 (defun Printer-get-device ()
|
|
|
75 (or printer-current-device (setq printer-current-device
|
|
|
76 (make-device 'msprinter printer-name))))
|
|
|
77
|
|
|
78 (defun Printer-clear-device ()
|
|
|
79 (setq printer-current-device nil))
|
|
|
80
|
|
491
|
81 (defcustom printer-page-header '((face bold date) nil (face bold buffer-name))
|
|
442
|
82 "*Controls printed page header.
|
|
|
83
|
|
|
84 This can be:
|
|
|
85 - nil. Header is not printed.
|
|
|
86 - An fbound symbol or lambda expression. The function is called with
|
|
|
87 one parameter, a print-context object, every time the headers need
|
|
|
88 to be set up. It can use the function `print-context-property' to
|
|
|
89 query the properties of this object. The return value is treated as
|
|
491
|
90 if it was literally specified: i.e. it will be reprocessed.
|
|
442
|
91 - A list of up to three elements, for left, center and right portions
|
|
|
92 of the header. Each of these can be
|
|
|
93 - nil, not to print the portion
|
|
|
94 - A string, which will be printed literally.
|
|
|
95 - A predefined symbol, on of the following:
|
|
491
|
96 printer-name Name of printer being printed to
|
|
442
|
97 short-file-name File name only, no path
|
|
|
98 long-file-name File name with its path
|
|
|
99 buffer-name Buffer name
|
|
|
100 date Date current when printing started
|
|
|
101 time Time current when printing started
|
|
|
102 page Current printout page number, 1-based
|
|
|
103 user-id User logon id
|
|
|
104 user-name User full name
|
|
491
|
105 - A list of three elements: (face FACE-NAME EXPR). EXPR is any of the
|
|
|
106 items given here. The item will be displayed in the given face.
|
|
442
|
107 - A cons of an extent and any of the items given here. The item will
|
|
|
108 be displayed using the extent's face, begin-glyph and end-glyph
|
|
|
109 properties.
|
|
|
110 - A list, each element of which is any of the items given here.
|
|
|
111 Each element of the list is rendered in sequence. For example,
|
|
|
112 '(\"Page \" page) is rendered as \"Page 5\" on the fifth page.
|
|
|
113 - An fbound symbol or lambda expression, called with one parameter,
|
|
|
114 a print-context object, as above. The return value is treated as
|
|
|
115 if it was literally specified: i.e. it will be reprocessed."
|
|
|
116 :type 'sexp
|
|
|
117 :group 'printing)
|
|
|
118
|
|
491
|
119 (defcustom printer-page-footer '(nil (face bold ("Page " page)))
|
|
442
|
120 "*Controls printed page footer.
|
|
|
121
|
|
|
122 Format is the same as `printer-page-header'."
|
|
|
123 :type 'sexp
|
|
|
124 :group 'printing)
|
|
|
125
|
|
491
|
126 (defun generate-header-element (element context)
|
|
|
127 (cond ((null element) nil)
|
|
|
128 ((stringp element) (insert element))
|
|
|
129 ((memq element '(printer-name
|
|
|
130 short-file-name long-file-name buffer-name
|
|
|
131 date time page user-id user-name))
|
|
|
132 (insert (print-context-property context element)))
|
|
|
133 ((and (consp element) (eq 'face (car element)))
|
|
|
134 (let ((p (point)))
|
|
|
135 (generate-header-element (third element) context)
|
|
|
136 (let ((x (make-extent p (point))))
|
|
|
137 (set-extent-face x (second element)))))
|
|
|
138 ((and (consp element) (extentp (car element)))
|
|
|
139 (let ((p (point)))
|
|
|
140 (generate-header-element (cdr element) context)
|
|
|
141 (let ((x (make-extent p (point))))
|
|
|
142 (set-extent-face x (extent-face (car element)))
|
|
|
143 (set-extent-begin-glyph x (extent-begin-glyph (car element)))
|
|
|
144 (set-extent-end-glyph x (extent-end-glyph (car element))))))
|
|
|
145 ((listp element)
|
|
|
146 (mapcar #'(lambda (el) (generate-header-element el context))
|
|
|
147 element))
|
|
|
148 ((functionp element)
|
|
|
149 (generate-header-element (funcall element context) context))
|
|
|
150 (t (error 'invalid-argument "Unknown header element" element))))
|
|
|
151
|
|
|
152 (defun generate-header-line (spec context)
|
|
|
153 (let* ((left (first spec))
|
|
|
154 (middle (second spec))
|
|
|
155 (right (third spec))
|
|
|
156 (left-start (point))
|
|
|
157 (middle-start (progn (generate-header-element left context)
|
|
|
158 (point)))
|
|
|
159 (right-start (progn (generate-header-element middle context)
|
|
|
160 (point)))
|
|
|
161 (right-end (progn (generate-header-element right context)
|
|
|
162 (point)))
|
|
|
163 (left-width (- middle-start left-start))
|
|
|
164 (middle-width (- right-start middle-start))
|
|
|
165 (right-width (- right-end right-start))
|
|
|
166 (winwidth (- (window-width (Print-context-window context)) 1))
|
|
|
167 (spaces1 (max (- (/ (- winwidth middle-width) 2) left-width) 0))
|
|
|
168 (spaces2 (max (- (- winwidth right-width)
|
|
|
169 (+ left-width spaces1 middle-width))
|
|
|
170 0)))
|
|
|
171 (goto-char right-start)
|
|
|
172 (insert-char ?\ spaces2)
|
|
|
173 (goto-char middle-start)
|
|
|
174 (insert-char ?\ spaces1)))
|
|
|
175
|
|
442
|
176 (defun print-context-property (print-context prop)
|
|
|
177 "Return property PROP of PRINT-CONTEXT.
|
|
|
178
|
|
|
179 Valid properties are
|
|
|
180
|
|
491
|
181 print-buffer Buffer being printed
|
|
|
182 print-window Window on printer device containing print buffer
|
|
|
183 print-frame Frame on printer device corresponding to current page
|
|
|
184 print-device Device referring to printer
|
|
|
185 print-start-time Time current when printing started (`current-time' format)
|
|
|
186 print-page Current printout page number, 1-based
|
|
|
187 printer-name Name of printer being printed to
|
|
442
|
188 short-file-name File name only, no path
|
|
|
189 long-file-name File name with its path
|
|
|
190 buffer-name Buffer name
|
|
491
|
191 date Date current when printing started (as a string)
|
|
|
192 time Time current when printing started (as a string)
|
|
|
193 page Current printout page number, 1-based (as a string)
|
|
|
194 user-id User logon id (as a string)
|
|
442
|
195 user-name User full name"
|
|
491
|
196 (let* ((window (Print-context-window print-context))
|
|
|
197 (pageno (Print-context-pageno print-context))
|
|
|
198 (start-time (Print-context-start-time print-context))
|
|
|
199 (printer-name (Print-context-printer-name print-context))
|
|
|
200 (buffer (window-buffer window)))
|
|
|
201 (case prop
|
|
|
202 (print-buffer buffer)
|
|
|
203 (print-window window)
|
|
|
204 (print-frame (window-frame window))
|
|
|
205 (print-device (frame-device (window-frame window)))
|
|
|
206 (print-start-time start-time)
|
|
|
207 (print-page pageno)
|
|
|
208 (printer-name printer-name)
|
|
|
209 (short-file-name (let ((name (buffer-file-name buffer)))
|
|
|
210 (if name (file-name-nondirectory name) "")))
|
|
|
211 (long-file-name (let ((name (buffer-file-name buffer)))
|
|
|
212 (or name "")))
|
|
|
213 (buffer-name (buffer-name buffer))
|
|
|
214 (date (format-time-string "%x" start-time))
|
|
|
215 (time (format-time-string "%X" start-time))
|
|
|
216 (page (format "%d" pageno))
|
|
|
217 (user-id (format "%d" (user-uid)))
|
|
|
218 (user-name (format "%d" (user-login-name)))
|
|
|
219 (t (error 'invalid-argument "Unrecognized print-context property"
|
|
|
220 prop)))))
|
|
442
|
221
|
|
506
|
222 (defun generic-page-setup ()
|
|
|
223 "Display the Page Setup dialog box.
|
|
|
224 Changes made are recorded internally."
|
|
|
225 (interactive)
|
|
|
226 (let* ((d (Printer-get-device))
|
|
|
227 (props
|
|
|
228 (condition-case err
|
|
|
229 (make-dialog-box 'page-setup :device d
|
|
|
230 :properties default-msprinter-frame-plist)
|
|
|
231 (error
|
|
|
232 (Printer-clear-device)
|
|
|
233 (signal (car err) (cdr err))))))
|
|
|
234 (while props
|
|
|
235 (setq default-msprinter-frame-plist
|
|
|
236 (plist-put default-msprinter-frame-plist (car props) (cadr props)))
|
|
|
237 (setq props (cddr props)))))
|
|
|
238
|
|
491
|
239 (defun generic-print-buffer (&optional buffer display-print-dialog)
|
|
444
|
240 "Print buffer BUFFER using a printing method appropriate to the O.S. being run.
|
|
442
|
241 Under Unix, `lpr' is normally used to spool out a no-frills version of the
|
|
|
242 buffer, or the `ps-print' package is used to pretty-print the buffer to a
|
|
|
243 PostScript printer. Under MS Windows, the built-in printing support is used.
|
|
|
244
|
|
491
|
245 If DISPLAY-PRINT-DIALOG is t, the print dialog will first be
|
|
|
246 displayed, allowing the user to select various printing settings
|
|
|
247 \(e.g. which printer to print to, the range of pages, number of copies,
|
|
|
248 modes such landscape/portrait/2-up/4-up [2 or 4 (small!) logical pages
|
|
|
249 per physical page], etc.). At this point the user can cancel the printing
|
|
|
250 operation using the dialog box, and `generic-print-buffer' will not print
|
|
|
251 anything. When called interactively, use a prefix arg to suppress the
|
|
|
252 display of the print dialog box.
|
|
|
253
|
|
444
|
254 If BUFFER is nil or omitted, the current buffer is used."
|
|
503
|
255 (interactive (list nil (not current-prefix-arg)))
|
|
510
|
256 (let* ((print-region (and (interactive-p) (region-active-p)))
|
|
|
257 (start (if print-region (region-beginning) (point-min buffer)))
|
|
|
258 (end (if print-region (region-end) (point-max buffer))))
|
|
|
259 (if (or (not (valid-specifier-tag-p 'msprinter))
|
|
|
260 (not display-print-dialog))
|
|
|
261 (generic-print-region start end buffer)
|
|
|
262 (let* ((d (Printer-get-device))
|
|
|
263 (props (condition-case err
|
|
|
264 (make-dialog-box 'print :device d
|
|
|
265 :allow-selection print-region
|
|
|
266 :selected-page-button
|
|
|
267 (if print-region 'selection 'all))
|
|
|
268 (error
|
|
|
269 (Printer-clear-device)
|
|
|
270 (signal (car err) (cdr err))))))
|
|
|
271 (and props
|
|
|
272 (let ((really-print-region
|
|
|
273 (eq (plist-get props 'selected-page-button) 'selection)))
|
|
|
274 (generic-print-region (if really-print-region start
|
|
|
275 (point-min buffer))
|
|
|
276 (if really-print-region end
|
|
|
277 (point-max buffer))
|
|
|
278 buffer d props)))))))
|
|
442
|
279
|
|
491
|
280 (defun generic-print-region (start end &optional buffer print-device props)
|
|
442
|
281 "Print region using a printing method appropriate to the O.S. being run.
|
|
444
|
282 The region between START and END of BUFFER (defaults to the current
|
|
|
283 buffer) is printed.
|
|
442
|
284
|
|
|
285 Under Unix, `lpr' is normally used to spool out a no-frills version of the
|
|
|
286 buffer, or the `ps-print' package is used to pretty-print the buffer to a
|
|
491
|
287 PostScript printer. Under MS Windows, the built-in printing support is used.
|
|
|
288
|
|
|
289 Optional PRINT-DEVICE is a device, already created, to use to do the
|
|
|
290 printing. This is typically used when this function was invoked from
|
|
|
291 `generic-print-buffer' and it displayed a dialog box. That function created
|
|
|
292 the device, and then the dialog box stuffed it with the user's selections
|
|
|
293 of how the buffer should be printed.
|
|
|
294
|
|
|
295 PROPS, if given, is typically the plist returned from the call to
|
|
|
296 `make-dialog-box' that displayed the Print box. It contains properties
|
|
|
297 relevant to us when we print.
|
|
|
298
|
|
|
299 Recognized properties are the same as those in `make-dialog-box':
|
|
|
300
|
|
|
301 name Printer device name. If omitted, the current system-selected
|
|
|
302 printer will be used.
|
|
|
303 from-page First page to print, 1-based. If omitted, printing starts from
|
|
|
304 the beginning.
|
|
|
305 to-page Last page to print, inclusive, If omitted, printing ends at
|
|
|
306 the end.
|
|
|
307 copies Number of copies to print. If omitted, one copy is printed."
|
|
442
|
308 (cond ((valid-specifier-tag-p 'msprinter)
|
|
510
|
309 ;; loop, printing one copy of document per loop. kill and
|
|
|
310 ;; re-create the frame each time so that we eject the piece
|
|
|
311 ;; of paper at the end even if we're printing more than one
|
|
|
312 ;; page per sheet of paper.
|
|
707
|
313 (let ((copies (plist-get props 'copies 1))
|
|
|
314 ;; This is not relevant to printing and can mess up
|
|
|
315 ;; msprinter frame sizing
|
|
|
316 default-frame-plist)
|
|
510
|
317 (while (> copies 0)
|
|
|
318 (let (d f header-buffer footer-buffer)
|
|
|
319 (setq buffer (decode-buffer buffer))
|
|
|
320 (unwind-protect
|
|
|
321 (with-current-buffer buffer
|
|
|
322 (save-restriction
|
|
|
323 (narrow-to-region start end)
|
|
|
324 (setq d (or print-device (Printer-get-device)))
|
|
|
325 (setq f (make-frame
|
|
|
326 (list* 'name
|
|
|
327 (concat
|
|
491
|
328 (substitute ?_ ?. (buffer-name buffer))
|
|
|
329 " - XEmacs")
|
|
510
|
330 '(menubar-visible-p
|
|
|
331 nil
|
|
|
332 has-modeline-p nil
|
|
|
333 default-toolbar-visible-p nil
|
|
|
334 default-gutter-visible-p nil
|
|
|
335 minibuffer none
|
|
|
336 modeline-shadow-thickness 0
|
|
|
337 vertical-scrollbar-visible-p nil
|
|
|
338 horizontal-scrollbar-visible-p nil))
|
|
|
339 d))
|
|
|
340 (let* ((w (frame-root-window f))
|
|
|
341 (vertdpi
|
|
|
342 (cdr (device-system-metric d 'device-dpi)))
|
|
|
343 (pixel-vertical-clip-threshold (/ vertdpi 2))
|
|
|
344 (from-page (plist-get props 'from-page 1))
|
|
|
345 (to-page (plist-get props 'to-page))
|
|
|
346 (context (make-Print-context
|
|
|
347 :start-time (current-time)
|
|
|
348 ;; #### bogus! we need accessors for
|
|
|
349 ;; print-settings objects.
|
|
|
350 :printer-name
|
|
|
351 (or (plist-get props 'name)
|
|
|
352 printer-name
|
|
|
353 (mswindows-get-default-printer))))
|
|
|
354 header-window
|
|
|
355 footer-window)
|
|
491
|
356
|
|
510
|
357 (when printer-page-header
|
|
|
358 (let ((window-min-height 2))
|
|
|
359 (setq header-window w)
|
|
|
360 (setq w (split-window w 2)))
|
|
|
361 (setq header-buffer
|
|
|
362 (generate-new-buffer " *header*"))
|
|
|
363 (set-window-buffer header-window header-buffer))
|
|
491
|
364
|
|
510
|
365 (when printer-page-footer
|
|
|
366 (let ((window-min-height 2))
|
|
|
367 (setq footer-window
|
|
|
368 (split-window w (- (window-height w) 2))))
|
|
|
369 (setq footer-buffer
|
|
|
370 (generate-new-buffer " *footer*"))
|
|
|
371 (set-window-buffer footer-window footer-buffer))
|
|
491
|
372
|
|
510
|
373 (setf (Print-context-window context) w)
|
|
|
374
|
|
|
375 (let ((last-end 0) ; bufpos at end of previous page
|
|
|
376 reached-end ; t if we've reached the end of the
|
|
491
|
377 ; text we're printing
|
|
510
|
378 (pageno 1))
|
|
|
379 (set-window-buffer w buffer)
|
|
|
380 (set-window-start w start)
|
|
491
|
381
|
|
510
|
382 ;; loop, printing one page per loop
|
|
|
383 (while (and (not reached-end)
|
|
|
384 ;; stop at end of region of text or
|
|
|
385 ;; outside of ranges of pages given
|
|
|
386 (or (not to-page) (<= pageno to-page)))
|
|
491
|
387
|
|
510
|
388 (setf (Print-context-pageno context) pageno)
|
|
491
|
389
|
|
510
|
390 ;; only actually print the page if it's in the
|
|
|
391 ;; range.
|
|
|
392 (when (>= pageno from-page)
|
|
|
393 (when printer-page-header
|
|
|
394 (with-current-buffer header-buffer
|
|
|
395 (erase-buffer)
|
|
|
396 (generate-header-line printer-page-header
|
|
|
397 context)
|
|
|
398 (goto-char (point-min))
|
|
|
399 (set-window-start header-window
|
|
|
400 (point-min))))
|
|
491
|
401
|
|
510
|
402 (when printer-page-footer
|
|
|
403 (with-current-buffer footer-buffer
|
|
|
404 (erase-buffer)
|
|
|
405 (insert "\n")
|
|
|
406 (generate-header-line printer-page-footer
|
|
|
407 context)
|
|
|
408 (goto-char (point-min))
|
|
|
409 (set-window-start footer-window
|
|
|
410 (point-min))))
|
|
491
|
411
|
|
510
|
412 (redisplay-frame f t)
|
|
|
413 (print-job-eject-page f)
|
|
|
414 )
|
|
|
415 ;; but use the GUARANTEE argument to `window-end'
|
|
|
416 ;; so that we get the right value even if we
|
|
|
417 ;; didn't do a redisplay.
|
|
|
418 (let ((this-end (window-end w t))
|
|
|
419 (pixvis
|
|
|
420 (window-last-line-visible-height w)))
|
|
|
421 ;; in case we get stuck somewhere, bow out
|
|
|
422 ;; rather than printing an infinite number of
|
|
|
423 ;; pages. #### this will fail with an image
|
|
|
424 ;; bigger than an entire page. but we really
|
|
|
425 ;; need this check here. we should be more
|
|
|
426 ;; clever in our check, to deal with this case.
|
|
|
427 (if (or (= this-end last-end)
|
|
|
428 ;; #### fuckme! window-end returns a
|
|
|
429 ;; value outside of the valid range of
|
|
|
430 ;; buffer positions!!!
|
|
|
431 (>= this-end end))
|
|
|
432 (setq reached-end t)
|
|
|
433 (setq last-end this-end)
|
|
|
434 (set-window-start w this-end)
|
|
|
435 (if pixvis
|
|
|
436 (with-selected-window w
|
|
|
437 ;; #### scroll-down should take a
|
|
|
438 ;; window arg.
|
|
|
439 (let ((window-pixel-scroll-increment
|
|
|
440 pixvis))
|
|
|
441 (scroll-down 1))))))
|
|
546
|
442 (setq pageno (1+ pageno)))))))
|
|
|
443 (and f (delete-frame f))
|
|
|
444 (and header-buffer (kill-buffer header-buffer))
|
|
|
445 (and footer-buffer (kill-buffer footer-buffer))))
|
|
510
|
446 (setq copies (1- copies)))))
|
|
442
|
447 ((and (not (eq system-type 'windows-nt))
|
|
503
|
448 (fboundp 'lpr-region))
|
|
776
|
449 (declare-fboundp (lpr-region start end)))
|
|
442
|
450 (t (error "No print support available"))))
|
