This commit was manufactured by cvs2svn to create branch 'chise-r21-4-19'.
[chise/xemacs-chise.git] / lisp / printer.el
diff --git a/lisp/printer.el b/lisp/printer.el
new file mode 100644 (file)
index 0000000..9f0b6d7
--- /dev/null
@@ -0,0 +1,456 @@
+;;; printer.el --- support for hard-copy printing in XEmacs
+
+;; Copyright (C) 2000 Ben Wing.
+;; Copyright (C) 2000 Kirill Katsnelson.
+
+;; Maintainer: XEmacs Development Team
+;; Keywords: printer, printing, internal, dumped
+
+;; This file is part of XEmacs.
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+
+;;; Synched up with: Not in FSF.
+
+;;; Authorship:
+
+;; Created 2000 by Ben Wing, to provide the high-level interface onto the
+;; print support implemented by Kirill Katsnelson.
+
+;;; Commentary:
+
+;; This file is dumped with XEmacs.
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;                          generic printing code                        ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; #### should be named print-buffer, but that's currently in
+;; lpr-buffer with some horrible definition: print-buffer == "print with
+;; headings", lpr-buffer == "print without headings", and the headings are
+;; generated by calling the external program "pr"!  This is major stone-age
+;; here!
+;;
+;; I propose junking that package entirely and creating a unified,
+;; modern API here that will work well with modern GUI's on top of it,
+;; and with various different actual implementations (e.g. lpr or the
+;; pretty-print package on Unix, built-in msprinter support on
+;; Windows), where the workings of a particular implementation is
+;; hidden from the user and there is a consistent set of options to
+;; control how to print, which works across all implementations.
+;;
+;; The code here currently only really supports Windows.
+
+(defgroup printing nil
+  "Generic printing support."
+  :group 'wp)
+
+(defcustom printer-name nil
+  "*Name of printer to print to.
+If nil, use default.
+Under Windows, use `mswindows-printer-list' to get names of installed
+printers."
+  :type 'string
+  :group 'printing)
+
+(defstruct Print-context pageno window start-time printer-name)
+
+(defvar printer-current-device nil)
+
+(defun Printer-get-device ()
+  (or printer-current-device (setq printer-current-device
+                                  (make-device 'msprinter printer-name))))
+
+(defun Printer-clear-device ()
+  ;; relying on GC to delete the device is too error-prone since there
+  ;; only can be one anyway.
+  (and printer-current-device (delete-device printer-current-device))
+  (setq printer-current-device nil))
+
+(defcustom printer-page-header '((face bold date) nil (face bold buffer-name))
+"*Controls printed page header.
+
+This can be:
+- nil.  Header is not printed.
+- An fbound symbol or lambda expression.  The function is called with
+   one parameter, a print-context object, every time the headers need
+   to be set up.  It can use the function `print-context-property' to
+   query the properties of this object.  The return value is treated as
+   if it was literally specified: i.e. it will be reprocessed.
+- A list of up to three elements, for left, center and right portions
+   of the header.  Each of these can be
+   - nil, not to print the portion
+   - A string, which will be printed literally.
+   - A predefined symbol, on of the following:
+     printer-name     Name of printer being printed to
+     short-file-name  File name only, no path
+     long-file-name   File name with its path
+     buffer-name      Buffer name
+     date             Date current when printing started
+     time             Time current when printing started
+     page             Current printout page number, 1-based
+     user-id          User logon id
+     user-name        User full name
+   - A list of three elements: (face FACE-NAME EXPR).  EXPR is any of the
+     items given here.  The item will be displayed in the given face.
+   - A cons of an extent and any of the items given here.  The item will
+     be displayed using the extent's face, begin-glyph and end-glyph
+     properties.
+   - A list, each element of which is any of the items given here.
+     Each element of the list is rendered in sequence.  For example,
+     '(\"Page \" page) is rendered as \"Page 5\" on the fifth page.
+   - An fbound symbol or lambda expression, called with one parameter,
+     a print-context object, as above.  The return value is treated as
+     if it was literally specified: i.e. it will be reprocessed."
+  :type 'sexp
+  :group 'printing)
+
+(defcustom printer-page-footer '(nil (face bold ("Page " page)))
+"*Controls printed page footer.
+
+Format is the same as `printer-page-header'."
+  :type 'sexp
+  :group 'printing)
+
+(defun generate-header-element (element context)
+    (cond ((null element) nil)
+         ((stringp element) (insert element))
+         ((memq element '(printer-name
+                          short-file-name long-file-name buffer-name
+                          date time page user-id user-name))
+          (insert (print-context-property context element)))
+         ((and (consp element) (eq 'face (car element)))
+          (let ((p (point)))
+            (generate-header-element (third element) context)
+            (let ((x (make-extent p (point))))
+              (set-extent-face x (second element)))))
+         ((and (consp element) (extentp (car element)))
+          (let ((p (point)))
+            (generate-header-element (cdr element) context)
+            (let ((x (make-extent p (point))))
+              (set-extent-face x (extent-face (car element)))
+              (set-extent-begin-glyph x (extent-begin-glyph (car element)))
+              (set-extent-end-glyph x (extent-end-glyph (car element))))))
+         ((listp element)
+          (mapcar #'(lambda (el) (generate-header-element el context))
+                  element))
+         ((functionp element)
+          (generate-header-element (funcall element context) context))
+         (t (error 'invalid-argument "Unknown header element" element))))
+
+(defun generate-header-line (spec context)
+  (let* ((left (first spec))
+        (middle (second spec))
+        (right (third spec))
+        (left-start (point))
+        (middle-start (progn (generate-header-element left context)
+                             (point)))
+        (right-start (progn (generate-header-element middle context)
+                            (point)))
+        (right-end (progn (generate-header-element right context)
+                          (point)))
+        (left-width (- middle-start left-start))
+        (middle-width (- right-start middle-start))
+        (right-width (- right-end right-start))
+        (winwidth (- (window-width (Print-context-window context)) 1))
+        (spaces1 (max (- (/ (- winwidth middle-width) 2) left-width) 0))
+        (spaces2 (max (- (- winwidth right-width)
+                         (+ left-width spaces1 middle-width))
+                      0)))
+    (goto-char right-start)
+    (insert-char ?\  spaces2)
+    (goto-char middle-start)
+    (insert-char ?\  spaces1)))
+
+(defun print-context-property (print-context prop)
+  "Return property PROP of PRINT-CONTEXT.
+
+Valid properties are
+
+print-buffer     Buffer being printed
+print-window     Window on printer device containing print buffer
+print-frame      Frame on printer device corresponding to current page
+print-device     Device referring to printer
+print-start-time Time current when printing started (`current-time' format)
+print-page       Current printout page number, 1-based
+printer-name     Name of printer being printed to
+short-file-name  File name only, no path
+long-file-name   File name with its path
+buffer-name      Buffer name
+date             Date current when printing started (as a string)
+time             Time current when printing started (as a string)
+page             Current printout page number, 1-based (as a string)
+user-id          User logon id (as a string)
+user-name        User full name"
+  (let* ((window (Print-context-window print-context))
+        (pageno (Print-context-pageno print-context))
+        (start-time (Print-context-start-time print-context))
+        (printer-name (Print-context-printer-name print-context))
+        (buffer (window-buffer window)))
+    (case prop
+      (print-buffer buffer)
+      (print-window window)
+      (print-frame (window-frame window))
+      (print-device (frame-device (window-frame window)))
+      (print-start-time start-time)
+      (print-page pageno)
+      (printer-name printer-name)
+      (short-file-name (let ((name (buffer-file-name buffer)))
+                        (if name (file-name-nondirectory name) "")))
+      (long-file-name (let ((name (buffer-file-name buffer)))
+                       (or name "")))
+      (buffer-name (buffer-name buffer))
+      (date (format-time-string "%x" start-time))
+      (time (format-time-string "%X" start-time))
+      (page (format "%d" pageno))
+      (user-id (format "%d" (user-uid)))
+      (user-name (format "%d" (user-login-name)))
+      (t (error 'invalid-argument "Unrecognized print-context property"
+               prop)))))
+
+(defun generic-page-setup ()
+  "Display the Page Setup dialog box.
+Changes made are recorded internally."
+  (interactive)
+  (let* ((d (Printer-get-device))
+        (props
+         (condition-case err
+             (make-dialog-box 'page-setup :device d
+                              :properties default-msprinter-frame-plist)
+           (error
+            (Printer-clear-device)
+            (signal (car err) (cdr err))))))
+    (while props
+      (setq default-msprinter-frame-plist
+           (plist-put default-msprinter-frame-plist (car props) (cadr props)))
+      (setq props (cddr props)))))
+
+(defun generic-print-buffer (&optional buffer display-print-dialog)
+  "Print buffer BUFFER using a printing method appropriate to the O.S. being run.
+Under Unix, `lpr' is normally used to spool out a no-frills version of the
+buffer, or the `ps-print' package is used to pretty-print the buffer to a
+PostScript printer.  Under MS Windows, the built-in printing support is used.
+
+If DISPLAY-PRINT-DIALOG is t, the print dialog will first be
+displayed, allowing the user to select various printing settings
+\(e.g. which printer to print to, the range of pages, number of copies,
+modes such landscape/portrait/2-up/4-up [2 or 4 (small!) logical pages
+per physical page], etc.).  At this point the user can cancel the printing
+operation using the dialog box, and `generic-print-buffer' will not print
+anything.  When called interactively, use a prefix arg to suppress the
+display of the print dialog box.
+
+If BUFFER is nil or omitted, the current buffer is used."
+  (interactive (list nil (not current-prefix-arg)))
+  (condition-case err
+      (let* ((print-region (and (interactive-p) (region-active-p)))
+            (start (if print-region (region-beginning) (point-min buffer)))
+            (end (if print-region (region-end) (point-max buffer))))
+       (if (or (not (valid-specifier-tag-p 'msprinter))
+               (not display-print-dialog))
+           (generic-print-region start end buffer)
+         (let* ((d (Printer-get-device))
+                (props (make-dialog-box 'print :device d
+                                        :allow-selection print-region
+                                        :selected-page-button
+                                        (if print-region 'selection 'all))))
+           (and props
+                (let ((really-print-region
+                       (eq (plist-get props 'selected-page-button) 'selection)))
+                  (generic-print-region (if really-print-region start
+                                          (point-min buffer))
+                                        (if really-print-region end
+                                          (point-max buffer))
+                                        buffer d props))))))
+    (error
+     ;; Make sure we catch all errors thrown from the native code.
+     (Printer-clear-device)
+     (signal (car err) (cdr err)))))
+
+(defun generic-print-region (start end &optional buffer print-device props)
+  "Print region using a printing method appropriate to the O.S. being run.
+The region between START and END of BUFFER (defaults to the current
+buffer) is printed.
+
+Under Unix, `lpr' is normally used to spool out a no-frills version of the
+buffer, or the `ps-print' package is used to pretty-print the buffer to a
+PostScript printer.  Under MS Windows, the built-in printing support is used.
+
+Optional PRINT-DEVICE is a device, already created, to use to do the
+printing.  This is typically used when this function was invoked from
+`generic-print-buffer' and it displayed a dialog box.  That function created
+the device, and then the dialog box stuffed it with the user's selections
+of how the buffer should be printed.
+
+PROPS, if given, is typically the plist returned from the call to
+`make-dialog-box' that displayed the Print box.  It contains properties
+relevant to us when we print.  
+
+Recognized properties are the same as those in `make-dialog-box':
+
+  name       Printer device name.  If omitted, the current system-selected
+             printer will be used.
+  from-page  First page to print, 1-based. If omitted, printing starts from
+             the beginning.
+  to-page    Last page to print, inclusive, If omitted, printing ends at
+             the end.
+  copies     Number of copies to print.  If omitted, one copy is printed."
+  (cond ((valid-specifier-tag-p 'msprinter)
+        ;; loop, printing one copy of document per loop.  kill and
+        ;; re-create the frame each time so that we eject the piece
+        ;; of paper at the end even if we're printing more than one
+        ;; page per sheet of paper.
+        (let ((copies (plist-get props 'copies 1))
+              ;; This is not relevant to printing and can mess up
+              ;; msprinter frame sizing
+              default-frame-plist)
+          (while (> copies 0)
+            (let (d f header-buffer footer-buffer)
+              (setq buffer (decode-buffer buffer))
+              (unwind-protect
+                  (with-current-buffer buffer
+                    (save-restriction
+                      (narrow-to-region start end)
+                      (setq d (or print-device (Printer-get-device)))
+                      (setq f (make-frame
+                               (list* 'name
+                                      (concat
+                                       (substitute ?_ ?. (buffer-name buffer))
+                                       " - XEmacs")
+                                      '(menubar-visible-p
+                                        nil
+                                        has-modeline-p nil
+                                        default-toolbar-visible-p nil
+                                        default-gutter-visible-p nil
+                                        minibuffer none
+                                        modeline-shadow-thickness 0
+                                        vertical-scrollbar-visible-p nil
+                                        horizontal-scrollbar-visible-p nil
+                                        [default foreground] "black"
+                                        [default background] "white"))
+                               d))
+                      (let* ((w (frame-root-window f))
+                             (vertdpi
+                              (cdr (device-system-metric d 'device-dpi)))
+                             (pixel-vertical-clip-threshold (/ vertdpi 2))
+                             (from-page (plist-get props 'from-page 1))
+                             (to-page (plist-get props 'to-page))
+                             (context (make-Print-context
+                                       :start-time (current-time)
+                                       ;; #### bogus! we need accessors for
+                                       ;; print-settings objects.
+                                       :printer-name
+                                       (or (plist-get props 'name)
+                                           printer-name
+                                           (mswindows-get-default-printer))))
+                             header-window
+                             footer-window)
+
+                        (when printer-page-header
+                          (let ((window-min-height 2))
+                            (setq header-window w)
+                            (setq w (split-window w 2)))
+                          (setq header-buffer
+                                (generate-new-buffer " *header*"))
+                          (set-window-buffer header-window header-buffer))
+
+                        (when printer-page-footer
+                          (let ((window-min-height 2))
+                            (setq footer-window
+                                  (split-window w (- (window-height w) 2))))
+                          (setq footer-buffer
+                                (generate-new-buffer " *footer*"))
+                          (set-window-buffer footer-window footer-buffer))
+
+                        (setf (Print-context-window context) w)
+
+                        (let ((last-end 0) ; bufpos at end of previous page
+                              reached-end ; t if we've reached the end of the
+                                       ; text we're printing
+                              (pageno 1))
+                          (set-window-buffer w buffer)
+                          (set-window-start w start)
+
+                          ;; loop, printing one page per loop
+                          (while (and (not reached-end)
+                                      ;; stop at end of region of text or
+                                      ;; outside of ranges of pages given
+                                      (or (not to-page) (<= pageno to-page)))
+
+                            (setf (Print-context-pageno context) pageno)
+
+                            ;; only actually print the page if it's in the
+                            ;; range.
+                            (when (>= pageno from-page)
+                              (when printer-page-header
+                                (with-current-buffer header-buffer
+                                  (erase-buffer)
+                                  (generate-header-line printer-page-header
+                                                        context)
+                                  (goto-char (point-min))
+                                  (set-window-start header-window
+                                                    (point-min))))
+
+                              (when printer-page-footer
+                                (with-current-buffer footer-buffer
+                                  (erase-buffer)
+                                  (insert "\n")
+                                  (generate-header-line printer-page-footer
+                                                        context)
+                                  (goto-char (point-min))
+                                  (set-window-start footer-window
+                                                    (point-min))))
+
+                              (redisplay-frame f t)
+                              (print-job-eject-page f)
+                              )
+                            ;; but use the GUARANTEE argument to `window-end'
+                            ;; so that we get the right value even if we
+                            ;; didn't do a redisplay.
+                            (let ((this-end (window-end w t))
+                                  (pixvis
+                                   (window-last-line-visible-height w)))
+                              ;; in case we get stuck somewhere, bow out
+                              ;; rather than printing an infinite number of
+                              ;; pages.  #### this will fail with an image
+                              ;; bigger than an entire page.  but we really
+                              ;; need this check here.  we should be more
+                              ;; clever in our check, to deal with this case.
+                              (if (or (= this-end last-end)
+                                      ;; #### fuckme!  window-end returns a
+                                      ;; value outside of the valid range of
+                                      ;; buffer positions!!!
+                                      (>= this-end end))
+                                  (setq reached-end t)
+                                (setq last-end this-end)
+                                (set-window-start w this-end)
+                                (if pixvis
+                                    (with-selected-window w
+                                      ;; #### scroll-down should take a
+                                      ;; window arg.
+                                      (let ((window-pixel-scroll-increment
+                                             pixvis))
+                                        (scroll-down 1))))))
+                            (setq pageno (1+ pageno))))))
+                    (and f (delete-frame f))
+                    (and header-buffer (kill-buffer header-buffer))
+                    (and footer-buffer (kill-buffer footer-buffer)))))
+            (setq copies (1- copies)))))
+       ((and (not (eq system-type 'windows-nt))
+             (fboundp 'lpr-region))
+        (lpr-region start end))
+       (t (error "No print support available"))))