Mercurial > hg > xemacs-beta

comparison lisp/printer.el @ 491:b3bbdc4058d7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2001-04-30 09:26:20 by ben] fix mswindows printer support Implement headers and footers. Implement calling Print dialog box (#### but it doesn't quite work yet).
author ben
date Mon, 30 Apr 2001 09:26:20 +0000
parents 576fb035e263
children 98fb34b6fbe9
comparison
equal deleted inserted replaced
490:38fb9ae12edd 491:b3bbdc4058d7
66 Under Windows, use `mswindows-printer-list' to get names of installed 66 Under Windows, use `mswindows-printer-list' to get names of installed
67 printers." 67 printers."
68 :type 'string 68 :type 'string
69 :group 'printing) 69 :group 'printing)
70 70
71 (defcustom printer-page-header '(date buffer-name) 71 (defstruct Print-context pageno window start-time printer-name)
72
73 (defcustom printer-page-header '((face bold date) nil (face bold buffer-name))
72 "*Controls printed page header. 74 "*Controls printed page header.
73
74 #### not yet implemented.
75 75
76 This can be: 76 This can be:
77 - nil. Header is not printed. 77 - nil. Header is not printed.
78 - An fbound symbol or lambda expression. The function is called with 78 - An fbound symbol or lambda expression. The function is called with
79 one parameter, a print-context object, every time the headers need 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 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 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. 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 83 - A list of up to three elements, for left, center and right portions
84 of the header. Each of these can be 84 of the header. Each of these can be
85 - nil, not to print the portion 85 - nil, not to print the portion
86 - A string, which will be printed literally. 86 - A string, which will be printed literally.
87 - A predefined symbol, on of the following: 87 - A predefined symbol, on of the following:
88 printer-name Name of printer being printed to
88 short-file-name File name only, no path 89 short-file-name File name only, no path
89 long-file-name File name with its path 90 long-file-name File name with its path
90 buffer-name Buffer name 91 buffer-name Buffer name
91 date Date current when printing started 92 date Date current when printing started
92 time Time current when printing started 93 time Time current when printing started
93 page Current printout page number, 1-based 94 page Current printout page number, 1-based
94 user-id User logon id 95 user-id User logon id
95 user-name User full name 96 user-name User full name
97 - A list of three elements: (face FACE-NAME EXPR). EXPR is any of the
98 items given here. The item will be displayed in the given face.
96 - A cons of an extent and any of the items given here. The item will 99 - 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 100 be displayed using the extent's face, begin-glyph and end-glyph
98 properties. 101 properties.
99 - A list, each element of which is any of the items given here. 102 - 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, 103 Each element of the list is rendered in sequence. For example,
103 a print-context object, as above. The return value is treated as 106 a print-context object, as above. The return value is treated as
104 if it was literally specified: i.e. it will be reprocessed." 107 if it was literally specified: i.e. it will be reprocessed."
105 :type 'sexp 108 :type 'sexp
106 :group 'printing) 109 :group 'printing)
107 110
108 (defcustom printer-page-footer '(nil page) 111 (defcustom printer-page-footer '(nil (face bold ("Page " page)))
109 "*Controls printed page footer. 112 "*Controls printed page footer.
110
111 #### not yet implemented.
112 113
113 Format is the same as `printer-page-header'." 114 Format is the same as `printer-page-header'."
114 :type 'sexp 115 :type 'sexp
115 :group 'printing) 116 :group 'printing)
116 117
118 (defun generate-header-element (element context)
119 (cond ((null element) nil)
120 ((stringp element) (insert element))
121 ((memq element '(printer-name
122 short-file-name long-file-name buffer-name
123 date time page user-id user-name))
124 (insert (print-context-property context element)))
125 ((and (consp element) (eq 'face (car element)))
126 (let ((p (point)))
127 (generate-header-element (third element) context)
128 (let ((x (make-extent p (point))))
129 (set-extent-face x (second element)))))
130 ((and (consp element) (extentp (car element)))
131 (let ((p (point)))
132 (generate-header-element (cdr element) context)
133 (let ((x (make-extent p (point))))
134 (set-extent-face x (extent-face (car element)))
135 (set-extent-begin-glyph x (extent-begin-glyph (car element)))
136 (set-extent-end-glyph x (extent-end-glyph (car element))))))
137 ((listp element)
138 (mapcar #'(lambda (el) (generate-header-element el context))
139 element))
140 ((functionp element)
141 (generate-header-element (funcall element context) context))
142 (t (error 'invalid-argument "Unknown header element" element))))
143
144 (defun generate-header-line (spec context)
145 (let* ((left (first spec))
146 (middle (second spec))
147 (right (third spec))
148 (left-start (point))
149 (middle-start (progn (generate-header-element left context)
150 (point)))
151 (right-start (progn (generate-header-element middle context)
152 (point)))
153 (right-end (progn (generate-header-element right context)
154 (point)))
155 (left-width (- middle-start left-start))
156 (middle-width (- right-start middle-start))
157 (right-width (- right-end right-start))
158 (winwidth (- (window-width (Print-context-window context)) 1))
159 (spaces1 (max (- (/ (- winwidth middle-width) 2) left-width) 0))
160 (spaces2 (max (- (- winwidth right-width)
161 (+ left-width spaces1 middle-width))
162 0)))
163 (goto-char right-start)
164 (insert-char ?\ spaces2)
165 (goto-char middle-start)
166 (insert-char ?\ spaces1)))
167
117 (defun print-context-property (print-context prop) 168 (defun print-context-property (print-context prop)
118 "Return property PROP of PRINT-CONTEXT. 169 "Return property PROP of PRINT-CONTEXT.
119 170
120 Valid properties are 171 Valid properties are
121 172
122 print-buffer Buffer being printed. 173 print-buffer Buffer being printed
123 print-window Window on printer device containing print buffer. 174 print-window Window on printer device containing print buffer
124 print-frame Frame on printer device corresponding to current page. 175 print-frame Frame on printer device corresponding to current page
125 print-device Device referring to printer. 176 print-device Device referring to printer
126 printer-name Name of printer being printed to. 177 print-start-time Time current when printing started (`current-time' format)
178 print-page Current printout page number, 1-based
179 printer-name Name of printer being printed to
127 short-file-name File name only, no path 180 short-file-name File name only, no path
128 long-file-name File name with its path 181 long-file-name File name with its path
129 buffer-name Buffer name 182 buffer-name Buffer name
130 date Date current when printing started 183 date Date current when printing started (as a string)
131 time Time current when printing started 184 time Time current when printing started (as a string)
132 page Current printout page number, 1-based 185 page Current printout page number, 1-based (as a string)
133 user-id User logon id 186 user-id User logon id (as a string)
134 user-name User full name" 187 user-name User full name"
135 (error "not yet implemented")) 188 (let* ((window (Print-context-window print-context))
136 189 (pageno (Print-context-pageno print-context))
137 (defun generic-print-buffer (&optional buffer) 190 (start-time (Print-context-start-time print-context))
191 (printer-name (Print-context-printer-name print-context))
192 (buffer (window-buffer window)))
193 (case prop
194 (print-buffer buffer)
195 (print-window window)
196 (print-frame (window-frame window))
197 (print-device (frame-device (window-frame window)))
198 (print-start-time start-time)
199 (print-page pageno)
200 (printer-name printer-name)
201 (short-file-name (let ((name (buffer-file-name buffer)))
202 (if name (file-name-nondirectory name) "")))
203 (long-file-name (let ((name (buffer-file-name buffer)))
204 (or name "")))
205 (buffer-name (buffer-name buffer))
206 (date (format-time-string "%x" start-time))
207 (time (format-time-string "%X" start-time))
208 (page (format "%d" pageno))
209 (user-id (format "%d" (user-uid)))
210 (user-name (format "%d" (user-login-name)))
211 (t (error 'invalid-argument "Unrecognized print-context property"
212 prop)))))
213
214 (defun generic-print-buffer (&optional buffer display-print-dialog)
138 "Print buffer BUFFER using a printing method appropriate to the O.S. being run. 215 "Print buffer BUFFER 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 216 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 217 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. 218 PostScript printer. Under MS Windows, the built-in printing support is used.
142 219
220 If DISPLAY-PRINT-DIALOG is t, the print dialog will first be
221 displayed, allowing the user to select various printing settings
222 \(e.g. which printer to print to, the range of pages, number of copies,
223 modes such landscape/portrait/2-up/4-up [2 or 4 (small!) logical pages
224 per physical page], etc.). At this point the user can cancel the printing
225 operation using the dialog box, and `generic-print-buffer' will not print
226 anything. When called interactively, use a prefix arg to suppress the
227 display of the print dialog box.
228
143 If BUFFER is nil or omitted, the current buffer is used." 229 If BUFFER is nil or omitted, the current buffer is used."
144 (interactive) 230 ;; #### for some reason, displaying a dialog box makes the printing
145 (generic-print-region (point-min buffer) (point-max buffer) buffer)) 231 ;; fail unless y-or-n-p is called (see below). when this is fixed,
146 232 ;; remove one of the calls to `not' in the following line.
147 (defun generic-print-region (start end &optional buffer) 233 (interactive (list nil (not (not current-prefix-arg))))
234 (if (or (not (valid-specifier-tag-p 'msprinter))
235 (not display-print-dialog))
236 (generic-print-region (point-min buffer) (point-max buffer) buffer)
237 (let* ((d (make-device 'msprinter printer-name))
238 (props (make-dialog-box 'print :device d)))
239 (and props (generic-print-region (point-min buffer)
240 (point-max buffer) buffer
241 d props)))))
242
243 (defun generic-print-region (start end &optional buffer print-device props)
148 "Print region using a printing method appropriate to the O.S. being run. 244 "Print region using a printing method appropriate to the O.S. being run.
149 The region between START and END of BUFFER (defaults to the current 245 The region between START and END of BUFFER (defaults to the current
150 buffer) is printed. 246 buffer) is printed.
151 247
152 Under Unix, `lpr' is normally used to spool out a no-frills version of the 248 Under Unix, `lpr' is normally used to spool out a no-frills version of the
153 buffer, or the `ps-print' package is used to pretty-print the buffer to a 249 buffer, or the `ps-print' package is used to pretty-print the buffer to a
154 PostScript printer. Under MS Windows, the built-in printing support is used." 250 PostScript printer. Under MS Windows, the built-in printing support is used.
251
252 Optional PRINT-DEVICE is a device, already created, to use to do the
253 printing. This is typically used when this function was invoked from
254 `generic-print-buffer' and it displayed a dialog box. That function created
255 the device, and then the dialog box stuffed it with the user's selections
256 of how the buffer should be printed.
257
258 PROPS, if given, is typically the plist returned from the call to
259 `make-dialog-box' that displayed the Print box. It contains properties
260 relevant to us when we print.
261
262 Recognized properties are the same as those in `make-dialog-box':
263
264 name Printer device name. If omitted, the current system-selected
265 printer will be used.
266 from-page First page to print, 1-based. If omitted, printing starts from
267 the beginning.
268 to-page Last page to print, inclusive, If omitted, printing ends at
269 the end.
270 copies Number of copies to print. If omitted, one copy is printed."
155 (cond ((valid-specifier-tag-p 'msprinter) 271 (cond ((valid-specifier-tag-p 'msprinter)
156 (let (d f) 272 (let (d f header-buffer footer-buffer)
157 (setq buffer (decode-buffer buffer)) 273 (setq buffer (decode-buffer buffer))
158 (unwind-protect 274 (unwind-protect
159 (progn 275 (progn
160 (setq d (make-device 'msprinter printer-name)) 276 (setq d (or print-device
277 (make-device 'msprinter printer-name)))
161 (setq f (make-frame 278 (setq f (make-frame
162 (list* 'name (concat (substitute ?_ ?. 279 (list* 'name (concat
163 (buffer-name buffer)) 280 (substitute ?_ ?. (buffer-name buffer))
164 " - XEmacs") 281 " - XEmacs")
165 '(menubar-visible-p nil 282 '(menubar-visible-p
283 nil
166 has-modeline-p nil 284 has-modeline-p nil
167 default-toolbar-visible-p nil 285 default-toolbar-visible-p nil
168 default-gutter-visible-p nil 286 default-gutter-visible-p nil
169 minibuffer none 287 minibuffer none
170 modeline-shadow-thickness 0 288 modeline-shadow-thickness 0
172 horizontal-scrollbar-visible-p nil)) 290 horizontal-scrollbar-visible-p nil))
173 d)) 291 d))
174 (let* ((w (frame-root-window f)) 292 (let* ((w (frame-root-window f))
175 (vertdpi (cdr (device-system-metric d 'device-dpi))) 293 (vertdpi (cdr (device-system-metric d 'device-dpi)))
176 (pixel-vertical-clip-threshold (/ vertdpi 2)) 294 (pixel-vertical-clip-threshold (/ vertdpi 2))
177 (last-end 0) 295 (from-page (plist-get props 'from-page 1))
178 done) 296 (to-page (plist-get props 'to-page))
179 (set-window-buffer w (or buffer (current-buffer))) 297 (copies (plist-get props 'copies 1))
180 (set-window-start w start) 298 (context (make-Print-context
181 (while (not done) 299 :start-time (current-time)
182 (redisplay-frame f) 300 ;; #### bogus! we need accessors for
183 (print-job-eject-page f) 301 ;; print-settings objects.
184 (let ((this-end (window-end w)) 302 :printer-name
185 (pixvis (window-last-line-visible-height w))) 303 (or (plist-get props 'name)
186 ;; in case we get stuck somewhere, bow out 304 printer-name
187 ;; rather than printing an infinite number of 305 (mswindows-get-default-printer))))
188 ;; pages. #### this will fail with an image 306 header-window
189 ;; bigger than an entire page. but we really 307 footer-window)
190 ;; need this check here. we should be more 308
191 ;; clever in our check, to deal with this case. 309 (when printer-page-header
192 (if (or (= this-end last-end) 310 (let ((window-min-height 2))
193 ;; #### fuckme! window-end returns a value 311 (setq header-window w)
194 ;; outside of the valid range of buffer 312 (setq w (split-window w 2)))
195 ;; positions!!! 313 (setq header-buffer (generate-new-buffer " *header*"))
196 (>= this-end end)) 314 (set-window-buffer header-window header-buffer))
197 (setq done t) 315
198 (setq last-end this-end) 316 (when printer-page-footer
199 (set-window-start w this-end) 317 (let ((window-min-height 2))
200 (if pixvis 318 (setq footer-window
201 (save-selected-window 319 (split-window w (- (window-height w) 2))))
202 (select-window w) 320 (setq footer-buffer (generate-new-buffer " *footer*"))
203 ;; #### scroll-down should take a window arg. 321 (set-window-buffer footer-window footer-buffer))
204 (let ((window-pixel-scroll-increment pixvis)) 322
205 (scroll-down 1))))))))) 323 (setf (Print-context-window context) w)
324
325 ;; loop, printing one copy of document per loop
326 (while (> copies 0)
327 (let ((last-end 0) ; bufpos at end of previous page
328 reached-end ; t if we've reached the end of the
329 ; text we're printing
330 (pageno 1))
331 (set-window-buffer w buffer)
332 (set-window-start w start)
333
334 ;; loop, printing one page per loop
335 (while (and (not reached-end)
336 ;; stop at end of region of text or
337 ;; outside of ranges of pages given
338 (or (not to-page) (<= pageno to-page)))
339
340 (setf (Print-context-pageno context) pageno)
341
342 ;; only actually print the page if it's in the
343 ;; range.
344 (when (>= pageno from-page)
345 ;; none of these work.
346 ; (mapcar #'(lambda (foo)
347 ; (redisplay-device foo t))
348 ; (delete-if #'(lambda (foo)
349 ; (eq (device-type foo)
350 ; 'msprinter))
351 ; (device-list)))
352 ; (mapcar #'(lambda (foo)
353 ; (redraw-device foo t))
354 ; (delete-if #'(lambda (foo)
355 ; (eq (device-type foo)
356 ; 'msprinter))
357 ; (device-list)))
358 ; (sit-for 0.01)
359 ;; but this one sure as hell does.
360 ; (y-or-n-p "continue")
361 (when printer-page-header
362 (with-current-buffer header-buffer
363 (erase-buffer)
364 (generate-header-line printer-page-header
365 context)
366 (goto-char (point-min))
367 (set-window-start header-window (point-min))))
368
369 (when printer-page-footer
370 (with-current-buffer footer-buffer
371 (erase-buffer)
372 (insert "\n")
373 (generate-header-line printer-page-footer
374 context)
375 (goto-char (point-min))
376 (set-window-start footer-window (point-min))))
377
378 (redisplay-frame f)
379 (print-job-eject-page f)
380 )
381 ;; but use the GUARANTEE argument to `window-end'
382 ;; so that we get the right value even if we
383 ;; didn't do a redisplay.
384 (let ((this-end (window-end w t))
385 (pixvis (window-last-line-visible-height w)))
386 ;; in case we get stuck somewhere, bow out
387 ;; rather than printing an infinite number of
388 ;; pages. #### this will fail with an image
389 ;; bigger than an entire page. but we really
390 ;; need this check here. we should be more
391 ;; clever in our check, to deal with this case.
392 (if (or (= this-end last-end)
393 ;; #### fuckme! window-end returns a value
394 ;; outside of the valid range of buffer
395 ;; positions!!!
396 (>= this-end end))
397 (setq reached-end t)
398 (setq last-end this-end)
399 (set-window-start w this-end)
400 (if pixvis
401 (save-selected-window
402 (select-window w)
403 ;; #### scroll-down should take a
404 ;; window arg.
405 (let ((window-pixel-scroll-increment
406 pixvis))
407 (scroll-down 1))))))
408 (setq pageno (1+ pageno))))
409 (setq copies (1- copies)))))
206 (and f (delete-frame f)) 410 (and f (delete-frame f))
207 (and d (delete-device d)) 411 (and d (delete-device d))
412 (and header-buffer (kill-buffer header-buffer))
413 (and footer-buffer (kill-buffer footer-buffer))
208 ))) 414 )))
209 ((and (not (eq system-type 'windows-nt)) 415 ((and (not (eq system-type 'windows-nt))
210 (fboundp 'lpr-buffer)) 416 (fboundp 'lpr-buffer))
211 (lpr-region buffer)) 417 (lpr-region buffer))
212 (t (error "No print support available")))) 418 (t (error "No print support available"))))