diff options
| -rw-r--r-- | lisp/ChangeLog.unicode | 58 | ||||
| -rw-r--r-- | lisp/ps-bdf.el | 6 | ||||
| -rw-r--r-- | lisp/ps-def.el | 461 | ||||
| -rw-r--r-- | lisp/ps-mule.el | 64 | ||||
| -rw-r--r-- | lisp/ps-print.el | 525 | ||||
| -rw-r--r-- | lisp/ps-samp.el | 249 |
6 files changed, 779 insertions, 584 deletions
diff --git a/lisp/ChangeLog.unicode b/lisp/ChangeLog.unicode index 7d2b53b680b..0f439efb050 100644 --- a/lisp/ChangeLog.unicode +++ b/lisp/ChangeLog.unicode @@ -1,3 +1,61 @@ +2007-01-25 Vinicius Jose Latorre <viniciusjl@ig.com.br> + + * ps-print.el: Split XEmacs/Emacs definitions and sample setup code + into separate files. + (ps-print-version): New Version 7.2. + (ps-postscript-code-directory): Fix XEmacs initialization. + (ps-generate-postscript-with-faces): Call + ps-generate-postscript-with-faces1 (new fun). + (ps-color-format, ps-float-format): Vars moved to ps-def.el. + (ps-xemacs-color-name, ps-mapper, ps-extent-sorter) + (ps-xemacs-face-kind-p, ps-mark-active-p, ps-face-foreground-name) + (ps-face-background-name, ps-frame-parameter, ps-color-device) + (ps-color-values, ps-face-bold-p, ps-face-italic-p): Funs moved to + ps-def.el. + (ps-prsc, ps-c-prsc, ps-s-prsc, ps-rmail-mode-hook) + (ps-rmail-print-message-from-summary, ps-print-message-from-summary) + (ps-article-subject, ps-article-author, ps-gnus-article-prepare-hook) + (ps-vm-mode-hook, ps-gnus-print-article-from-summary) + (ps-vm-print-message-from-summary, ps-gnus-summary-setup, ps-info-file) + (ps-info-node, ps-info-mode-hook, ps-jts-ps-setup, ps-jack-setup): Funs + moved to ps-samp.el. + + * ps-bdf.el (installation-directory, coding-system-for-read): Vars + moved to ps-def.el. + + * ps-mule.el (leading-code-private-22): Var moved to ps-def.el. + (charset-bytes, charset-dimension, charset-id, charset-width) + (find-charset-region, char-width, chars-in-region, forward-point) + (decompose-composite-char, encode-coding-string, coding-system-p) + (ccl-execute-on-string, define-ccl-program, multibyte-string-p) + (string-make-multibyte, encode-char): Funs moved to ps-def.el. + + * ps-def.el: New file. XEmacs/Emacs definitions. + (ps-generate-postscript-with-faces1): New fun. + (ps-color-format, ps-float-format): Vars moved from ps-print.el. + (ps-xemacs-color-name, ps-mapper, ps-extent-sorter) + (ps-xemacs-face-kind-p, ps-mark-active-p, ps-face-foreground-name) + (ps-face-background-name, ps-frame-parameter, ps-color-device) + (ps-color-values, ps-face-bold-p, ps-face-italic-p): Funs moved from + ps-print.el. + (installation-directory, coding-system-for-read): Vars moved from + ps-bdf.el. + (leading-code-private-22): Var moved from ps-mule.el. + (charset-bytes, charset-dimension, charset-id, charset-width) + (find-charset-region, char-width, chars-in-region, forward-point) + (decompose-composite-char, encode-coding-string, coding-system-p) + (ccl-execute-on-string, define-ccl-program, multibyte-string-p) + (string-make-multibyte, encode-char): Funs moved from ps-mule.el. + + * ps-samp.el: New file. Sample setup code. + (ps-prsc, ps-c-prsc, ps-s-prsc, ps-rmail-mode-hook) + (ps-rmail-print-message-from-summary, ps-print-message-from-summary) + (ps-article-subject, ps-article-author, ps-gnus-article-prepare-hook) + (ps-vm-mode-hook, ps-gnus-print-article-from-summary) + (ps-vm-print-message-from-summary, ps-gnus-summary-setup, ps-info-file) + (ps-info-node, ps-info-mode-hook, ps-jts-ps-setup, ps-jack-setup): Funs + moved from ps-print.el. + 2007-01-21 Vinicius Jose Latorre <viniciusjl@ig.com.br> * ps-print.el: Handle frame parameters (background and/or foreground diff --git a/lisp/ps-bdf.el b/lisp/ps-bdf.el index 615f98b950b..568baf38afd 100644 --- a/lisp/ps-bdf.el +++ b/lisp/ps-bdf.el @@ -38,11 +38,7 @@ ;;; Code: (eval-and-compile - (require 'ps-mule) - - ;; to avoid XEmacs compilation gripes - (defvar installation-directory nil) - (defvar coding-system-for-read nil)) + (require 'ps-mule)) ;;;###autoload (defvar bdf-directory-list diff --git a/lisp/ps-def.el b/lisp/ps-def.el new file mode 100644 index 00000000000..ffd8a7bd6c1 --- /dev/null +++ b/lisp/ps-def.el @@ -0,0 +1,461 @@ +;;; ps-def.el --- XEmacs and Emacs definitions for ps-print + +;; Copyright (C) 2007 Free Software Foundation, Inc. + +;; Author: Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Kenichi Handa <handa@m17n.org> (multi-byte characters) +;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters) +;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Keywords: wp, print, PostScript +;; Version: 7.2 +;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre + +;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; See ps-print.el for documentation. + +;;; Code: + + + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; XEmacs Definitions + + +(cond + ((featurep 'xemacs) ; xemacs + + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ps-bdf + + (defvar installation-directory nil) + (defvar coding-system-for-read nil) + + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ps-mule + + (defvar leading-code-private-22 157) + + (or (fboundp 'charset-bytes) + (defun charset-bytes (charset) 1)) ; ascii + + (or (fboundp 'charset-dimension) + (defun charset-dimension (charset) 1)) ; ascii + + (or (fboundp 'charset-id) + (defun charset-id (charset) 0)) ; ascii + + (or (fboundp 'charset-width) + (defun charset-width (charset) 1)) ; ascii + + (or (fboundp 'find-charset-region) + (defun find-charset-region (beg end &optional table) + (list 'ascii))) + + (or (fboundp 'char-width) + (defun char-width (char) 1)) ; ascii + + (or (fboundp 'chars-in-region) + (defun chars-in-region (beg end) + (- (max beg end) (min beg end)))) + + (or (fboundp 'forward-point) + (defun forward-point (arg) + (save-excursion + (let ((count (abs arg)) + (step (if (zerop arg) + 0 + (/ arg arg)))) + (while (and (> count 0) + (< (point-min) (point)) (< (point) (point-max))) + (forward-char step) + (setq count (1- count))) + (+ (point) (* count step)))))) + + (or (fboundp 'decompose-composite-char) + (defun decompose-composite-char (char &optional type + with-composition-rule) + nil)) + + (or (fboundp 'encode-coding-string) + (defun encode-coding-string (string coding-system &optional nocopy) + (if nocopy + string + (copy-sequence string)))) + + (or (fboundp 'coding-system-p) + (defun coding-system-p (obj) nil)) + + (or (fboundp 'ccl-execute-on-string) + (defun ccl-execute-on-string (ccl-prog status str + &optional contin unibyte-p) + str)) + + (or (fboundp 'define-ccl-program) + (defmacro define-ccl-program (name ccl-program &optional doc) + `(defconst ,name nil ,doc))) + + (or (fboundp 'multibyte-string-p) + (defun multibyte-string-p (str) + (let ((len (length str)) + (i 0) + multibyte) + (while (and (< i len) (not (setq multibyte (> (aref str i) 255)))) + (setq i (1+ i))) + multibyte))) + + (or (fboundp 'string-make-multibyte) + (defalias 'string-make-multibyte 'copy-sequence)) + + (or (fboundp 'encode-char) + (defun encode-char (ch ccs) + ch)) + + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ps-print + + ;; GNU Emacs + (or (fboundp 'line-beginning-position) + (defun line-beginning-position (&optional n) + (save-excursion + (and n (/= n 1) (forward-line (1- n))) + (beginning-of-line) + (point)))) + + + ;; GNU Emacs + (or (fboundp 'find-composition) + (defalias 'find-composition 'ignore)) + + + (defun ps-xemacs-color-name (color) + (if (color-specifier-p color) + (color-name color) + color)) + + + (defalias 'ps-mark-active-p 'region-active-p) + + + (defun ps-face-foreground-name (face) + (ps-xemacs-color-name (face-foreground face))) + + + (defun ps-face-background-name (face) + (ps-xemacs-color-name (face-background face))) + + + (defun ps-frame-parameter (param) + (frame-property nil param)) + + + ;; Return t if the device (which can be changed during an emacs session) + ;; can handle colors. + ;; XEmacs change: Need to check for emacs-major-version too. + (if (or (> emacs-major-version 19) + (and (= emacs-major-version 19) + (>= emacs-minor-version 12))) + ;; xemacs >= 19.12 + (defun ps-color-device () + (eq (device-class) 'color)) + ;; xemacs < 19.12 + (setq ps-print-color-p nil) + (defalias 'ps-color-device 'ignore)) + + + (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-xemacs-face-kind-p (face kind kind-regex) + (let* ((frame-font (or (face-font-instance face) + (face-font-instance 'default))) + (kind-cons + (and frame-font + (assq kind + (font-instance-properties frame-font)))) + (kind-spec (cdr-safe kind-cons)) + (case-fold-search t)) + (and kind-spec (string-match kind-regex kind-spec)))) + + + ;; to avoid XEmacs compilation gripes + (defvar coding-system-for-write nil) + (defvar coding-system-for-read nil) + (defvar buffer-file-coding-system nil) + + + (and (fboundp 'find-coding-system) + (or (funcall 'find-coding-system 'raw-text-unix) + (funcall 'copy-coding-system 'no-conversion-unix 'raw-text-unix))) + + + (defun ps-color-values (x-color) + (let ((color (ps-xemacs-color-name x-color))) + (cond + ((fboundp 'x-color-values) + (funcall 'x-color-values color)) + ((and (fboundp 'color-instance-rgb-components) + (ps-color-device)) + (funcall 'color-instance-rgb-components + (if (color-instance-p x-color) + x-color + (make-color-instance color)))) + (t + (error "No available function to determine X color values"))))) + + + (defun ps-face-bold-p (face) + (or (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold") + (memq face ps-bold-faces))) ; Kludge-compatible + + + (defun ps-face-italic-p (face) + (or (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o") + (ps-xemacs-face-kind-p face 'SLANT "i\\|o") + (memq face ps-italic-faces))) ; Kludge-compatible + + + ;; XEmacs will have to make do with %s (princ) for floats. + (defvar ps-color-format "%s %s %s") + (defvar ps-float-format "%s ") + + + (defun ps-generate-postscript-with-faces1 (from to) + ;; Generate some PostScript. + (let ((face 'default) + (position to) + ;; XEmacs + ;; Build the list of extents... + (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) + extent-list nil) + + ;; Loop through the extents... + (while a + (setq record (car a) + position (car record) + + record (cdr record) + type (car record) + + record (cdr record) + 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. + (and (>= from (point-min)) + (ps-plot-with-face from (min position (point-max)) face)) + + (cond + ((eq type 'push) + (and (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) + from position + a (cdr a))) + + (ps-plot-with-face from to face))) + + ) + (t ; emacs + ;; Do nothing + )) ; end cond featurep + + + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Emacs Definitions + + +(cond + ((featurep 'xemacs) ; xemacs + ;; Do nothing + ) + (t ; emacs + + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; ps-print + + (defvar mark-active nil) + + + (defun ps-mark-active-p () + mark-active) + + + (defun ps-face-foreground-name (face) + (face-foreground face nil t)) + + + (defun ps-face-background-name (face) + (face-background face nil t)) + + + (defun ps-frame-parameter (param) + (frame-parameter nil param)) + + + ;; Return t if the device (which can be changed during an emacs session) can + ;; handle colors. This function is not yet implemented for GNU emacs. + (defun ps-color-device () + (if (fboundp 'color-values) + (funcall 'color-values "Green") + t)) + + + (defun ps-color-values (x-color) + (cond + ((fboundp 'color-values) + (funcall 'color-values x-color)) + ((fboundp 'x-color-values) + (funcall 'x-color-values x-color)) + (t + (error "No available function to determine X color values")))) + + + (defun ps-face-bold-p (face) + (or (face-bold-p face) + (memq face ps-bold-faces))) + + + (defun ps-face-italic-p (face) + (or (face-italic-p face) + (memq face ps-italic-faces))) + + + ;; 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. + (defvar ps-color-format "%0.3f %0.3f %0.3f") + (defvar ps-float-format "%0.3f ") + + + (defun ps-generate-postscript-with-faces1 (from to) + ;; Generate some PostScript. + (let ((face 'default) + (position to) + ;; Emacs + (property-change from) + (overlay-change from) + (save-buffer-invisibility-spec buffer-invisibility-spec) + (buffer-invisibility-spec nil) + before-string after-string) + (while (< from to) + (and (< property-change to) ; Don't search for property change + ; unless previous search succeeded. + (setq property-change (next-property-change from nil to))) + (and (< 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) + before-string nil + after-string nil) + ;; 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 save-buffer-invisibility-spec t) + (not (null prop)) + (or (memq prop save-buffer-invisibility-spec) + (assq prop save-buffer-invisibility-spec)))) + 'emacs--invisible--face) + ((get-text-property from 'face)) + (t 'default))) + (let ((overlays (overlays-at from)) + (face-priority -1)) ; text-property + (while (and overlays + (not (eq face 'emacs--invisible--face))) + (let* ((overlay (car overlays)) + (overlay-invisible + (overlay-get overlay 'invisible)) + (overlay-priority + (or (overlay-get overlay 'priority) 0))) + (and (> overlay-priority face-priority) + (setq before-string + (or (overlay-get overlay 'before-string) + before-string) + after-string + (or (and (<= (overlay-end overlay) position) + (overlay-get overlay 'after-string)) + after-string) + face-priority overlay-priority + face + (cond + ((if (eq save-buffer-invisibility-spec t) + (not (null overlay-invisible)) + (or (memq overlay-invisible + save-buffer-invisibility-spec) + (assq overlay-invisible + save-buffer-invisibility-spec))) + 'emacs--invisible--face) + ((overlay-get overlay 'face)) + (t face) + )))) + (setq overlays (cdr overlays)))) + ;; Plot up to this record. + (and before-string + (ps-plot-string before-string)) + (ps-plot-with-face from position face) + (and after-string + (ps-plot-string after-string)) + (setq from position)) + (ps-plot-with-face from to face))) + + )) ; end cond featurep + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'ps-def) + +;;; arch-tag: fb06a585-1112-4206-885d-a57d95d50579 +;;; ps-def.el ends here diff --git a/lisp/ps-mule.el b/lisp/ps-mule.el index 5223e751d6c..04eb19a6bca 100644 --- a/lisp/ps-mule.el +++ b/lisp/ps-mule.el @@ -91,69 +91,7 @@ ;;; Code: (eval-and-compile - (require 'ps-print) - - ;; to avoid XEmacs compilation gripes - (defvar leading-code-private-22 157) - (or (fboundp 'charset-bytes) - (defun charset-bytes (charset) 1)) ; ascii - (or (fboundp 'charset-dimension) - (defun charset-dimension (charset) 1)) ; ascii - (or (fboundp 'charset-id) - (defun charset-id (charset) 0)) ; ascii - (or (fboundp 'charset-width) - (defun charset-width (charset) 1)) ; ascii - (or (fboundp 'find-charset-region) - (defun find-charset-region (beg end &optional table) - (list 'ascii))) - (or (fboundp 'char-width) - (defun char-width (char) 1)) ; ascii - (or (fboundp 'chars-in-region) - (defun chars-in-region (beg end) - (- (max beg end) (min beg end)))) - (or (fboundp 'forward-point) - (defun forward-point (arg) - (save-excursion - (let ((count (abs arg)) - (step (if (zerop arg) - 0 - (/ arg arg)))) - (while (and (> count 0) - (< (point-min) (point)) (< (point) (point-max))) - (forward-char step) - (setq count (1- count))) - (+ (point) (* count step)))))) - (or (fboundp 'decompose-composite-char) - (defun decompose-composite-char (char &optional type - with-composition-rule) - nil)) - (or (fboundp 'encode-coding-string) - (defun encode-coding-string (string coding-system &optional nocopy) - (if nocopy - string - (copy-sequence string)))) - (or (fboundp 'coding-system-p) - (defun coding-system-p (obj) nil)) - (or (fboundp 'ccl-execute-on-string) - (defun ccl-execute-on-string (ccl-prog status str - &optional contin unibyte-p) - str)) - (or (fboundp 'define-ccl-program) - (defmacro define-ccl-program (name ccl-program &optional doc) - `(defconst ,name nil ,doc))) - (or (fboundp 'multibyte-string-p) - (defun multibyte-string-p (str) - (let ((len (length str)) - (i 0) - multibyte) - (while (and (< i len) (not (setq multibyte (> (aref str i) 255)))) - (setq i (1+ i))) - multibyte))) - (or (fboundp 'string-make-multibyte) - (defalias 'string-make-multibyte 'copy-sequence)) - (or (fboundp 'encode-char) - (defun encode-char (ch ccs) - ch))) + (require 'ps-print)) ;;;###autoload diff --git a/lisp/ps-print.el b/lisp/ps-print.el index 1003015aee0..e50342dac91 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -10,11 +10,11 @@ ;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters) ;; Vinicius Jose Latorre <viniciusjl@ig.com.br> ;; Keywords: wp, print, PostScript -;; Version: 7.1 +;; Version: 7.2 ;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre -(defconst ps-print-version "7.1" - "ps-print.el, v 7.1 <2007/01/21 vinicius> +(defconst ps-print-version "7.2" + "ps-print.el, v 7.2 <2007/01/19 vinicius> Vinicius's last change version -- this file may have been edited as part of Emacs without changes to the version number. When reporting bugs, please also @@ -1445,6 +1445,7 @@ Please send all bug fixes and enhancements to (require 'lpr) + (or (featurep 'lisp-float-type) (error "`ps-print' requires floating point support")) @@ -1463,82 +1464,14 @@ Please send all bug fixes and enhancements to 'emacs)))) -;; GNU Emacs -(or (fboundp 'line-beginning-position) - (defun line-beginning-position (&optional n) - (save-excursion - (and n (/= n 1) (forward-line (1- n))) - (beginning-of-line) - (point)))) - - -;; to avoid compilation gripes - -;; XEmacs -(defalias 'ps-x-color-instance-p 'color-instance-p) -(defalias 'ps-x-color-instance-rgb-components 'color-instance-rgb-components) -(defalias 'ps-x-color-name 'color-name) -(defalias 'ps-x-color-specifier-p 'color-specifier-p) -(defalias 'ps-x-copy-coding-system 'copy-coding-system) -(defalias 'ps-x-device-class 'device-class) -(defalias 'ps-x-extent-end-position 'extent-end-position) -(defalias 'ps-x-extent-face 'extent-face) -(defalias 'ps-x-extent-priority 'extent-priority) -(defalias 'ps-x-extent-start-position 'extent-start-position) -(defalias 'ps-x-face-font-instance 'face-font-instance) -(defalias 'ps-x-find-coding-system 'find-coding-system) -(defalias 'ps-x-font-instance-properties 'font-instance-properties) -(defalias 'ps-x-make-color-instance 'make-color-instance) -(defalias 'ps-x-map-extents 'map-extents) -(defalias 'ps-x-frame-property 'frame-property) - -;; GNU Emacs -(defalias 'ps-e-face-bold-p 'face-bold-p) -(defalias 'ps-e-face-italic-p 'face-italic-p) -(defalias 'ps-e-next-overlay-change 'next-overlay-change) -(defalias 'ps-e-overlays-at 'overlays-at) -(defalias 'ps-e-overlay-get 'overlay-get) -(defalias 'ps-e-overlay-end 'overlay-end) -(defalias 'ps-e-x-color-values 'x-color-values) -(defalias 'ps-e-color-values 'color-values) -(defalias 'ps-e-frame-parameter 'frame-parameter) -(if (fboundp 'find-composition) - (defalias 'ps-e-find-composition 'find-composition) - (defalias 'ps-e-find-composition 'ignore)) - - (defconst ps-windows-system (memq system-type '(emx win32 w32 mswindows ms-dos windows-nt))) (defconst ps-lp-system (memq system-type '(usg-unix-v dgux hpux irix))) -(defun ps-xemacs-color-name (color) - (if (ps-x-color-specifier-p color) - (ps-x-color-name color) - color)) - - -(cond ((featurep 'xemacs) ; xemacs - (defalias 'ps-mark-active-p 'region-active-p) - (defun ps-face-foreground-name (face) - (ps-xemacs-color-name (face-foreground face))) - (defun ps-face-background-name (face) - (ps-xemacs-color-name (face-background face))) - (defun ps-frame-parameter (param) - (ps-x-frame-property nil param)) - ) - (t ; emacs 23 or higher - (defvar mark-active nil) - (defun ps-mark-active-p () - mark-active) - (defun ps-face-foreground-name (face) - (face-foreground face nil t)) - (defun ps-face-background-name (face) - (face-background face nil t)) - (defun ps-frame-parameter (param) - (ps-e-frame-parameter nil param)) - )) +;; Load XEmacs/Emacs definitions +(eval-and-compile (require 'ps-def)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -3344,9 +3277,9 @@ It's like the very first character of buffer (or region) is ^L (\\014)." (defcustom ps-postscript-code-directory (or (if (featurep 'xemacs) (cond ((fboundp 'locate-data-directory) ; xemacs - (locate-data-directory "ps-print")) + (funcall 'locate-data-directory "ps-print")) ((boundp 'data-directory) ; xemacs - data-directory) + (symbol-value 'data-directory)) (t ; don't know what to do nil)) data-directory) ; emacs @@ -3838,107 +3771,6 @@ It can be retrieved with `(ps-get ALIST-SYM KEY)'." (format-time-string "%T")) -(and (featurep 'xemacs) - ;; XEmacs change: Need to check for emacs-major-version too. - (or (< emacs-major-version 19) - (and (= emacs-major-version 19) (< emacs-minor-version 12))) - (setq ps-print-color-p nil)) - - -;; Return t if the device (which can be changed during an emacs session) -;; can handle colors. -;; This function is not yet implemented for GNU emacs. -(cond ((and (featurep 'xemacs) - ;; XEmacs change: Need to check for emacs-major-version too. - (or (> emacs-major-version 19) - (and (= emacs-major-version 19) - (>= emacs-minor-version 12)))) ; xemacs >= 19.12 - (defun ps-color-device () - (eq (ps-x-device-class) 'color))) - - (t ; emacs - (defun ps-color-device () - (if (fboundp 'color-values) - (ps-e-color-values "Green") - t)))) - - -(defun ps-mapper (extent list) - (nconc list - (list (list (ps-x-extent-start-position extent) 'push extent) - (list (ps-x-extent-end-position extent) 'pull extent))) - nil) - -(defun ps-extent-sorter (a b) - (< (ps-x-extent-priority a) (ps-x-extent-priority b))) - -(defun ps-xemacs-face-kind-p (face kind kind-regex) - (let* ((frame-font (or (ps-x-face-font-instance face) - (ps-x-face-font-instance 'default))) - (kind-cons - (and frame-font - (assq kind - (ps-x-font-instance-properties frame-font)))) - (kind-spec (cdr-safe kind-cons)) - (case-fold-search t)) - (and kind-spec (string-match kind-regex kind-spec)))) - -(cond ((featurep 'xemacs) ; xemacs - - ;; to avoid XEmacs compilation gripes - (defvar coding-system-for-write nil) - (defvar coding-system-for-read nil) - (defvar buffer-file-coding-system nil) - - (and (fboundp 'find-coding-system) - (or (ps-x-find-coding-system 'raw-text-unix) - (ps-x-copy-coding-system 'no-conversion-unix 'raw-text-unix))) - - (defun ps-color-values (x-color) - (let ((color (ps-xemacs-color-name x-color))) - (cond - ((fboundp 'x-color-values) - (ps-e-x-color-values color)) - ((and (fboundp 'color-instance-rgb-components) - (ps-color-device)) - (ps-x-color-instance-rgb-components - (if (ps-x-color-instance-p x-color) - x-color - (ps-x-make-color-instance color)))) - (t - (error "No available function to determine X color values"))))) - - (defun ps-face-bold-p (face) - (or (ps-xemacs-face-kind-p face 'WEIGHT_NAME "bold\\|demibold") - (memq face ps-bold-faces))) ; Kludge-compatible - - (defun ps-face-italic-p (face) - (or (ps-xemacs-face-kind-p face 'ANGLE_NAME "i\\|o") - (ps-xemacs-face-kind-p face 'SLANT "i\\|o") - (memq face ps-italic-faces))) ; Kludge-compatible - ) - - (t ; emacs - - (defun ps-color-values (x-color) - (cond - ((fboundp 'color-values) - (ps-e-color-values x-color)) - ((fboundp 'x-color-values) - (ps-e-x-color-values x-color)) - (t - (error "No available function to determine X color values")))) - - (defun ps-face-bold-p (face) - (or (ps-e-face-bold-p face) - (memq face ps-bold-faces))) - - (defun ps-face-italic-p (face) - (or (ps-e-face-italic-p face) - (memq face ps-italic-faces))) - )) - - (defvar ps-print-color-scale 1.0) (defun ps-color-scale (color) @@ -4018,15 +3850,6 @@ Note: No major/minor-mode is activated and no local variables are evaluated for (defvar ps-razchunk 0) (defvar ps-color-p nil) -(defvar ps-color-format - (if (featurep 'xemacs) - ;; XEmacs will have to make do with %s (princ) for floats. - "%s %s %s" - - ;; 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")) ;; These values determine how much print-height to deduct when headers/footers ;; are turned on. This is a pretty clumsy way of handling it, but it'll do for @@ -4906,15 +4729,6 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th (vector 0 0 0 0))))) -;; 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. -;; XEmacs will have to make do with %s (princ) for floats. - -(defvar ps-float-format (if (featurep 'xemacs) - "%s " ; xemacs - "%0.3f ")) ; emacs - - (defun ps-float-format (value &optional default) (let ((literal (or value default))) (cond ((null literal) @@ -6442,125 +6256,7 @@ If FACE is not a valid face name, it is used default face." (save-restriction (narrow-to-region from to) (ps-print-ensure-fontified from to) - (let ((face 'default) - (position to)) - (cond - ((featurep 'xemacs) ; xemacs - ;; Build the list of extents... - (let ((a (cons 'dummy nil)) - record type extent extent-list) - (ps-x-map-extents 'ps-mapper nil from to a) - (setq a (sort (cdr a) 'car-less-than-car) - extent-list nil) - - ;; Loop through the extents... - (while a - (setq record (car a) - position (car record) - - record (cdr record) - type (car record) - - record (cdr record) - 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. - (and (>= from (point-min)) - (ps-plot-with-face from (min position (point-max)) face)) - - (cond - ((eq type 'push) - (and (ps-x-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 - (ps-x-extent-face (car extent-list)) - 'default) - from position - a (cdr a))))) - - (t ; emacs - (let ((property-change from) - (overlay-change from) - (save-buffer-invisibility-spec buffer-invisibility-spec) - (buffer-invisibility-spec nil) - before-string after-string) - (while (< from to) - (and (< property-change to) ; Don't search for property change - ; unless previous search succeeded. - (setq property-change (next-property-change from nil to))) - (and (< overlay-change to) ; Don't search for overlay change - ; unless previous search succeeded. - (setq overlay-change (min (ps-e-next-overlay-change from) - to))) - (setq position (min property-change overlay-change) - before-string nil - after-string nil) - ;; 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 save-buffer-invisibility-spec t) - (not (null prop)) - (or (memq prop save-buffer-invisibility-spec) - (assq prop save-buffer-invisibility-spec)))) - 'emacs--invisible--face) - ((get-text-property from 'face)) - (t 'default))) - (let ((overlays (ps-e-overlays-at from)) - (face-priority -1)) ; text-property - (while (and overlays - (not (eq face 'emacs--invisible--face))) - (let* ((overlay (car overlays)) - (overlay-invisible - (ps-e-overlay-get overlay 'invisible)) - (overlay-priority - (or (ps-e-overlay-get overlay 'priority) 0))) - (and (> overlay-priority face-priority) - (setq before-string - (or (ps-e-overlay-get overlay 'before-string) - before-string) - after-string - (or (and (<= (ps-e-overlay-end overlay) position) - (ps-e-overlay-get overlay 'after-string)) - after-string) - face-priority overlay-priority - face - (cond - ((if (eq save-buffer-invisibility-spec t) - (not (null overlay-invisible)) - (or (memq overlay-invisible - save-buffer-invisibility-spec) - (assq overlay-invisible - save-buffer-invisibility-spec))) - 'emacs--invisible--face) - ((ps-e-overlay-get overlay 'face)) - (t face) - )))) - (setq overlays (cdr overlays)))) - ;; Plot up to this record. - (and before-string - (ps-plot-string before-string)) - (ps-plot-with-face from position face) - (and after-string - (ps-plot-string after-string)) - (setq from position))))) - (ps-plot-with-face from to face)))) + (ps-generate-postscript-with-faces1 from to))) (defun ps-generate-postscript (from to) (ps-plot-region from to 0 nil)) @@ -6756,209 +6452,6 @@ If FACE is not a valid face name, it is used default face." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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 () - `(if (featurep 'xemacs) 'f22 [f22])) -(defmacro ps-c-prsc () - `(if (featurep 'xemacs) '(control f22) [C-f22])) -(defmacro ps-s-prsc () - `(if (featurep 'xemacs) '(shift f22) [S-f22])) - -;; A hook to bind to `rmail-mode-hook' to locally bind prsc and set the -;; `ps-left-headers' specially for mail messages. -(defun ps-rmail-mode-hook () - (local-set-key (ps-prsc) 'ps-rmail-print-message-from-summary) - (setq ps-header-lines 3 - ps-left-header - ;; The left headers will display the message's subject, its - ;; author, and the name of the folder it was in. - '(ps-article-subject ps-article-author buffer-name))) - -;; See `ps-gnus-print-article-from-summary'. This function does the -;; same thing for rmail. -(defun ps-rmail-print-message-from-summary () - (interactive) - (ps-print-message-from-summary 'rmail-summary-buffer "RMAIL")) - -;; Used in `ps-rmail-print-article-from-summary', -;; `ps-gnus-print-article-from-summary' and `ps-vm-print-message-from-summary'. -(defun ps-print-message-from-summary (summary-buffer summary-default) - (let ((ps-buf (or (and (boundp summary-buffer) - (symbol-value summary-buffer)) - summary-default))) - (and (get-buffer ps-buf) - (save-excursion - (set-buffer ps-buf) - (ps-spool-buffer-with-faces))))) - -;; 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> or - ;; "Jim Thompson" <thompson@wg2.waii.com> - ((string-match "\\(\"?\\)\\(.*\\)\\1[ \t]+<.*>" fromstring) - (substring fromstring (match-beginning 2) (match-end 2))) - - ;; 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 - ps-left-header - ;; The left headers will display the article's subject, its - ;; author, and the newsgroup it was in. - '(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. -(defun ps-vm-mode-hook () - (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary) - (setq ps-header-lines 3 - ps-left-header - ;; The left headers will display the message's subject, its - ;; author, and the name of the folder it was in. - '(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) - (ps-print-message-from-summary 'gnus-article-buffer "*Article*")) - -;; See `ps-gnus-print-article-from-summary'. This function does the -;; same thing for vm. -(defun ps-vm-print-message-from-summary () - (interactive) - (ps-print-message-from-summary 'vm-mail-buffer "")) - -;; 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. - '(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 - ps-print-color-p nil - ps-lpr-command "lpr" - 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 nil - - 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) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; To make this file smaller, some commands go in a separate file. ;; But autoload them here to make the separation invisible. diff --git a/lisp/ps-samp.el b/lisp/ps-samp.el new file mode 100644 index 00000000000..60f2c2b2d34 --- /dev/null +++ b/lisp/ps-samp.el @@ -0,0 +1,249 @@ +;;; ps-samp.el --- ps-print sample setup code + +;; Copyright (C) 2007 Free Software Foundation, Inc. + +;; Author: Jim Thompson (was <thompson@wg2.waii.com>) +;; Jacques Duthen (was <duthen@cegelec-red.fr>) +;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Kenichi Handa <handa@m17n.org> (multi-byte characters) +;; Maintainer: Kenichi Handa <handa@m17n.org> (multi-byte characters) +;; Vinicius Jose Latorre <viniciusjl@ig.com.br> +;; Keywords: wp, print, PostScript +;; Version: 7.2 +;; X-URL: http://www.emacswiki.org/cgi-bin/wiki/ViniciusJoseLatorre + +;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; See ps-print.el for documentation. + +;;; Code: + + +(eval-and-compile (require 'ps-print)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 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 () + `(if (featurep 'xemacs) 'f22 [f22])) +(defmacro ps-c-prsc () + `(if (featurep 'xemacs) '(control f22) [C-f22])) +(defmacro ps-s-prsc () + `(if (featurep 'xemacs) '(shift f22) [S-f22])) + +;; A hook to bind to `rmail-mode-hook' to locally bind prsc and set the +;; `ps-left-headers' specially for mail messages. +(defun ps-rmail-mode-hook () + (local-set-key (ps-prsc) 'ps-rmail-print-message-from-summary) + (setq ps-header-lines 3 + ps-left-header + ;; The left headers will display the message's subject, its + ;; author, and the name of the folder it was in. + '(ps-article-subject ps-article-author buffer-name))) + +;; See `ps-gnus-print-article-from-summary'. This function does the +;; same thing for rmail. +(defun ps-rmail-print-message-from-summary () + (interactive) + (ps-print-message-from-summary 'rmail-summary-buffer "RMAIL")) + +;; Used in `ps-rmail-print-article-from-summary', +;; `ps-gnus-print-article-from-summary' and `ps-vm-print-message-from-summary'. +(defun ps-print-message-from-summary (summary-buffer summary-default) + (let ((ps-buf (or (and (boundp summary-buffer) + (symbol-value summary-buffer)) + summary-default))) + (and (get-buffer ps-buf) + (save-excursion + (set-buffer ps-buf) + (ps-spool-buffer-with-faces))))) + +;; 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> or + ;; "Jim Thompson" <thompson@wg2.waii.com> + ((string-match "\\(\"?\\)\\(.*\\)\\1[ \t]+<.*>" fromstring) + (substring fromstring (match-beginning 2) (match-end 2))) + + ;; 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 + ps-left-header + ;; The left headers will display the article's subject, its + ;; author, and the newsgroup it was in. + '(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. +(defun ps-vm-mode-hook () + (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary) + (setq ps-header-lines 3 + ps-left-header + ;; The left headers will display the message's subject, its + ;; author, and the name of the folder it was in. + '(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) + (ps-print-message-from-summary 'gnus-article-buffer "*Article*")) + +;; See `ps-gnus-print-article-from-summary'. This function does the +;; same thing for vm. +(defun ps-vm-print-message-from-summary () + (interactive) + (ps-print-message-from-summary 'vm-mail-buffer "")) + +;; 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. + '(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 + ps-print-color-p nil + ps-lpr-command "lpr" + 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 nil + + 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-samp) + +;;; arch-tag: fb06a585-1112-4206-885d-a57d95d50579 +;;; ps-samp.el ends here |