Mercurial > hg > xemacs-beta

comparison lisp/printer.el @ 442:abe6d1db359e r21-2-36

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-36
author cvs
date Mon, 13 Aug 2007 11:35:02 +0200
parents
children 576fb035e263
comparison
equal deleted inserted replaced
441:72a7cfa4a488 442:abe6d1db359e
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"))))