|
406
|
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 ; "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 '(name "Test!"
|
|
|
163 menubar-visible-p nil
|
|
|
164 has-modeline-p nil
|
|
|
165 default-toolbar-visible-p nil
|
|
|
166 default-gutter-visible-p nil
|
|
|
167 minibuffer none
|
|
|
168 modeline-shadow-thickness 0
|
|
|
169 vertical-scrollbar-visible-p nil
|
|
|
170 horizontal-scrollbar-visible-p nil)
|
|
|
171 d))
|
|
|
172 (let* ((w (frame-root-window f))
|
|
|
173 (vertdpi (cdr (device-system-metric d 'device-dpi)))
|
|
|
174 (pixel-vertical-clip-threshold (/ vertdpi 2))
|
|
|
175 (last-end 0)
|
|
|
176 done)
|
|
|
177 (set-window-buffer w (or buf (current-buffer)))
|
|
|
178 (set-window-start w b)
|
|
|
179 (while (not done)
|
|
|
180 (redisplay-frame f)
|
|
|
181 (print-job-eject-page f)
|
|
|
182 (let ((end (window-end w))
|
|
|
183 (pixvis (window-last-line-visible-height w)))
|
|
|
184 ;; in case we get stuck somewhere, bow out
|
|
|
185 ;; rather than printing an infinite number of
|
|
|
186 ;; pages. #### this will fail with an image
|
|
|
187 ;; bigger than an entire page. but we really
|
|
|
188 ;; need this check here. we should be more
|
|
|
189 ;; clever in our check, to deal with this case.
|
|
|
190 (if (or (= end last-end)
|
|
|
191 ;; #### fuckme! window-end returns a value
|
|
|
192 ;; outside of the valid range of buffer
|
|
|
193 ;; positions!!!
|
|
|
194 (>= end e))
|
|
|
195 (setq done t)
|
|
|
196 (setq last-end end)
|
|
|
197 (set-window-start w end)
|
|
|
198 (if pixvis
|
|
|
199 (save-selected-window
|
|
|
200 (select-window w)
|
|
|
201 ;; #### scroll-down should take a window arg.
|
|
|
202 (let ((window-pixel-scroll-increment pixvis))
|
|
|
203 (scroll-down 1)))))))))
|
|
|
204 (and f (delete-frame f))
|
|
|
205 (and d (delete-device d))
|
|
|
206 )))
|
|
|
207 ((and (not (eq system-type 'windows-nt))
|
|
|
208 (fboundp 'lpr-buffer))
|
|
|
209 (lpr-region buf))
|
|
|
210 (t (error "No print support available"))))
|
