git.chise.org Git - chise/xemacs-chise.git.1/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 is just a start and needs a huge amount of work.  Probably
  57 ;; the interfaces below will change and the functions renamed.
  58
  59 (defgroup printing nil
  60   "Generic printing support."
  61   :group 'wp)
  62
  63 (defcustom printer-name nil ; "Okidata OL610e/PS PostScript"
  64   "*Name of printer to print to.
  65 If nil, use default.
  66 Under MS Windows, this can have the form `\\\\STOLI\\HP-345-PS'."
  67   :type 'string
  68   :group 'printing)
  69
  70 (defcustom printer-page-header '(date buffer-name)
  71 "*Controls printed page header.
  72
  73 #### not yet implemented.
  74
  75 This can be:
  76 - nil.  Header is not printed.
  77 - An fbound symbol or lambda expression.  The function is called with
  78    one parameter, a print-context object, every time the headers need
  79    to be set up.  It can use the function `print-context-property' to
  80    query the properties of this object.  The return value is treated as
  81      if it was literally specified: i.e. it will be reprocessed.
  82 - A list of up to three elements, for left, center and right portions
  83    of the header.  Each of these can be
  84    - nil, not to print the portion
  85    - A string, which will be printed literally.
  86    - A predefined symbol, on of the following:
  87      short-file-name  File name only, no path
  88      long-file-name   File name with its path
  89      buffer-name      Buffer name
  90      date             Date current when printing started
  91      time             Time current when printing started
  92      page             Current printout page number, 1-based
  93      user-id          User logon id
  94      user-name        User full name
  95    - A cons of an extent and any of the items given here.  The item will
  96      be displayed using the extent's face, begin-glyph and end-glyph
  97      properties.
  98    - A list, each element of which is any of the items given here.
  99      Each element of the list is rendered in sequence.  For example,
 100      '(\"Page \" page) is rendered as \"Page 5\" on the fifth page.
 101    - An fbound symbol or lambda expression, called with one parameter,
 102      a print-context object, as above.  The return value is treated as
 103      if it was literally specified: i.e. it will be reprocessed."
 104   :type 'sexp
 105   :group 'printing)
 106
 107 (defcustom printer-page-footer '(nil page)
 108 "*Controls printed page footer.
 109
 110 #### not yet implemented.
 111
 112 Format is the same as `printer-page-header'."
 113   :type 'sexp
 114   :group 'printing)
 115
 116 (defun print-context-property (print-context prop)
 117   "Return property PROP of PRINT-CONTEXT.
 118
 119 Valid properties are
 120
 121 print-buffer     Buffer being printed.
 122 print-window     Window on printer device containing print buffer.
 123 print-frame      Frame on printer device corresponding to current page.
 124 print-device     Device referring to printer.
 125 printer-name     Name of printer being printed to.
 126 short-file-name  File name only, no path
 127 long-file-name   File name with its path
 128 buffer-name      Buffer name
 129 date             Date current when printing started
 130 time             Time current when printing started
 131 page             Current printout page number, 1-based
 132 user-id          User logon id
 133 user-name        User full name"
 134   (error "not yet implemented"))
 135
 136 (defun generic-print-buffer (&optional buf)
 137   "Print buffer BUF using a printing method appropriate to the O.S. being run.
 138 Under Unix, `lpr' is normally used to spool out a no-frills version of the
 139 buffer, or the `ps-print' package is used to pretty-print the buffer to a
 140 PostScript printer.  Under MS Windows, the built-in printing support is used.
 141
 142 If BUF is nil or omitted, the current buffer is used."
 143   (interactive)
 144   (generic-print-region (point-min buf) (point-max buf) buf))
 145
 146 (defun generic-print-region (b e &optional buf)
 147   "Print region using a printing method appropriate to the O.S. being run.
 148 The region between B and E of BUF (defaults to the current buffer) is printed.
 149
 150 Under Unix, `lpr' is normally used to spool out a no-frills version of the
 151 buffer, or the `ps-print' package is used to pretty-print the buffer to a
 152 PostScript printer.  Under MS Windows, the built-in printing support is used."
 153   (cond ((valid-specifier-tag-p 'msprinter)
 154          (or (stringp printer-name)
 155              (error "Please set `printer-name'"))
 156          (let (d f)
 157            (setq buf (decode-buffer buf))
 158            (unwind-protect
 159                (progn
 160                  (setq d (make-device 'msprinter printer-name))
 161                  (setq f (make-frame
 162                           (list* 'name (concat (substitute ?_ ?.
 163                                                            (buffer-name buf))
 164                                                " - XEmacs")
 165                                  '(menubar-visible-p nil
 166                                    has-modeline-p nil
 167                                    default-toolbar-visible-p nil
 168                                    default-gutter-visible-p nil
 169                                    minibuffer none
 170                                    modeline-shadow-thickness 0
 171                                    vertical-scrollbar-visible-p nil
 172                                    horizontal-scrollbar-visible-p nil))
 173                           d))
 174                  (let* ((w (frame-root-window f))
 175                         (vertdpi (cdr (device-system-metric d 'device-dpi)))
 176                         (pixel-vertical-clip-threshold (/ vertdpi 2))
 177                         (last-end 0)
 178                         done)
 179                    (set-window-buffer w (or buf (current-buffer)))
 180                    (set-window-start w b)
 181                    (while (not done)
 182                      (redisplay-frame f)
 183                      (print-job-eject-page f)
 184                      (let ((end (window-end w))
 185                            (pixvis (window-last-line-visible-height w)))
 186                        ;; in case we get stuck somewhere, bow out
 187                        ;; rather than printing an infinite number of
 188                        ;; pages.  #### this will fail with an image
 189                        ;; bigger than an entire page.  but we really
 190                        ;; need this check here.  we should be more
 191                        ;; clever in our check, to deal with this case.
 192                        (if (or (= end last-end)
 193                                ;; #### fuckme!  window-end returns a value
 194                                ;; outside of the valid range of buffer
 195                                ;; positions!!!
 196                                (>= end e))
 197                            (setq done t)
 198                          (setq last-end end)
 199                          (set-window-start w end)
 200                          (if pixvis
 201                              (save-selected-window
 202                                (select-window w)
 203                                ;; #### scroll-down should take a window arg.
 204                                (let ((window-pixel-scroll-increment pixvis))
 205                                  (scroll-down 1)))))))))
 206              (and f (delete-frame f))
 207              (and d (delete-device d))
 208              )))
 209         ((and (not (eq system-type 'windows-nt))
 210               (fboundp 'lpr-buffer))
 211          (lpr-region buf))
 212         (t (error "No print support available"))))