|
442
|
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
|
|
|
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 buf)
|
|
|
138 "Print buffer BUF 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 BUF is nil or omitted, the current buffer is used."
|
|
|
144 (interactive)
|
|
|
145 (generic-print-region (point-min buf) (point-max buf) buf))
|
|
|
146
|
|
|
147 (defun generic-print-region (b e &optional buf)
|
|
|
148 "Print region using a printing method appropriate to the O.S. being run.
|
|
|
149 The region between B and E of BUF (defaults to the current buffer) is printed.
|
|
|
150
|
|
|
151 Under Unix, `lpr' is normally used to spool out a no-frills version of the
|
|
|
152 buffer, or the `ps-print' package is used to pretty-print the buffer to a
|
|
|
153 PostScript printer. Under MS Windows, the built-in printing support is used."
|
|
|
154 (cond ((valid-specifier-tag-p 'msprinter)
|
|
|
155 (let (d f)
|
|
|
156 (setq buf (decode-buffer buf))
|
|
|
157 (unwind-protect
|
|
|
158 (progn
|
|
|
159 (setq d (make-device 'msprinter printer-name))
|
|
|
160 (setq f (make-frame
|
|
|
161 (list* 'name (concat (substitute ?_ ?.
|
|
|
162 (buffer-name buf))
|
|
|
163 " - XEmacs")
|
|
|
164 '(menubar-visible-p nil
|
|
|
165 has-modeline-p nil
|
|
|
166 default-toolbar-visible-p nil
|
|
|
167 default-gutter-visible-p nil
|
|
|
168 minibuffer none
|
|
|
169 modeline-shadow-thickness 0
|
|
|
170 vertical-scrollbar-visible-p nil
|
|
|
171 horizontal-scrollbar-visible-p nil))
|
|
|
172 d))
|
|
|
173 (let* ((w (frame-root-window f))
|
|
|
174 (vertdpi (cdr (device-system-metric d 'device-dpi)))
|
|
|
175 (pixel-vertical-clip-threshold (/ vertdpi 2))
|
|
|
176 (last-end 0)
|
|
|
177 done)
|
|
|
178 (set-window-buffer w (or buf (current-buffer)))
|
|
|
179 (set-window-start w b)
|
|
|
180 (while (not done)
|
|
|
181 (redisplay-frame f)
|
|
|
182 (print-job-eject-page f)
|
|
|
183 (let ((end (window-end w))
|
|
|
184 (pixvis (window-last-line-visible-height w)))
|
|
|
185 ;; in case we get stuck somewhere, bow out
|
|
|
186 ;; rather than printing an infinite number of
|
|
|
187 ;; pages. #### this will fail with an image
|
|
|
188 ;; bigger than an entire page. but we really
|
|
|
189 ;; need this check here. we should be more
|
|
|
190 ;; clever in our check, to deal with this case.
|
|
|
191 (if (or (= end last-end)
|
|
|
192 ;; #### fuckme! window-end returns a value
|
|
|
193 ;; outside of the valid range of buffer
|
|
|
194 ;; positions!!!
|
|
|
195 (>= end e))
|
|
|
196 (setq done t)
|
|
|
197 (setq last-end end)
|
|
|
198 (set-window-start w end)
|
|
|
199 (if pixvis
|
|
|
200 (save-selected-window
|
|
|
201 (select-window w)
|
|
|
202 ;; #### scroll-down should take a window arg.
|
|
|
203 (let ((window-pixel-scroll-increment pixvis))
|
|
|
204 (scroll-down 1)))))))))
|
|
|
205 (and f (delete-frame f))
|
|
|
206 (and d (delete-device d))
|
|
|
207 )))
|
|
|
208 ((and (not (eq system-type 'windows-nt))
|
|
|
209 (fboundp 'lpr-buffer))
|
|
|
210 (lpr-region buf))
|
|
|
211 (t (error "No print support available"))))
|
