Split XEmacs/Emacs definitions and sample setup code into separate files

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