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))))
+ − 266 (if (or (not (valid-specifier-tag-p 'msprinter))
+ − 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."
442
+ − 315 (cond ((valid-specifier-tag-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"))))
