Add new editor variable LPR-PROCEDURE to allow complete customization

of the printing method.

diff --git a/v7/src/edwin/loadef.scm b/v7/src/edwin/loadef.scm
index ced2fa71abcdbc0610adec4e0e25ce5f3aff7155..7a265fc7be9f372a0f6a35dc5a7df2e320c5c667 100644 (file)
--- a/v7/src/edwin/loadef.scm
+++ b/v7/src/edwin/loadef.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/loadef.scm,v 1.16 1992/08/21 23:52:31 cph Exp $
+;;;    $Id: loadef.scm,v 1.17 1992/11/05 20:45:32 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -119,7 +119,7 @@
   "These keywords cause the lines below them to be indented to the right.
 This must be a regular expression, or #F to disable the option."
   false)
-
+\f
 (define-library 'TEXINFO-MODE
   '("tximod" (EDWIN)))
 
@@ -154,24 +154,30 @@ Otherwise, a new buffer is created for each topic."
 (define-library 'print
   '("print" (EDWIN)))
 
-(define-variable lpr-switches
-  "List of strings to pass as extra switch args to lpr when it is invoked."
-  '()
-  list-of-strings?)
+(define-variable lpr-procedure
+  "Procedure that spools some text to the printer, or #F for the default.
+Procedure is called with four arguments: a region to be printed, a flag
+indicating that the text should be printed with page headers, a title string
+to appear in the header lines and on the title page, and the buffer in which
+the text was originally stored (for editor variable references).  If this
+variable's value is #F, the text is printed using LPR-COMMAND."
+  false
+  (lambda (object) (or (not object) (procedure? object))))
 
 (define-variable lpr-command
   "Shell command for printing a file"
   "lpr"
   string?)
 
+(define-variable lpr-switches
+  "List of strings to pass as extra switch args to lpr when it is invoked."
+  '()
+  list-of-strings?)
+
 (define lpr-prompt-for-name?
   ;; If true, lpr commands prompt for a name to appear on the title page.
   false)
 
-(define lpr-most-recent-name
-  ;; If name prompting is enabled, the last name is saved here.
-  false)
-
 (define lpr-print-not-special?
   ;; If true, the print-* commands are just like the lpr-* commands.
   false)

diff --git a/v7/src/edwin/print.scm b/v7/src/edwin/print.scm
index c3de8d3148ee52403ac0ea30acf3cd2af21d594d..833574c227469e09b965c5456d2f4d8be50324ed 100644 (file)
--- a/v7/src/edwin/print.scm
+++ b/v7/src/edwin/print.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/print.scm,v 1.11 1992/09/02 02:04:19 cph Exp $
+;;;    $Id: print.scm,v 1.12 1992/11/05 20:45:41 cph Exp $
 ;;;
 ;;;    Copyright (c) 1991-92 Massachusetts Institute of Technology
 ;;;
@@ -74,34 +74,37 @@ Variable LPR-SWITCHES is a list of extra switches (strings) to pass to lpr."
   (lambda  (region)
     (print-region/internal region true)))
 
-(define (print-region/internal region print-command?)
-  (let ((switches (print-region-switches region print-command?))
-       (source-buffer (mark-buffer (region-start region))))
-    (message "Spooling...")
-    (call-with-temporary-buffer " *spool temp*"
-      (lambda (temp-buffer)
-       (insert-region (region-start region)
-                      (region-end region)
-                      (buffer-point temp-buffer))
-       (let ((width (ref-variable tab-width source-buffer)))
-         (if (not (= width 8))
-             (begin
-               (define-variable-local-value! temp-buffer
-                 (ref-variable-object tab-width)
-                 width)
-               (untabify-region (buffer-start temp-buffer)
-                                (buffer-end temp-buffer)))))
-       (shell-command region (buffer-end temp-buffer) false false
-                      (string-append (ref-variable lpr-command source-buffer)
-                                     switches))))
-    (append-message "done")))
+(define (print-region/internal region print-headers?)
+  (message "Spooling...")
+  (let ((buffer (mark-buffer (region-start region)))
+       (print-headers? (and print-headers? (not lpr-print-not-special?)))
+       (title (print-region-title-string region)))
+    (let ((call-printer
+          (lambda (region)
+            ((or (ref-variable lpr-procedure buffer) print-region/default)
+             region print-headers? title buffer)))
+         (width (ref-variable tab-width buffer)))
+      (if (= width 8)
+         (call-printer region)
+         (call-with-temporary-buffer " *spool temp*"
+           (lambda (temp-buffer)
+             (insert-region (region-start region)
+                            (region-end region)
+                            (buffer-point temp-buffer))
+             (define-variable-local-value! temp-buffer
+               (ref-variable-object tab-width)
+               width)
+             (untabify-region (buffer-start temp-buffer)
+                              (buffer-end temp-buffer))
+             (call-printer (buffer-region temp-buffer)))))))
+  (append-message "done"))
 \f
-(define (print-region-switches region print-command?)
-  (print/assemble-switches
-   (print-region-title-string region)
-   (if (and print-command? (not lpr-print-not-special?))
-       '("-p")
-       '())))
+(define (print-region/default region print-headers? title buffer)
+  (shell-command region false false false
+                (string-append
+                 (ref-variable lpr-command buffer)
+                 (print/assemble-switches title
+                                          (if print-headers? '("-p") '())))))
 
 (define (print-region-title-string region)
   (let ((buffer-title
@@ -142,14 +145,16 @@ Variable LPR-SWITCHES is a list of extra switches (strings) to pass to lpr."
                      (car switches)
                      (loop (cdr switches)))))))
 
-(define (print/job-name)
-  (and lpr-prompt-for-name?
-       (let ((job-name
-             (prompt-for-string "Name to print on title page"
-                                lpr-most-recent-name
-                                'INSERTED-DEFAULT)))
-        (if (string-null? job-name)
-            false
-            (begin
-              (set! lpr-most-recent-name job-name)
-              job-name)))))
\ No newline at end of file
+(define print/job-name
+  (let ((most-recent-name false))
+    (lambda ()
+      (and lpr-prompt-for-name?
+          (let ((job-name
+                 (prompt-for-string "Name to print on title page"
+                                    most-recent-name
+                                    'INSERTED-DEFAULT)))
+            (if (string-null? job-name)
+                false
+                (begin
+                  (set! most-recent-name job-name)
+                  job-name)))))))
\ No newline at end of file