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