;;; ps-print.el --- Print text from the buffer as PostScript
-;; Copyright (C) 1993-2000 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 2000 Free Software Foundation, Inc.
;; Author: Jim Thompson (was <thompson@wg2.waii.com>)
;; Author: Jacques Duthen (was <duthen@cegelec-red.fr>)
;; Maintainer: Kenichi Handa <handa@etl.go.jp> (multi-byte characters)
;; Maintainer: Vinicius Jose Latorre <vinicius@cpqd.com.br>
;; Keywords: wp, print, PostScript
-;; Time-stamp: <2000/10/10 14:04:29 vinicius>
-;; Version: 6.1
+;; Time-stamp: <2000/10/28 23:38:44 Vinicius>
+;; Version: 6.3
;; X-URL: http://www.cpqd.com.br/~vinicius/emacs/
-(defconst ps-print-version "6.1"
- "ps-print.el, v 6.1 <2000/10/10 vinicius>
+(defconst ps-print-version "6.3"
+ "ps-print.el, v 6.3 <2000/10/28 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
;;; Code:
-(unless (featurep 'lisp-float-type)
- (error "`ps-print' requires floating point support"))
-
-
-;; For Emacs 20.2 and the earlier version.
+(eval-and-compile
+ (unless (featurep 'lisp-float-type)
+ (error "`ps-print' requires floating point support"))
-(or (fboundp 'set-buffer-multibyte)
- (defun set-buffer-multibyte (arg)
- (setq enable-multibyte-characters arg)))
-(or (fboundp 'string-as-unibyte)
- (defun string-as-unibyte (arg) arg))
+ ;; For Emacs 20.2 and the earlier version.
-(or (fboundp 'string-as-multibyte)
- (defun string-as-multibyte (arg) arg))
+ (or (fboundp 'set-buffer-multibyte)
+ (defun set-buffer-multibyte (arg)
+ (setq enable-multibyte-characters arg)))
-(or (fboundp 'char-charset)
- (defun char-charset (arg) 'ascii))
+ (or (fboundp 'string-as-unibyte)
+ (defun string-as-unibyte (arg) arg))
-(or (fboundp 'charset-after)
- (defun charset-after (&optional arg)
- (char-charset (char-after arg))))
+ (or (fboundp 'string-as-multibyte)
+ (defun string-as-multibyte (arg) arg))
+ (or (fboundp 'char-charset)
+ (defun char-charset (arg) 'ascii))
-;; GNU Emacs
-(or (fboundp 'line-beginning-position)
- (defun line-beginning-position (&optional n)
- (save-excursion
- (and n (/= n 1) (forward-line (1- n)))
- (beginning-of-line)
- (point))))
+ (or (fboundp 'charset-after)
+ (defun charset-after (&optional arg)
+ (char-charset (char-after arg))))
-;; to avoid compilation gripes
-(eval-and-compile
- (mapcar #'(lambda (sym)
- (or (fboundp sym)
- (defalias sym 'ignore)))
- '(;; XEmacs
- color-instance-p
- color-instance-rgb-components
- color-name
- color-specifier-p
- copy-coding-system
- device-class
- extent-end-position
- extent-face
- extent-priority
- extent-start-position
- face-font-instance
- find-coding-system
- font-instance-properties
- make-color-instance
- map-extents)))
-
-
-(defconst ps-windows-system
- (memq system-type '(emx win32 w32 mswindows ms-dos windows-nt)))
-(defconst ps-lp-system
- (memq system-type '(usq-unix-v dgux hpux irix)))
+ ;; GNU Emacs
+ (or (fboundp 'line-beginning-position)
+ (defun line-beginning-position (&optional n)
+ (save-excursion
+ (and n (/= n 1) (forward-line (1- n)))
+ (beginning-of-line)
+ (point))))
+
+
+ ;; to avoid compilation gripes
+
+ ;; XEmacs
+ (defalias 'ps-x-color-instance-p 'color-instance-p)
+ (defalias 'ps-x-color-instance-rgb-components 'color-instance-rgb-components)
+ (defalias 'ps-x-color-name 'color-name)
+ (defalias 'ps-x-color-specifier-p 'color-specifier-p)
+ (defalias 'ps-x-copy-coding-system 'copy-coding-system)
+ (defalias 'ps-x-device-class 'device-class)
+ (defalias 'ps-x-extent-end-position 'extent-end-position)
+ (defalias 'ps-x-extent-face 'extent-face)
+ (defalias 'ps-x-extent-priority 'extent-priority)
+ (defalias 'ps-x-extent-start-position 'extent-start-position)
+ (defalias 'ps-x-face-font-instance 'face-font-instance)
+ (defalias 'ps-x-find-coding-system 'find-coding-system)
+ (defalias 'ps-x-font-instance-properties 'font-instance-properties)
+ (defalias 'ps-x-make-color-instance 'make-color-instance)
+ (defalias 'ps-x-map-extents 'map-extents)
+
+ ;; GNU Emacs
+ (defalias 'ps-e-x-color-values 'x-color-values)
+ (defalias 'ps-e-color-values 'color-values)
+ (if (fboundp 'find-composition)
+ (defalias 'ps-e-find-composition 'find-composition)
+ (defalias 'ps-e-find-composition 'ignore))
+
+
+ (defconst ps-windows-system
+ (memq system-type '(emx win32 w32 mswindows ms-dos windows-nt)))
+ (defconst ps-lp-system
+ (memq system-type '(usq-unix-v dgux hpux irix))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
`ps-selected-pages' is saved in `ps-last-selected-pages' (see it for
documentation). So you can restore the latest selected pages by using
`ps-last-selected-pages' or by calling `ps-restore-selected-pages' command (see
-it for documentation)."
+it for documentation).
+
+See also `ps-even-or-odd-pages'."
:type '(repeat :tag "Selected Pages"
(radio :tag "Page"
(integer :tag "Number")
`odd' print only odd pages.
-Any other value is treated as nil."
+Any other value is treated as nil.
+
+If you set `ps-selected-pages' (see it for documentation), first the pages are
+filtered by `ps-selected-pages' and then by `ps-even-or-odd-pages'. For
+example, if we have:
+
+ (setq ps-selected-pages '(1 4 (6 . 10) 12))
+
+We have the following results:
+
+ `ps-even-or-odd-pages' PAGES PRINTED
+ nil 1, 4, 6, 7, 8, 9, 10, 12
+ even 4, 6, 8, 10, 12
+ odd 1, 7, 9"
:type '(choice :menu-tag "Print Even/Odd Pages"
:tag "Print Even/Odd Pages"
(const :tag "All Pages" nil)
;;; Colors
;; Printing color requires x-color-values.
-(defcustom ps-print-color-p (or (fboundp 'x-color-values) ; Emacs
- (fboundp 'color-instance-rgb-components))
+(defcustom ps-print-color-p
+ (or (and (fboundp 'color-values) ; Emacs
+ (ps-e-color-values "Green"))
+ (fboundp 'x-color-values) ; Emacs
+ (fboundp 'color-instance-rgb-components))
; XEmacs
"*Non-nil means print the buffer's text in color."
:type 'boolean
(t
sym)))
-(defvar ps-print-emacs-type
- (cond ((string-match "XEmacs" emacs-version) 'xemacs)
- ((string-match "Lucid" emacs-version) 'lucid)
- ((string-match "Epoch" emacs-version) 'epoch)
- (t 'emacs)))
-(if (memq ps-print-emacs-type '(lucid xemacs))
- (if (< emacs-minor-version 12)
- (setq ps-print-color-p nil))
- (require 'faces)) ; face-font, face-underline-p,
+(eval-and-compile
+ (defvar ps-print-emacs-type
+ (cond ((string-match "XEmacs" emacs-version) 'xemacs)
+ ((string-match "Lucid" emacs-version) 'lucid)
+ ((string-match "Epoch" emacs-version) 'epoch)
+ (t 'emacs)))
+
+ (if (memq ps-print-emacs-type '(lucid xemacs))
+ (if (< emacs-minor-version 12)
+ (setq ps-print-color-p nil))
+ (require 'faces)) ; face-font, face-underline-p,
; x-font-regexp
-;; Return t if the device (which can be changed during an emacs session)
-;; can handle colors.
-;; This is function is not yet implemented for GNU emacs.
-(cond ((and (eq ps-print-emacs-type 'xemacs)
- (>= emacs-minor-version 12)) ; xemacs
- (defun ps-color-device ()
- (eq (device-class) 'color))
- )
+ ;; Return t if the device (which can be changed during an emacs session)
+ ;; can handle colors.
+ ;; This function is not yet implemented for GNU emacs.
+ (cond ((and (eq ps-print-emacs-type 'xemacs)
+ (>= emacs-minor-version 12)) ; xemacs
+ (defun ps-color-device ()
+ (eq (ps-x-device-class) 'color)))
+
+ (t ; emacs
+ (defun ps-color-device ()
+ (if (fboundp 'color-values)
+ (ps-e-color-values "Green")
+ t))))
+
+
+ (defun ps-mapper (extent list)
+ (nconc list
+ (list (list (ps-x-extent-start-position extent) 'push extent)
+ (list (ps-x-extent-end-position extent) 'pull extent)))
+ nil)
+
+ (defun ps-extent-sorter (a b)
+ (< (ps-x-extent-priority a) (ps-x-extent-priority b)))
+
+ (defun ps-xemacs-face-kind-p (face kind kind-regex)
+ (let* ((frame-font (or (ps-x-face-font-instance face)
+ (ps-x-face-font-instance 'default)))
+ (kind-cons
+ (and frame-font
+ (assq kind
+ (ps-x-font-instance-properties frame-font))))
+ (kind-spec (cdr-safe kind-cons))
+ (case-fold-search t))
+ (and kind-spec (string-match kind-regex kind-spec))))
+
+ (defun ps-xemacs-color-name (color)
+ (if (ps-x-color-specifier-p color)
+ (ps-x-color-name color)
+ color))
+
+ (cond ((eq ps-print-emacs-type 'emacs) ; emacs
+
+ (defun ps-color-values (x-color)
+ (cond
+ ((fboundp 'color-values)
+ (ps-e-color-values x-color))
+ ((fboundp 'x-color-values)
+ (ps-e-x-color-values x-color))
+ (t
+ (error "No available function to determine X color values."))))
+
+ (defalias 'ps-face-foreground-name 'face-foreground)
+ (defalias 'ps-face-background-name 'face-background)
+
+ (defun ps-face-bold-p (face)
+ (or (face-bold-p face)
+ (memq face ps-bold-faces)))
+
+ (defun ps-face-italic-p (face)
+ (or (face-italic-p face)
+ (memq face ps-italic-faces)))
+ )
+ ; xemacs
+ ; lucid
+ (t ; epoch
+
+ (or (ps-x-find-coding-system 'raw-text-unix)
+ (ps-x-copy-coding-system 'no-conversion-unix 'raw-text-unix))
+
+ (defun ps-color-values (x-color)
+ (let ((color (ps-xemacs-color-name x-color)))
+ (cond
+ ((fboundp 'x-color-values)
+ (ps-e-x-color-values color))
+ ((and (fboundp 'color-instance-rgb-components)
+ (ps-color-device))
+ (ps-x-color-instance-rgb-components
+ (if (ps-x-color-instance-p x-color)
+ x-color
+ (ps-x-make-color-instance color))))
+ (t
+ (error "No available function to determine X color values.")))))
- (t ; emacs
- (defun ps-color-device ()
- t)
- ))
+ (defun ps-face-foreground-name (face)
+ (ps-xemacs-color-name (face-foreground face)))
+
+ (defun ps-face-background-name (face)
+ (ps-xemacs-color-name (face-background face)))
+
+ (defun ps-face-bold-p (face)
+ (or (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold")
+ (memq face ps-bold-faces))) ; Kludge-compatible
+
+ (defun ps-face-italic-p (face)
+ (or (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o")
+ (ps-xemacs-face-kind-p face 'SLANT "i\\|o")
+ (memq face ps-italic-faces))) ; Kludge-compatible
+ )))
+
+
+(defvar ps-print-color-scale 1.0)
+
+(defun ps-color-scale (color)
+ ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
+ (mapcar #'(lambda (value) (/ value ps-print-color-scale))
+ (ps-color-values color)))
+
+
+(defun ps-face-underlined-p (face)
+ (or (face-underline-p face)
+ (memq face ps-underlined-faces)))
(require 'time-stamp)
(defvar ps-page-postscript 0)
(defvar ps-page-order 0)
(defvar ps-page-count 0)
+(defvar ps-page-n-up 0)
(defvar ps-showline-count 1)
(defvar ps-first-page nil)
(defvar ps-last-page nil)
+(defvar ps-print-page-p t)
(defvar ps-control-or-escape-regexp nil)
(defvar ps-n-up-on nil)
(defvar ps-height-remaining nil)
(defvar ps-width-remaining nil)
-(defvar ps-print-color-scale nil)
-
(defvar ps-font-size-internal nil)
(defvar ps-header-font-size-internal nil)
(defvar ps-header-title-font-size-internal nil)
(defun ps-font-lock-face-attributes ()
(and (boundp 'font-lock-mode) (symbol-value 'font-lock-mode)
(boundp 'font-lock-face-attributes)
- (let ((face-attributes font-lock-face-attributes))
+ (let ((face-attributes (symbol-value 'font-lock-face-attributes)))
(while face-attributes
(let* ((face-attribute
(car (prog1 face-attributes
".ps"))
(prompt (format "Save PostScript to file: (default %s) " name))
(res (read-file-name prompt default-directory name nil)))
- (while (cond ((not (file-writable-p res))
+ (while (cond ((file-directory-p res)
(ding)
- (setq prompt "is unwritable"))
+ (setq prompt "It's a directory"))
+ ((not (file-writable-p res))
+ (ding)
+ (setq prompt "File is unwritable"))
((file-exists-p res)
- (setq prompt "exists")
+ (setq prompt "File exists")
(not (y-or-n-p (format "File `%s' exists; overwrite? "
res))))
(t nil))
(setq res (read-file-name
- (format "File %s; save PostScript to file: " prompt)
+ (format "%s; save PostScript to file: " prompt)
(file-name-directory res) nil nil
(file-name-nondirectory res))))
(if (file-directory-p res)
(< ps-last-page ps-page-postscript)))))
-(defsubst ps-print-page-p ()
- (and (cond ((null ps-first-page))
- ((<= ps-page-postscript ps-last-page)
- (<= ps-first-page ps-page-postscript))
- (ps-selected-pages
- (ps-selected-pages)
- (and (<= ps-first-page ps-page-postscript)
- (<= ps-page-postscript ps-last-page)))
- (t
- nil))
- (cond ((eq ps-even-or-odd-pages 'even)
- (= (logand ps-page-postscript 1) 0))
- ((eq ps-even-or-odd-pages 'odd)
- (= (logand ps-page-postscript 1) 1))
- (t)
- )))
+(defun ps-print-page-p ()
+ (setq ps-print-page-p
+ (and (cond ((null ps-first-page))
+ ((<= ps-page-postscript ps-last-page)
+ (<= ps-first-page ps-page-postscript))
+ (ps-selected-pages
+ (ps-selected-pages)
+ (and (<= ps-first-page ps-page-postscript)
+ (<= ps-page-postscript ps-last-page)))
+ (t
+ nil))
+ (cond ((eq ps-even-or-odd-pages 'even)
+ (= (logand ps-page-postscript 1) 0))
+ ((eq ps-even-or-odd-pages 'odd)
+ (= (logand ps-page-postscript 1) 1))
+ (t)
+ ))))
(defun ps-output (&rest args)
- (when (ps-print-page-p)
+ (when ps-print-page-p
(setcdr ps-output-tail args)
(while (cdr ps-output-tail)
(setq ps-output-tail (cdr ps-output-tail)))))
(ps-get-page-dimensions)
(setq ps-page-postscript 0
ps-page-order 0
+ ps-page-n-up 0
+ ps-print-page-p t
ps-background-text-count 0
ps-background-image-count 0
ps-background-pages nil
))
-(defmacro ps-page-number ()
- `(1+ (/ (1- ps-page-count) ps-number-of-columns)))
-
-(defun ps-end-file (needs-begin-file)
- (ps-flush-output)
- ;; Back to the PS output buffer to set the last page n-up printing
- (save-excursion
- (let ((pages-per-sheet (mod ps-page-postscript ps-n-up-printing))
- case-fold-search)
- (set-buffer ps-spool-buffer)
- (goto-char (point-max))
- (and (> pages-per-sheet 0)
- (re-search-backward "^[0-9]+ BeginSheet$" nil t)
- (replace-match (format "%d BeginSheet" pages-per-sheet) t))))
- ;; Set dummy page
- (and ps-spool-duplex (= (mod ps-page-order 2) 1)
- (let (ps-first-page)
- (ps-dummy-page)))
- ;; Set end of PostScript file
- (or ps-first-page
- (ps-output "EndSheet\n"))
- (setq ps-first-page nil) ; disable selected pages
- (ps-output "\n%%Trailer\n%%Pages: "
- (format "%d"
- (if (and needs-begin-file ps-banner-page-when-duplexing)
- (1+ ps-page-order)
- ps-page-order))
- "\n\nEndDoc\n\n%%EOF\n"))
+(defun ps-page-number ()
+ (if ps-print-only-one-header
+ (1+ (/ (1- ps-page-count) ps-number-of-columns))
+ ps-page-count))
(defun ps-next-page ()
(defun ps-header-sheet ()
;; Print only when a new sheet begins.
- (let ((print-posterior (ps-print-page-p)))
- (setq ps-page-postscript (1+ ps-page-postscript))
- (cond ((ps-print-page-p)
- (setq ps-page-order (1+ ps-page-order))
- (and print-posterior (> ps-page-order 1)
- (ps-output "EndSheet\n"))
- (ps-output (if ps-n-up-on
- (format "\n%%%%Page: (%d \\(%d\\)) %d\n"
- ps-page-order ps-page-postscript ps-page-order)
- (format "\n%%%%Page: %d %d\n"
- ps-page-postscript ps-page-order))
- (format "%d BeginSheet\nBeginDSCPage\n"
- ps-n-up-printing)))
- (print-posterior
- (let (ps-first-page)
- (ps-output "EndSheet\n"))))))
-
-
-(defsubst ps-header-page ()
+ (setq ps-page-order (1+ ps-page-order))
+ (and (> ps-page-order 1)
+ (ps-output "EndSheet\n"))
+ (ps-output (if ps-n-up-on
+ (format "\n%%%%Page: (%d \\(%d\\)) %d\n"
+ ps-page-order ps-page-postscript ps-page-order)
+ (format "\n%%%%Page: %d %d\n"
+ ps-page-postscript ps-page-order))
+ (format "%d BeginSheet\nBeginDSCPage\n"
+ ps-n-up-printing)))
+
+
+(defun ps-header-page ()
;; set total line and page number when printing has finished
;; (see `ps-generate')
- (run-hooks
- (if (prog1
- (zerop (mod ps-page-count ps-number-of-columns))
- (setq ps-page-count (1+ ps-page-count)))
- (prog1
- (if (zerop (mod ps-page-postscript ps-n-up-printing))
- ;; Print only when a new sheet begins.
- (progn
- (ps-header-sheet)
- 'ps-print-begin-sheet-hook)
- ;; Print only when a new page begins.
- (setq ps-page-postscript (1+ ps-page-postscript))
- (ps-output "BeginDSCPage\n")
- 'ps-print-begin-page-hook)
- (ps-background ps-page-postscript))
- ;; Print only when a new column begins.
- (ps-output "BeginDSCPage\n")
- 'ps-print-begin-column-hook)))
+ (if (zerop (mod ps-page-count ps-number-of-columns))
+ (progn
+ (setq ps-page-postscript (1+ ps-page-postscript))
+ (when (ps-print-page-p)
+ (if (zerop (mod ps-page-n-up ps-n-up-printing))
+ ;; Print only when a new sheet begins.
+ (progn
+ (ps-header-sheet)
+ (run-hooks 'ps-print-begin-sheet-hook))
+ ;; Print only when a new page begins.
+ (ps-output "BeginDSCPage\n")
+ (run-hooks 'ps-print-begin-page-hook))
+ (ps-background ps-page-postscript)
+ (setq ps-page-n-up (1+ ps-page-n-up))))
+ ;; Print only when a new column begins.
+ (ps-output "BeginDSCPage\n")
+ (run-hooks 'ps-print-begin-column-hook))
+ (setq ps-page-count (1+ ps-page-count)))
(defun ps-begin-page ()
(ps-get-page-dimensions)
(ps-header-page)
(ps-output (format "/LineNumber %d def\n" ps-showline-count)
- (format "/PageNumber %d def\n" (if ps-print-only-one-header
- (ps-page-number)
- ps-page-count)))
+ (format "/PageNumber %d def\n" (ps-page-number)))
(when ps-print-header
(ps-generate-header "HeaderLinesLeft" ps-left-header)
(defun ps-end-page ()
(ps-output "EndPage\nEndDSCPage\n"))
-(defun ps-dummy-page ()
- (let ((ps-n-up-printing 0))
- (ps-header-sheet))
- (ps-output "/PrintHeader false def
-/ColumnIndex 0 def
-/PrintLineNumber false def
-BeginPage
-EndPage
-EndDSCPage\n")
- (setq ps-page-postscript ps-n-up-printing))
-
(defun ps-next-line ()
(setq ps-showline-count (1+ ps-showline-count))
(let ((lh (ps-line-height 'ps-font-for-text)))
(if (re-search-forward ps-control-or-escape-regexp to t)
;; region with some control characters or some multi-byte characters
(let* ((match-point (match-beginning 0))
- (match (char-after match-point))
- (composition (find-composition from (1+ match-point))))
+ (match (char-after match-point))
+ (composition (ps-e-find-composition from (1+ match-point))))
(if composition
(if (and (nth 2 composition)
(<= (car composition) match-point))
((> match 255) ; a multi-byte character
(let* ((charset (char-charset match))
- (composition (find-composition match-point to))
+ (composition (ps-e-find-composition match-point to))
(stop (if (nth 2 composition) (car composition) to)))
(or (eq charset 'composition)
(while (and (< (point) stop) (eq (charset-after) charset))
(ps-output-string str)
(ps-output " S\n")))
-(defun ps-color-scale (color)
- ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval.
- (mapcar #'(lambda (value) (/ value ps-print-color-scale))
- (ps-color-values color)))
-
-
-(defun ps-xemacs-color-name (color)
- (if (color-specifier-p color)
- (color-name color)
- color))
-
-
-(cond ((eq ps-print-emacs-type 'emacs) ; emacs
-
- (defun ps-color-values (x-color)
- (if (fboundp 'x-color-values)
- (x-color-values x-color)
- (error "No available function to determine X color values.")))
- )
- ; xemacs
- ; lucid
- (t ; epoch
-
- (or (find-coding-system 'raw-text-unix)
- (copy-coding-system 'no-conversion-unix 'raw-text-unix))
-
- (defun ps-color-values (x-color)
- (let ((color (ps-xemacs-color-name x-color)))
- (cond
- ((fboundp 'x-color-values)
- (x-color-values color))
- ((and (fboundp 'color-instance-rgb-components)
- (ps-color-device))
- (color-instance-rgb-components
- (if (color-instance-p x-color)
- x-color
- (make-color-instance color))))
- (t
- (error "No available function to determine X color values.")))))
- ))
-
(defun ps-face-attributes (face)
"Return face attribute vector.
(goto-char to))
-(defun ps-xemacs-face-kind-p (face kind kind-regex)
- (let* ((frame-font (or (face-font-instance face)
- (face-font-instance 'default)))
- (kind-cons (and frame-font
- (assq kind
- (font-instance-properties frame-font))))
- (kind-spec (cdr-safe kind-cons))
- (case-fold-search t))
- (and kind-spec (string-match kind-regex kind-spec))))
-
-
-(cond ((eq ps-print-emacs-type 'emacs) ; emacs
-
- (defalias 'ps-face-foreground-name 'face-foreground)
- (defalias 'ps-face-background-name 'face-background)
-
- (defun ps-face-bold-p (face)
- (or (face-bold-p face)
- (memq face ps-bold-faces)))
-
- (defun ps-face-italic-p (face)
- (or (face-italic-p face)
- (memq face ps-italic-faces)))
- )
- ; xemacs
- ; lucid
- (t ; epoch
- (defun ps-face-foreground-name (face)
- (ps-xemacs-color-name (face-foreground face)))
-
- (defun ps-face-background-name (face)
- (ps-xemacs-color-name (face-background face)))
-
- (defun ps-face-bold-p (face)
- (or (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold")
- (memq face ps-bold-faces))) ; Kludge-compatible
-
- (defun ps-face-italic-p (face)
- (or (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o")
- (ps-xemacs-face-kind-p face 'SLANT "i\\|o")
- (memq face ps-italic-faces))) ; Kludge-compatible
- ))
-
-
-(defun ps-face-underlined-p (face)
- (or (face-underline-p face)
- (memq face ps-underlined-faces)))
-
-
;; Ensure that face-list is fbound.
(or (fboundp 'face-list) (defalias 'face-list 'list-faces))
(ps-face-background-name face))))
-(cond ((not (eq ps-print-emacs-type 'emacs))
- ; xemacs
- ; lucid
- ; epoch
- (defun ps-mapper (extent list)
- (nconc list (list (list (extent-start-position extent) 'push extent)
- (list (extent-end-position extent) 'pull extent)))
- nil)
-
- (defun ps-extent-sorter (a b)
- (< (extent-priority a) (extent-priority b)))
- ))
-
-
+;; to avoid compilation gripes
(defun ps-print-ensure-fontified (start end)
- (and (boundp 'lazy-lock-mode) (symbol-value 'lazy-lock-mode)
- (lazy-lock-fontify-region start end)))
+ (cond
+ ((and (boundp 'jit-lock-mode) (symbol-value 'jit-lock-mode))
+ (defalias 'ps-jitify 'jit-lock-fontify-now) ; avoid compilation gripes
+ (ps-jitify start end))
+ ((and (boundp 'lazy-lock-mode) (symbol-value 'lazy-lock-mode))
+ (defalias 'ps-lazify 'lazy-lock-fontify-region) ; avoid compilation gripes
+ (ps-lazify start end))))
+
(defun ps-generate-postscript-with-faces (from to)
;; Some initialization...
;; Build the list of extents...
(let ((a (cons 'dummy nil))
record type extent extent-list)
- (map-extents 'ps-mapper nil from to a)
+ (ps-x-map-extents 'ps-mapper nil from to a)
(setq a (sort (cdr a) 'car-less-than-car)
extent-list nil)
;; XEmacs 19.12: for some reason, we're getting into a
;; situation in which some of the records have
;; positions less than 'from'. Since we've narrowed
- ;; the buffer, this'll generate errors. This is a
- ;; hack, but don't call ps-plot-with-face unless from >
- ;; point-min.
- (and (>= from (point-min)) (<= position (point-max))
- (ps-plot-with-face from position face))
+ ;; the buffer, this'll generate errors. This is a hack,
+ ;; but don't call ps-plot-with-face unless from > point-min.
+ (and (>= from (point-min))
+ (ps-plot-with-face from (min position (point-max)) face))
(cond
((eq type 'push)
- (and (extent-face extent)
+ (and (ps-x-extent-face extent)
(setq extent-list (sort (cons extent extent-list)
'ps-extent-sorter))))
'ps-extent-sorter))))
(setq face (if extent-list
- (extent-face (car extent-list))
+ (ps-x-extent-face (car extent-list))
'default)
from position
a (cdr a)))))
(goto-char (point-min))
(or (looking-at (regexp-quote ps-adobe-tag))
(setq needs-begin-file t))
- (save-excursion
- (set-buffer ps-source-buffer)
- (ps-begin-job)
- (when needs-begin-file
- (ps-begin-file)
- (ps-mule-initialize))
- (ps-mule-begin-job from to)
- (ps-selected-pages)
- (ps-begin-page))
+
(set-buffer ps-source-buffer)
+ (save-excursion
+ (let ((ps-print-page-p t)
+ ps-even-or-odd-pages)
+ (ps-begin-job)
+ (when needs-begin-file
+ (ps-begin-file)
+ (ps-mule-initialize))
+ (ps-mule-begin-job from to)
+ (ps-selected-pages)))
+ (ps-begin-page)
(funcall genfunc from to)
(ps-end-page)
-
- (ps-end-file needs-begin-file)
- (ps-end-job)
+ (ps-end-job needs-begin-file)
;; Setting this variable tells the unwind form that the
;; the PostScript was generated without error.
(and ps-razzle-dazzle (message "Formatting...done"))))))
-(defun ps-end-job ()
- (ps-flush-output)
- (let ((total-lines (cdr ps-printing-region))
- (total-pages (if ps-print-only-one-header
- (ps-page-number)
- ps-page-count))
- case-fold-search)
- (set-buffer ps-spool-buffer)
- ;; Back to the PS output buffer to set the page count
- (goto-char (point-min))
- (and (re-search-forward "^/Lines 0 def\n/PageCount 0 def$" nil t)
- (replace-match (format "/Lines %d def\n/PageCount %d def"
- total-lines total-pages) t)))
- ;; selected pages
+(defun ps-end-job (needs-begin-file)
+ (let ((ps-print-page-p t))
+ (ps-flush-output)
+ (save-excursion
+ (let ((pages-per-sheet (mod ps-page-n-up ps-n-up-printing))
+ (total-lines (cdr ps-printing-region))
+ (total-pages (ps-page-number))
+ case-fold-search)
+ (set-buffer ps-spool-buffer)
+ ;; Back to the PS output buffer to set the last page n-up printing
+ (goto-char (point-max))
+ (and (> pages-per-sheet 0)
+ (re-search-backward "^[0-9]+ BeginSheet$" nil t)
+ (replace-match (format "%d BeginSheet" pages-per-sheet) t))
+ ;; Back to the PS output buffer to set the page count
+ (goto-char (point-min))
+ (and (re-search-forward "^/Lines 0 def\n/PageCount 0 def$" nil t)
+ (replace-match (format "/Lines %d def\n/PageCount %d def"
+ total-lines total-pages) t))))
+ ;; Set dummy page
+ (and ps-spool-duplex (= (mod ps-page-order 2) 1)
+ (let ((ps-n-up-printing 0))
+ (ps-header-sheet)
+ (ps-output "/PrintHeader false def\n/ColumnIndex 0 def\n"
+ "/PrintLineNumber false def\nBeginPage\n")
+ (ps-end-page)))
+ ;; Set end of PostScript file
+ (ps-output "EndSheet\n\n%%Trailer\n%%Pages: "
+ (number-to-string
+ (if (and needs-begin-file
+ ps-banner-page-when-duplexing)
+ (1+ ps-page-order)
+ ps-page-order))
+ "\n\nEndDoc\n\n%%EOF\n")
+ (ps-flush-output))
+ ;; disable selected pages
(setq ps-selected-pages nil))
HCoop / bpt / emacs.git / blobdiff