;;; ps-print.el --- print text from the buffer as PostScript
-;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
-;; Free Software Foundation, Inc.
+;; Copyright (C) 1993-2011 Free Software Foundation, Inc.
;; Author: Jim Thompson (was <thompson@wg2.waii.com>)
;; Jacques Duthen (was <duthen@cegelec-red.fr>)
;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters)
;; Vinicius Jose Latorre <viniciusjl@ig.com.br>
;; Keywords: wp, print, PostScript
-;; Version: 7.3.3
+;; Version: 7.3.5
;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre
-(defconst ps-print-version "7.3.3"
- "ps-print.el, v 7.3.3 <2008/10/22 vinicius>
+(defconst ps-print-version "7.3.5"
+ "ps-print.el, v 7.3.5 <2009/12/23 vinicius>
Vinicius's last change version -- this file may have been edited as part of
Emacs without changes to the version number. When reporting bugs, please also
;; Acknowledgments
;; ---------------
;;
+;; Thanks to Eduard Wiebe <usenet@pusto.de> for fixing face
+;; background/foreground extraction.
+;;
;; Thanks to Friedrich Delgado Friedrichs <friedel@nomaden.org> for new label
;; printer page sizes.
;;
(require 'lpr)
-(or (featurep 'lisp-float-type)
- (error "`ps-print' requires floating point support"))
-
-
(if (featurep 'xemacs)
- ()
+ (or (featurep 'lisp-float-type)
+ (error "`ps-print' requires floating point support"))
(unless (and (boundp 'emacs-major-version)
(>= emacs-major-version 23))
(error "`ps-print' only supports Emacs 23 and higher")))
(defconst ps-windows-system
- (memq system-type '(emx win32 w32 mswindows ms-dos windows-nt)))
+ (memq system-type '(ms-dos windows-nt)))
(defconst ps-lp-system
(memq system-type '(usg-unix-v hpux irix)))
;; Load XEmacs/Emacs definitions
-(eval-and-compile (require 'ps-def))
+(require 'ps-def)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Interface to the command system
(defgroup postscript nil
- "PostScript Group."
+ "Support for printing and PostScript."
:tag "PostScript"
:version "20"
- :group 'emacs)
+ :group 'external)
(defgroup ps-print nil
"PostScript generator for Emacs."
;;;###autoload
(defcustom ps-page-dimensions-database
+ (purecopy
(list (list 'a4 (/ (* 72 21.0) 2.54) (/ (* 72 29.7) 2.54) "A4")
(list 'a3 (/ (* 72 29.7) 2.54) (/ (* 72 42.0) 2.54) "A3")
(list 'letter (* 72 8.5) (* 72 11.0) "Letter")
'(topcoatedpaper 396.0 136.0 "TopcoatedPaper150")
'(vhsface 205.0 127.0 "VHSFace")
'(vhsspine 400.0 50.0 "VHSSpine")
- '(zipdisk 156.0 136.0 "ZipDisk"))
+ '(zipdisk 156.0 136.0 "ZipDisk")))
"List associating a symbolic paper type to its width, height and doc media.
See `ps-paper-type'."
:type '(repeat (list :tag "Paper Type"
(ps-header-font-size-internal
(or ps-header-font-size-internal
(ps-get-font-size 'ps-header-font-size)))
+ (ps-footer-font-size-internal
+ (or ps-footer-font-size-internal
+ (ps-get-font-size 'ps-footer-font-size)))
(ps-header-title-font-size-internal
(or ps-header-title-font-size-internal
(ps-get-font-size 'ps-header-title-font-size)))
(buf (get-buffer-create "*Line-lengths*"))
(ifs ps-font-size-internal) ; initial font size
- (icw (ps-avg-char-width 'ps-font-for-text)) ; initial character width
(print-width (progn (ps-get-page-dimensions)
ps-print-width))
+ (icw (ps-avg-char-width 'ps-font-for-text)) ; initial character width
(ps-setup (ps-setup)) ; setup for the current buffer
(fs-min 5) ; minimum font size
cw-min ; minimum character width
(ps-header-font-size-internal
(or ps-header-font-size-internal
(ps-get-font-size 'ps-header-font-size)))
+ (ps-footer-font-size-internal
+ (or ps-footer-font-size-internal
+ (ps-get-font-size 'ps-footer-font-size)))
(ps-header-title-font-size-internal
(or ps-header-title-font-size-internal
(ps-get-font-size 'ps-header-title-font-size)))
(buf (get-buffer-create "*Nb-Pages*"))
(ils ps-line-spacing-internal) ; initial line spacing
(ifs ps-font-size-internal) ; initial font size
- (ilh (ps-line-height 'ps-font-for-text)) ; initial line height
(page-height (progn (ps-get-page-dimensions)
ps-print-height))
+ (ilh (ps-line-height 'ps-font-for-text)) ; initial line height
(ps-setup (ps-setup)) ; setup for the current buffer
(fs-min 4) ; minimum font size
lh-min ; minimum line height
(ps-output 'prologue (if (stringp args) (list args) args)))
(defun ps-flush-output ()
- (save-excursion
- (set-buffer ps-spool-buffer)
+ (with-current-buffer ps-spool-buffer
(goto-char (point-max))
(while ps-output-head
(let ((it (car ps-output-head)))
(defun ps-insert-file (fname)
(ps-flush-output)
- (save-excursion
- (set-buffer ps-spool-buffer)
+ (with-current-buffer ps-spool-buffer
(goto-char (point-max))
(insert-file-contents fname)))
(defun ps-get-boundingbox ()
- (save-excursion
- (set-buffer ps-spool-buffer)
+ (with-current-buffer ps-spool-buffer
(save-excursion
(if (re-search-forward ps-boundingbox-re nil t)
(vector (string-to-number ; lower x
;; coordinate adjustment to center image
;; around x and y position
(let ((box (ps-get-boundingbox)))
- (save-excursion
- (set-buffer ps-spool-buffer)
+ (with-current-buffer ps-spool-buffer
(save-excursion
(if (re-search-backward "^--back--" nil t)
(replace-match
ps-line-number-step
ps-zebra-stripe-height))))
;; spooling buffer
- (save-excursion
- (set-buffer ps-spool-buffer)
+ (with-current-buffer ps-spool-buffer
(goto-char (point-max))
(and (re-search-backward "^%%Trailer$" nil t)
(delete-region (match-beginning 0) (point-max))))
(ps-get-page-dimensions)
;; final check
(unless (listp ps-lpr-switches)
- (error "`ps-lpr-switches' value should be a list."))
+ (error "`ps-lpr-switches' value should be a list"))
(and ps-color-p
(equal ps-default-background ps-default-foreground)
(error
(memq attr '(foreground-color :foreground background-color :background)))
+(defun ps-face-extract-color (face-attrs)
+ (let ((color (cdr face-attrs)))
+ (if (listp color)
+ (car color)
+ color)))
+
+
(defun ps-face-attributes (face)
"Return face attribute vector.
return the attribute vector.
If FACE is not a valid face name, use default face."
+ (and (stringp face) (facep face) (setq face (intern face)))
(cond
(ps-black-white-faces-alist
(or (and (symbolp face)
(cons new-face ps-print-face-alist)))
new-face))))
((ps-face-foreground-color-p (car face))
- (vector 0 (cdr face) nil))
+ (vector 0 (ps-face-extract-color face) nil))
((ps-face-background-color-p (car face))
- (vector 0 nil (cdr face)))
+ (vector 0 nil (ps-face-extract-color face)))
(t
(vector 0 nil nil))))
(ps-face-attributes face-or-list))
;; only foreground color, not a `real' face
((ps-face-foreground-color-p (car face-or-list))
- (vector 0 (cdr face-or-list) nil))
+ (vector 0 (ps-face-extract-color face-or-list) nil))
;; only background color, not a `real' face
((ps-face-background-color-p (car face-or-list))
- (vector 0 nil (cdr face-or-list)))
+ (vector 0 nil (ps-face-extract-color face-or-list)))
;; list of faces
(t
(let ((effects 0)
(ps-face-background-name face))))
-;; to avoid compilation gripes
-(defalias 'ps-jitify 'jit-lock-fontify-now)
-(defalias 'ps-lazify 'lazy-lock-fontify-region)
-
+(declare-function jit-lock-fontify-now "jit-lock" (&optional start end))
+(declare-function lazy-lock-fontify-region "lazy-lock" (beg end))
;; to avoid compilation gripes
(defun ps-print-ensure-fontified (start end)
(cond ((and (boundp 'jit-lock-mode) (symbol-value 'jit-lock-mode))
- (ps-jitify start end))
+ (jit-lock-fontify-now start end))
((and (boundp 'lazy-lock-mode) (symbol-value 'lazy-lock-mode))
- (ps-lazify start end))))
+ (lazy-lock-fontify-region start end))))
(defun ps-generate-postscript-with-faces (from to)
(and ps-razzle-dazzle (message "Wrote %s" filename)))
;; Else, spool to the printer
(and ps-razzle-dazzle (message "Printing..."))
- (save-excursion
- (set-buffer ps-spool-buffer)
+ (with-current-buffer ps-spool-buffer
(let* ((coding-system-for-write 'raw-text-unix)
(ps-printer-name (or ps-printer-name
(and (boundp 'printer-name)
(error "Unprinted PostScript"))))
(cond ((fboundp 'add-hook)
- (funcall 'add-hook 'kill-emacs-hook 'ps-kill-emacs-check))
+ (unless noninteractive
+ (funcall 'add-hook 'kill-emacs-hook 'ps-kill-emacs-check)))
(kill-emacs-hook
(message "Won't override existing `kill-emacs-hook'"))
(t
;; But autoload them here to make the separation invisible.
\f
;;;### (autoloads (ps-mule-end-job ps-mule-begin-job ps-mule-initialize
-;;;;;; ps-multibyte-buffer) "ps-mule" "ps-mule.el" "8611812e601bd374ad6c457dcedc9675")
+;;;;;; ps-multibyte-buffer) "ps-mule" "ps-mule.el" "14536f28e0dcaa956901bb59ad86a875")
;;; Generated autoloads from ps-mule.el
(defvar ps-multibyte-buffer nil "\
(provide 'ps-print)
-;; arch-tag: fb06a585-1112-4206-885d-a57d95d50579
;;; ps-print.el ends here
HCoop / bpt / emacs.git / blobdiff