Mercurial > hg > xemacs-beta

comparison lisp/printer.el @ 406:b8cc9ab3f761 r21-2-33

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-33
author cvs
date Mon, 13 Aug 2007 11:17:09 +0200
parents
children de805c49cfc1
comparison
equal deleted inserted replaced
405:0e08f63c74d2 406:b8cc9ab3f761
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"))))