Mercurial > hg > xemacs-beta

comparison lisp/printer.el @ 510:5bdbc721d46a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2001-05-06 08:33:35 by ben] implement printing the selection when it's selected. force redisplay when set-charset-ccl-program called. if bytecomp or byte-optimize need recompiling, then load the .el version of them first, recompile them, and reload the .elc versions to recompile everything else (so we won't be waiting until the cows come home).
author ben
date Sun, 06 May 2001 08:33:41 +0000
parents 39ccc7dd8077
children 666d73d6ac56
comparison
equal deleted inserted replaced
509:68eb53e4b7e5 510:5bdbc721d46a
251 anything. When called interactively, use a prefix arg to suppress the 251 anything. When called interactively, use a prefix arg to suppress the
252 display of the print dialog box. 252 display of the print dialog box.
253 253
254 If BUFFER is nil or omitted, the current buffer is used." 254 If BUFFER is nil or omitted, the current buffer is used."
255 (interactive (list nil (not current-prefix-arg))) 255 (interactive (list nil (not current-prefix-arg)))
256 (if (or (not (valid-specifier-tag-p 'msprinter)) 256 (let* ((print-region (and (interactive-p) (region-active-p)))
257 (not display-print-dialog)) 257 (start (if print-region (region-beginning) (point-min buffer)))
258 (generic-print-region (point-min buffer) (point-max buffer) buffer) 258 (end (if print-region (region-end) (point-max buffer))))
259 (let* ((d (Printer-get-device)) 259 (if (or (not (valid-specifier-tag-p 'msprinter))
260 (props (condition-case err 260 (not display-print-dialog))
261 (make-dialog-box 'print :device d) 261 (generic-print-region start end buffer)
262 (error 262 (let* ((d (Printer-get-device))
263 (Printer-clear-device) 263 (props (condition-case err
264 (signal (car err) (cdr err)))))) 264 (make-dialog-box 'print :device d
265 (and props (generic-print-region (point-min buffer) 265 :allow-selection print-region
266 (point-max buffer) buffer 266 :selected-page-button
267 d props))))) 267 (if print-region 'selection 'all))
268 (error
269 (Printer-clear-device)
270 (signal (car err) (cdr err))))))
271 (and props
272 (let ((really-print-region
273 (eq (plist-get props 'selected-page-button) 'selection)))
274 (generic-print-region (if really-print-region start
275 (point-min buffer))
276 (if really-print-region end
277 (point-max buffer))
278 buffer d props)))))))
268 279
269 (defun generic-print-region (start end &optional buffer print-device props) 280 (defun generic-print-region (start end &optional buffer print-device props)
270 "Print region using a printing method appropriate to the O.S. being run. 281 "Print region using a printing method appropriate to the O.S. being run.
271 The region between START and END of BUFFER (defaults to the current 282 The region between START and END of BUFFER (defaults to the current
272 buffer) is printed. 283 buffer) is printed.
293 the beginning. 304 the beginning.
294 to-page Last page to print, inclusive, If omitted, printing ends at 305 to-page Last page to print, inclusive, If omitted, printing ends at
295 the end. 306 the end.
296 copies Number of copies to print. If omitted, one copy is printed." 307 copies Number of copies to print. If omitted, one copy is printed."
297 (cond ((valid-specifier-tag-p 'msprinter) 308 (cond ((valid-specifier-tag-p 'msprinter)
298 (let (d f header-buffer footer-buffer) 309 ;; loop, printing one copy of document per loop. kill and
299 (setq buffer (decode-buffer buffer)) 310 ;; re-create the frame each time so that we eject the piece
300 (unwind-protect 311 ;; of paper at the end even if we're printing more than one
301 (progn 312 ;; page per sheet of paper.
302 (setq d (or print-device (Printer-get-device))) 313 (let ((copies (plist-get props 'copies 1)))
303 (setq f (make-frame 314 (while (> copies 0)
304 (list* 'name (concat 315 (let (d f header-buffer footer-buffer)
316 (setq buffer (decode-buffer buffer))
317 (unwind-protect
318 (with-current-buffer buffer
319 (save-restriction
320 (narrow-to-region start end)
321 (setq d (or print-device (Printer-get-device)))
322 (setq f (make-frame
323 (list* 'name
324 (concat
305 (substitute ?_ ?. (buffer-name buffer)) 325 (substitute ?_ ?. (buffer-name buffer))
306 " - XEmacs") 326 " - XEmacs")
307 '(menubar-visible-p 327 '(menubar-visible-p
308 nil 328 nil
309 has-modeline-p nil 329 has-modeline-p nil
310 default-toolbar-visible-p nil 330 default-toolbar-visible-p nil
311 default-gutter-visible-p nil 331 default-gutter-visible-p nil
312 minibuffer none 332 minibuffer none
313 modeline-shadow-thickness 0 333 modeline-shadow-thickness 0
314 vertical-scrollbar-visible-p nil 334 vertical-scrollbar-visible-p nil
315 horizontal-scrollbar-visible-p nil)) 335 horizontal-scrollbar-visible-p nil))
316 d)) 336 d))
317 (let* ((w (frame-root-window f)) 337 (let* ((w (frame-root-window f))
318 (vertdpi (cdr (device-system-metric d 'device-dpi))) 338 (vertdpi
319 (pixel-vertical-clip-threshold (/ vertdpi 2)) 339 (cdr (device-system-metric d 'device-dpi)))
320 (from-page (plist-get props 'from-page 1)) 340 (pixel-vertical-clip-threshold (/ vertdpi 2))
321 (to-page (plist-get props 'to-page)) 341 (from-page (plist-get props 'from-page 1))
322 (copies (plist-get props 'copies 1)) 342 (to-page (plist-get props 'to-page))
323 (context (make-Print-context 343 (context (make-Print-context
324 :start-time (current-time) 344 :start-time (current-time)
325 ;; #### bogus! we need accessors for 345 ;; #### bogus! we need accessors for
326 ;; print-settings objects. 346 ;; print-settings objects.
327 :printer-name 347 :printer-name
328 (or (plist-get props 'name) 348 (or (plist-get props 'name)
329 printer-name 349 printer-name
330 (mswindows-get-default-printer)))) 350 (mswindows-get-default-printer))))
331 header-window 351 header-window
332 footer-window) 352 footer-window)
333 353
334 (when printer-page-header 354 (when printer-page-header
335 (let ((window-min-height 2)) 355 (let ((window-min-height 2))
336 (setq header-window w) 356 (setq header-window w)
337 (setq w (split-window w 2))) 357 (setq w (split-window w 2)))
338 (setq header-buffer (generate-new-buffer " *header*")) 358 (setq header-buffer
339 (set-window-buffer header-window header-buffer)) 359 (generate-new-buffer " *header*"))
340 360 (set-window-buffer header-window header-buffer))
341 (when printer-page-footer 361
342 (let ((window-min-height 2)) 362 (when printer-page-footer
343 (setq footer-window 363 (let ((window-min-height 2))
344 (split-window w (- (window-height w) 2)))) 364 (setq footer-window
345 (setq footer-buffer (generate-new-buffer " *footer*")) 365 (split-window w (- (window-height w) 2))))
346 (set-window-buffer footer-window footer-buffer)) 366 (setq footer-buffer
347 367 (generate-new-buffer " *footer*"))
348 (setf (Print-context-window context) w) 368 (set-window-buffer footer-window footer-buffer))
349 369
350 ;; loop, printing one copy of document per loop 370 (setf (Print-context-window context) w)
351 (while (> copies 0) 371
352 (let ((last-end 0) ; bufpos at end of previous page 372 (let ((last-end 0) ; bufpos at end of previous page
353 reached-end ; t if we've reached the end of the 373 reached-end ; t if we've reached the end of the
354 ; text we're printing 374 ; text we're printing
355 (pageno 1)) 375 (pageno 1))
356 (set-window-buffer w buffer) 376 (set-window-buffer w buffer)
357 (set-window-start w start) 377 (set-window-start w start)
358 378
359 ;; loop, printing one page per loop 379 ;; loop, printing one page per loop
360 (while (and (not reached-end) 380 (while (and (not reached-end)
361 ;; stop at end of region of text or 381 ;; stop at end of region of text or
362 ;; outside of ranges of pages given 382 ;; outside of ranges of pages given
363 (or (not to-page) (<= pageno to-page))) 383 (or (not to-page) (<= pageno to-page)))
364 384
365 (setf (Print-context-pageno context) pageno) 385 (setf (Print-context-pageno context) pageno)
366 386
367 ;; only actually print the page if it's in the 387 ;; only actually print the page if it's in the
368 ;; range. 388 ;; range.
369 (when (>= pageno from-page) 389 (when (>= pageno from-page)
370 (when printer-page-header 390 (when printer-page-header
371 (with-current-buffer header-buffer 391 (with-current-buffer header-buffer
372 (erase-buffer) 392 (erase-buffer)
373 (generate-header-line printer-page-header 393 (generate-header-line printer-page-header
374 context) 394 context)
375 (goto-char (point-min)) 395 (goto-char (point-min))
376 (set-window-start header-window (point-min)))) 396 (set-window-start header-window
377 397 (point-min))))
378 (when printer-page-footer 398
379 (with-current-buffer footer-buffer 399 (when printer-page-footer
380 (erase-buffer) 400 (with-current-buffer footer-buffer
381 (insert "\n") 401 (erase-buffer)
382 (generate-header-line printer-page-footer 402 (insert "\n")
383 context) 403 (generate-header-line printer-page-footer
384 (goto-char (point-min)) 404 context)
385 (set-window-start footer-window (point-min)))) 405 (goto-char (point-min))
386 406 (set-window-start footer-window
387 (redisplay-frame f t) 407 (point-min))))
388 (print-job-eject-page f) 408
389 ) 409 (redisplay-frame f t)
390 ;; but use the GUARANTEE argument to `window-end' 410 (print-job-eject-page f)
391 ;; so that we get the right value even if we 411 )
392 ;; didn't do a redisplay. 412 ;; but use the GUARANTEE argument to `window-end'
393 (let ((this-end (window-end w t)) 413 ;; so that we get the right value even if we
394 (pixvis (window-last-line-visible-height w))) 414 ;; didn't do a redisplay.
395 ;; in case we get stuck somewhere, bow out 415 (let ((this-end (window-end w t))
396 ;; rather than printing an infinite number of 416 (pixvis
397 ;; pages. #### this will fail with an image 417 (window-last-line-visible-height w)))
398 ;; bigger than an entire page. but we really 418 ;; in case we get stuck somewhere, bow out
399 ;; need this check here. we should be more 419 ;; rather than printing an infinite number of
400 ;; clever in our check, to deal with this case. 420 ;; pages. #### this will fail with an image
401 (if (or (= this-end last-end) 421 ;; bigger than an entire page. but we really
402 ;; #### fuckme! window-end returns a value 422 ;; need this check here. we should be more
403 ;; outside of the valid range of buffer 423 ;; clever in our check, to deal with this case.
404 ;; positions!!! 424 (if (or (= this-end last-end)
405 (>= this-end end)) 425 ;; #### fuckme! window-end returns a
406 (setq reached-end t) 426 ;; value outside of the valid range of
407 (setq last-end this-end) 427 ;; buffer positions!!!
408 (set-window-start w this-end) 428 (>= this-end end))
409 (if pixvis 429 (setq reached-end t)
410 (save-selected-window 430 (setq last-end this-end)
411 (select-window w) 431 (set-window-start w this-end)
412 ;; #### scroll-down should take a 432 (if pixvis
413 ;; window arg. 433 (with-selected-window w
414 (let ((window-pixel-scroll-increment 434 ;; #### scroll-down should take a
415 pixvis)) 435 ;; window arg.
416 (scroll-down 1)))))) 436 (let ((window-pixel-scroll-increment
417 (setq pageno (1+ pageno)))) 437 pixvis))
418 (setq copies (1- copies))))) 438 (scroll-down 1))))))
419 (and f (delete-frame f)) 439 (setq pageno (1+ pageno))))))
420 (and header-buffer (kill-buffer header-buffer)) 440 (and f (delete-frame f))
421 (and footer-buffer (kill-buffer footer-buffer)) 441 (and header-buffer (kill-buffer header-buffer))
422 ))) 442 (and footer-buffer (kill-buffer footer-buffer)))))
443 (setq copies (1- copies)))))
423 ((and (not (eq system-type 'windows-nt)) 444 ((and (not (eq system-type 'windows-nt))
424 (fboundp 'lpr-region)) 445 (fboundp 'lpr-region))
425 (lpr-region buffer)) 446 (lpr-region buffer))
426 (t (error "No print support available")))) 447 (t (error "No print support available"))))