cgit.sxemacs.org Git - sxemacs/blob - lisp/printer.el

   1 ;;; printer.el --- support for hard-copy printing in SXEmacs
   2
   3 ;; Copyright (C) 2000 Ben Wing.
   4 ;; Copyright (C) 2000 Kirill Katsnelson.
   5
   6 ;; Maintainer: SXEmacs Development Team
   7 ;; Keywords: printer, printing, internal, dumped
   8
   9 ;; This file is part of SXEmacs.
  10
  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.
  15
  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.
  20
  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/>.
  23
  24 ;;; Synched up with: Not in FSF.
  25
  26 ;;; Authorship:
  27
  28 ;; Created 2000 by Ben Wing, to provide the high-level interface onto the
  29 ;; print support implemented by Kirill Katsnelson.
  30
  31 ;;; Commentary:
  32
  33 ;; This file is dumped with SXEmacs.
  34
  35 \f
  36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37 ;;                          generic printing code                        ;;
  38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39
  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
  44 ;; here!
  45 ;;
  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.
  53 ;;
  54 ;; The code here currently only really supports Windows.
  55
  56 (defgroup printing nil
  57   "Generic printing support."
  58   :group 'wp)
  59
  60 (defcustom printer-name nil
  61   "*Name of printer to print to.
  62 If nil, use default."
  63   :type 'string
  64   :group 'printing)
  65
  66 (defstruct Print-context pageno window start-time printer-name)
  67
  68 (defvar printer-current-device nil)
  69
  70 (defun Printer-get-device ()
  71   (or printer-current-device (setq printer-current-device
  72                                    (make-device 'msprinter printer-name))))
  73
  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))
  79
  80 (defcustom printer-page-header '((face bold date) nil (face bold buffer-name))
  81 "*Controls printed page header.
  82
  83 This can be:
  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
 108      properties.
 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."
 115   :type 'sexp
 116   :group 'printing)
 117
 118 (defcustom printer-page-footer '(nil (face bold ("Page " page)))
 119 "*Controls printed page footer.
 120
 121 Format is the same as `printer-page-header'."
 122   :type 'sexp
 123   :group 'printing)
 124
 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)))
 133            (let ((p (point)))
 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)))
 138            (let ((p (point)))
 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))))))
 144           ((listp element)
 145            (mapcar #'(lambda (el) (generate-header-element el context))
 146                    element))
 147           ((functionp element)
 148            (generate-header-element (funcall element context) context))
 149           (t (error 'invalid-argument "Unknown header element" element))))
 150
 151 (defun generate-header-line (spec context)
 152   (let* ((left (first spec))
 153          (middle (second spec))
 154          (right (third spec))
 155          (left-start (point))
 156          (middle-start (progn (generate-header-element left context)
 157                               (point)))
 158          (right-start (progn (generate-header-element middle context)
 159                              (point)))
 160          (right-end (progn (generate-header-element right context)
 161                            (point)))
 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))
 169                        0)))
 170     (goto-char right-start)
 171     (insert-char ?\  spaces2)
 172     (goto-char middle-start)
 173     (insert-char ?\  spaces1)))
 174
 175 (defun print-context-property (print-context prop)
 176   "Return property PROP of PRINT-CONTEXT.
 177
 178 Valid properties are
 179
 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)))
 200     (case prop
 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)
 206       (print-page pageno)
 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)))
 211                         (or name "")))
 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"
 219                 prop)))))
 220
 221 (defun generic-page-setup ()
 222   "Display the Page Setup dialog box.
 223 Changes made are recorded internally."
 224   (interactive)
 225   (let* ((d (Printer-get-device))
 226          (props
 227           (condition-case err
 228               (make-dialog-box 'page-setup :device d
 229                                :properties (declare-boundp
 230                                             default-msprinter-frame-plist))
 231             (error
 232              (Printer-clear-device)
 233              (signal (car err) (cdr err))))))
 234     (while props
 235       (with-boundp 'default-msprinter-frame-plist
 236         (setq default-msprinter-frame-plist
 237               (plist-put default-msprinter-frame-plist (car props)
 238                          (cadr props))))
 239         (setq props (cddr props)))))
 240
 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.
 246
 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.
 255
 256 If BUFFER is nil or omitted, the current buffer is used."
 257   (interactive (list nil (not current-prefix-arg)))
 258   (condition-case err
 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))))
 270             (and props
 271                  (let ((really-print-region
 272                         (eq (plist-get props 'selected-page-button) 'selection)))
 273                    (generic-print-region (if really-print-region start
 274                                            (point-min buffer))
 275                                          (if really-print-region end
 276                                            (point-max buffer))
 277                                          buffer d props))))))
 278     (error
 279      ;; Make sure we catch all errors thrown from the native code.
 280      (Printer-clear-device)
 281      (signal (car err) (cdr err)))))
 282
 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
 286 buffer) is printed.
 287
 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.
 291
 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.
 297
 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.
 301
 302 Recognized properties are the same as those in `make-dialog-box':
 303
 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
 307              the beginning.
 308   to-page    Last page to print, inclusive, If omitted, printing ends at
 309              the end.
 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
 319                default-frame-plist)
 320            (while (> copies 0)
 321              (let (d f header-buffer footer-buffer)
 322                (setq buffer (decode-buffer buffer))
 323                (unwind-protect
 324                    (with-current-buffer buffer
 325                      (save-restriction
 326                        (narrow-to-region start end)
 327                        (setq d (or print-device (Printer-get-device)))
 328                        (setq f (make-frame
 329                                 (list* 'name
 330                                        (concat
 331                                         (substitute ?_ ?. (buffer-name buffer))
 332                                         " - XEmacs")
 333                                        '(menubar-visible-p
 334                                          nil
 335                                          has-modeline-p nil
 336                                          default-toolbar-visible-p nil
 337                                          default-gutter-visible-p nil
 338                                          minibuffer none
 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"))
 344                                 d))
 345                        (let* ((w (frame-root-window f))
 346                               (vertdpi
 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.
 355                                         :printer-name
 356                                         (or (plist-get props 'name)
 357                                             printer-name)))
 358                               header-window
 359                               footer-window)
 360
 361                          (when printer-page-header
 362                            (let ((window-min-height 2))
 363                              (setq header-window w)
 364                              (setq w (split-window w 2)))
 365                            (setq header-buffer
 366                                  (generate-new-buffer " *header*"))
 367                            (set-window-buffer header-window header-buffer))
 368
 369                          (when printer-page-footer
 370                            (let ((window-min-height 2))
 371                              (setq footer-window
 372                                    (split-window w (- (window-height w) 2))))
 373                            (setq footer-buffer
 374                                  (generate-new-buffer " *footer*"))
 375                            (set-window-buffer footer-window footer-buffer))
 376
 377                          (setf (Print-context-window context) w)
 378
 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
 382                                (pageno 1))
 383                            (set-window-buffer w buffer)
 384                            (set-window-start w start)
 385
 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)))
 391
 392                              (setf (Print-context-pageno context) pageno)
 393
 394                              ;; only actually print the page if it's in the
 395                              ;; range.
 396                              (when (>= pageno from-page)
 397                                (when printer-page-header
 398                                  (with-current-buffer header-buffer
 399                                    (erase-buffer)
 400                                    (generate-header-line printer-page-header
 401                                                          context)
 402                                    (goto-char (point-min))
 403                                    (set-window-start header-window
 404                                                      (point-min))))
 405
 406                                (when printer-page-footer
 407                                  (with-current-buffer footer-buffer
 408                                    (erase-buffer)
 409                                    (insert "\n")
 410                                    (generate-header-line printer-page-footer
 411                                                          context)
 412                                    (goto-char (point-min))
 413                                    (set-window-start footer-window
 414                                                      (point-min))))
 415
 416                                (redisplay-frame f t)
 417                                (print-job-eject-page f)
 418                                )
 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))
 423                                    (pixvis
 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!!!
 435                                        (>= this-end end))
 436                                    (setq reached-end t)
 437                                  (setq last-end this-end)
 438                                  (set-window-start w this-end)
 439                                  (if pixvis
 440                                      (with-selected-window w
 441                                        ;; #### scroll-down should take a
 442                                        ;; window arg.
 443                                        (let ((window-pixel-scroll-increment
 444                                               pixvis))
 445                                          (scroll-down 1))))))
 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"))))