git.chise.org Git - chise/xemacs-chise.git-/blob - lisp/printer.el

   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 \f
  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 ;;
  56 ;; The code here currently only really supports Windows.
  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
  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   ;; 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))
  82   (setq printer-current-device nil))
  83
  84 (defcustom printer-page-header '((face bold date) nil (face bold buffer-name))
  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
  93    if it was literally specified: i.e. it will be reprocessed.
  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:
  99      printer-name     Name of printer being printed to
 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
 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.
 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
 122 (defcustom printer-page-footer '(nil (face bold ("Page " page)))
 123 "*Controls printed page footer.
 124
 125 Format is the same as `printer-page-header'."
 126   :type 'sexp
 127   :group 'printing)
 128
 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))
 169          (winwidth (- (window-width (Print-context-window context)) 1))
 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
 179 (defun print-context-property (print-context prop)
 180   "Return property PROP of PRINT-CONTEXT.
 181
 182 Valid properties are
 183
 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
 191 short-file-name  File name only, no path
 192 long-file-name   File name with its path
 193 buffer-name      Buffer name
 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)
 198 user-name        User full name"
 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)))))
 224
 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
 233                                :properties default-msprinter-frame-plist)
 234             (error
 235              (Printer-clear-device)
 236              (signal (car err) (cdr err))))))
 237     (while props
 238       (setq default-msprinter-frame-plist
 239             (plist-put default-msprinter-frame-plist (car props) (cadr props)))
 240       (setq props (cddr props)))))
 241
 242 (defun generic-print-buffer (&optional buffer display-print-dialog)
 243   "Print buffer BUFFER using a printing method appropriate to the O.S. being run.
 244 Under Unix, `lpr' is normally used to spool out a no-frills version of the
 245 buffer, or the `ps-print' package is used to pretty-print the buffer to a
 246 PostScript printer.  Under MS Windows, the built-in printing support is used.
 247
 248 If DISPLAY-PRINT-DIALOG is t, the print dialog will first be
 249 displayed, allowing the user to select various printing settings
 250 \(e.g. which printer to print to, the range of pages, number of copies,
 251 modes such landscape/portrait/2-up/4-up [2 or 4 (small!) logical pages
 252 per physical page], etc.).  At this point the user can cancel the printing
 253 operation using the dialog box, and `generic-print-buffer' will not print
 254 anything.  When called interactively, use a prefix arg to suppress the
 255 display of the print dialog box.
 256
 257 If BUFFER is nil or omitted, the current buffer is used."
 258   (interactive (list nil (not current-prefix-arg)))
 259   (condition-case err
 260       (let* ((print-region (and (interactive-p) (region-active-p)))
 261              (start (if print-region (region-beginning) (point-min buffer)))
 262              (end (if print-region (region-end) (point-max buffer))))
 263         (if (or (not (valid-specifier-tag-p 'msprinter))
 264                 (not display-print-dialog))
 265             (generic-print-region start end buffer)
 266           (let* ((d (Printer-get-device))
 267                  (props (make-dialog-box 'print :device d
 268                                          :allow-selection print-region
 269                                          :selected-page-button
 270                                          (if print-region 'selection 'all))))
 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))))))
 279     (error
 280      ;; Make sure we catch all errors thrown from the native code.
 281      (Printer-clear-device)
 282      (signal (car err) (cdr err)))))
 283
 284 (defun generic-print-region (start end &optional buffer print-device props)
 285   "Print region using a printing method appropriate to the O.S. being run.
 286 The region between START and END of BUFFER (defaults to the current
 287 buffer) is printed.
 288
 289 Under Unix, `lpr' is normally used to spool out a no-frills version of the
 290 buffer, or the `ps-print' package is used to pretty-print the buffer to a
 291 PostScript printer.  Under MS Windows, the built-in printing support is used.
 292
 293 Optional PRINT-DEVICE is a device, already created, to use to do the
 294 printing.  This is typically used when this function was invoked from
 295 `generic-print-buffer' and it displayed a dialog box.  That function created
 296 the device, and then the dialog box stuffed it with the user's selections
 297 of how the buffer should be printed.
 298
 299 PROPS, if given, is typically the plist returned from the call to
 300 `make-dialog-box' that displayed the Print box.  It contains properties
 301 relevant to us when we print.
 302
 303 Recognized properties are the same as those in `make-dialog-box':
 304
 305   name       Printer device name.  If omitted, the current system-selected
 306              printer will be used.
 307   from-page  First page to print, 1-based. If omitted, printing starts from
 308              the beginning.
 309   to-page    Last page to print, inclusive, If omitted, printing ends at
 310              the end.
 311   copies     Number of copies to print.  If omitted, one copy is printed."
 312   (cond ((valid-specifier-tag-p 'msprinter)
 313          ;; loop, printing one copy of document per loop.  kill and
 314          ;; re-create the frame each time so that we eject the piece
 315          ;; of paper at the end even if we're printing more than one
 316          ;; page per sheet of paper.
 317          (let ((copies (plist-get props 'copies 1))
 318                ;; This is not relevant to printing and can mess up
 319                ;; msprinter frame sizing
 320                default-frame-plist)
 321            (while (> copies 0)
 322              (let (d f header-buffer footer-buffer)
 323                (setq buffer (decode-buffer buffer))
 324                (unwind-protect
 325                    (with-current-buffer buffer
 326                      (save-restriction
 327                        (narrow-to-region start end)
 328                        (setq d (or print-device (Printer-get-device)))
 329                        (setq f (make-frame
 330                                 (list* 'name
 331                                        (concat
 332                                         (substitute ?_ ?. (buffer-name buffer))
 333                                         " - XEmacs")
 334                                        '(menubar-visible-p
 335                                          nil
 336                                          has-modeline-p nil
 337                                          default-toolbar-visible-p nil
 338                                          default-gutter-visible-p nil
 339                                          minibuffer none
 340                                          modeline-shadow-thickness 0
 341                                          vertical-scrollbar-visible-p nil
 342                                          horizontal-scrollbar-visible-p nil
 343                                          [default foreground] "black"
 344                                          [default background] "white"))
 345                                 d))
 346                        (let* ((w (frame-root-window f))
 347                               (vertdpi
 348                                (cdr (device-system-metric d 'device-dpi)))
 349                               (pixel-vertical-clip-threshold (/ vertdpi 2))
 350                               (from-page (plist-get props 'from-page 1))
 351                               (to-page (plist-get props 'to-page))
 352                               (context (make-Print-context
 353                                         :start-time (current-time)
 354                                         ;; #### bogus! we need accessors for
 355                                         ;; print-settings objects.
 356                                         :printer-name
 357                                         (or (plist-get props 'name)
 358                                             printer-name
 359                                             (mswindows-get-default-printer))))
 360                               header-window
 361                               footer-window)
 362
 363                          (when printer-page-header
 364                            (let ((window-min-height 2))
 365                              (setq header-window w)
 366                              (setq w (split-window w 2)))
 367                            (setq header-buffer
 368                                  (generate-new-buffer " *header*"))
 369                            (set-window-buffer header-window header-buffer))
 370
 371                          (when printer-page-footer
 372                            (let ((window-min-height 2))
 373                              (setq footer-window
 374                                    (split-window w (- (window-height w) 2))))
 375                            (setq footer-buffer
 376                                  (generate-new-buffer " *footer*"))
 377                            (set-window-buffer footer-window footer-buffer))
 378
 379                          (setf (Print-context-window context) w)
 380
 381                          (let ((last-end 0) ; bufpos at end of previous page
 382                                reached-end ; t if we've reached the end of the
 383                                         ; text we're printing
 384                                (pageno 1))
 385                            (set-window-buffer w buffer)
 386                            (set-window-start w start)
 387
 388                            ;; loop, printing one page per loop
 389                            (while (and (not reached-end)
 390                                        ;; stop at end of region of text or
 391                                        ;; outside of ranges of pages given
 392                                        (or (not to-page) (<= pageno to-page)))
 393
 394                              (setf (Print-context-pageno context) pageno)
 395
 396                              ;; only actually print the page if it's in the
 397                              ;; range.
 398                              (when (>= pageno from-page)
 399                                (when printer-page-header
 400                                  (with-current-buffer header-buffer
 401                                    (erase-buffer)
 402                                    (generate-header-line printer-page-header
 403                                                          context)
 404                                    (goto-char (point-min))
 405                                    (set-window-start header-window
 406                                                      (point-min))))
 407
 408                                (when printer-page-footer
 409                                  (with-current-buffer footer-buffer
 410                                    (erase-buffer)
 411                                    (insert "\n")
 412                                    (generate-header-line printer-page-footer
 413                                                          context)
 414                                    (goto-char (point-min))
 415                                    (set-window-start footer-window
 416                                                      (point-min))))
 417
 418                                (redisplay-frame f t)
 419                                (print-job-eject-page f)
 420                                )
 421                              ;; but use the GUARANTEE argument to `window-end'
 422                              ;; so that we get the right value even if we
 423                              ;; didn't do a redisplay.
 424                              (let ((this-end (window-end w t))
 425                                    (pixvis
 426                                     (window-last-line-visible-height w)))
 427                                ;; in case we get stuck somewhere, bow out
 428                                ;; rather than printing an infinite number of
 429                                ;; pages.  #### this will fail with an image
 430                                ;; bigger than an entire page.  but we really
 431                                ;; need this check here.  we should be more
 432                                ;; clever in our check, to deal with this case.
 433                                (if (or (= this-end last-end)
 434                                        ;; #### fuckme!  window-end returns a
 435                                        ;; value outside of the valid range of
 436                                        ;; buffer positions!!!
 437                                        (>= this-end end))
 438                                    (setq reached-end t)
 439                                  (setq last-end this-end)
 440                                  (set-window-start w this-end)
 441                                  (if pixvis
 442                                      (with-selected-window w
 443                                        ;; #### scroll-down should take a
 444                                        ;; window arg.
 445                                        (let ((window-pixel-scroll-increment
 446                                               pixvis))
 447                                          (scroll-down 1))))))
 448                              (setq pageno (1+ pageno))))))
 449                      (and f (delete-frame f))
 450                      (and header-buffer (kill-buffer header-buffer))
 451                      (and footer-buffer (kill-buffer footer-buffer)))))
 452              (setq copies (1- copies)))))
 453         ((and (not (eq system-type 'windows-nt))
 454               (fboundp 'lpr-region))
 455          (lpr-region start end))
 456         (t (error "No print support available"))))