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 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
  64   "*Name of printer to print to.
  65 If nil, use default.
  66 Under Windows, use `mswindows-printer-list' to get names of installed
  67 printers."
  68   :type 'string
  69   :group 'printing)
  70
  71 (defcustom printer-page-header '(date buffer-name)
  72 "*Controls printed page header.
  73
  74 #### not yet implemented.
  75
  76 This can be:
  77 - nil.  Header is not printed.
  78 - An fbound symbol or lambda expression.  The function is called with
  79    one parameter, a print-context object, every time the headers need
  80    to be set up.  It can use the function `print-context-property' to
  81    query the properties of this object.  The return value is treated as
  82      if it was literally specified: i.e. it will be reprocessed.
  83 - A list of up to three elements, for left, center and right portions
  84    of the header.  Each of these can be
  85    - nil, not to print the portion
  86    - A string, which will be printed literally.
  87    - A predefined symbol, on of the following:
  88      short-file-name  File name only, no path
  89      long-file-name   File name with its path
  90      buffer-name      Buffer name
  91      date             Date current when printing started
  92      time             Time current when printing started
  93      page             Current printout page number, 1-based
  94      user-id          User logon id
  95      user-name        User full name
  96    - A cons of an extent and any of the items given here.  The item will
  97      be displayed using the extent's face, begin-glyph and end-glyph
  98      properties.
  99    - A list, each element of which is any of the items given here.
 100      Each element of the list is rendered in sequence.  For example,
 101      '(\"Page \" page) is rendered as \"Page 5\" on the fifth page.
 102    - An fbound symbol or lambda expression, called with one parameter,
 103      a print-context object, as above.  The return value is treated as
 104      if it was literally specified: i.e. it will be reprocessed."
 105   :type 'sexp
 106   :group 'printing)
 107
 108 (defcustom printer-page-footer '(nil page)
 109 "*Controls printed page footer.
 110
 111 #### not yet implemented.
 112
 113 Format is the same as `printer-page-header'."
 114   :type 'sexp
 115   :group 'printing)
 116
 117 (defun print-context-property (print-context prop)
 118   "Return property PROP of PRINT-CONTEXT.
 119
 120 Valid properties are
 121
 122 print-buffer     Buffer being printed.
 123 print-window     Window on printer device containing print buffer.
 124 print-frame      Frame on printer device corresponding to current page.
 125 print-device     Device referring to printer.
 126 printer-name     Name of printer being printed to.
 127 short-file-name  File name only, no path
 128 long-file-name   File name with its path
 129 buffer-name      Buffer name
 130 date             Date current when printing started
 131 time             Time current when printing started
 132 page             Current printout page number, 1-based
 133 user-id          User logon id
 134 user-name        User full name"
 135   (error "not yet implemented"))
 136
 137 (defun generic-print-buffer (&optional buffer)
 138   "Print buffer BUFFER using a printing method appropriate to the O.S. being run.
 139 Under Unix, `lpr' is normally used to spool out a no-frills version of the
 140 buffer, or the `ps-print' package is used to pretty-print the buffer to a
 141 PostScript printer.  Under MS Windows, the built-in printing support is used.
 142
 143 If BUFFER is nil or omitted, the current buffer is used."
 144   (interactive)
 145   (generic-print-region (point-min buffer) (point-max buffer) buffer))
 146
 147 (defun generic-print-region (start end &optional buffer)
 148   "Print region using a printing method appropriate to the O.S. being run.
 149 The region between START and END of BUFFER (defaults to the current
 150 buffer) is printed.
 151
 152 Under Unix, `lpr' is normally used to spool out a no-frills version of the
 153 buffer, or the `ps-print' package is used to pretty-print the buffer to a
 154 PostScript printer.  Under MS Windows, the built-in printing support is used."
 155   (cond ((valid-specifier-tag-p 'msprinter)
 156          (let (d f)
 157            (setq buffer (decode-buffer buffer))
 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 buffer))
 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 buffer (current-buffer)))
 180                    (set-window-start w start)
 181                    (while (not done)
 182                      (redisplay-frame f)
 183                      (print-job-eject-page f)
 184                      (let ((this-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 (= this-end last-end)
 193                                ;; #### fuckme!  window-end returns a value
 194                                ;; outside of the valid range of buffer
 195                                ;; positions!!!
 196                                (>= this-end end))
 197                            (setq done t)
 198                          (setq last-end this-end)
 199                          (set-window-start w this-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 buffer))
 212         (t (error "No print support available"))))