1 ;;; printer.el --- support for hard-copy printing in SXEmacs
3 ;; Copyright (C) 2000 Ben Wing.
4 ;; Copyright (C) 2000 Kirill Katsnelson.
6 ;; Maintainer: SXEmacs Development Team
7 ;; Keywords: printer, printing, internal, dumped
9 ;; This file is part of SXEmacs.
11 ;; SXEmacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; SXEmacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
24 ;;; Synched up with: Not in FSF.
28 ;; Created 2000 by Ben Wing, to provide the high-level interface onto the
29 ;; print support implemented by Kirill Katsnelson.
33 ;; This file is dumped with SXEmacs.
36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37 ;; generic printing code ;;
38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
40 ;; #### should be named print-buffer, but that's currently in
41 ;; lpr-buffer with some horrible definition: print-buffer == "print with
42 ;; headings", lpr-buffer == "print without headings", and the headings are
43 ;; generated by calling the external program "pr"! This is major stone-age
46 ;; I propose junking that package entirely and creating a unified,
47 ;; modern API here that will work well with modern GUI's on top of it,
48 ;; and with various different actual implementations (e.g. lpr or the
49 ;; pretty-print package on Unix, built-in msprinter support on
50 ;; Windows), where the workings of a particular implementation is
51 ;; hidden from the user and there is a consistent set of options to
52 ;; control how to print, which works across all implementations.
54 ;; The code here currently only really supports Windows.
56 (defgroup printing nil
57 "Generic printing support."
60 (defcustom printer-name nil
61 "*Name of printer to print to.
66 (defstruct Print-context pageno window start-time printer-name)
68 (defvar printer-current-device nil)
70 (defun Printer-get-device ()
71 (or printer-current-device (setq printer-current-device
72 (make-device 'msprinter printer-name))))
74 (defun Printer-clear-device ()
75 ;; relying on GC to delete the device is too error-prone since there
76 ;; only can be one anyway.
77 (and printer-current-device (delete-device printer-current-device))
78 (setq printer-current-device nil))
80 (defcustom printer-page-header '((face bold date) nil (face bold buffer-name))
81 "*Controls printed page header.
84 - nil. Header is not printed.
85 - An fbound symbol or lambda expression. The function is called with
86 one parameter, a print-context object, every time the headers need
87 to be set up. It can use the function `print-context-property' to
88 query the properties of this object. The return value is treated as
89 if it was literally specified: i.e. it will be reprocessed.
90 - A list of up to three elements, for left, center and right portions
91 of the header. Each of these can be
92 - nil, not to print the portion
93 - A string, which will be printed literally.
94 - A predefined symbol, on of the following:
95 printer-name Name of printer being printed to
96 short-file-name File name only, no path
97 long-file-name File name with its path
98 buffer-name Buffer name
99 date Date current when printing started
100 time Time current when printing started
101 page Current printout page number, 1-based
102 user-id User logon id
103 user-name User full name
104 - A list of three elements: (face FACE-NAME EXPR). EXPR is any of the
105 items given here. The item will be displayed in the given face.
106 - A cons of an extent and any of the items given here. The item will
107 be displayed using the extent's face, begin-glyph and end-glyph
109 - A list, each element of which is any of the items given here.
110 Each element of the list is rendered in sequence. For example,
111 '(\"Page \" page) is rendered as \"Page 5\" on the fifth page.
112 - An fbound symbol or lambda expression, called with one parameter,
113 a print-context object, as above. The return value is treated as
114 if it was literally specified: i.e. it will be reprocessed."
118 (defcustom printer-page-footer '(nil (face bold ("Page " page)))
119 "*Controls printed page footer.
121 Format is the same as `printer-page-header'."
125 (defun generate-header-element (element context)
126 (cond ((null element) nil)
127 ((stringp element) (insert element))
128 ((memq element '(printer-name
129 short-file-name long-file-name buffer-name
130 date time page user-id user-name))
131 (insert (print-context-property context element)))
132 ((and (consp element) (eq 'face (car element)))
134 (generate-header-element (third element) context)
135 (let ((x (make-extent p (point))))
136 (set-extent-face x (second element)))))
137 ((and (consp element) (extentp (car element)))
139 (generate-header-element (cdr element) context)
140 (let ((x (make-extent p (point))))
141 (set-extent-face x (extent-face (car element)))
142 (set-extent-begin-glyph x (extent-begin-glyph (car element)))
143 (set-extent-end-glyph x (extent-end-glyph (car element))))))
145 (mapcar #'(lambda (el) (generate-header-element el context))
148 (generate-header-element (funcall element context) context))
149 (t (error 'invalid-argument "Unknown header element" element))))
151 (defun generate-header-line (spec context)
152 (let* ((left (first spec))
153 (middle (second spec))
156 (middle-start (progn (generate-header-element left context)
158 (right-start (progn (generate-header-element middle context)
160 (right-end (progn (generate-header-element right context)
162 (left-width (- middle-start left-start))
163 (middle-width (- right-start middle-start))
164 (right-width (- right-end right-start))
165 (winwidth (- (window-width (Print-context-window context)) 1))
166 (spaces1 (max (- (/ (- winwidth middle-width) 2) left-width) 0))
167 (spaces2 (max (- (- winwidth right-width)
168 (+ left-width spaces1 middle-width))
170 (goto-char right-start)
171 (insert-char ?\ spaces2)
172 (goto-char middle-start)
173 (insert-char ?\ spaces1)))
175 (defun print-context-property (print-context prop)
176 "Return property PROP of PRINT-CONTEXT.
180 print-buffer Buffer being printed
181 print-window Window on printer device containing print buffer
182 print-frame Frame on printer device corresponding to current page
183 print-device Device referring to printer
184 print-start-time Time current when printing started (`current-time' format)
185 print-page Current printout page number, 1-based
186 printer-name Name of printer being printed to
187 short-file-name File name only, no path
188 long-file-name File name with its path
189 buffer-name Buffer name
190 date Date current when printing started (as a string)
191 time Time current when printing started (as a string)
192 page Current printout page number, 1-based (as a string)
193 user-id User logon id (as a string)
194 user-name User full name"
195 (let* ((window (Print-context-window print-context))
196 (pageno (Print-context-pageno print-context))
197 (start-time (Print-context-start-time print-context))
198 (printer-name (Print-context-printer-name print-context))
199 (buffer (window-buffer window)))
201 (print-buffer buffer)
202 (print-window window)
203 (print-frame (window-frame window))
204 (print-device (frame-device (window-frame window)))
205 (print-start-time start-time)
207 (printer-name printer-name)
208 (short-file-name (let ((name (buffer-file-name buffer)))
209 (if name (file-name-nondirectory name) "")))
210 (long-file-name (let ((name (buffer-file-name buffer)))
212 (buffer-name (buffer-name buffer))
213 (date (format-time-string "%x" start-time))
214 (time (format-time-string "%X" start-time))
215 (page (format "%d" pageno))
216 (user-id (format "%d" (user-uid)))
217 (user-name (format "%d" (user-login-name)))
218 (t (error 'invalid-argument "Unrecognized print-context property"
221 (defun generic-page-setup ()
222 "Display the Page Setup dialog box.
223 Changes made are recorded internally."
225 (let* ((d (Printer-get-device))
228 (make-dialog-box 'page-setup :device d
229 :properties (declare-boundp
230 default-msprinter-frame-plist))
232 (Printer-clear-device)
233 (signal (car err) (cdr err))))))
235 (with-boundp 'default-msprinter-frame-plist
236 (setq default-msprinter-frame-plist
237 (plist-put default-msprinter-frame-plist (car props)
239 (setq props (cddr props)))))
241 (defun generic-print-buffer (&optional buffer display-print-dialog)
242 "Print buffer BUFFER using a printing method appropriate to the O.S. being run.
243 Under Unix, `lpr' is normally used to spool out a no-frills version of the
244 buffer, or the `ps-print' package is used to pretty-print the buffer to a
245 PostScript printer. Under MS Windows, the built-in printing support is used.
247 If DISPLAY-PRINT-DIALOG is t, the print dialog will first be
248 displayed, allowing the user to select various printing settings
249 \(e.g. which printer to print to, the range of pages, number of copies,
250 modes such landscape/portrait/2-up/4-up [2 or 4 (small!) logical pages
251 per physical page], etc.). At this point the user can cancel the printing
252 operation using the dialog box, and `generic-print-buffer' will not print
253 anything. When called interactively, use a prefix arg to suppress the
254 display of the print dialog box.
256 If BUFFER is nil or omitted, the current buffer is used."
257 (interactive (list nil (not current-prefix-arg)))
259 (let* ((print-region (and (interactive-p) (region-active-p)))
260 (start (if print-region (region-beginning) (point-min buffer)))
261 (end (if print-region (region-end) (point-max buffer))))
262 (if (or (not (valid-specifier-tag-p 'msprinter))
263 (not display-print-dialog))
264 (generic-print-region start end buffer)
265 (let* ((d (Printer-get-device))
266 (props (make-dialog-box 'print :device d
267 :allow-selection print-region
268 :selected-page-button
269 (if print-region 'selection 'all))))
271 (let ((really-print-region
272 (eq (plist-get props 'selected-page-button) 'selection)))
273 (generic-print-region (if really-print-region start
275 (if really-print-region end
279 ;; Make sure we catch all errors thrown from the native code.
280 (Printer-clear-device)
281 (signal (car err) (cdr err)))))
283 (defun generic-print-region (start end &optional buffer print-device props)
284 "Print region using a printing method appropriate to the O.S. being run.
285 The region between START and END of BUFFER (defaults to the current
288 Under Unix, `lpr' is normally used to spool out a no-frills version of the
289 buffer, or the `ps-print' package is used to pretty-print the buffer to a
290 PostScript printer. Under MS Windows, the built-in printing support is used.
292 Optional PRINT-DEVICE is a device, already created, to use to do the
293 printing. This is typically used when this function was invoked from
294 `generic-print-buffer' and it displayed a dialog box. That function created
295 the device, and then the dialog box stuffed it with the user's selections
296 of how the buffer should be printed.
298 PROPS, if given, is typically the plist returned from the call to
299 `make-dialog-box' that displayed the Print box. It contains properties
300 relevant to us when we print.
302 Recognized properties are the same as those in `make-dialog-box':
304 name Printer device name. If omitted, the current system-selected
305 printer will be used.
306 from-page First page to print, 1-based. If omitted, printing starts from
308 to-page Last page to print, inclusive, If omitted, printing ends at
310 copies Number of copies to print. If omitted, one copy is printed."
311 (cond ((valid-specifier-tag-p 'msprinter)
312 ;; loop, printing one copy of document per loop. kill and
313 ;; re-create the frame each time so that we eject the piece
314 ;; of paper at the end even if we're printing more than one
315 ;; page per sheet of paper.
316 (let ((copies (plist-get props 'copies 1))
317 ;; This is not relevant to printing and can mess up
318 ;; msprinter frame sizing
321 (let (d f header-buffer footer-buffer)
322 (setq buffer (decode-buffer buffer))
324 (with-current-buffer buffer
326 (narrow-to-region start end)
327 (setq d (or print-device (Printer-get-device)))
331 (substitute ?_ ?. (buffer-name buffer))
336 default-toolbar-visible-p nil
337 default-gutter-visible-p nil
339 modeline-shadow-thickness 0
340 vertical-scrollbar-visible-p nil
341 horizontal-scrollbar-visible-p nil
342 [default foreground] "black"
343 [default background] "white"))
345 (let* ((w (frame-root-window f))
347 (cdr (device-system-metric d 'device-dpi)))
348 (pixel-vertical-clip-threshold (/ vertdpi 2))
349 (from-page (plist-get props 'from-page 1))
350 (to-page (plist-get props 'to-page))
351 (context (make-Print-context
352 :start-time (current-time)
353 ;; #### bogus! we need accessors for
354 ;; print-settings objects.
356 (or (plist-get props 'name)
361 (when printer-page-header
362 (let ((window-min-height 2))
363 (setq header-window w)
364 (setq w (split-window w 2)))
366 (generate-new-buffer " *header*"))
367 (set-window-buffer header-window header-buffer))
369 (when printer-page-footer
370 (let ((window-min-height 2))
372 (split-window w (- (window-height w) 2))))
374 (generate-new-buffer " *footer*"))
375 (set-window-buffer footer-window footer-buffer))
377 (setf (Print-context-window context) w)
379 (let ((last-end 0) ; bufpos at end of previous page
380 reached-end ; t if we've reached the end of the
381 ; text we're printing
383 (set-window-buffer w buffer)
384 (set-window-start w start)
386 ;; loop, printing one page per loop
387 (while (and (not reached-end)
388 ;; stop at end of region of text or
389 ;; outside of ranges of pages given
390 (or (not to-page) (<= pageno to-page)))
392 (setf (Print-context-pageno context) pageno)
394 ;; only actually print the page if it's in the
396 (when (>= pageno from-page)
397 (when printer-page-header
398 (with-current-buffer header-buffer
400 (generate-header-line printer-page-header
402 (goto-char (point-min))
403 (set-window-start header-window
406 (when printer-page-footer
407 (with-current-buffer footer-buffer
410 (generate-header-line printer-page-footer
412 (goto-char (point-min))
413 (set-window-start footer-window
416 (redisplay-frame f t)
417 (print-job-eject-page f)
419 ;; but use the GUARANTEE argument to `window-end'
420 ;; so that we get the right value even if we
421 ;; didn't do a redisplay.
422 (let ((this-end (window-end w t))
424 (window-last-line-visible-height w)))
425 ;; in case we get stuck somewhere, bow out
426 ;; rather than printing an infinite number of
427 ;; pages. #### this will fail with an image
428 ;; bigger than an entire page. but we really
429 ;; need this check here. we should be more
430 ;; clever in our check, to deal with this case.
431 (if (or (= this-end last-end)
432 ;; #### fuckme! window-end returns a
433 ;; value outside of the valid range of
434 ;; buffer positions!!!
437 (setq last-end this-end)
438 (set-window-start w this-end)
440 (with-selected-window w
441 ;; #### scroll-down should take a
443 (let ((window-pixel-scroll-increment
446 (setq pageno (1+ pageno))))))
447 (and f (delete-frame f))
448 (and header-buffer (kill-buffer header-buffer))
449 (and footer-buffer (kill-buffer footer-buffer)))))
450 (setq copies (1- copies)))))
451 ((and-fboundp 'lpr-region
452 (lpr-region start end)))
453 (t (error "No print support available"))))