# HG changeset patch # User steveb # Date 931506590 0 # Fri Jul 09 07:49:50 1999 +0000 # Node ID 172f1ae2cf0daa07f0d38cce0d97eedf20dab1f3 # Parent 1fb807bc65713b252ea87c73dbb6e8f8dec97894 miscellaneous fixes diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +1999-06-29 SL Baur <steve@miho.m17n.org> + + * Makefile (ELCS): ps-print.el removed. + 1999-03-19 Didier Verna <didier@xemacs.org> * mchat.el: version 2.0 released. diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -19,7 +19,7 @@ # This XEmacs package contains independent single file lisp packages -VERSION = 1.15 +VERSION = 1.16 AUTHOR_VERSION = MAINTAINER = XEmacs Development Team <xemacs-beta@xemacs.org> PACKAGE = os-utils @@ -28,7 +28,7 @@ CATEGORY = os ELCS = arc-mode.elc background.elc crypt.elc ftelnet.elc inf-lisp.elc \ - jka-compr.elc kermit.elc ledit.elc lpr.elc ps-print.elc rlogin.elc \ + jka-compr.elc kermit.elc ledit.elc lpr.elc rlogin.elc \ spell.elc ssh.elc tar-mode.elc telnet.elc terminal.elc uncompress.elc include ../../XEmacs.rules diff --git a/jka-compr.el b/jka-compr.el --- a/jka-compr.el +++ b/jka-compr.el @@ -3,6 +3,7 @@ ;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. ;; Author: jka@ece.cmu.edu (Jay K. Adams) +;; Maintainer: FSF ;; Keywords: data ;; This file is part of XEmacs. @@ -22,7 +23,7 @@ ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; 02111-1307, USA. -;; Synched up with: FSF 19.34 +;; Synched up with: FSF 20.3.10.1 ;;; Commentary: @@ -118,11 +119,11 @@ :type 'string :group 'jka-compr) -(defvar jka-compr-use-shell t) - +(defvar jka-compr-use-shell + (not (memq system-type '(ms-dos windows-nt)))) ;;; I have this defined so that .Z files are assumed to be in unix -;;; compress format; and .gz files, in gzip format. +;;; compress format; and .gz files, in gzip format, and .bz2 files in bzip fmt. (defcustom jka-compr-compression-info-list ;;[regexp ;; compr-message compr-prog compr-args @@ -132,6 +133,10 @@ "compressing" "compress" ("-c") "uncompressing" "uncompress" ("-c") nil t] + ["\\.bz2\\(~\\|\\.~[0-9]+~\\)?\\'" ; XEmacs change + "bzip2ing" "bzip2" nil + "unbzip2ing" "bzip2" ("-d") + nil t] ["\\.tgz\\'" "zipping" "gzip" ("-c" "-q") "unzipping" "gzip" ("-c" "-q" "-d") @@ -139,11 +144,7 @@ ["\\.gz\\(~\\|\\.~[0-9]+~\\)?\\'" "zipping" "gzip" ("-c" "-q") "unzipping" "gzip" ("-c" "-q" "-d") - t t] - ["\\.bz2\\(~\\|\\.~[0-9]+~\\)?\\'" - "bzipping" "bzip2" ("-f") - "unbzipping" "bzip2" ("-d") - nil t]) + t t]) "List of vectors that describe available compression techniques. Each element, which describes a compression technique, is a vector of @@ -168,8 +169,8 @@ uncompress-args is a list of args to pass to the uncompress program - append-flag is non-nil if files compressed with this technique can - be appended to without decompressing them first. + append-flag is non-nil if this compression technique can be + appended auto-mode flag non-nil means strip the regexp from file names before attempting to set the mode. @@ -177,7 +178,7 @@ Because of the way `call-process' is defined, discarding the stderr output of a program adds the overhead of starting a shell each time the program is invoked." - :type '(repeat (vector :tag "Compression Technique" + :type '(repeat (vector :tag "Compression Technique" ; XEmacs change regexp (choice :tag "Compress Message" (string :format "%v") @@ -195,7 +196,10 @@ (defvar jka-compr-mode-alist-additions (list (cons "\\.tgz\\'" 'tar-mode)) - "A list of pairs to add to auto-mode-alist when jka-compr is installed.") + "A list of pairs to add to `auto-mode-alist' when jka-compr is installed.") + +;; List of all the elements we actually added to file-coding-system-alist. +(defvar jka-compr-added-to-file-coding-system-alist nil) (defvar jka-compr-file-name-handler-entry nil @@ -234,23 +238,22 @@ (defun jka-compr-error (prog args infile message &optional errfile) + (let ((errbuf (get-buffer-create " *jka-compr-error*")) (curbuf (current-buffer))) - (set-buffer errbuf) - (widen) (erase-buffer) - (insert (format "Error while executing \"%s %s < %s\"\n\n" - prog - (mapconcat 'identity args " ") - infile)) + (with-current-buffer errbuf + (widen) (erase-buffer) + (insert (format "Error while executing \"%s %s < %s\"\n\n" + prog + (mapconcat 'identity args " ") + infile)) - (and errfile - (insert-file-contents errfile)) + (and errfile + (insert-file-contents errfile))) + (display-buffer errbuf)) - (set-buffer curbuf) - (display-buffer errbuf)) - (signal 'compression-error (list "Opening input file" - (format "error %s" message) - infile))) + (signal 'compression-error + (list "Opening input file" (format "error %s" message) infile))) (defvar jka-compr-dd-program @@ -279,6 +282,7 @@ ;; dd seems to be unreliable about ;; providing the last block. So, always ;; read one more than you think you need. + ;; XEmacs change -- de-ebolify (if count (concat "count=" (number-to-string (1+ count))) "")))) @@ -306,7 +310,9 @@ (defun jka-compr-call-process (prog message infile output temp args) (if jka-compr-use-shell - (let ((err-file (jka-compr-make-temp-name))) + (let ((err-file (jka-compr-make-temp-name)) + (coding-system-for-read (or coding-system-for-read 'undecided)) + (coding-system-for-write 'no-conversion)) (unwind-protect @@ -338,20 +344,18 @@ (jka-compr-error prog args infile message)) (and (stringp output) - (let ((cbuf (current-buffer))) - (set-buffer temp) + (with-current-buffer temp (write-region (point-min) (point-max) output) - (erase-buffer) - (set-buffer cbuf))))) + (erase-buffer))))) ;;; Support for temp files. Much of this was inspired if not lifted ;;; from ange-ftp. (defcustom jka-compr-temp-name-template - "/tmp/jka-com" + (expand-file-name "jka-com" (temp-directory)) "Prefix added to all temp files created by jka-compr. -There should be no more than seven characters after the final `/'" +There should be no more than seven characters after the final `/'." :type 'string :group 'jka-compr) @@ -417,13 +421,17 @@ (compress-args (jka-compr-info-compress-args info)) (uncompress-args (jka-compr-info-uncompress-args info)) (base-name (file-name-nondirectory visit-file)) - temp-file cbuf temp-buffer) + temp-file temp-buffer + ;; we need to leave `last-coding-system-used' set to its + ;; value after calling write-region the first time, so + ;; that `basic-save-buffer' sees the right value. + ;; XEmacs change: we don't have `last-coding-system-used'. + ;; (coding-system-used last-coding-system-used) + ) - (setq cbuf (current-buffer) - temp-buffer (get-buffer-create " *jka-compr-wr-temp*")) - (set-buffer temp-buffer) - (widen) (erase-buffer) - (set-buffer cbuf) + (setq temp-buffer (get-buffer-create " *jka-compr-wr-temp*")) + (with-current-buffer temp-buffer + (widen) (erase-buffer)) (if (and append (not can-append) @@ -441,25 +449,33 @@ (message "%s %s..." compress-message base-name)) (jka-compr-run-real-handler 'write-region - (list start end temp-file t 'dont lockname coding-system)) - - (jka-compr-call-process compress-program - (concat compress-message - " " base-name) - temp-file - temp-buffer - nil - compress-args) + ;; XEmacs change: add lockname, c-s + (list start end temp-file t 'dont + lockname coding-system + )) - (set-buffer temp-buffer) - (jka-compr-run-real-handler 'write-region - (list (point-min) (point-max) - filename - (and append can-append) - 'dont lockname 'binary)) - (erase-buffer) - (set-buffer cbuf) + ;; save value used by the real write-region + ;; without any code conversion. + (let ((coding-system-for-read 'no-conversion)) + (jka-compr-call-process compress-program + (concat compress-message + " " base-name) + temp-file + temp-buffer + nil + compress-args)) + (with-current-buffer temp-buffer + (let ((coding-system-for-write 'no-conversion)) + (if (memq system-type '(ms-dos windows-nt)) + (setq buffer-file-type t) ) + (jka-compr-run-real-handler 'write-region + (list (point-min) (point-max) + filename + (and append can-append) 'dont + lockname coding-system + )) + (erase-buffer)) ) (jka-compr-delete-temp-file temp-file) (and @@ -480,10 +496,17 @@ (stringp visit)) (message "Wrote %s" visit-file)) + ;; ensure `last-coding-system-used' has an appropriate value + ;; XEmacs change: don't have `last-coding-system-used' + ;; (setq last-coding-system-used coding-system-used) + nil) (jka-compr-run-real-handler 'write-region - (list start end filename append visit lockname coding-system))))) + (list start end filename append visit + ;; XEmacs change + lockname coding-system + ))))) (defun jka-compr-insert-file-contents (file &optional visit beg end replace) @@ -506,8 +529,20 @@ (local-copy (jka-compr-run-real-handler 'file-local-copy (list filename))) local-file - size start) - + size start + (coding-system-for-read + (or coding-system-for-read + 'undecided))) + ;; XEmacs change; skip multibyte-mode crap +; (and (null enable-multibyte-characters) +; (or (auto-coding-alist-lookup +; (jka-compr-byte-compiler-base-file-name file)) +; 'raw-text)) +; (let ((coding (find-operation-coding-system +; 'insert-file-contents +; (jka-compr-byte-compiler-base-file-name file)))) +; (and (consp coding) (car coding))) +; 'undecided)) ) (setq local-file (or local-copy filename)) (and @@ -589,18 +624,22 @@ (signal 'file-error (cons "Opening input file" (nth 2 notfound)))) + ;; This is done in insert-file-contents after we return. + ;; That is a little weird, but better to go along with it now + ;; than to change it now. + ;; Run the functions that insert-file-contents would. - (let ((p after-insert-file-functions) - (insval size)) - (while p - (setq insval (funcall (car p) size)) - (if insval - (progn - (or (integerp insval) - (signal 'wrong-type-argument - (list 'integerp insval))) - (setq size insval))) - (setq p (cdr p)))) +; (let ((p after-insert-file-functions) +; (insval size)) +; (while p +; (setq insval (funcall (car p) size)) +; (if insval +; (progn +; (or (integerp insval) +; (signal 'wrong-type-argument +; (list 'integerp insval))) +; (setq size insval))) +; (setq p (cdr p)))) (list filename size)) @@ -623,42 +662,45 @@ (temp-file (jka-compr-make-temp-name t)) (temp-buffer (get-buffer-create " *jka-compr-flc-temp*")) (notfound nil) - (cbuf (current-buffer)) local-file) (setq local-file (or local-copy filename)) (unwind-protect - (progn + (with-current-buffer temp-buffer (and uncompress-message (message "%s %s..." uncompress-message base-name)) - (set-buffer temp-buffer) - - (jka-compr-call-process uncompress-program - (concat uncompress-message - " " base-name) - local-file - t - nil - uncompress-args) + ;; Here we must read the output of uncompress program + ;; and write it to TEMP-FILE without any code + ;; conversion. An appropriate code conversion (if + ;; necessary) is done by the later I/O operation + ;; (e.g. load). + (let ((coding-system-for-read 'no-conversion) + (coding-system-for-write 'no-conversion)) + (jka-compr-call-process uncompress-program + (concat uncompress-message + " " base-name) + local-file + t + nil + uncompress-args) - (and - uncompress-message - (message "%s %s...done" uncompress-message base-name)) + (and + uncompress-message + (message "%s %s...done" uncompress-message base-name)) - (write-region - (point-min) (point-max) temp-file nil 'dont)) + (write-region + (point-min) (point-max) temp-file nil 'dont))) (and local-copy (file-exists-p local-copy) (delete-file local-copy)) - (set-buffer cbuf) (kill-buffer temp-buffer)) temp-file) @@ -696,7 +738,7 @@ (let ((info (jka-compr-get-compression-info file))) (if (and info (jka-compr-info-strip-extension info)) (save-match-data - (substring file 0 (string-match (jka-compr-info-regexp info) file))) + (substring file 0 (string-match (jka-compr-info-regexp info) file))) file))) (put 'write-region 'jka-compr 'jka-compr-write-region) @@ -706,10 +748,15 @@ (put 'byte-compiler-base-file-name 'jka-compr 'jka-compr-byte-compiler-base-file-name) +(defvar jka-compr-inhibit nil + "Non-nil means inhibit automatic uncompression temporarily. +Lisp programs can bind this to t to do that. +It is not recommended to set this variable permanently to anything but nil.") + (defun jka-compr-handler (operation &rest args) (save-match-data (let ((jka-op (get operation 'jka-compr))) - (if jka-op + (if (and jka-op (not jka-compr-inhibit)) (apply jka-op args) (jka-compr-run-real-handler operation args))))) @@ -771,7 +818,6 @@ flag)) - (defun jka-compr-build-file-regexp () (concat "\\(" @@ -781,6 +827,7 @@ "\\)\\|\\(") "\\)")) +;;; XEmacs: ;;;###autoload (defun jka-compr-install () "Install jka-compr. @@ -793,8 +840,18 @@ (setq file-name-handler-alist (cons jka-compr-file-name-handler-entry file-name-handler-alist)) + (setq jka-compr-added-to-file-coding-system-alist nil) + (mapcar (function (lambda (x) + ;; Don't do multibyte encoding on the compressed files. + (let ((elt (cons (jka-compr-info-regexp x) + '(no-conversion . no-conversion)))) + (setq file-coding-system-alist + (cons elt file-coding-system-alist)) + (setq jka-compr-added-to-file-coding-system-alist + (cons elt jka-compr-added-to-file-coding-system-alist))) + (and (jka-compr-info-strip-extension x) ;; Make entries in auto-mode-alist so that modes ;; are chosen right according to the file names @@ -857,13 +914,42 @@ (setcdr last (cdr (cdr last))) (setq last (cdr last)))) - (setq auto-mode-alist (cdr ama)))) + (setq auto-mode-alist (cdr ama))) + + (let* ((ama (cons nil file-coding-system-alist)) + (last ama) + entry) + + (while (cdr last) + (setq entry (car (cdr last))) + (if (member entry jka-compr-added-to-file-coding-system-alist) + (setcdr last (cdr (cdr last))) + (setq last (cdr last)))) + + (setq file-coding-system-alist (cdr ama)))) (defun jka-compr-installed-p () "Return non-nil if jka-compr is installed. The return value is the entry in `file-name-handler-alist' for jka-compr." - (rassq 'jka-compr-handler file-name-handler-alist)) + + (let ((fnha file-name-handler-alist) + (installed nil)) + + (while (and fnha (not installed)) + (and (eq (cdr (car fnha)) 'jka-compr-handler) + (setq installed (car fnha))) + (setq fnha (cdr fnha))) + + installed)) + + +;;; Add the file I/O hook if it does not already exist. +;;; Make sure that jka-compr-file-name-handler-entry is eq to the +;;; entry for jka-compr in file-name-handler-alist. +;; No no no no! +;(and (jka-compr-installed-p) +; (jka-compr-uninstall)) ;; No no no no! diff --git a/package-info.in b/package-info.in --- a/package-info.in +++ b/package-info.in @@ -13,7 +13,7 @@ filename FILENAME md5sum MD5SUM size SIZE - provides (archive-mode background crypt crypt++ inf-lisp jka-compr lpr mchat ps-print tar-mode telnet terminal uncompress) + provides (archive-mode background crypt crypt++ inf-lisp jka-compr lpr mchat tar-mode telnet terminal uncompress) requires (REQUIRES) type single )) diff --git a/ps-print.el b/ps-print.el deleted file mode 100644 --- a/ps-print.el +++ /dev/null @@ -1,3194 +0,0 @@ -;;; ps-print.el --- Jim's Pretty-Good PostScript Generator for Emacs 19. - -;; Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc. - -;; Author: Jim Thompson (was <thompson@wg2.waii.com>) -;; Maintainer: Jacques Duthen <duthen@club-internet.fr> -;; Keywords: print, PostScript -;; Time-stamp: <97/01/29 23:21:25 tjchol01> -;; Version: 3.05 - -(defconst ps-print-version "3.05" - "ps-print.el, v 3.05 <97/01/17 duthen> - -Jack'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 report the version of Emacs, if any, that ps-print was -distributed with. - -Please send all bug fixes and enhancements to - Jacques Duthen <duthen@cegelec-red.fr>. -") - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; LCD Archive Entry: -;; ps-print|James C. Thompson|thompson@wg2.waii.com| -;; Jim's Pretty-Good PostScript Generator for Emacs 19 (ps-print)| -;; 26-Feb-1994|2.8|~/packages/ps-print.el| - -;; 3.05 [jack] <97/01/16 duthen> -;; Ben Wing <ben@666.com> took ps-print.el from the official 19.34 -;; GNU distribution: -;; -rw-rw-r-- 1 duthen 69315 Jul 22 1996 ps-print.el -;; He patched it for XEmacs. -;; Steven L Baur <steve@miranova.com> sent me this version which has -;; 26 diffs with 19.34. -;; I merge these 26 diffs into my 3.04 version. - -;; `ps-paper-type': ###autoload. -;; `ps-print-color-p' `ps-color-values': Replace pixel-components by -;; color-instance-rgb-components for XEmacs. -;; `ps-color-device': New function to dynamically test the device -;; color capability, added where ps-print-color-p is tested. -;; `ps-xemacs-face-kind-p': Fixed. -;; `ps-do-despool': Permit dynamic evaluation at print time of -;; ps-lpr-switches. -;; `ps-eval-switch' `ps-flatten-list' `ps-flatten-list-1': New for -;; the previous feature. -;; `ps-gnus-print-article-from-summary': Updated for Gnus 5. - - -;; 3.04 [jack] after [simon] Oct 8, 1996 Simon Marshall <simon@gnu.ai.mit.edu> -;; `ps-print-version': -;; Fix value. -;; `cl' `lisp-float-type': -;; Require them. -;; `ps-number-of-columns' `ps-*-font-size': -;; Try to select defaults better suited when `ps-landscape-mode' is non-nil. -;; `ps-*-faces': -;; Change default for Font Lock mode faces when `ps-print-color-p' is nil. -;; `ps-right-header': -;; Replace `time-stamp-yy/mm/dd' by `time-stamp-mon-dd-yyyy'. -;; `ps-end-file' `ps-begin-page': -;; Fix bug in page count for Ghostview. -;; `ps-generate-postscript-with-faces': -;; Replace `ps-sorter' by `car-less-than-car'. -;; `ps-plot' `ps-generate': -;; Replace `%d' by `%3d'. - -;; 3.03 [jack] Sept 27, 1996 Jacques Duthen <duthen@cegelec-red.fr> -;; Merge 31 diffs between 19.29 and 19.34 - -;; 3.02 [jack] June 26, 1996 Jacques Duthen <duthen@cegelec-red.fr> -;; Add new page dimensions to `ps-page-dimensions-database' for `paper-type' -;; Improve landscape mode `ps-landscape-mode' and multiple columns -;; printing `ps-number-of-columns': -;; The text and the margins are no more scaled. -;; Simplify the semantics of `ps-inter-column' (space between columns). -;; Add error checking for negative `ps-print-width' and `ps-print-height'. -;; Change the semantics of `ps-top-margin' which is now the TOP MARGIN, -;; and add `ps-header-offset' instead of having `ps-top-margin' split in 2. -;; Add `ps-header-font-family', `ps-header-font-size' and -;; `ps-header-title-font-size' to control the header. -;; Add `ps-header-line-pad'. -;; Change the semantics of `ps-font-info-database' to have symbolic -;; font families. -;; Add new fonts to `ps-font-info-database': `Courier' `Helvetica' -;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk' -;; Make public `ps-font-family' and `ps-font-size' so that the user -;; can directly control the text font and size without loading ps-print. -;; Add error checking for unknown font families and a message giving -;; the exhaustive list of available font families. -;; Document how to install a new font family. -;; Add `/ReportAllFontInfo' to get all the font families of the printer. -;; Add the possibility to make `mixed' font families. -;; Add `ps-setup' to get the current setup. -;; Add tools `ps-line-lengths' `ps-nb-pages-buffer' `ps-nb-pages-region' -;; to help choose the font size. -;; Split `ps-print-prologue' in two to insert info from header fonts -;; Replace indexes by macro `ps-page-dimensions-get-width' -;; to get access to the dimensions list. -;; Add `ps-select-font' inside `ps-get-page-dimensions'. -;; Fix the "clumsy" `ps-page-height' management. -;; Move `ps-get-page-dimensions' to the beginning of `ps-begin-file' -;; to get early error checking. -;; Add sample setup `ps-jack-setup'. -;; -;; Rewrite a lot of postscript code and add comments inside it -;; (maybe they should not (or optionally) be included in the generated -;; Postscript). -;; Translate the origin to (lm, bm) to simplify the other moves. -;; Fix bug in `/HeaderOffset' with `/PrintStartY'. -;; Fix bug in `/SetHeaderLines'. -;; Change `/ReportFontInfo' for use by `/ReportAllFontInfo'. - -;; 3.01 [jack] June 4, 1996 Jacques Duthen <duthen@cegelec-red.fr> -;; Manage float value for every variable representing a size. -;; Add `ps-font-info-database' `ps-inter-column' - -;; 3.00 [jack] May 17, 1996 Jacques Duthen <duthen@cegelec-red.fr> -;; based on 2.8 Jim's Pretty-Good version: -;; Add `ps-landscape-mode' and `ps-number-of-columns' -;; for dumb multi-column landscape mode. - -;; Baseline-version: 2.8. (Jim'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 report the -;; version of Emacs, if any, that ps-print was distributed with.) - -;;; Commentary: - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; About ps-print -;; -------------- -;; -;; This package provides printing of Emacs buffers on PostScript -;; printers; the buffer's bold and italic text attributes are -;; preserved in the printer output. Ps-print is intended for use with -;; Emacs 19 or Lucid Emacs, together with a fontifying package such as -;; font-lock or hilit. -;; -;; -;; Using ps-print -;; -------------- -;; -;; The Commands -;; -;; Ps-print provides eight commands for generating PostScript images -;; of Emacs buffers: -;; -;; ps-print-buffer -;; ps-print-buffer-with-faces -;; ps-print-region -;; ps-print-region-with-faces -;; ps-spool-buffer -;; ps-spool-buffer-with-faces -;; ps-spool-region -;; ps-spool-region-with-faces -;; -;; These commands all perform essentially the same function: they -;; generate PostScript images suitable for printing on a PostScript -;; printer or displaying with GhostScript. These commands are -;; collectively referred to as "ps-print- commands". -;; -;; The word "print" or "spool" in the command name determines when the -;; PostScript image is sent to the printer: -;; -;; print - The PostScript image is immediately sent to the -;; printer; -;; -;; spool - The PostScript image is saved temporarily in an -;; Emacs buffer. Many images may be spooled locally -;; before printing them. To send the spooled images -;; to the printer, use the command `ps-despool'. -;; -;; The spooling mechanism was designed for printing lots of small -;; files (mail messages or netnews articles) to save paper that would -;; otherwise be wasted on banner pages, and to make it easier to find -;; your output at the printer (it's easier to pick up one 50-page -;; printout than to find 50 single-page printouts). -;; -;; Ps-print has a hook in the `kill-emacs-hooks' so that you won't -;; accidentally quit from Emacs while you have unprinted PostScript -;; waiting in the spool buffer. If you do attempt to exit with -;; spooled PostScript, you'll be asked if you want to print it, and if -;; you decline, you'll be asked to confirm the exit; this is modeled -;; on the confirmation that Emacs uses for modified buffers. -;; -;; The word "buffer" or "region" in the command name determines how -;; much of the buffer is printed: -;; -;; buffer - Print the entire buffer. -;; -;; region - Print just the current region. -;; -;; The -with-faces suffix on the command name means that the command -;; will include font, color, and underline information in the -;; PostScript image, so the printed image can look as pretty as the -;; buffer. The ps-print- commands without the -with-faces suffix -;; don't include font, color, or underline information; images printed -;; with these commands aren't as pretty, but are faster to generate. -;; -;; Two ps-print- command examples: -;; -;; ps-print-buffer - print the entire buffer, -;; without font, color, or -;; underline information, and -;; send it immediately to the -;; printer. -;; -;; ps-spool-region-with-faces - print just the current region; -;; include font, color, and -;; underline information, and -;; spool the image in Emacs to -;; send to the printer later. -;; -;; -;; Invoking Ps-Print -;; ----------------- -;; -;; To print your buffer, type -;; -;; M-x ps-print-buffer -;; -;; or substitute one of the other seven ps-print- commands. The -;; command will generate the PostScript image and print or spool it as -;; specified. By giving the command a prefix argument -;; -;; C-u M-x ps-print-buffer -;; -;; it will save the PostScript image to a file instead of sending it -;; to the printer; you will be prompted for the name of the file to -;; save the image to. The prefix argument is ignored by the commands -;; that spool their images, but you may save the spooled images to a -;; file by giving a prefix argument to `ps-despool': -;; -;; C-u M-x ps-despool -;; -;; When invoked this way, `ps-despool' will prompt you for the name of -;; the file to save to. -;; -;; Any of the `ps-print-' commands can be bound to keys; I recommend -;; binding `ps-spool-buffer-with-faces', `ps-spool-region-with-faces', -;; and `ps-despool'. Here are the bindings I use on my Sun 4 keyboard: -;; -;; (global-set-key 'f22 'ps-spool-buffer-with-faces) ;f22 is prsc -;; (global-set-key '(shift f22) 'ps-spool-region-with-faces) -;; (global-set-key '(control f22) 'ps-despool) -;; -;; -;; The Printer Interface -;; --------------------- -;; -;; The variables `ps-lpr-command' and `ps-lpr-switches' determine what -;; command is used to send the PostScript images to the printer, and -;; what arguments to give the command. These are analogous to -;; `lpr-command' and `lpr-switches'. -;; -;; Make sure that they contain appropriate values for your system; -;; see the usage notes below and the documentation of these variables. -;; -;; NOTE: `ps-lpr-command' and `ps-lpr-switches' take their initial values -;; from the variables `lpr-command' and `lpr-switches'. If you have -;; `lpr-command' set to invoke a pretty-printer such as `enscript', -;; then ps-print won't work properly. `ps-lpr-command' must name -;; a program that does not format the files it prints. -;; -;; -;; The Page Layout -;; --------------- -;; -;; All dimensions are floats in PostScript points. -;; 1 inch == 2.54 cm == 72 points -;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points -;; -;; The variable `ps-paper-type' determines the size of paper ps-print -;; formats for; it should contain one of the symbols: -;; `a4' `a3' `letter' `legal' `letter-small' `tabloid' -;; `ledger' `statement' `executive' `a4small' `b4' `b5' -;; -;; The variable `ps-landscape-mode' determines the orientation -;; of the printing on the page: -;; nil means `portrait' mode, non-nil means `landscape' mode. -;; There is no oblique mode yet, though this is easy to do in ps. - -;; In landscape mode, the text is NOT scaled: you may print 70 lines -;; in portrait mode and only 50 lignes in landscape mode. -;; The margins represent margins in the printed paper: -;; the top margin is the margin between the top of the page -;; and the printed header, whatever the orientation is. -;; -;; The variable `ps-number-of-columns' determines the number of columns -;; both in landscape and portrait mode. -;; You can use: -;; - (the standard) one column portrait mode -;; - (my favorite) two columns landscape mode (which spares trees) -;; but also -;; - one column landscape mode for files with very long lines. -;; - multi-column portrait or landscape mode -;; -;; -;; Horizontal layout -;; ----------------- -;; -;; The horizontal layout is determined by the variables -;; `ps-left-margin' `ps-inter-column' `ps-right-margin' -;; as follows: -;; -;; ------------------------------------------ -;; | | | | | | | | -;; | lm | text | ic | text | ic | text | rm | -;; | | | | | | | | -;; ------------------------------------------ -;; -;; If `ps-number-of-columns' is 1, `ps-inter-column' is not relevant. -;; Usually, lm = rm > 0 and ic = lm -;; If (ic < 0), the text of adjacent columns can overlap. -;; -;; -;; Vertical layout -;; --------------- -;; -;; The vertical layout is determined by the variables -;; `ps-bottom-margin' `ps-top-margin' `ps-header-offset' -;; as follows: -;; -;; |--------| |--------| -;; | tm | | tm | -;; |--------| |--------| -;; | header | | | -;; |--------| | | -;; | ho | | | -;; |--------| or | text | -;; | | | | -;; | text | | | -;; | | | | -;; |--------| |--------| -;; | bm | | bm | -;; |--------| |--------| -;; -;; If `ps-print-header' is nil, `ps-header-offset' is not relevant. -;; The margins represent margins in the printed paper: -;; the top margin is the margin between the top of the page -;; and the printed header, whatever the orientation is. -;; -;; -;; Headers -;; ------- -;; -;; Ps-print can print headers at the top of each column; the default -;; headers contain the following four items: on the left, the name of -;; the buffer and, if the buffer is visiting a file, the file's -;; directory; on the right, the page number and date of printing. -;; The default headers look something like this: -;; -;; ps-print.el 1/21 -;; /home/jct/emacs-lisp/ps/new 94/12/31 -;; -;; When printing on duplex printers, left and right are reversed so -;; that the page numbers are toward the outside (cf. `ps-spool-duplex'). -;; -;; Headers are configurable: -;; To turn them off completely, set `ps-print-header' to nil. -;; To turn off the header's gaudy framing box, -;; set `ps-print-header-frame' to nil. -;; -;; The font family and size of text in the header are determined -;; by the variables `ps-header-font-family', `ps-header-font-size' and -;; `ps-header-title-font-size' (see below). -;; -;; The variable `ps-header-line-pad' determines the portion of a header -;; title line height to insert between the header frame and the text -;; it contains, both in the vertical and horizontal directions: -;; .5 means half a line. - -;; Page numbers are printed in `n/m' format, indicating page n of m pages; -;; to omit the total page count and just print the page number, -;; set `ps-show-n-of-n' to nil. -;; -;; The amount of information in the header can be changed by changing -;; the number of lines. To show less, set `ps-header-lines' to 1, and -;; the header will show only the buffer name and page number. To show -;; more, set `ps-header-lines' to 3, and the header will show the time of -;; printing below the date. -;; -;; To change the content of the headers, change the variables -;; `ps-left-header' and `ps-right-header'. -;; These variables are lists, specifying top-to-bottom the text -;; to display on the left or right side of the header. -;; Each element of the list should be a string or a symbol. -;; Strings are inserted directly into the PostScript arrays, -;; and should contain the PostScript string delimiters '(' and ')'. -;; -;; Symbols in the header format lists can either represent functions -;; or variables. Functions are called, and should return a string to -;; show in the header. Variables should contain strings to display in -;; the header. In either case, function or variable, the PostScript -;; string delimiters are added by ps-print, and should not be part of -;; the returned value. -;; -;; Here's an example: say we want the left header to display the text -;; -;; Moe -;; Larry -;; Curly -;; -;; where we have a function to return "Moe" -;; -;; (defun moe-func () -;; "Moe") -;; -;; a variable specifying "Larry" -;; -;; (setq larry-var "Larry") -;; -;; and a literal for "Curly". Here's how `ps-left-header' should be -;; set: -;; -;; (setq ps-left-header (list 'moe-func 'larry-var "(Curly)")) -;; -;; Note that Curly has the PostScript string delimiters inside his -;; quotes -- those aren't misplaced lisp delimiters! -;; -;; Without them, PostScript would attempt to call the undefined -;; function Curly, which would result in a PostScript error. -;; -;; Since most printers don't report PostScript errors except by -;; aborting the print job, this kind of error can be hard to track down. -;; -;; Consider yourself warned! -;; -;; -;; Duplex Printers -;; --------------- -;; -;; If you have a duplex-capable printer (one that prints both sides of -;; the paper), set `ps-spool-duplex' to t. -;; Ps-print will insert blank pages to make sure each buffer starts -;; on the correct side of the paper. -;; Don't forget to set `ps-lpr-switches' to select duplex printing -;; for your printer. -;; -;; -;; Font managing -;; ------------- -;; -;; Ps-print now knows rather precisely some fonts: -;; the variable `ps-font-info-database' contains information -;; for a list of font families (currently mainly `Courier' `Helvetica' -;; `Times' `Palatino' `Helvetica-Narrow' `NewCenturySchlbk'). -;; Each font family contains the font names for standard, bold, italic -;; and bold-italic characters, a reference size (usually 10) and the -;; corresponding line height, width of a space and average character width. -;; -;; The variable `ps-font-family' determines which font family -;; is to be used for ordinary text. -;; If its value does not correspond to a known font family, -;; an error message is printed into the `*Messages*' buffer, -;; which lists the currently available font families. -;; -;; The variable `ps-font-size' determines the size (in points) -;; of the font for ordinary text, when generating Postscript. -;; Its value is a float. -;; -;; Similarly, the variable `ps-header-font-family' determines -;; which font family is to be used for text in the header. -;; The variable `ps-header-font-size' determines the font size, -;; in points, for text in the header. -;; The variable `ps-header-title-font-size' determines the font size, -;; in points, for the top line of text in the header. -;; -;; -;; Adding a new font family -;; ------------------------ -;; -;; To use a new font family, you MUST first teach ps-print -;; this font, i.e., add its information to `ps-font-info-database', -;; otherwise ps-print cannot correctly place line and page breaks. -;; -;; For example, assuming `Helvetica' is unknown, -;; you first need to do the following ONLY ONCE: -;; -;; - create a new buffer -;; - generate the PostScript image to a file (C-u M-x ps-print-buffer) -;; - open this file and find the line: -;; `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage' -;; - delete the leading `%' (which is the Postscript comment character) -;; - replace in this line `Courier' by the new font (say `Helvetica') -;; to get the line: -;; `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage' -;; - send this file to the printer (or to ghostscript). -;; You should read the following on the output page: -;; -;; For Helvetica 10 point, the line height is 11.56, the space width is 2.78 -;; and a crude estimate of average character width is 5.09243 -;; -;; - Add these values to the `ps-font-info-database': -;; (setq ps-font-info-database -;; (append -;; '((Helvetica ; the family name -;; "Helvetica" "Helvetica-Bold" "Helvetica-Oblique" "Helvetica-BoldOblique" -;; 10.0 11.56 2.78 5.09243)) -;; ps-font-info-database)) -;; - Now you can use this font family with any size: -;; (setq ps-font-family 'Helvetica) -;; - if you want to use this family in another emacs session, you must -;; put into your `~/.emacs': -;; (require 'ps-print) -;; (setq ps-font-info-database (append ...))) -;; if you don't want to load ps-print, you have to copy the whole value: -;; (setq ps-font-info-database '(<your stuff> <the standard stuff>)) -;; or, if you can wait until the `ps-print-hook' is implemented, do: -;; (add-hook 'ps-print-hook '(setq ps-font-info-database (append ...))) -;; This does not work yet, since there is no `ps-print-hook' yet. -;; -;; You can create new `mixed' font families like: -;; (my-mixed-family -;; "Courier-Bold" "Helvetica" -;; "Zapf-Chancery-MediumItalic" "NewCenturySchlbk-BoldItalic" -;; 10.0 10.55 6.0 6.0) -;; Now you can use your new font family with any size: -;; (setq ps-font-family 'my-mixed-family) -;; -;; You can get information on all the fonts resident in YOUR printer -;; by uncommenting the line: -;; % 3 cm 20 cm moveto ReportAllFontInfo showpage -;; -;; The postscript file should be sent to YOUR postscript printer. -;; If you send it to ghostscript or to another postscript printer, -;; you may get slightly different results. -;; Anyway, as ghostscript fonts are autoload, you won't get -;; much font info. -;; -;; -;; How Ps-Print Deals With Faces -;; ----------------------------- -;; -;; The ps-print-*-with-faces commands attempt to determine which faces -;; should be printed in bold or italic, but their guesses aren't -;; always right. For example, you might want to map colors into faces -;; so that blue faces print in bold, and red faces in italic. -;; -;; It is possible to force ps-print to consider specific faces bold or -;; italic, no matter what font they are displayed in, by setting the -;; variables `ps-bold-faces' and `ps-italic-faces'. These variables -;; contain lists of faces that ps-print should consider bold or -;; italic; to set them, put code like the following into your .emacs -;; file: -;; -;; (setq ps-bold-faces '(my-blue-face)) -;; (setq ps-italic-faces '(my-red-face)) -;; -;; Faces like bold-italic that are both bold and italic should go in -;; *both* lists. -;; -;; Ps-print keeps internal lists of which fonts are bold and which are -;; italic; these lists are built the first time you invoke ps-print. -;; For the sake of efficiency, the lists are built only once; the same -;; lists are referred in later invocations of ps-print. -;; -;; Because these lists are built only once, it's possible for them to -;; get out of sync, if a face changes, or if new faces are added. To -;; get the lists back in sync, you can set the variable -;; `ps-build-face-reference' to t, and the lists will be rebuilt the -;; next time ps-print is invoked. -;; -;; -;; How Ps-Print Deals With Color -;; ----------------------------- -;; -;; Ps-print detects faces with foreground and background colors -;; defined and embeds color information in the PostScript image. -;; The default foreground and background colors are defined by the -;; variables `ps-default-fg' and `ps-default-bg'. -;; On black-and-white printers, colors are displayed in grayscale. -;; To turn off color output, set `ps-print-color-p' to nil. -;; -;; -;; Utilities -;; --------- -;; -;; Some tools are provided to help you customize your font setup. -;; -;; `ps-setup' returns (some part of) the current setup. -;; -;; To avoid wrapping too many lines, you may want to adjust the -;; left and right margins and the font size. On UN*X systems, do: -;; pr -t file | awk '{printf "%3d %s\n", length($0), $0}' | sort -r | head -;; to determine the longest lines of your file. -;; Then, the command `ps-line-lengths' will give you the correspondence -;; between a line length (number of characters) and the maximum font -;; size which doesn't wrap such a line with the current ps-print setup. -;; -;; The commands `ps-nb-pages-buffer' and `ps-nb-pages-region' display -;; the correspondence between a number of pages and the maximum font -;; size which allow the number of lines of the current buffer or of -;; its current region to fit in this number of pages. -;; Note: line folding is not taken into account in this process -;; and could change the results. -;; -;; -;; New since version 1.5 -;; --------------------- -;; -;; Color output capability. -;; Automatic detection of font attributes (bold, italic). -;; Configurable headers with page numbers. -;; Slightly faster. -;; Support for different paper sizes. -;; Better conformance to PostScript Document Structure Conventions. -;; -;; -;; New since version 2.8 -;; --------------------- -;; -;; [jack] 960517 Jacques Duthen <duthen@cegelec-red.fr> -;; -;; Font familiy and float size for text and header. -;; Landscape mode. -;; Multiple columns. -;; Tools for page setup. -;; -;; -;; Known bugs and limitations of ps-print: -;; -------------------------------------- -;; -;; Although color printing will work in XEmacs 19.12, it doesn't work -;; well; in particular, bold or italic fonts don't print in the right -;; background color. -;; -;; Invisible properties aren't correctly ignored in XEmacs 19.12. -;; -;; Automatic font-attribute detection doesn't work well, especially -;; with hilit19 and older versions of get-create-face. Users having -;; problems with auto-font detection should use the lists -;; `ps-italic-faces' and `ps-bold-faces' and/or turn off automatic -;; detection by setting `ps-auto-font-detect' to nil. -;; -;; Automatic font-attribute detection doesn't work with XEmacs 19.12 -;; in tty mode; use the lists `ps-italic-faces' and `ps-bold-faces' -;; instead. -;; -;; Still too slow; could use some hand-optimization. -;; -;; ASCII Control characters other than tab, linefeed and pagefeed are -;; not handled. -;; -;; Default background color isn't working. -;; -;; Faces are always treated as opaque. -;; -;; Epoch and Emacs 18 not supported. At all. -;; -;; Fixed-pitch fonts work better for line folding, but are not required. -;; -;; `ps-nb-pages-buffer' and `ps-nb-pages-region' don't take care -;; of folding lines. -;; -;; -;; Things to change: -;; ---------------- -;; -;; Add `ps-print-hook' (I don't know how to do that (yet!)). -;; Add 4-up capability (really needed?). -;; Add line numbers (should not be too hard). -;; Add `ps-non-bold-faces' and `ps-non-italic-faces' (should be easy). -;; Put one header per page over the columns (easy but needed?). -;; Improve the memory management for big files (hard?). -;; `ps-nb-pages-buffer' and `ps-nb-pages-region' should take care -;; of folding lines. -;; -;; -;; Acknowledgements -;; ---------------- -;; Thanks to Jim Thompson <?@?> for the 2.8 version I started from. -;; [jack] -;; -;; Thanks to Kevin Rodgers <kevinr@ihs.com> for adding support for -;; color and the invisible property. -;; -;; Thanks to Avishai Yacobi, avishaiy@mcil.comm.mot.com, for writing -;; the initial port to Emacs 19. His code is no longer part of -;; ps-print, but his work is still appreciated. -;; -;; Thanks to Remi Houdaille and Michel Train, michel@metasoft.fdn.org, -;; for adding underline support. Their code also is no longer part of -;; ps-print, but their efforts are not forgotten. -;; -;; Thanks also to all of you who mailed code to add features to -;; ps-print; although I didn't use your code, I still appreciate your -;; sharing it with me. -;; -;; Thanks to all who mailed comments, encouragement, and criticism. -;; Thanks also to all who responded to my survey; I had too many -;; responses to reply to them all, but I greatly appreciate your -;; interest. -;; -;; Jim -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Code: - -(eval-when-compile - (require 'cl)) - -(unless (featurep 'lisp-float-type) - (error "`ps-print' requires floating point support")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; User Variables: - -;;; Interface to the command system - -(defgroup ps-print nil - "Postscript generator for Emacs 19" - :prefix "ps-" - :group 'wp) - -(defgroup ps-print-horizontal nil - "Horizontal page layout" - :prefix "ps-" - :tag "Horizontal" - :group 'ps-print) - -(defgroup ps-print-vertical nil - "Vertical page layout" - :prefix "ps-" - :tag "Vertical" - :group 'ps-print) - -(defgroup ps-print-header nil - "Headers layout" - :prefix "ps-" - :tag "Header" - :group 'ps-print) - -(defgroup ps-print-font nil - "Fonts customization" - :prefix "ps-" - :tag "Font" - :group 'ps-print) - -(defgroup ps-print-color nil - "Color customization" - :prefix "ps-" - :tag "Color" - :group 'ps-print) - -(defgroup ps-print-face nil - "Faces customization" - :prefix "ps-" - :tag "PS Faces" - :group 'ps-print - :group 'faces) - - -(defcustom ps-lpr-command lpr-command - "*The shell command for printing a PostScript file." - :type 'string - :group 'ps-print) - -(defcustom ps-lpr-switches lpr-switches - "*A list of extra switches to pass to `ps-lpr-command'." - :type '(repeat string) - :group 'ps-print) - -;;; Page layout - -;; All page dimensions are in PostScript points. -;; 1 inch == 2.54 cm == 72 points -;; 1 cm == (/ 1 2.54) inch == (/ 72 2.54) points - -;; Letter 8.5 inch x 11.0 inch -;; Legal 8.5 inch x 14.0 inch -;; A4 8.26 inch x 11.69 inch = 21.0 cm x 29.7 cm - -;; LetterSmall 7.68 inch x 10.16 inch -;; Tabloid 11.0 inch x 17.0 inch -;; Ledger 17.0 inch x 11.0 inch -;; Statement 5.5 inch x 8.5 inch -;; Executive 7.5 inch x 10.0 inch -;; A3 11.69 inch x 16.5 inch = 29.7 cm x 42.0 cm -;; A4Small 7.47 inch x 10.85 inch -;; B4 10.125 inch x 14.33 inch -;; B5 7.16 inch x 10.125 inch - -(defcustom ps-page-dimensions-database - (list (list 'a4 (/ (* 72 21.0) 2.54) (/ (* 72 29.7) 2.54)) - (list 'a3 (/ (* 72 29.7) 2.54) (/ (* 72 42.0) 2.54)) - (list 'letter (* 72 8.5) (* 72 11.0)) - (list 'legal (* 72 8.5) (* 72 14.0)) - (list 'letter-small (* 72 7.68) (* 72 10.16)) - (list 'tabloid (* 72 11.0) (* 72 17.0)) - (list 'ledger (* 72 17.0) (* 72 11.0)) - (list 'statement (* 72 5.5) (* 72 8.5)) - (list 'executive (* 72 7.5) (* 72 10.0)) - (list 'a4small (* 72 7.47) (* 72 10.85)) - (list 'b4 (* 72 10.125) (* 72 14.33)) - (list 'b5 (* 72 7.16) (* 72 10.125))) - "*List associating a symbolic paper type to its width and height. -see `ps-paper-type'." - :type '(repeat (list :tag "Paper Type" - (symbol :tag "Name") - (number :tag "Width") - (number :tag "Height"))) - :group 'ps-print) - -;;;###autoload -(defcustom ps-paper-type 'letter - "*Specifies the size of paper to format for. -Should be one of the paper types defined in `ps-page-dimensions-database', for -example `letter', `legal' or `a4'." - :type '(symbol :validate (lambda (wid) - (if (assq (widget-value wid) ps-page-dimensions-database) - nil - (widget-put wid :error "Unknown paper size") - wid))) - :group 'ps-print) - -(defcustom ps-landscape-mode 'nil - "*Non-nil means print in landscape mode." - :type 'boolean - :group 'ps-print) - -(defcustom ps-number-of-columns (if ps-landscape-mode 2 1) - "*Specifies the number of columns" - :type 'integer - :group 'ps-print) - -;;; Horizontal layout - -;; ------------------------------------------ -;; | | | | | | | | -;; | lm | text | ic | text | ic | text | rm | -;; | | | | | | | | -;; ------------------------------------------ - -(defcustom ps-left-margin (/ (* 72 2.0) 2.54) ; 2 cm - "*Left margin in points (1/72 inch)." - :type 'number - :group 'ps-print-horizontal) - -(defcustom ps-right-margin (/ (* 72 2.0) 2.54) ; 2 cm - "*Right margin in points (1/72 inch)." - :type 'number - :group 'ps-print-horizontal) - -(defcustom ps-inter-column (/ (* 72 2.0) 2.54) ; 2 cm - "*Horizontal space between columns in points (1/72 inch)." - :type 'number - :group 'ps-print-horizontal) - -;;; Vertical layout - -;; |--------| -;; | tm | -;; |--------| -;; | header | -;; |--------| -;; | ho | -;; |--------| -;; | text | -;; |--------| -;; | bm | -;; |--------| - -(defcustom ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm - "*Bottom margin in points (1/72 inch)." - :type 'number - :group 'ps-print-vertical) - -(defcustom ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm - "*Top margin in points (1/72 inch)." - :type 'number - :group 'ps-print-vertical) - -(defcustom ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm - "*Vertical space in points (1/72 inch) between the main text and the header." - :type 'number - :group 'ps-print-vertical) - -(defcustom ps-header-line-pad 0.15 - "*Portion of a header title line height to insert between the header frame -and the text it contains, both in the vertical and horizontal directions." - :type 'number - :group 'ps-print-vertical) - -;;; Header setup - -(defcustom ps-print-header t - "*Non-nil means print a header at the top of each page. -By default, the header displays the buffer name, page number, and, if -the buffer is visiting a file, the file's directory. Headers are -customizable by changing variables `ps-header-left' and -`ps-header-right'." - :type 'boolean - :group 'ps-print-header) - -(defcustom ps-print-header-frame t - "*Non-nil means draw a gaudy frame around the header." - :type 'boolean - :group 'ps-print-header) - -(defcustom ps-header-lines 2 - "*Number of lines to display in page header, when generating Postscript." - :type 'integer - :group 'ps-print-header) -(make-variable-buffer-local 'ps-header-lines) - -(defcustom ps-show-n-of-n t - "*Non-nil means show page numbers as N/M, meaning page N of M. -Note: page numbers are displayed as part of headers, see variable -`ps-print-headers'." - :type 'boolean - :group 'ps-print-header) - -(defcustom ps-spool-duplex nil ; Not many people have duplex - ; printers, so default to nil. - "*Non-nil indicates spooling is for a two-sided printer. -For a duplex printer, the `ps-spool-*' commands will insert blank pages -as needed between print jobs so that the next buffer printed will -start on the right page. Also, if headers are turned on, the headers -will be reversed on duplex printers so that the page numbers fall to -the left on even-numbered pages." - :type 'boolean - :group 'ps-print-header) - -;;; Fonts - -(defcustom ps-font-info-database - '((Courier ; the family key - "Courier" "Courier-Bold" "Courier-Oblique" "Courier-BoldOblique" - 10.0 10.55 6.0 6.0) - (Helvetica ; the family key - "Helvetica" "Helvetica-Bold" "Helvetica-Oblique" "Helvetica-BoldOblique" - 10.0 11.56 2.78 5.09243) - (Times - "Times-Roman" "Times-Bold" "Times-Italic" "Times-BoldItalic" - 10.0 11.0 2.5 4.71432) - (Palatino - "Palatino-Roman" "Palatino-Bold" "Palatino-Italic" "Palatino-BoldItalic" - 10.0 12.1 2.5 5.08676) - (Helvetica-Narrow - "Helvetica-Narrow" "Helvetica-Narrow-Bold" - "Helvetica-Narrow-Oblique" "Helvetica-Narrow-BoldOblique" - 10.0 11.56 2.2796 4.17579) - (NewCenturySchlbk - "NewCenturySchlbk-Roman" "NewCenturySchlbk-Bold" - "NewCenturySchlbk-Italic" "NewCenturySchlbk-BoldItalic" - 10.0 12.15 2.78 5.31162) - ;; got no bold for the next ones - (AvantGarde-Book - "AvantGarde-Book" "AvantGarde-Book" - "AvantGarde-BookOblique" "AvantGarde-BookOblique" - 10.0 11.77 2.77 5.45189) - (AvantGarde-Demi - "AvantGarde-Demi" "AvantGarde-Demi" - "AvantGarde-DemiOblique" "AvantGarde-DemiOblique" - 10.0 12.72 2.8 5.51351) - (Bookman-Demi - "Bookman-Demi" "Bookman-Demi" - "Bookman-DemiItalic" "Bookman-DemiItalic" - 10.0 11.77 3.4 6.05946) - (Bookman-Light - "Bookman-Light" "Bookman-Light" - "Bookman-LightItalic" "Bookman-LightItalic" - 10.0 11.79 3.2 5.67027) - ;; got no bold and no italic for the next ones - (Symbol - "Symbol" "Symbol" "Symbol" "Symbol" - 10.0 13.03 2.5 3.24324) - (Zapf-Dingbats - "Zapf-Dingbats" "Zapf-Dingbats" "Zapf-Dingbats" "Zapf-Dingbats" - 10.0 9.63 2.78 2.78) - (Zapf-Chancery-MediumItalic - "Zapf-Chancery-MediumItalic" "Zapf-Chancery-MediumItalic" - "Zapf-Chancery-MediumItalic" "Zapf-Chancery-MediumItalic" - 10.0 11.45 2.2 4.10811) -) - "*Font info database: font family (the key), name, bold, italic, bold-italic, -reference size, line height, space width, average character width. -To get the info for another specific font (say Helvetica), do the following: -- create a new buffer -- generate the PostScript image to a file (C-u M-x ps-print-buffer) -- open this file and delete the leading `%' (which is the Postscript - comment character) from the line - `% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage' - to get the line - `3 cm 20 cm moveto 10 /Helvetica ReportFontInfo showpage' -- add the values to `ps-font-info-database'. -You can get all the fonts of YOUR printer using `ReportAllFontInfo'." - :type '(repeat (list :tag "Font Definition" - (symbol :tag "Font") - (string :tag "Name") - (string :tag "Bold") - (string :tag "Italic") - (string :tag "Bold-Italic") - (number :tag "Reference Size") - (number :tag "Line Height") - (number :tag "Space Width") - (number :tag "Average Character Width"))) - :group 'ps-print-font) - -(defcustom ps-font-family 'Courier - "Font family name for ordinary text, when generating Postscript." - :type 'symbol - :group 'ps-print-font) - -(defcustom ps-font-size (if ps-landscape-mode 7 8.5) - "Font size, in points, for ordinary text, when generating Postscript." - :type 'number - :group 'ps-print-font) - -(defcustom ps-header-font-family 'Helvetica - "Font family name for text in the header, when generating Postscript." - :type 'symbol - :group 'ps-print-font) - -(defcustom ps-header-font-size (if ps-landscape-mode 10 12) - "Font size, in points, for text in the header, when generating Postscript." - :type 'number - :group 'ps-print-font) - -(defcustom ps-header-title-font-size (if ps-landscape-mode 12 14) - "Font size, in points, for the top line of text in the header, -when generating Postscript." - :type 'number - :group 'ps-print-font) - -;;; Colors - -;;;###autoload -;;; The 19.33 fsf version includes a test on pixel components instead -;;; of color-instance-rgb-components -(defcustom ps-print-color-p (or (fboundp 'x-color-values) ; fsf - (fboundp 'color-instance-rgb-components)) - ; xemacs -; Printing color requires x-color-values. - "*If non-nil, print the buffer's text in color." - :type 'boolean - :group 'ps-print-color) - -(defcustom ps-default-fg '(0.0 0.0 0.0) - "*RGB values of the default foreground color. Defaults to black." - :type '(list (number :tag "Red") (number :tag "Green") (number :tag "Blue")) - :group 'ps-print-color) - -(defcustom ps-default-bg '(1.0 1.0 1.0) - "*RGB values of the default background color. Defaults to white." - :type '(list (number :tag "Red") (number :tag "Green") (number :tag "Blue")) - :group 'ps-print-color) - -(defcustom ps-auto-font-detect t - "*Non-nil means automatically detect bold/italic face attributes. -nil means rely solely on the lists `ps-bold-faces', `ps-italic-faces', -and `ps-underlined-faces'." - :type 'boolean - :group 'ps-print-font) - -(defcustom ps-bold-faces - (unless ps-print-color-p - '(font-lock-function-name-face - font-lock-builtin-face - font-lock-variable-name-face - font-lock-keyword-face - font-lock-warning-face)) - "*A list of the \(non-bold\) faces that should be printed in bold font. -This applies to generating Postscript." - :type '(repeat face) - :group 'ps-print-face) - -(defcustom ps-italic-faces - (unless ps-print-color-p - '(font-lock-variable-name-face - font-lock-string-face - font-lock-comment-face - font-lock-warning-face)) - "*A list of the \(non-italic\) faces that should be printed in italic font. -This applies to generating Postscript." - :type '(repeat face) - :group 'ps-print-face) - -(defcustom ps-underlined-faces - (unless ps-print-color-p - '(font-lock-function-name-face - font-lock-type-face - font-lock-reference-face - font-lock-warning-face)) - "*A list of the \(non-underlined\) faces that should be printed underlined. -This applies to generating Postscript." - :type '(repeat face) - :group 'ps-print-face) - -(defcustom ps-left-header - (list 'ps-get-buffer-name 'ps-header-dirpart) - "*The items to display (each on a line) on the left part of the page header. -This applies to generating Postscript. - -The value should be a list of strings and symbols, each representing an -entry in the PostScript array HeaderLinesLeft. - -Strings are inserted unchanged into the array; those representing -PostScript string literals should be delimited with PostScript string -delimiters '(' and ')'. - -For symbols with bound functions, the function is called and should -return a string to be inserted into the array. For symbols with bound -values, the value should be a string to be inserted into the array. -In either case, function or variable, the string value has PostScript -string delimiters added to it." - :type '(repeat (choice string symbol)) - :group 'ps-print-header) -(make-variable-buffer-local 'ps-left-header) - -(defcustom ps-right-header - (list "/pagenumberstring load" 'time-stamp-mon-dd-yyyy 'time-stamp-hh:mm:ss) - "*The items to display (each on a line) on the right part of the page header. -This applies to generating Postscript. - -See the variable `ps-left-header' for a description of the format of -this variable." - :type '(repeat (choice string symbol)) - :group 'ps-print-header) -(make-variable-buffer-local 'ps-right-header) - -(defcustom ps-razzle-dazzle t - "*Non-nil means report progress while formatting buffer." - :type 'boolean - :group 'ps-print) - -(defvar ps-adobe-tag "%!PS-Adobe-3.0\n" - "*Contains the header line identifying the output as PostScript. -By default, `ps-adobe-tag' contains the standard identifier. Some -printers require slightly different versions of this line.") - -(defcustom ps-build-face-reference t - "*Non-nil means build the reference face lists. - -Ps-print sets this value to nil after it builds its internal reference -lists of bold and italic faces. By settings its value back to t, you -can force ps-print to rebuild the lists the next time you invoke one -of the ...-with-faces commands. - -You should set this value back to t after you change the attributes of -any face, or create new faces. Most users shouldn't have to worry -about its setting, though." - :type 'boolean - :group 'ps-print-face) - -(defcustom ps-always-build-face-reference nil - "*Non-nil means always rebuild the reference face lists. - -If this variable is non-nil, ps-print will rebuild its internal -reference lists of bold and italic faces *every* time one of the --with-faces commands is called. Most users shouldn't need to set this -variable." - :type 'boolean - :group 'ps-print-face) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; User commands - -;;;###autoload -(defun ps-print-buffer (&optional filename) - "Generate and print a PostScript image of the buffer. - -When called with a numeric prefix argument (C-u), prompts the user for -the name of a file to save the PostScript image in, instead of sending -it to the printer. - -More specifically, the FILENAME argument is treated as follows: if it -is nil, send the image to the printer. If FILENAME is a string, save -the PostScript image in a file with that name. If FILENAME is a -number, prompt the user for the name of the file to save in." - - (interactive (list (ps-print-preprint current-prefix-arg))) - (ps-generate (current-buffer) (point-min) (point-max) - 'ps-generate-postscript) - (ps-do-despool filename)) - - -;;;###autoload -(defun ps-print-buffer-with-faces (&optional filename) - "Generate and print a PostScript image of the buffer. -Like `ps-print-buffer', but includes font, color, and underline -information in the generated image. This command works only if you -are using a window system, so it has a way to determine color values." - (interactive (list (ps-print-preprint current-prefix-arg))) - (ps-generate (current-buffer) (point-min) (point-max) - 'ps-generate-postscript-with-faces) - (ps-do-despool filename)) - - -;;;###autoload -(defun ps-print-region (from to &optional filename) - "Generate and print a PostScript image of the region. -Like `ps-print-buffer', but prints just the current region." - - (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg))) - (ps-generate (current-buffer) from to - 'ps-generate-postscript) - (ps-do-despool filename)) - - -;;;###autoload -(defun ps-print-region-with-faces (from to &optional filename) - "Generate and print a PostScript image of the region. -Like `ps-print-region', but includes font, color, and underline -information in the generated image. This command works only if you -are using a window system, so it has a way to determine color values." - - (interactive (list (point) (mark) (ps-print-preprint current-prefix-arg))) - (ps-generate (current-buffer) from to - 'ps-generate-postscript-with-faces) - (ps-do-despool filename)) - - -;;;###autoload -(defun ps-spool-buffer () - "Generate and spool a PostScript image of the buffer. -Like `ps-print-buffer' except that the PostScript image is saved in a -local buffer to be sent to the printer later. - -Use the command `ps-despool' to send the spooled images to the printer." - (interactive) - (ps-generate (current-buffer) (point-min) (point-max) - 'ps-generate-postscript)) - - -;;;###autoload -(defun ps-spool-buffer-with-faces () - "Generate and spool a PostScript image of the buffer. -Like `ps-spool-buffer', but includes font, color, and underline -information in the generated image. This command works only if you -are using a window system, so it has a way to determine color values. - -Use the command `ps-despool' to send the spooled images to the printer." - - (interactive) - (ps-generate (current-buffer) (point-min) (point-max) - 'ps-generate-postscript-with-faces)) - - -;;;###autoload -(defun ps-spool-region (from to) - "Generate a PostScript image of the region and spool locally. -Like `ps-spool-buffer', but spools just the current region. - -Use the command `ps-despool' to send the spooled images to the printer." - (interactive "r") - (ps-generate (current-buffer) from to - 'ps-generate-postscript)) - - -;;;###autoload -(defun ps-spool-region-with-faces (from to) - "Generate a PostScript image of the region and spool locally. -Like `ps-spool-region', but includes font, color, and underline -information in the generated image. This command works only if you -are using a window system, so it has a way to determine color values. - -Use the command `ps-despool' to send the spooled images to the printer." - (interactive "r") - (ps-generate (current-buffer) from to - 'ps-generate-postscript-with-faces)) - -;;;###autoload -(defun ps-despool (&optional filename) - "Send the spooled PostScript to the printer. - -When called with a numeric prefix argument (C-u), prompt the user for -the name of a file to save the spooled PostScript in, instead of sending -it to the printer. - -More specifically, the FILENAME argument is treated as follows: if it -is nil, send the image to the printer. If FILENAME is a string, save -the PostScript image in a file with that name. If FILENAME is a -number, prompt the user for the name of the file to save in." - (interactive (list (ps-print-preprint current-prefix-arg))) - (ps-do-despool filename)) - -;;;###autoload -(defun ps-line-lengths () - "*Display the correspondence between a line length and a font size, -using the current ps-print setup. -Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head" - (interactive) - (ps-line-lengths-internal)) - -;;;###autoload -(defun ps-nb-pages-buffer (nb-lines) - "*Display an approximate correspondence between a font size and the number -of pages the current buffer would require to print -using the current ps-print setup." - (interactive (list (count-lines (point-min) (point-max)))) - (ps-nb-pages nb-lines)) - -;;;###autoload -(defun ps-nb-pages-region (nb-lines) - "*Display an approximate correspondence between a font size and the number -of pages the current region would require to print -using the current ps-print setup." - (interactive (list (count-lines (mark) (point)))) - (ps-nb-pages nb-lines)) - -;;;###autoload -(defun ps-setup () - "*Return the current setup" - (format " - (setq ps-print-color-p %s - ps-lpr-command \"%s\" - ps-lpr-switches %s - - ps-paper-type '%s - ps-landscape-mode %s - ps-number-of-columns %s - - ps-left-margin %s - ps-right-margin %s - ps-inter-column %s - ps-bottom-margin %s - ps-top-margin %s - ps-header-offset %s - ps-header-line-pad %s - ps-print-header %s - ps-print-header-frame %s - ps-header-lines %s - ps-show-n-of-n %s - ps-spool-duplex %s - - ps-font-family '%s - ps-font-size %s - ps-header-font-family '%s - ps-header-font-size %s - ps-header-title-font-size %s) -" - ps-print-color-p - ps-lpr-command - ps-lpr-switches - ps-paper-type - ps-landscape-mode - ps-number-of-columns - ps-left-margin - ps-right-margin - ps-inter-column - ps-bottom-margin - ps-top-margin - ps-header-offset - ps-header-line-pad - ps-print-header - ps-print-header-frame - ps-header-lines - ps-show-n-of-n - ps-spool-duplex - ps-font-family - ps-font-size - ps-header-font-family - ps-header-font-size - ps-header-title-font-size)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Utility functions and variables: - -(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 (or (eq ps-print-emacs-type 'lucid) - (eq ps-print-emacs-type '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. -(defun ps-color-device () - (if (and (eq ps-print-emacs-type 'xemacs) - (>= emacs-minor-version 12)) - (eq (device-class) 'color) - t)) - -(require 'time-stamp) - -(defvar ps-font nil - "Font family name for ordinary text, when generating Postscript.") - -(defvar ps-font-bold nil - "Font family name for bold text, when generating Postscript.") - -(defvar ps-font-italic nil - "Font family name for italic text, when generating Postscript.") - -(defvar ps-font-bold-italic nil - "Font family name for bold italic text, when generating Postscript.") - -(defvar ps-avg-char-width nil - "The average width, in points, of a character, for generating Postscript. -This is the value that ps-print uses to determine the length, -x-dimension, of the text it has printed, and thus affects the point at -which long lines wrap around.") - -(defvar ps-space-width nil - "The width of a space character, for generating Postscript. -This value is used in expanding tab characters.") - -(defvar ps-line-height nil - "The height of a line, for generating Postscript. -This is the value that ps-print uses to determine the height, -y-dimension, of the lines of text it has printed, and thus affects the -point at which page-breaks are placed. -The line-height is *not* the same as the point size of the font.") - -(defvar ps-print-prologue-1 - "% ISOLatin1Encoding stolen from ps_init.ps in GhostScript 2.6.1.4: -/ISOLatin1Encoding where { pop } { -% -- The ISO Latin-1 encoding vector isn't known, so define it. -% -- The first half is the same as the standard encoding, -% -- except for minus instead of hyphen at code 055. -/ISOLatin1Encoding -StandardEncoding 0 45 getinterval aload pop - /minus -StandardEncoding 46 82 getinterval aload pop -%*** NOTE: the following are missing in the Adobe documentation, -%*** but appear in the displayed table: -%*** macron at 0225, dieresis at 0230, cedilla at 0233, space at 0240. -% 0200 (128) - /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef - /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef - /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent - /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron -% 0240 (160) - /space /exclamdown /cent /sterling - /currency /yen /brokenbar /section - /dieresis /copyright /ordfeminine /guillemotleft - /logicalnot /hyphen /registered /macron - /degree /plusminus /twosuperior /threesuperior - /acute /mu /paragraph /periodcentered - /cedilla /onesuperior /ordmasculine /guillemotright - /onequarter /onehalf /threequarters /questiondown -% 0300 (192) - /Agrave /Aacute /Acircumflex /Atilde - /Adieresis /Aring /AE /Ccedilla - /Egrave /Eacute /Ecircumflex /Edieresis - /Igrave /Iacute /Icircumflex /Idieresis - /Eth /Ntilde /Ograve /Oacute - /Ocircumflex /Otilde /Odieresis /multiply - /Oslash /Ugrave /Uacute /Ucircumflex - /Udieresis /Yacute /Thorn /germandbls -% 0340 (224) - /agrave /aacute /acircumflex /atilde - /adieresis /aring /ae /ccedilla - /egrave /eacute /ecircumflex /edieresis - /igrave /iacute /icircumflex /idieresis - /eth /ntilde /ograve /oacute - /ocircumflex /otilde /odieresis /divide - /oslash /ugrave /uacute /ucircumflex - /udieresis /yacute /thorn /ydieresis -256 packedarray def -} ifelse - -/reencodeFontISO { %def - dup - length 5 add dict % Make a new font (a new dict the same size - % as the old one) with room for our new symbols. - - begin % Make the new font the current dictionary. - - - { 1 index /FID ne - { def } { pop pop } ifelse - } forall % Copy each of the symbols from the old dictionary - % to the new one except for the font ID. - - /Encoding ISOLatin1Encoding def % Override the encoding with - % the ISOLatin1 encoding. - - % Use the font's bounding box to determine the ascent, descent, - % and overall height; don't forget that these values have to be - % transformed using the font's matrix. - -% ^ (x2 y2) -% | | -% | v -% | +----+ - - -% | | | ^ -% | | | | Ascent (usually > 0) -% | | | | -% (0 0) -> +--+----+--------> -% | | | -% | | v Descent (usually < 0) -% (x1 y1) --> +----+ - - - - FontBBox % -- x1 y1 x2 y2 - FontMatrix transform /Ascent exch def pop - FontMatrix transform /Descent exch def pop - /FontHeight Ascent Descent sub def % use `sub' because descent < 0 - - % Define these in case they're not in the FontInfo - % (also, here they're easier to get to. - /UnderlinePosition 1 def - /UnderlineThickness 1 def - - % Get the underline position and thickness if they're defined. - currentdict /FontInfo known { - FontInfo - - dup /UnderlinePosition known { - dup /UnderlinePosition get - 0 exch FontMatrix transform exch pop - /UnderlinePosition exch def - } if - - dup /UnderlineThickness known { - /UnderlineThickness get - 0 exch FontMatrix transform exch pop - /UnderlineThickness exch def - } if - - } if - - currentdict % Leave the new font on the stack - end % Stop using the font as the current dictionary. - definefont % Put the font into the font dictionary - pop % Discard the returned font. -} bind def - -/DefFont { % Font definition - findfont exch scalefont reencodeFontISO -} def - -/F { % Font selection - findfont - dup /Ascent get /Ascent exch def - dup /Descent get /Descent exch def - dup /FontHeight get /FontHeight exch def - dup /UnderlinePosition get /UnderlinePosition exch def - dup /UnderlineThickness get /UnderlineThickness exch def - setfont -} def - -/FG /setrgbcolor load def - -/bg false def -/BG { - dup /bg exch def - { mark 4 1 roll ] /bgcolor exch def } if -} def - -% B width C -% +-----------+ -% | Ascent (usually > 0) -% A + + -% | Descent (usually < 0) -% +-----------+ -% E width D - -/dobackground { % width -- - currentpoint % -- width x y - gsave - newpath - moveto % A (x y) - 0 Ascent rmoveto % B - dup 0 rlineto % C - 0 Descent Ascent sub rlineto % D - neg 0 rlineto % E - closepath - bgcolor aload pop setrgbcolor - fill - grestore -} def - -/dobackgroundstring { % string -- - stringwidth pop - dobackground -} def - -/dounderline { % fromx fromy -- - currentpoint - gsave - UnderlineThickness setlinewidth - 4 2 roll - UnderlinePosition add moveto - UnderlinePosition add lineto - stroke - grestore -} def - -/eolbg { % dobackground until right margin - PrintWidth % -- x-eol - currentpoint pop % -- cur-x - sub % -- width until eol - dobackground -} def - -/eolul { % idem for underline - PrintWidth % -- x-eol - currentpoint exch pop % -- x-eol cur-y - dounderline -} def - -/SL { % Soft Linefeed - bg { eolbg } if - ul { eolul } if - 0 currentpoint exch pop LineHeight sub moveto -} def - -/HL /SL load def % Hard Linefeed - -/sp1 { currentpoint 3 -1 roll } def - -% Some debug -/dcp { currentpoint exch 40 string cvs print (, ) print = } def -/dp { print 2 copy - exch 40 string cvs print (, ) print = } def - -/S { - bg { dup dobackgroundstring } if - ul { sp1 } if - show - ul { dounderline } if -} def - -/W { - ul { sp1 } if - ( ) stringwidth % Get the width of a space in the current font. - pop % Discard the Y component. - mul % Multiply the width of a space - % by the number of spaces to plot - bg { dup dobackground } if - 0 rmoveto - ul { dounderline } if -} def - -/BeginDoc { - % ---- save the state of the document (useful for ghostscript!) - /docState save def - % ---- [jack] Kludge: my ghostscript window is 21x27.7 instead of 21x29.7 - /JackGhostscript where { - pop 1 27.7 29.7 div scale - } if - LandscapeMode { - % ---- translate to bottom-right corner of Portrait page - LandscapePageHeight 0 translate - 90 rotate - } if - /ColumnWidth PrintWidth InterColumn add def - % ---- translate to lower left corner of TEXT - LeftMargin BottomMargin translate - % ---- define where printing will start - /f0 F % this installs Ascent - /PrintStartY PrintHeight Ascent sub def - /ColumnIndex 1 def -} def - -/EndDoc { - % ---- on last page but not last column, spit out the page - ColumnIndex 1 eq not { showpage } if - % ---- restore the state of the document (useful for ghostscript!) - docState restore -} def - -/BeginDSCPage { - % ---- when 1st column, save the state of the page - ColumnIndex 1 eq { /pageState save def } if - % ---- save the state of the column - /columnState save def -} def - -/BeginPage { - PrintHeader { - PrintHeaderFrame { HeaderFrame } if - HeaderText - } if - 0 PrintStartY moveto % move to where printing will start -} def - -/EndPage { - bg { eolbg } if - ul { eolul } if -} def - -/EndDSCPage { - ColumnIndex NumberOfColumns eq { - % ---- on last column, spit out the page - showpage - % ---- restore the state of the page - pageState restore - /ColumnIndex 1 def - } { % else - % ---- restore the state of the current column - columnState restore - % ---- and translate to the next column - ColumnWidth 0 translate - /ColumnIndex ColumnIndex 1 add def - } ifelse -} def - -/ul false def - -/UL { /ul exch def } def - -/SetHeaderLines { % nb-lines -- - /HeaderLines exch def - % ---- bottom up - HeaderPad - HeaderLines 1 sub HeaderLineHeight mul add - HeaderTitleLineHeight add - HeaderPad add - /HeaderHeight exch def -} def - -% |---------| -% | tm | -% |---------| -% | header | -% |-+-------| <-- (x y) -% | ho | -% |---------| -% | text | -% |-+-------| <-- (0 0) -% | bm | -% |---------| - -/HeaderFrameStart { % -- x y - 0 PrintHeight HeaderOffset add -} def - -/HeaderFramePath { - PrintWidth 0 rlineto - 0 HeaderHeight rlineto - PrintWidth neg 0 rlineto - 0 HeaderHeight neg rlineto -} def - -/HeaderFrame { - gsave - 0.4 setlinewidth - % ---- fill a black rectangle (the shadow of the next one) - HeaderFrameStart moveto - 1 -1 rmoveto - HeaderFramePath - 0 setgray fill - % ---- do the next rectangle ... - HeaderFrameStart moveto - HeaderFramePath - gsave 0.9 setgray fill grestore % filled with grey - gsave 0 setgray stroke grestore % drawn with black - grestore -} def - -/HeaderStart { - HeaderFrameStart - exch HeaderPad add exch % horizontal pad - % ---- bottom up - HeaderPad add % vertical pad - HeaderDescent sub - HeaderLineHeight HeaderLines 1 sub mul add -} def - -/strcat { - dup length 3 -1 roll dup length dup 4 -1 roll add string dup - 0 5 -1 roll putinterval - dup 4 2 roll exch putinterval -} def - -/pagenumberstring { - PageNumber 32 string cvs - ShowNofN { - (/) strcat - PageCount 32 string cvs strcat - } if -} def - -/HeaderText { - HeaderStart moveto - - HeaderLinesRight HeaderLinesLeft % -- rightLines leftLines - - % ---- hack: `PN 1 and' == `PN 2 modulo' - - % ---- if duplex and even page number, then exchange left and right - Duplex PageNumber 1 and 0 eq and { exch } if - - { % ---- process the left lines - aload pop - exch F - gsave - dup xcheck { exec } if - show - grestore - 0 HeaderLineHeight neg rmoveto - } forall - - HeaderStart moveto - - { % ---- process the right lines - aload pop - exch F - gsave - dup xcheck { exec } if - dup stringwidth pop - PrintWidth exch sub HeaderPad 2 mul sub 0 rmoveto - show - grestore - 0 HeaderLineHeight neg rmoveto - } forall -} def - -/ReportFontInfo { - 2 copy - /t0 3 1 roll DefFont - /t0 F - /lh FontHeight def - /sw ( ) stringwidth pop def - /aw (01234567890abcdefghijklmnopqrstuvwxyz) dup length exch - stringwidth pop exch div def - /t1 12 /Helvetica-Oblique DefFont - /t1 F - gsave - (For ) show - 128 string cvs show - ( ) show - 32 string cvs show - ( point, the line height is ) show - lh 32 string cvs show - (, the space width is ) show - sw 32 string cvs show - (,) show - grestore - 0 FontHeight neg rmoveto - gsave - (and a crude estimate of average character width is ) show - aw 32 string cvs show - (.) show - grestore - 0 FontHeight neg rmoveto -} def - -/cm { % cm to point - 72 mul 2.54 div -} def - -/ReportAllFontInfo { - FontDirectory - { % key = font name value = font dictionary - pop 10 exch ReportFontInfo - } forall -} def - -% 3 cm 20 cm moveto 10 /Courier ReportFontInfo showpage -% 3 cm 20 cm moveto ReportAllFontInfo showpage - -") - -(defvar ps-print-prologue-2 - " -% ---- These lines must be kept together because... - -/h0 F -/HeaderTitleLineHeight FontHeight def - -/h1 F -/HeaderLineHeight FontHeight def -/HeaderDescent Descent def - -% ---- ...because `F' has a side-effect on `FontHeight' and `Descent' - -") - -;; Start Editing Here: - -(defvar ps-source-buffer nil) -(defvar ps-spool-buffer-name "*PostScript*") -(defvar ps-spool-buffer nil) - -(defvar ps-output-head nil) -(defvar ps-output-tail nil) - -(defvar ps-page-count 0) -(defvar ps-showpage-count 0) - -(defvar ps-current-font 0) -(defvar ps-current-underline-p nil) -(defvar ps-default-color (if ps-print-color-p ps-default-fg)) ; black -(defvar ps-current-color ps-default-color) -(defvar ps-current-bg nil) - -(defvar ps-razchunk 0) - -(defvar ps-color-format - (if (eq ps-print-emacs-type 'emacs) - - ;;Emacs understands the %f format; we'll - ;;use it to limit color RGB values to - ;;three decimals to cut down some on the - ;;size of the PostScript output. - "%0.3f %0.3f %0.3f" - - ;; Lucid emacsen will have to make do with - ;; %s (princ) for floats. - "%s %s %s")) - -;; These values determine how much print-height to deduct when headers -;; are turned on. This is a pretty clumsy way of handling it, but -;; it'll do for now. - -(defvar ps-header-font) -(defvar ps-header-title-font) - -(defvar ps-header-line-height) -(defvar ps-header-title-line-height) -(defvar ps-header-pad 0 - "Vertical and horizontal space in points (1/72 inch) between the header frame -and the text it contains.") - -;; Define accessors to the dimensions list. - -(defmacro ps-page-dimensions-get-width (dims) `(nth 0 ,dims)) -(defmacro ps-page-dimensions-get-height (dims) `(nth 1 ,dims)) - -(defvar ps-landscape-page-height) - -(defvar ps-print-width nil) -(defvar ps-print-height nil) - -(defvar ps-height-remaining) -(defvar ps-width-remaining) - -(defvar ps-ref-bold-faces nil) -(defvar ps-ref-italic-faces nil) -(defvar ps-ref-underlined-faces nil) - -(defvar ps-print-color-scale nil) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Internal functions - -(defun ps-line-lengths-internal () - "Display the correspondence between a line length and a font size, -using the current ps-print setup. -Try: pr -t file | awk '{printf \"%3d %s\n\", length($0), $0}' | sort -r | head" - (let ((buf (get-buffer-create "*Line-lengths*")) - (ifs ps-font-size) ; initial font size - (icw ps-avg-char-width) ; initial character width - (print-width (progn (ps-get-page-dimensions) - ps-print-width)) - (ps-setup (ps-setup)) ; setup for the current buffer - (fs-min 5) ; minimum font size - cw-min ; minimum character width - nb-cpl-max ; maximum nb of characters per line - (fs-max 14) ; maximum font size - cw-max ; maximum character width - nb-cpl-min ; minimum nb of characters per line - fs ; current font size - cw ; current character width - nb-cpl ; current nb of characters per line - ) - (setq cw-min (/ (* icw fs-min) ifs) - nb-cpl-max (floor (/ print-width cw-min)) - cw-max (/ (* icw fs-max) ifs) - nb-cpl-min (floor (/ print-width cw-max))) - (setq nb-cpl nb-cpl-min) - (set-buffer buf) - (goto-char (point-max)) - (if (not (bolp)) (insert "\n")) - (insert ps-setup) - (insert "nb char per line / font size\n") - (while (<= nb-cpl nb-cpl-max) - (setq cw (/ print-width (float nb-cpl)) - fs (/ (* ifs cw) icw)) - (insert (format "%3s %s\n" nb-cpl fs)) - (setq nb-cpl (1+ nb-cpl))) - (insert "\n") - (display-buffer buf 'not-this-window))) - -(defun ps-nb-pages (nb-lines) - "Display an approximate correspondence between a font size and the number -of pages the number of lines would require to print -using the current ps-print setup." - (let ((buf (get-buffer-create "*Nb-Pages*")) - (ifs ps-font-size) ; initial font size - (ilh ps-line-height) ; initial line height - (page-height (progn (ps-get-page-dimensions) - ps-print-height)) - (ps-setup (ps-setup)) ; setup for the current buffer - (fs-min 4) ; minimum font size - lh-min ; minimum line height - nb-lpp-max ; maximum nb of lines per page - nb-page-min ; minimum nb of pages - (fs-max 14) ; maximum font size - lh-max ; maximum line height - nb-lpp-min ; minimum nb of lines per page - nb-page-max ; maximum nb of pages - fs ; current font size - lh ; current line height - nb-lpp ; current nb of lines per page - nb-page ; current nb of pages - ) - (setq lh-min (/ (* ilh fs-min) ifs) - nb-lpp-max (floor (/ page-height lh-min)) - nb-page-min (ceiling (/ (float nb-lines) nb-lpp-max)) - lh-max (/ (* ilh fs-max) ifs) - nb-lpp-min (floor (/ page-height lh-max)) - nb-page-max (ceiling (/ (float nb-lines) nb-lpp-min))) - (setq nb-page nb-page-min) - (set-buffer buf) - (goto-char (point-max)) - (if (not (bolp)) (insert "\n")) - (insert ps-setup) - (insert (format "%d lines\n" nb-lines)) - (insert "nb page / font size\n") - (while (<= nb-page nb-page-max) - (setq nb-lpp (ceiling (/ nb-lines (float nb-page))) - lh (/ page-height nb-lpp) - fs (/ (* ifs lh) ilh)) - (insert (format "%s %s\n" nb-page fs)) - (setq nb-page (1+ nb-page))) - (insert "\n") - (display-buffer buf 'not-this-window))) - -(defun ps-select-font () - "Choose the font name and size (scaling data)." - (let ((assoc (assq ps-font-family ps-font-info-database)) - l fn fb fi bi sz lh sw aw) - (if (null assoc) - (error "Don't have data to scale font %s. Known fonts families are %s" - ps-font-family - (mapcar 'car ps-font-info-database))) - (setq l (cdr assoc) - fn (prog1 (car l) (setq l (cdr l))) ; need `pop' - fb (prog1 (car l) (setq l (cdr l))) - fi (prog1 (car l) (setq l (cdr l))) - bi (prog1 (car l) (setq l (cdr l))) - sz (prog1 (car l) (setq l (cdr l))) - lh (prog1 (car l) (setq l (cdr l))) - sw (prog1 (car l) (setq l (cdr l))) - aw (prog1 (car l) (setq l (cdr l)))) - - (setq ps-font fn) - (setq ps-font-bold fb) - (setq ps-font-italic fi) - (setq ps-font-bold-italic bi) - ;; These data just need to be rescaled: - (setq ps-line-height (/ (* lh ps-font-size) sz)) - (setq ps-space-width (/ (* sw ps-font-size) sz)) - (setq ps-avg-char-width (/ (* aw ps-font-size) sz)) - ps-font-family)) - -(defun ps-select-header-font () - "Choose the font name and size (scaling data) for the header." - (let ((assoc (assq ps-header-font-family ps-font-info-database)) - l fn fb fi bi sz lh sw aw) - (if (null assoc) - (error "Don't have data to scale font %s. Known fonts families are %s" - ps-font-family - (mapcar 'car ps-font-info-database))) - (setq l (cdr assoc) - fn (prog1 (car l) (setq l (cdr l))) ; need `pop' - fb (prog1 (car l) (setq l (cdr l))) - fi (prog1 (car l) (setq l (cdr l))) - bi (prog1 (car l) (setq l (cdr l))) - sz (prog1 (car l) (setq l (cdr l))) - lh (prog1 (car l) (setq l (cdr l))) - sw (prog1 (car l) (setq l (cdr l))) - aw (prog1 (car l) (setq l (cdr l)))) - - ;; Font name - (setq ps-header-font fn) - (setq ps-header-title-font fb) - ;; Line height: These data just need to be rescaled: - (setq ps-header-title-line-height (/ (* lh ps-header-title-font-size) sz)) - (setq ps-header-line-height (/ (* lh ps-header-font-size) sz)) - ps-header-font-family)) - -(defun ps-get-page-dimensions () - (let ((page-dimensions (cdr (assq ps-paper-type ps-page-dimensions-database))) - page-width page-height) - (cond - ((null page-dimensions) - (error "`ps-paper-type' must be one of:\n%s" - (mapcar 'car ps-page-dimensions-database))) - ((< ps-number-of-columns 1) - (error "The number of columns %d should not be negative"))) - - (ps-select-font) - (ps-select-header-font) - - (setq page-width (ps-page-dimensions-get-width page-dimensions) - page-height (ps-page-dimensions-get-height page-dimensions)) - - ;; Landscape mode - (if ps-landscape-mode - ;; exchange width and height - (setq page-width (prog1 page-height (setq page-height page-width)))) - - ;; It is used to get the lower right corner (only in landscape mode) - (setq ps-landscape-page-height page-height) - - ;; | lm | text | ic | text | ic | text | rm | - ;; page-width == lm + n * pw + (n - 1) * ic + rm - ;; => pw == (page-width - lm -rm - (n - 1) * ic) / n - (setq ps-print-width - (/ (- page-width - ps-left-margin ps-right-margin - (* (1- ps-number-of-columns) ps-inter-column)) - ps-number-of-columns)) - (if (<= ps-print-width 0) - (error "Bad horizontal layout: -page-width == %s -ps-left-margin == %s -ps-right-margin == %s -ps-inter-column == %s -ps-number-of-columns == %s -| lm | text | ic | text | ic | text | rm | -page-width == lm + n * print-width + (n - 1) * ic + rm -=> print-width == %d !" - page-width - ps-left-margin - ps-right-margin - ps-inter-column - ps-number-of-columns - ps-print-width)) - - (setq ps-print-height - (- page-height ps-bottom-margin ps-top-margin)) - (if (<= ps-print-height 0) - (error "Bad vertical layout: -ps-top-margin == %s -ps-bottom-margin == %s -page-height == bm + print-height + tm -=> print-height == %d !" - ps-top-margin - ps-bottom-margin - ps-print-height)) - ;; If headers are turned on, deduct the height of the header from - ;; the print height. - (cond - (ps-print-header - (setq ps-header-pad - (* ps-header-line-pad ps-header-title-line-height)) - (setq ps-print-height - (- ps-print-height - ps-header-offset - ps-header-pad - ps-header-title-line-height - (* ps-header-line-height (- ps-header-lines 1)) - ps-header-pad)))) - (if (<= ps-print-height 0) - (error "Bad vertical layout: -ps-top-margin == %s -ps-bottom-margin == %s -ps-header-offset == %s -ps-header-pad == %s -header-height == %s -page-height == bm + print-height + tm - ho - hh -=> print-height == %d !" - ps-top-margin - ps-bottom-margin - ps-header-offset - ps-header-pad - (+ ps-header-pad - ps-header-title-line-height - (* ps-header-line-height (- ps-header-lines 1)) - ps-header-pad) - ps-print-height)))) - -(defun ps-print-preprint (&optional filename) - (if (and filename - (or (numberp filename) - (listp filename))) - (let* ((name (concat (buffer-name) ".ps")) - (prompt (format "Save PostScript to file: (default %s) " - name)) - (res (read-file-name prompt default-directory name nil))) - (if (file-directory-p res) - (expand-file-name name (file-name-as-directory res)) - res)))) - -;; The following functions implement a simple list-buffering scheme so -;; that ps-print doesn't have to repeatedly switch between buffers -;; while spooling. The functions ps-output and ps-output-string build -;; up the lists; the function ps-flush-output takes the lists and -;; insert its contents into the spool buffer (*PostScript*). - -(defun ps-output-string-prim (string) - (insert "(") ;insert start-string delimiter - (save-excursion ;insert string - (insert string)) - - ;; Find and quote special characters as necessary for PS - (while (re-search-forward "[()\\]" nil t) - (save-excursion - (forward-char -1) - (insert "\\"))) - - (goto-char (point-max)) - (insert ")")) ;insert end-string delimiter - -(defun ps-init-output-queue () - (setq ps-output-head (list "")) - (setq ps-output-tail ps-output-head)) - -(defun ps-output (&rest args) - (setcdr ps-output-tail args) - (while (cdr ps-output-tail) - (setq ps-output-tail (cdr ps-output-tail)))) - -(defun ps-output-string (string) - (ps-output t string)) - -(defun ps-flush-output () - (save-excursion - (set-buffer ps-spool-buffer) - (goto-char (point-max)) - (while ps-output-head - (let ((it (car ps-output-head))) - (if (not (eq t it)) - (insert it) - (setq ps-output-head (cdr ps-output-head)) - (ps-output-string-prim (car ps-output-head)))) - (setq ps-output-head (cdr ps-output-head)))) - (ps-init-output-queue)) - -(defun ps-insert-file (fname) - (ps-flush-output) - - ;; Check to see that the file exists and is readable; if not, throw - ;; an error. - (if (not (file-readable-p fname)) - (error "Could not read file `%s'" fname)) - - (save-excursion - (set-buffer ps-spool-buffer) - (goto-char (point-max)) - (insert-file fname))) - -;; These functions insert the arrays that define the contents of the -;; headers. - -(defun ps-generate-header-line (fonttag &optional content) - (ps-output " [ " fonttag " ") - (cond - ;; Literal strings should be output as is -- the string must - ;; contain its own PS string delimiters, '(' and ')', if necessary. - ((stringp content) - (ps-output content)) - - ;; Functions are called -- they should return strings; they will be - ;; inserted as strings and the PS string delimiters added. - ((and (symbolp content) (fboundp content)) - (ps-output-string (funcall content))) - - ;; Variables will have their contents inserted. They should - ;; contain strings, and will be inserted as strings. - ((and (symbolp content) (boundp content)) - (ps-output-string (symbol-value content))) - - ;; Anything else will get turned into an empty string. - (t - (ps-output-string ""))) - (ps-output " ]\n")) - -(defun ps-generate-header (name contents) - (ps-output "/" name " [\n") - (if (> ps-header-lines 0) - (let ((count 1)) - (ps-generate-header-line "/h0" (car contents)) - (while (and (< count ps-header-lines) - (setq contents (cdr contents))) - (ps-generate-header-line "/h1" (car contents)) - (setq count (+ count 1))) - (ps-output "] def\n")))) - -(defun ps-output-boolean (name bool) - (ps-output (format "/%s %s def\n" name (if bool "true" "false")))) - -(defun ps-begin-file () - (ps-get-page-dimensions) - (setq ps-showpage-count 0) - - (ps-output ps-adobe-tag) - (ps-output "%%Title: " (buffer-name) "\n") ;Take job name from name of - ;first buffer printed - (ps-output "%%Creator: " (user-full-name) "\n") - (ps-output "%%CreationDate: " - (time-stamp-hh:mm:ss) " " (time-stamp-mon-dd-yyyy) "\n") - (ps-output "%%Pages: (atend)\n") - (ps-output "%%EndComments\n\n") - - (ps-output "%%BeginProlog\n") - (ps-output-boolean "LandscapeMode" ps-landscape-mode) - (ps-output (format "/NumberOfColumns %d def\n" ps-number-of-columns)) - - (ps-output (format "/LandscapePageHeight %s def\n" ps-landscape-page-height)) - (ps-output (format "/PrintWidth %s def\n" ps-print-width)) - (ps-output (format "/PrintHeight %s def\n" ps-print-height)) - - (ps-output (format "/LeftMargin %s def\n" ps-left-margin)) - (ps-output (format "/RightMargin %s def\n" ps-right-margin)) ; not used - (ps-output (format "/InterColumn %s def\n" ps-inter-column)) - - (ps-output (format "/BottomMargin %s def\n" ps-bottom-margin)) - (ps-output (format "/TopMargin %s def\n" ps-top-margin)) ; not used - (ps-output (format "/HeaderOffset %s def\n" ps-header-offset)) - (ps-output (format "/HeaderPad %s def\n" ps-header-pad)) - - (ps-output-boolean "PrintHeader" ps-print-header) - (ps-output-boolean "PrintHeaderFrame" ps-print-header-frame) - (ps-output-boolean "ShowNofN" ps-show-n-of-n) - (ps-output-boolean "Duplex" ps-spool-duplex) - - (ps-output (format "/LineHeight %s def\n" ps-line-height)) - - (ps-output ps-print-prologue-1) - (ps-output "%%EndProlog\n\n") - - - (ps-output "%%BeginSetup\n") - - ;; Header fonts - (ps-output ; /h0 14 /Helvetica-Bold Font - (format "/h0 %s /%s DefFont\n" ps-header-title-font-size ps-header-title-font)) - (ps-output ; /h1 12 /Helvetica Font - (format "/h1 %s /%s DefFont\n" ps-header-font-size ps-header-font)) - - (ps-output ps-print-prologue-2) - - ;; Text fonts - (ps-output (format "/f0 %s /%s DefFont\n" ps-font-size ps-font)) - (ps-output (format "/f1 %s /%s DefFont\n" ps-font-size ps-font-bold)) - (ps-output (format "/f2 %s /%s DefFont\n" ps-font-size ps-font-italic)) - (ps-output (format "/f3 %s /%s DefFont\n" ps-font-size ps-font-bold-italic)) - - (ps-output "\nBeginDoc\n\n") - (ps-output "%%EndSetup\n") -) - -(defun ps-header-dirpart () - (let ((fname (buffer-file-name))) - (if fname - (if (string-equal (buffer-name) (file-name-nondirectory fname)) - (file-name-directory fname) - fname) - ""))) - -(defun ps-get-buffer-name () - (cond - ;; Indulge Jim this little easter egg: - ((string= (buffer-name) "ps-print.el") - "Hey, Cool! It's ps-print.el!!!") - ;; Indulge Jack this other little easter egg: - ((string= (buffer-name) "sokoban.el") - "Super! C'est sokoban.el!") - (t (buffer-name)))) - -(defun ps-begin-job () - (setq ps-page-count 0)) - -(defun ps-end-file () - (ps-output "\n\n%%Trailer\n") - (ps-output (format "%%%%Pages: %d\n" (1+ (/ (1- ps-page-count) - ps-number-of-columns)))) - (ps-output "EndDoc\n") - (ps-output "%%EOF\n")) - -(defun ps-next-page () - (ps-end-page) - (ps-flush-output) - (ps-begin-page)) - -(defun ps-begin-page (&optional dummypage) - (ps-get-page-dimensions) - (setq ps-width-remaining ps-print-width) - (setq ps-height-remaining ps-print-height) - - ;; Print only when a new real page begins. - (when (zerop (mod ps-page-count ps-number-of-columns)) - (ps-output (format "\n%%%%Page: %d %d\n" - (1+ (/ ps-page-count ps-number-of-columns)) - (1+ (/ ps-page-count ps-number-of-columns))))) - - (ps-output "BeginDSCPage\n") - (ps-output (format "/PageNumber %d def\n" (incf ps-page-count))) - (ps-output "/PageCount 0 def\n") - - (when ps-print-header - (ps-generate-header "HeaderLinesLeft" ps-left-header) - (ps-generate-header "HeaderLinesRight" ps-right-header) - (ps-output (format "%d SetHeaderLines\n" ps-header-lines))) - - (ps-output "BeginPage\n") - (ps-set-font ps-current-font) - (ps-set-bg ps-current-bg) - (ps-set-color ps-current-color) - (ps-set-underline ps-current-underline-p)) - -(defun ps-end-page () - (setq ps-showpage-count (+ 1 ps-showpage-count)) - (ps-output "EndPage\n") - (ps-output "EndDSCPage\n")) - -(defun ps-dummy-page () - (setq ps-showpage-count (+ 1 ps-showpage-count)) - (ps-output "%%Page: " (format "- %d\n" ps-showpage-count) - "BeginDSCPage -/PrintHeader false def -BeginPage -EndPage -EndDSCPage\n")) - -(defun ps-next-line () - (if (< ps-height-remaining ps-line-height) - (ps-next-page) - (setq ps-width-remaining ps-print-width) - (setq ps-height-remaining (- ps-height-remaining ps-line-height)) - (ps-hard-lf))) - -(defun ps-continue-line () - (if (< ps-height-remaining ps-line-height) - (ps-next-page) - (setq ps-width-remaining ps-print-width) - (setq ps-height-remaining (- ps-height-remaining ps-line-height)) - (ps-soft-lf))) - -;; [jack] Why hard and soft ? - -(defun ps-hard-lf () - (ps-output "HL\n")) - -(defun ps-soft-lf () - (ps-output "SL\n")) - -(defun ps-find-wrappoint (from to char-width) - (let ((avail (truncate (/ ps-width-remaining char-width))) - (todo (- to from))) - (if (< todo avail) - (cons to (* todo char-width)) - (cons (+ from avail) ps-width-remaining)))) - -(defun ps-basic-plot-string (from to &optional bg-color) - (let* ((wrappoint (ps-find-wrappoint from to ps-avg-char-width)) - (to (car wrappoint)) - (string (buffer-substring from to))) - (ps-output-string string) - (ps-output " S\n") - wrappoint)) - -(defun ps-basic-plot-whitespace (from to &optional bg-color) - (let* ((wrappoint (ps-find-wrappoint from to ps-space-width)) - (to (car wrappoint))) - - (ps-output (format "%d W\n" (- to from))) - wrappoint)) - -(defun ps-plot (plotfunc from to &optional bg-color) - (while (< from to) - (let* ((wrappoint (funcall plotfunc from to bg-color)) - (plotted-to (car wrappoint)) - (plotted-width (cdr wrappoint))) - (setq from plotted-to) - (setq ps-width-remaining (- ps-width-remaining plotted-width)) - (if (< from to) - (ps-continue-line)))) - (if ps-razzle-dazzle - (let* ((q-todo (- (point-max) (point-min))) - (q-done (- (point) (point-min))) - (chunkfrac (/ q-todo 8)) - (chunksize (if (> chunkfrac 1000) 1000 chunkfrac))) - (if (> (- q-done ps-razchunk) chunksize) - (let (foo) - (setq ps-razchunk q-done) - (setq foo - (if (< q-todo 100) - (/ (* 100 q-done) q-todo) - (/ q-done (/ q-todo 100)))) - (message "Formatting...%3d%%" foo)))))) - -(defun ps-set-font (font) - (setq ps-current-font font) - (ps-output (format "/f%d F\n" ps-current-font))) - -(defun ps-set-bg (color) - (if (setq ps-current-bg color) - (ps-output (format ps-color-format (nth 0 color) (nth 1 color) - (nth 2 color)) - " true BG\n") - (ps-output "false BG\n"))) - -(defun ps-set-color (color) - (if (setq ps-current-color color) - nil - (setq ps-current-color ps-default-fg)) - (ps-output (format ps-color-format (nth 0 ps-current-color) - (nth 1 ps-current-color) (nth 2 ps-current-color)) - " FG\n")) - -(defun ps-set-underline (underline-p) - (ps-output (if underline-p "true" "false") " UL\n") - (setq ps-current-underline-p underline-p)) - -(defun ps-plot-region (from to font fg-color &optional bg-color underline-p) - - (if (not (equal font ps-current-font)) - (ps-set-font font)) - - ;; Specify a foreground color only if one's specified and it's - ;; different than the current. - (if (not (equal fg-color ps-current-color)) - (ps-set-color fg-color)) - - (if (not (equal bg-color ps-current-bg)) - (ps-set-bg bg-color)) - - ;; Toggle underlining if different. - (if (not (equal underline-p ps-current-underline-p)) - (ps-set-underline underline-p)) - - ;; Starting at the beginning of the specified region... - (save-excursion - (goto-char from) - - ;; ...break the region up into chunks separated by tabs, linefeeds, - ;; and pagefeeds, and plot each chunk. - (while (< from to) - (if (re-search-forward "[\t\n\f]" to t) - (let ((match (char-after (match-beginning 0)))) - (cond - ((= match ?\t) - (let ((linestart - (save-excursion (beginning-of-line) (point)))) - (ps-plot 'ps-basic-plot-string from (- (point) 1) - bg-color) - (forward-char -1) - (setq from (+ linestart (current-column))) - (if (re-search-forward "[ \t]+" to t) - (ps-plot 'ps-basic-plot-whitespace - from (+ linestart (current-column)) - bg-color)))) - - ((= match ?\n) - (ps-plot 'ps-basic-plot-string from (- (point) 1) - bg-color) - (ps-next-line) - ) - - ((= match ?\f) - (ps-plot 'ps-basic-plot-string from (- (point) 1) - bg-color) - (ps-next-page))) - (setq from (point))) - (ps-plot 'ps-basic-plot-string from to bg-color) - (setq from to))))) - -(defun ps-color-value (x-color-value) - ;; Scale 16-bit X-COLOR-VALUE to PostScript color value in [0, 1] interval. - (/ x-color-value ps-print-color-scale)) - -(defun ps-color-values (x-color) - (cond ((fboundp 'color-instance-rgb-components) - (if (ps-color-device) - (color-instance-rgb-components - (if (color-instance-p x-color) x-color - (if (color-specifier-p x-color) - (make-color-instance (color-name x-color)) - (make-color-instance x-color)))) - (error "No available function to determine X color values."))) - ((fboundp 'x-color-values) - (x-color-values x-color)) - (t (error "No available function to determine X color values.")))) - -(defun ps-face-attributes (face) - (let ((differs (face-differs-from-default-p face))) - (list (memq face ps-ref-bold-faces) - (memq face ps-ref-italic-faces) - (memq face ps-ref-underlined-faces) - (and differs (face-foreground face)) - (and differs (face-background face))))) - -(defun ps-face-attribute-list (face-or-list) - (if (listp face-or-list) - (let (bold-p italic-p underline-p foreground background face-attr face) - (while face-or-list - (setq face (car face-or-list)) - (setq face-attr (ps-face-attributes face)) - (setq bold-p (or bold-p (nth 0 face-attr))) - (setq italic-p (or italic-p (nth 1 face-attr))) - (setq underline-p (or underline-p (nth 2 face-attr))) - (if foreground - nil - (setq foreground (nth 3 face-attr))) - (if background - nil - (setq background (nth 4 face-attr))) - (setq face-or-list (cdr face-or-list))) - (list bold-p italic-p underline-p foreground background)) - - (ps-face-attributes face-or-list))) - -(defun ps-plot-with-face (from to face) - (if face - (let* ((face-attr (ps-face-attribute-list face)) - (bold-p (nth 0 face-attr)) - (italic-p (nth 1 face-attr)) - (underline-p (nth 2 face-attr)) - (foreground (nth 3 face-attr)) - (background (nth 4 face-attr)) - (fg-color (if (and ps-print-color-p - (ps-color-device) - foreground) - (mapcar 'ps-color-value - (ps-color-values foreground)) - ps-default-color)) - (bg-color (if (and ps-print-color-p - (ps-color-device) - background) - (mapcar 'ps-color-value - (ps-color-values background))))) - (ps-plot-region from to - (cond ((and bold-p italic-p) 3) - (italic-p 2) - (bold-p 1) - (t 0)) -; (or fg-color '(0.0 0.0 0.0)) - fg-color - bg-color underline-p)) - (goto-char to))) - - -(defun ps-emacs-face-kind-p (face kind kind-regex kind-list) - (let ((frame-font (face-font face)) - (face-defaults (face-font face t))) - (or - ;; Check FACE defaults: - (and (listp face-defaults) - (memq kind face-defaults)) - - ;; Check the user's preferences - (memq face kind-list)))) - -(defun ps-xemacs-face-kind-p (face kind kind-regex kind-list) - (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)) - - (or (and kind-spec (string-match kind-regex kind-spec)) - ;; Kludge-compatible: - (memq face kind-list)))) - -(defun ps-face-bold-p (face) - (if (eq ps-print-emacs-type 'emacs) - (ps-emacs-face-kind-p face 'bold "-\\(bold\\|demibold\\)-" - ps-bold-faces) - (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold" - ps-bold-faces))) - -(defun ps-face-italic-p (face) - (if (eq ps-print-emacs-type 'emacs) - (ps-emacs-face-kind-p face 'italic "-[io]-" ps-italic-faces) - (or - (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o" ps-italic-faces) - (ps-xemacs-face-kind-p face 'SLANT "i\\|o" ps-italic-faces)))) - -(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)) - -(defun ps-build-reference-face-lists () - (if ps-auto-font-detect - (let ((faces (if (eq ps-print-emacs-type 'xemacs) - (face-list 5) - (face-list))) - the-face) - (setq ps-ref-bold-faces nil - ps-ref-italic-faces nil - ps-ref-underlined-faces nil) - (while faces - (setq the-face (car faces)) - (if (ps-face-italic-p the-face) - (setq ps-ref-italic-faces - (cons the-face ps-ref-italic-faces))) - (if (ps-face-bold-p the-face) - (setq ps-ref-bold-faces - (cons the-face ps-ref-bold-faces))) - (if (ps-face-underlined-p the-face) - (setq ps-ref-underlined-faces - (cons the-face ps-ref-underlined-faces))) - (setq faces (cdr faces)))) - (setq ps-ref-bold-faces ps-bold-faces) - (setq ps-ref-italic-faces ps-italic-faces) - (setq ps-ref-underlined-faces ps-underlined-faces)) - (setq ps-build-face-reference nil)) - -(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))) - -(defun ps-print-ensure-fontified (start end) - (if (and (boundp 'lazy-lock-mode) lazy-lock-mode) - (if (fboundp 'lazy-lock-fontify-region) - (lazy-lock-fontify-region start end) ; the new - (lazy-lock-fontify-buffer))) ; the old - (if (and (boundp 'lazy-shot-mode) lazy-shot-mode) ;; temporary untill - (lazy-shot-fontify-region start end))) ;; lazy-shot is renamed - - -(defun ps-generate-postscript-with-faces (from to) - ;; Build the reference lists of faces if necessary. - (if (or ps-always-build-face-reference - ps-build-face-reference) - (progn - (message "Collecting face information...") - (ps-build-reference-face-lists))) - ;; Set the color scale. We do it here instead of in the defvar so - ;; that ps-print can be dumped into emacs. This expression can't be - ;; evaluated at dump-time because X isn't initialized. - (setq ps-print-color-scale - (if (and ps-print-color-p (ps-color-device)) - (float (car (ps-color-values "white"))) - 1.0)) - ;; Generate some PostScript. - (save-restriction - (narrow-to-region from to) - (let ((face 'default) - (position to)) - (ps-print-ensure-fontified from to) - (cond ((or (eq ps-print-emacs-type 'lucid) - (eq ps-print-emacs-type 'xemacs)) - ;; Build the list of extents... - (let ((a (cons 'dummy nil)) - record type extent extent-list) - (map-extents 'ps-mapper nil from to a) - (setq a (sort (cdr a) 'car-less-than-car)) - - (setq extent-list nil) - - ;; Loop through the extents... - (while a - (setq record (car a)) - - (setq position (car record)) - (setq record (cdr record)) - - (setq type (car record)) - (setq record (cdr record)) - - (setq extent (car record)) - - ;; Plot up to this record. - ;; 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. - (if (and (>= from (point-min)) - (<= position (point-max))) - (ps-plot-with-face from position face)) - - (cond - ((eq type 'push) - (if (extent-face extent) - (setq extent-list (sort (cons extent extent-list) - 'ps-extent-sorter)))) - - ((eq type 'pull) - (setq extent-list (sort (delq extent extent-list) - 'ps-extent-sorter)))) - - (setq face - (if extent-list - (extent-face (car extent-list)) - 'default)) - - (setq from position) - (setq a (cdr a))))) - - ((eq ps-print-emacs-type 'emacs) - (let ((property-change from) - (overlay-change from)) - (while (< from to) - (if (< property-change to) ; Don't search for property change - ; unless previous search succeeded. - (setq property-change - (next-property-change from nil to))) - (if (< overlay-change to) ; Don't search for overlay change - ; unless previous search succeeded. - (setq overlay-change - (min (next-overlay-change from) to))) - (setq position - (min property-change overlay-change)) - ;; The code below is not quite correct, - ;; because a non-nil overlay invisible property - ;; which is inactive according to the current value - ;; of buffer-invisibility-spec nonetheless overrides - ;; a face text property. - (setq face - (cond ((let ((prop (get-text-property from 'invisible))) - ;; Decide whether this invisible property - ;; really makes the text invisible. - (if (eq buffer-invisibility-spec t) - (not (null prop)) - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec)))) - nil) - ((get-text-property from 'face)) - (t 'default))) - (let ((overlays (overlays-at from)) - (face-priority -1)) ; text-property - (while overlays - (let* ((overlay (car overlays)) - (overlay-face (overlay-get overlay 'face)) - (overlay-invisible (overlay-get overlay 'invisible)) - (overlay-priority (or (overlay-get overlay - 'priority) - 0))) - (if (and (or overlay-invisible overlay-face) - (> overlay-priority face-priority)) - (setq face (cond ((if (eq buffer-invisibility-spec t) - (not (null overlay-invisible)) - (or (memq overlay-invisible buffer-invisibility-spec) - (assq overlay-invisible buffer-invisibility-spec))) - nil) - ((and face overlay-face))) - face-priority overlay-priority))) - (setq overlays (cdr overlays)))) - ;; Plot up to this record. - (ps-plot-with-face from position face) - (setq from position))))) - (ps-plot-with-face from to face)))) - -(defun ps-generate-postscript (from to) - (ps-plot-region from to 0 nil)) - -(defun ps-generate (buffer from to genfunc) - (let ((from (min to from)) - (to (max to from)) - ;; This avoids trouble if chars with read-only properties - ;; are copied into ps-spool-buffer. - (inhibit-read-only t)) - (save-restriction - (narrow-to-region from to) - (if ps-razzle-dazzle - (message "Formatting...%3d%%" (setq ps-razchunk 0))) - (set-buffer buffer) - (setq ps-source-buffer buffer) - (setq ps-spool-buffer (get-buffer-create ps-spool-buffer-name)) - (ps-init-output-queue) - (let (safe-marker completed-safely needs-begin-file) - (unwind-protect - (progn - (set-buffer ps-spool-buffer) - - ;; Get a marker and make it point to the current end of the - ;; buffer, If an error occurs, we'll delete everything from - ;; the end of this marker onwards. - (setq safe-marker (make-marker)) - (set-marker safe-marker (point-max)) - - (goto-char (point-min)) - (if (looking-at (regexp-quote ps-adobe-tag)) - nil - (setq needs-begin-file t)) - (save-excursion - (set-buffer ps-source-buffer) - (if needs-begin-file (ps-begin-file)) - (ps-begin-job) - (ps-begin-page)) - (set-buffer ps-source-buffer) - (funcall genfunc from to) - (ps-end-page) - - (if (and ps-spool-duplex - (= (mod ps-page-count 2) 1)) - (ps-dummy-page)) - (ps-flush-output) - - ;; Back to the PS output buffer to set the page count - (set-buffer ps-spool-buffer) - (goto-char (point-max)) - (while (re-search-backward "^/PageCount 0 def$" nil t) - (replace-match (format "/PageCount %d def" ps-page-count) t)) - - ;; Setting this variable tells the unwind form that - ;; the postscript was generated without error. - (setq completed-safely t)) - - ;; Unwind form: If some bad mojo occurred while generating - ;; postscript, delete all the postscript that was generated. - ;; This protects the previously spooled files from getting - ;; corrupted. - (if (and (markerp safe-marker) (not completed-safely)) - (progn - (set-buffer ps-spool-buffer) - (delete-region (marker-position safe-marker) (point-max)))))) - - (if ps-razzle-dazzle - (message "Formatting...done"))))) - -;; Permit dynamic evaluation at print time of ps-lpr-switches -(defun ps-do-despool (filename) - (if (or (not (boundp 'ps-spool-buffer)) - (not (symbol-value 'ps-spool-buffer))) - (message "No spooled PostScript to print") - (ps-end-file) - (ps-flush-output) - (if filename - (save-excursion - (if ps-razzle-dazzle - (message "Saving...")) - (set-buffer ps-spool-buffer) - (setq filename (expand-file-name filename)) - (write-region (point-min) (point-max) filename) - (if ps-razzle-dazzle - (message "Wrote %s" filename))) - ;; Else, spool to the printer - (if ps-razzle-dazzle - (message "Printing...")) - (save-excursion - (set-buffer ps-spool-buffer) - (if (and (eq system-type 'ms-dos) (stringp dos-ps-printer)) - (write-region (point-min) (point-max) dos-ps-printer t 0) - (let ((binary-process-input t) ; for MS-DOS - (ps-lpr-sw ; Dynamic evaluation - (ps-flatten-list (mapcar 'ps-eval-switch ps-lpr-switches)))) - (apply 'call-process-region - (point-min) (point-max) ps-lpr-command nil - (if (fboundp 'start-process) 0 nil) - nil - ps-lpr-sw)))) - (if ps-razzle-dazzle - (message "Printing...done"))) - (kill-buffer ps-spool-buffer))) - -;; Dynamic evaluation -(defun ps-eval-switch (arg) - (cond ((stringp arg) arg) - ((functionp arg) (apply arg nil)) - ((symbolp arg) (symbol-value arg)) - ((consp arg) (apply (car arg) (cdr arg))) - (t nil))) - -;; `ps-flatten-list' is defined here (copied from "message.el" and -;; enhanced to handle dotted pairs as well) until we can get some -;; sensible autoloads, or `flatten-list' gets put somewhere decent. - -;; (ps-flatten-list '((a . b) c (d . e) (f g h) i . j)) -;; => (a b c d e f g h i j) - -(defun ps-flatten-list (&rest list) - (ps-flatten-list-1 list)) - -(defun ps-flatten-list-1 (list) - (cond - ((null list) (list)) - ((consp list) - (append (ps-flatten-list-1 (car list)) - (ps-flatten-list-1 (cdr list)))) - (t (list list)))) - -(defun ps-kill-emacs-check () - (let (ps-buffer) - (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name)) - (buffer-modified-p ps-buffer)) - (if (y-or-n-p "Unprinted PostScript waiting; print now? ") - (ps-despool))) - (if (and (setq ps-buffer (get-buffer ps-spool-buffer-name)) - (buffer-modified-p ps-buffer)) - (if (yes-or-no-p "Unprinted PostScript waiting; exit anyway? ") - nil - (error "Unprinted PostScript"))))) - -(if (fboundp 'add-hook) - (add-hook 'kill-emacs-hook 'ps-kill-emacs-check) - (if kill-emacs-hook - (message "Won't override existing kill-emacs-hook") - (setq kill-emacs-hook 'ps-kill-emacs-check))) - -;;; Sample Setup Code: - -;; This stuff is for anybody that's brave enough to look this far, -;; and able to figure out how to use it. It isn't really part of ps- -;; print, but I'll leave it here in hopes it might be useful: - -;; WARNING!!! The following code is *sample* code only. Don't use it -;; unless you understand what it does! - -(defmacro ps-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs) - [f22] ''f22)) -(defmacro ps-c-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs) - [C-f22] - ''(control f22))) -(defmacro ps-s-prsc () (list 'if (list 'eq 'ps-print-emacs-type ''emacs) - [S-f22] - ''(shift f22))) - -;; Look in an article or mail message for the Subject: line. To be -;; placed in ps-left-headers. -(defun ps-article-subject () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "^Subject:[ \t]+\\(.*\\)$" nil t) - (buffer-substring (match-beginning 1) (match-end 1)) - "Subject ???"))) - -;; Look in an article or mail message for the From: line. Sorta-kinda -;; understands RFC-822 addresses and can pull the real name out where -;; it's provided. To be placed in ps-left-headers. -(defun ps-article-author () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "^From:[ \t]+\\(.*\\)$" nil t) - (let ((fromstring (buffer-substring (match-beginning 1) (match-end 1)))) - (cond - - ;; Try first to match addresses that look like - ;; thompson@wg2.waii.com (Jim Thompson) - ((string-match ".*[ \t]+(\\(.*\\))" fromstring) - (substring fromstring (match-beginning 1) (match-end 1))) - - ;; Next try to match addresses that look like - ;; Jim Thompson <thompson@wg2.waii.com> - ((string-match "\\(.*\\)[ \t]+<.*>" fromstring) - (substring fromstring (match-beginning 1) (match-end 1))) - - ;; Couldn't find a real name -- show the address instead. - (t fromstring))) - "From ???"))) - -;; A hook to bind to gnus-Article-prepare-hook. This will set the ps- -;; left-headers specially for gnus articles. Unfortunately, gnus- -;; article-mode-hook is called only once, the first time the *Article* -;; buffer enters that mode, so it would only work for the first time -;; we ran gnus. The second time, this hook wouldn't get set up. The -;; only alternative is gnus-article-prepare-hook. -(defun ps-gnus-article-prepare-hook () - (setq ps-header-lines 3) - (setq ps-left-header - ;; The left headers will display the article's subject, its - ;; author, and the newsgroup it was in. - (list 'ps-article-subject 'ps-article-author 'gnus-newsgroup-name))) - -;; A hook to bind to vm-mode-hook to locally bind prsc and set the ps- -;; left-headers specially for mail messages. This header setup would -;; also work, I think, for RMAIL. -(defun ps-vm-mode-hook () - (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary) - (setq ps-header-lines 3) - (setq ps-left-header - ;; The left headers will display the message's subject, its - ;; author, and the name of the folder it was in. - (list 'ps-article-subject 'ps-article-author 'buffer-name))) - -;; Every now and then I forget to switch from the *Summary* buffer to -;; the *Article* before hitting prsc, and a nicely formatted list of -;; article subjects shows up at the printer. This function, bound to -;; prsc for the gnus *Summary* buffer means I don't have to switch -;; buffers first. -;; sb: Updated for Gnus 5. -(defun ps-gnus-print-article-from-summary () - (interactive) - (let ((ps-buf (if (boundp 'gnus-article-buffer) - gnus-article-buffer - "*Article*"))) - (if (get-buffer ps-buf) - (save-excursion - (set-buffer ps-buf) - (ps-spool-buffer-with-faces))))) - -;; See ps-gnus-print-article-from-summary. This function does the -;; same thing for vm. -(defun ps-vm-print-message-from-summary () - (interactive) - (if (and (boundp 'vm-mail-buffer) (symbol-value 'vm-mail-buffer)) - (save-excursion - (set-buffer (symbol-value 'vm-mail-buffer)) - (ps-spool-buffer-with-faces)))) - -;; A hook to bind to bind to gnus-summary-setup-buffer to locally bind -;; prsc. -(defun ps-gnus-summary-setup () - (local-set-key (ps-prsc) 'ps-gnus-print-article-from-summary)) - -;; Look in an article or mail message for the Subject: line. To be -;; placed in ps-left-headers. -(defun ps-info-file () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "File:[ \t]+\\([^, \t\n]*\\)" nil t) - (buffer-substring (match-beginning 1) (match-end 1)) - "File ???"))) - -;; Look in an article or mail message for the Subject: line. To be -;; placed in ps-left-headers. -(defun ps-info-node () - (save-excursion - (goto-char (point-min)) - (if (re-search-forward "Node:[ \t]+\\([^,\t\n]*\\)" nil t) - (buffer-substring (match-beginning 1) (match-end 1)) - "Node ???"))) - -(defun ps-info-mode-hook () - (setq ps-left-header - ;; The left headers will display the node name and file name. - (list 'ps-info-node 'ps-info-file))) - -;; WARNING! The following function is a *sample* only, and is *not* -;; meant to be used as a whole unless you understand what the effects -;; will be! (In fact, this is a copy of Jim's setup for ps-print -- -;; I'd be very surprised if it was useful to *anybody*, without -;; modification.) - -(defun ps-jts-ps-setup () - (global-set-key (ps-prsc) 'ps-spool-buffer-with-faces) ;f22 is prsc - (global-set-key (ps-s-prsc) 'ps-spool-region-with-faces) - (global-set-key (ps-c-prsc) 'ps-despool) - (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook) - (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup) - (add-hook 'vm-mode-hook 'ps-vm-mode-hook) - (add-hook 'vm-mode-hooks 'ps-vm-mode-hook) - (add-hook 'Info-mode-hook 'ps-info-mode-hook) - (setq ps-spool-duplex t) - (setq ps-print-color-p nil) - (setq ps-lpr-command "lpr") - (setq ps-lpr-switches '("-Jjct,duplex_long")) - 'ps-jts-ps-setup) - -;; WARNING! The following function is a *sample* only, and is *not* -;; meant to be used as a whole unless it corresponds to your needs. -;; (In fact, this is a copy of Jack's setup for ps-print -- -;; I would not be that surprised if it was useful to *anybody*, -;; without modification.) - -(defun ps-jack-setup () - (setq ps-print-color-p 'nil - ps-lpr-command "lpr" - ps-lpr-switches (list) - - ps-paper-type 'a4 - ps-landscape-mode 't - ps-number-of-columns 2 - - ps-left-margin (/ (* 72 1.0) 2.54) ; 1.0 cm - ps-right-margin (/ (* 72 1.0) 2.54) ; 1.0 cm - ps-inter-column (/ (* 72 1.0) 2.54) ; 1.0 cm - ps-bottom-margin (/ (* 72 1.5) 2.54) ; 1.5 cm - ps-top-margin (/ (* 72 1.5) 2.54) ; 1.5 cm - ps-header-offset (/ (* 72 1.0) 2.54) ; 1.0 cm - ps-header-line-pad .15 - ps-print-header t - ps-print-header-frame t - ps-header-lines 2 - ps-show-n-of-n t - ps-spool-duplex nil - - ps-font-family 'Courier - ps-font-size 5.5 - ps-header-font-family 'Helvetica - ps-header-font-size 6 - ps-header-title-font-size 8) - 'ps-jack-setup) - -(provide 'ps-print) - -;;; ps-print.el ends here