Mercurial > hg > xemacs-beta

comparison lisp/printer.el @ 506:39ccc7dd8077

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2001-05-05 08:39:59 by ben] Add Page Setup for Windows, take out Pretty Print. Implement Page Setup. Handle errors properly. Change top/bottom margin defaults to 0.5 inches.
author ben
date Sat, 05 May 2001 08:40:06 +0000
parents 98fb34b6fbe9
children 5bdbc721d46a
comparison
equal deleted inserted replaced
505:6495d35ba9df 506:39ccc7dd8077
51 ;; pretty-print package on Unix, built-in msprinter support on 51 ;; pretty-print package on Unix, built-in msprinter support on
52 ;; Windows), where the workings of a particular implementation is 52 ;; Windows), where the workings of a particular implementation is
53 ;; hidden from the user and there is a consistent set of options to 53 ;; hidden from the user and there is a consistent set of options to
54 ;; control how to print, which works across all implementations. 54 ;; control how to print, which works across all implementations.
55 ;; 55 ;;
56 ;; The code here is just a start and needs a huge amount of work. Probably 56 ;; The code here currently only really supports Windows.
57 ;; the interfaces below will change and the functions renamed.
58 57
59 (defgroup printing nil 58 (defgroup printing nil
60 "Generic printing support." 59 "Generic printing support."
61 :group 'wp) 60 :group 'wp)
62 61
67 printers." 66 printers."
68 :type 'string 67 :type 'string
69 :group 'printing) 68 :group 'printing)
70 69
71 (defstruct Print-context pageno window start-time printer-name) 70 (defstruct Print-context pageno window start-time printer-name)
71
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))
72 80
73 (defcustom printer-page-header '((face bold date) nil (face bold buffer-name)) 81 (defcustom printer-page-header '((face bold date) nil (face bold buffer-name))
74 "*Controls printed page header. 82 "*Controls printed page header.
75 83
76 This can be: 84 This can be:
209 (user-id (format "%d" (user-uid))) 217 (user-id (format "%d" (user-uid)))
210 (user-name (format "%d" (user-login-name))) 218 (user-name (format "%d" (user-login-name)))
211 (t (error 'invalid-argument "Unrecognized print-context property" 219 (t (error 'invalid-argument "Unrecognized print-context property"
212 prop))))) 220 prop)))))
213 221
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
214 (defun generic-print-buffer (&optional buffer display-print-dialog) 239 (defun generic-print-buffer (&optional buffer display-print-dialog)
215 "Print buffer BUFFER using a printing method appropriate to the O.S. being run. 240 "Print buffer BUFFER using a printing method appropriate to the O.S. being run.
216 Under Unix, `lpr' is normally used to spool out a no-frills version of the 241 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 242 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. 243 PostScript printer. Under MS Windows, the built-in printing support is used.
229 If BUFFER is nil or omitted, the current buffer is used." 254 If BUFFER is nil or omitted, the current buffer is used."
230 (interactive (list nil (not current-prefix-arg))) 255 (interactive (list nil (not current-prefix-arg)))
231 (if (or (not (valid-specifier-tag-p 'msprinter)) 256 (if (or (not (valid-specifier-tag-p 'msprinter))
232 (not display-print-dialog)) 257 (not display-print-dialog))
233 (generic-print-region (point-min buffer) (point-max buffer) buffer) 258 (generic-print-region (point-min buffer) (point-max buffer) buffer)
234 (let* ((d (make-device 'msprinter printer-name)) 259 (let* ((d (Printer-get-device))
235 (props (make-dialog-box 'print :device d))) 260 (props (condition-case err
261 (make-dialog-box 'print :device d)
262 (error
263 (Printer-clear-device)
264 (signal (car err) (cdr err))))))
236 (and props (generic-print-region (point-min buffer) 265 (and props (generic-print-region (point-min buffer)
237 (point-max buffer) buffer 266 (point-max buffer) buffer
238 d props))))) 267 d props)))))
239 268
240 (defun generic-print-region (start end &optional buffer print-device props) 269 (defun generic-print-region (start end &optional buffer print-device props)
268 (cond ((valid-specifier-tag-p 'msprinter) 297 (cond ((valid-specifier-tag-p 'msprinter)
269 (let (d f header-buffer footer-buffer) 298 (let (d f header-buffer footer-buffer)
270 (setq buffer (decode-buffer buffer)) 299 (setq buffer (decode-buffer buffer))
271 (unwind-protect 300 (unwind-protect
272 (progn 301 (progn
273 (setq d (or print-device 302 (setq d (or print-device (Printer-get-device)))
274 (make-device 'msprinter printer-name)))
275 (setq f (make-frame 303 (setq f (make-frame
276 (list* 'name (concat 304 (list* 'name (concat
277 (substitute ?_ ?. (buffer-name buffer)) 305 (substitute ?_ ?. (buffer-name buffer))
278 " - XEmacs") 306 " - XEmacs")
279 '(menubar-visible-p 307 '(menubar-visible-p
387 pixvis)) 415 pixvis))
388 (scroll-down 1)))))) 416 (scroll-down 1))))))
389 (setq pageno (1+ pageno)))) 417 (setq pageno (1+ pageno))))
390 (setq copies (1- copies))))) 418 (setq copies (1- copies)))))
391 (and f (delete-frame f)) 419 (and f (delete-frame f))
392 (and d (delete-device d))
393 (and header-buffer (kill-buffer header-buffer)) 420 (and header-buffer (kill-buffer header-buffer))
394 (and footer-buffer (kill-buffer footer-buffer)) 421 (and footer-buffer (kill-buffer footer-buffer))
395 ))) 422 )))
396 ((and (not (eq system-type 'windows-nt)) 423 ((and (not (eq system-type 'windows-nt))
397 (fboundp 'lpr-region)) 424 (fboundp 'lpr-region))