Mercurial > hg > xemacs-beta

comparison lisp/printer.el @ 444:576fb035e263 r21-2-37

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-37
author cvs
date Mon, 13 Aug 2007 11:36:19 +0200
parents abe6d1db359e
children b3bbdc4058d7
comparison
equal deleted inserted replaced
443:a8296e22da4e 444:576fb035e263
132 page Current printout page number, 1-based 132 page Current printout page number, 1-based
133 user-id User logon id 133 user-id User logon id
134 user-name User full name" 134 user-name User full name"
135 (error "not yet implemented")) 135 (error "not yet implemented"))
136 136
137 (defun generic-print-buffer (&optional buf) 137 (defun generic-print-buffer (&optional buffer)
138 "Print buffer BUF using a printing method appropriate to the O.S. being run. 138 "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 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 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. 141 PostScript printer. Under MS Windows, the built-in printing support is used.
142 142
143 If BUF is nil or omitted, the current buffer is used." 143 If BUFFER is nil or omitted, the current buffer is used."
144 (interactive) 144 (interactive)
145 (generic-print-region (point-min buf) (point-max buf) buf)) 145 (generic-print-region (point-min buffer) (point-max buffer) buffer))
146 146
147 (defun generic-print-region (b e &optional buf) 147 (defun generic-print-region (start end &optional buffer)
148 "Print region using a printing method appropriate to the O.S. being run. 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. 149 The region between START and END of BUFFER (defaults to the current
150 buffer) is printed.
150 151
151 Under Unix, `lpr' is normally used to spool out a no-frills version of the 152 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 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 PostScript printer. Under MS Windows, the built-in printing support is used."
154 (cond ((valid-specifier-tag-p 'msprinter) 155 (cond ((valid-specifier-tag-p 'msprinter)
155 (let (d f) 156 (let (d f)
156 (setq buf (decode-buffer buf)) 157 (setq buffer (decode-buffer buffer))
157 (unwind-protect 158 (unwind-protect
158 (progn 159 (progn
159 (setq d (make-device 'msprinter printer-name)) 160 (setq d (make-device 'msprinter printer-name))
160 (setq f (make-frame 161 (setq f (make-frame
161 (list* 'name (concat (substitute ?_ ?. 162 (list* 'name (concat (substitute ?_ ?.
162 (buffer-name buf)) 163 (buffer-name buffer))
163 " - XEmacs") 164 " - XEmacs")
164 '(menubar-visible-p nil 165 '(menubar-visible-p nil
165 has-modeline-p nil 166 has-modeline-p nil
166 default-toolbar-visible-p nil 167 default-toolbar-visible-p nil
167 default-gutter-visible-p nil 168 default-gutter-visible-p nil
173 (let* ((w (frame-root-window f)) 174 (let* ((w (frame-root-window f))
174 (vertdpi (cdr (device-system-metric d 'device-dpi))) 175 (vertdpi (cdr (device-system-metric d 'device-dpi)))
175 (pixel-vertical-clip-threshold (/ vertdpi 2)) 176 (pixel-vertical-clip-threshold (/ vertdpi 2))
176 (last-end 0) 177 (last-end 0)
177 done) 178 done)
178 (set-window-buffer w (or buf (current-buffer))) 179 (set-window-buffer w (or buffer (current-buffer)))
179 (set-window-start w b) 180 (set-window-start w start)
180 (while (not done) 181 (while (not done)
181 (redisplay-frame f) 182 (redisplay-frame f)
182 (print-job-eject-page f) 183 (print-job-eject-page f)
183 (let ((end (window-end w)) 184 (let ((this-end (window-end w))
184 (pixvis (window-last-line-visible-height w))) 185 (pixvis (window-last-line-visible-height w)))
185 ;; in case we get stuck somewhere, bow out 186 ;; in case we get stuck somewhere, bow out
186 ;; rather than printing an infinite number of 187 ;; rather than printing an infinite number of
187 ;; pages. #### this will fail with an image 188 ;; pages. #### this will fail with an image
188 ;; bigger than an entire page. but we really 189 ;; bigger than an entire page. but we really
189 ;; need this check here. we should be more 190 ;; need this check here. we should be more
190 ;; clever in our check, to deal with this case. 191 ;; clever in our check, to deal with this case.
191 (if (or (= end last-end) 192 (if (or (= this-end last-end)
192 ;; #### fuckme! window-end returns a value 193 ;; #### fuckme! window-end returns a value
193 ;; outside of the valid range of buffer 194 ;; outside of the valid range of buffer
194 ;; positions!!! 195 ;; positions!!!
195 (>= end e)) 196 (>= this-end end))
196 (setq done t) 197 (setq done t)
197 (setq last-end end) 198 (setq last-end this-end)
198 (set-window-start w end) 199 (set-window-start w this-end)
199 (if pixvis 200 (if pixvis
200 (save-selected-window 201 (save-selected-window
201 (select-window w) 202 (select-window w)
202 ;; #### scroll-down should take a window arg. 203 ;; #### scroll-down should take a window arg.
203 (let ((window-pixel-scroll-increment pixvis)) 204 (let ((window-pixel-scroll-increment pixvis))
205 (and f (delete-frame f)) 206 (and f (delete-frame f))
206 (and d (delete-device d)) 207 (and d (delete-device d))
207 ))) 208 )))
208 ((and (not (eq system-type 'windows-nt)) 209 ((and (not (eq system-type 'windows-nt))
209 (fboundp 'lpr-buffer)) 210 (fboundp 'lpr-buffer))
210 (lpr-region buf)) 211 (lpr-region buffer))
211 (t (error "No print support available")))) 212 (t (error "No print support available"))))