+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
;;; 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
--- /dev/null
+;;; 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:
+
+
+\f
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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
+
+
+\f
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide 'ps-def)
+
+;;; arch-tag: fb06a585-1112-4206-885d-a57d95d50579
+;;; ps-def.el ends here
;;; 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
;; 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
(require 'lpr)
+
(or (featurep 'lisp-float-type)
(error "`ps-print' requires floating point support"))
'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))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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
(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)
(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
(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)
(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))
(t
(setq kill-emacs-hook 'ps-kill-emacs-check)))
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; 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)
-
\f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To make this file smaller, some commands go in a separate file.
--- /dev/null
+;;; 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))
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 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)
+
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(provide 'ps-samp)
+
+;;; arch-tag: fb06a585-1112-4206-885d-a57d95d50579
+;;; ps-samp.el ends here