Change output procedures to ignore translate-file-data-on-output in

some circumstances.  This is necessary because RMAIL files want this
variable set to #F, but M-x write-region should ignore the variable
binding in that case and do translation anyway.

diff --git a/v7/src/edwin/autosv.scm b/v7/src/edwin/autosv.scm
index ec5a4b5db120738d2be90609f4a07be6a68aa5a9..4d9f8c325dbe84ae7cc6231f720d671a8ab007ee 100644 (file)
--- a/v7/src/edwin/autosv.scm
+++ b/v7/src/edwin/autosv.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: autosv.scm,v 1.30 1994/05/04 22:56:50 cph Exp $
+;;;    $Id: autosv.scm,v 1.31 1997/01/03 04:06:40 cph Exp $
 ;;;
-;;;    Copyright (c) 1986, 1989-94 Massachusetts Institute of Technology
+;;;    Copyright (c) 1986, 1989-97 Massachusetts Institute of Technology
 ;;;
 ;;;    This material was developed by the Scheme project at the
 ;;;    Massachusetts Institute of Technology, Department of
@@ -198,6 +198,7 @@ This file is not the file you visited; that changes only when you save."
    (lambda ()
      (write-region (buffer-unclipped-region buffer)
                   (buffer-auto-save-pathname buffer)
-                  false)
+                  #f
+                  'DEFAULT)
      (set-buffer-save-length! buffer)
      (set-buffer-auto-saved! buffer))))
\ No newline at end of file

diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm
index 99c1061dd24b377f3fb6adc24310b91f7d0f26fe..64a25496e021d124a7d77fdb641dd51db610a210 100644 (file)
--- a/v7/src/edwin/filcom.scm
+++ b/v7/src/edwin/filcom.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: filcom.scm,v 1.188 1996/04/23 23:08:06 cph Exp $
+;;;    $Id: filcom.scm,v 1.189 1997/01/03 04:06:46 cph Exp $
 ;;;
-;;;    Copyright (c) 1986, 1989-96 Massachusetts Institute of Technology
+;;;    Copyright (c) 1986, 1989-97 Massachusetts Institute of Technology
 ;;;
 ;;;    This material was developed by the Scheme project at the
 ;;;    Massachusetts Institute of Technology, Department of
@@ -521,13 +521,13 @@ Makes buffer visit that file, and marks it not modified."
   "Write current region into specified file."
   "r\nFWrite region to file"
   (lambda (region filename)
-    (write-region region filename true)))
+    (write-region region filename #t #t)))
 
 (define-command append-to-file
   "Write current region into specified file."
   "r\nFAppend to file"
   (lambda (region filename)
-    (append-to-file region filename true)))
+    (append-to-file region filename #t #t)))
 
 (define-command insert-file
   "Insert contents of file into existing text.

diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm
index f0d09b920ac38029606ae020335083b2a68c7e2a..234346618e51a778d95cd56768d85bffdbfebccd 100644 (file)
--- a/v7/src/edwin/fileio.scm
+++ b/v7/src/edwin/fileio.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: fileio.scm,v 1.139 1996/12/24 22:33:27 cph Exp $
+;;;    $Id: fileio.scm,v 1.140 1997/01/03 04:06:32 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-96 Massachusetts Institute of Technology
 ;;;
@@ -554,75 +554,76 @@ Otherwise, a message is written both before and after long file writes."
         (->pathname
          (write-region (buffer-unclipped-region buffer)
                        (buffer-pathname buffer)
-                       'VISIT))))
+                       'VISIT
+                       'DEFAULT))))
     (set-buffer-truename! buffer truename)
     (delete-auto-save-file! buffer)
     (set-buffer-save-length! buffer)
     (buffer-not-modified! buffer)
     (set-buffer-modification-time! buffer (file-modification-time truename))))
 
-(define (write-region region pathname message?)
-  (write-region* region pathname message? false))
-
-(define (append-to-file region pathname message?)
-  (write-region* region pathname message? true))
-
-(define (write-region* region pathname message? append?)
-  (let ((group (region-group region))
-       (start (region-start-index region))
-       (end (region-end-index region))
-       (pathname
-        (get-pathname-or-alternate (region-group region) pathname #t)))
-    (let ((translation
-          (and (ref-variable translate-file-data-on-output group)
-               (pathname-newline-translation pathname)))
-         (filename (->namestring pathname)))
-      (let ((method (write-file-method group pathname)))
-       (if method
-           (if append?
-               (let ((rmethod (read-file-method group pathname)))
-                 (if (not rmethod)
-                     (error "Can't append: no read method:"
-                            pathname))
-                 (call-with-temporary-buffer " append region"
-                   (lambda (buffer)
-                     (let ((vcopy
-                            (lambda (v)
-                              (define-variable-local-value! buffer v
-                                (variable-local-value group v)))))
-                       (vcopy
-                        (ref-variable-object translate-file-data-on-input))
-                       (vcopy
-                        (ref-variable-object translate-file-data-on-output)))
-                     (rmethod pathname (buffer-start buffer) #f)
-                     (insert-region (region-start region)
-                                    (region-end region)
-                                    (buffer-end buffer))
-                     (method (buffer-region buffer) pathname #f))))
-               (method region pathname (eq? 'VISIT message?)))
-           (let ((do-it
-                  (lambda ()
-                    (if append?
-                        (group-append-to-file translation group start end
-                                              filename)
-                        (group-write-to-file translation group start end
-                                             filename)))))
-             (cond ((not message?)
-                    (do-it))
-                   ((or (ref-variable enable-emacs-write-file-message)
-                        (<= (- end start) 50000))
-                    (do-it)
-                    (message "Wrote " filename))
-                   (else
-                    (let ((msg
-                           (string-append "Writing file " filename "...")))
-                      (message msg)
-                      (do-it)
-                      (message msg "done")))))))
-      ;; This isn't the correct truename on systems that support version
-      ;; numbers.  For those systems, the truename must be supplied by
-      ;; the operating system after the channel is closed.
-      filename)))
+(define (write-region region pathname message? translate?)
+  (write-region* region pathname message? #f translate?))
+
+(define (append-to-file region pathname message? translate?)
+  (write-region* region pathname message? #t translate?))
+
+(define (write-region* region pathname message? append? translate?)
+  (let* ((group (region-group region))
+        (start (region-start-index region))
+        (end (region-end-index region))
+        (pathname
+         (get-pathname-or-alternate (region-group region) pathname #t))
+        (translate?
+         (if (eq? 'DEFAULT translate?)
+             (ref-variable translate-file-data-on-output buffer)
+             translate?))
+        (translation (and translate? (pathname-newline-translation pathname)))
+        (filename (->namestring pathname))
+        (method (write-file-method group pathname)))
+    (if method
+       (if append?
+           (let ((rmethod (read-file-method group pathname)))
+             (if (not rmethod)
+                 (error "Can't append: no read method:" pathname))
+             (call-with-temporary-buffer " append region"
+               (lambda (buffer)
+                 (local-set-variable!
+                  translate-file-data-on-input
+                  (ref-variable translate-file-data-on-input buffer)
+                  buffer)
+                 (local-set-variable! translate-file-data-on-output
+                                      translate?
+                                      buffer)
+                 (rmethod pathname (buffer-start buffer) #f)
+                 (insert-region (region-start region)
+                                (region-end region)
+                                (buffer-end buffer))
+                 (method (buffer-region buffer) pathname #f))))
+           (method region pathname (eq? 'VISIT message?)))
+       (let ((do-it
+              (lambda ()
+                (if append?
+                    (group-append-to-file translation group start end
+                                          filename)
+                    (group-write-to-file translation group start end
+                                         filename)))))
+         (cond ((not message?)
+                (do-it))
+               ((or (ref-variable enable-emacs-write-file-message)
+                    (<= (- end start) 50000))
+                (do-it)
+                (message "Wrote " filename))
+               (else
+                (let ((msg
+                       (string-append "Writing file " filename "...")))
+                  (message msg)
+                  (do-it)
+                  (message msg "done"))))))
+    ;; This isn't the correct truename on systems that support version
+    ;; numbers.  For those systems, the truename must be supplied by
+    ;; the operating system after the channel is closed.
+    filename))
 \f
 (define (group-write-to-file translation group start end filename)
   (let ((channel (file-open-output-channel filename)))

diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm
index bf238dc40fece242a9d760f6275e6b74425d477b..d2557a1dfa363c329b3c7b2cb6bd9c2417657b17 100644 (file)
--- a/v7/src/edwin/rmail.scm
+++ b/v7/src/edwin/rmail.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: rmail.scm,v 1.54 1996/12/01 17:19:06 cph Exp $
+;;;    $Id: rmail.scm,v 1.55 1997/01/03 04:06:53 cph Exp $
 ;;;
-;;;    Copyright (c) 1991-96 Massachusetts Institute of Technology
+;;;    Copyright (c) 1991-97 Massachusetts Institute of Technology
 ;;;
 ;;;    This material was developed by the Scheme project at the
 ;;;    Massachusetts Institute of Technology, Department of
@@ -1564,23 +1564,8 @@ buffer visiting that file."
                (call-with-temporary-buffer " rmail output"
                  (lambda (buffer)
                    (insert-string babyl-initial-header (buffer-start buffer))
-                   (write-region (buffer-region buffer) pathname #f)))))
-         (let ((buf (->buffer (region-group region)))
-               (var (ref-variable-object translate-file-data-on-output))
-               (val))
-           (dynamic-wind
-            (lambda ()
-              (set! val
-                    (if (variable-local-value? buf var)
-                        (variable-local-value buf var)
-                        'NONE))
-              (define-variable-local-value! buf var #f))
-            (lambda ()
-              (append-to-file region pathname #f))
-            (lambda ()
-              (if (eq? val 'NONE)
-                  (undefine-variable-local-value! buf var)
-                  (define-variable-local-value! buf var val)))))))))
+                   (write-region (buffer-region buffer) pathname #f #f)))))
+         (append-to-file region pathname #f #f)))))
 \f
 (define-command rmail-output
   "Append this message to Unix mail file named FILE-NAME."

diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm
index ec873b53afc4d5a76d10e6a193eae5616759cb01..7b873a4cb121106d1953c9911e804c8201a0db55 100644 (file)
--- a/v7/src/edwin/sendmail.scm
+++ b/v7/src/edwin/sendmail.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Id: sendmail.scm,v 1.34 1996/04/24 01:30:11 cph Exp $
+;;;    $Id: sendmail.scm,v 1.35 1997/01/03 04:07:00 cph Exp $
 ;;;
-;;;    Copyright (c) 1991-96 Massachusetts Institute of Technology
+;;;    Copyright (c) 1991-97 Massachusetts Institute of Technology
 ;;;
 ;;;    This material was developed by the Scheme project at the
 ;;;    Massachusetts Institute of Technology, Department of
@@ -716,7 +716,8 @@ the user from the mailer."
                        (insert-region start end (buffer-end buffer))
                        (append-to-file (make-region start end)
                                        pathname
-                                       true))))
+                                       #t
+                                       #t))))
                pathnames)
       (kill-buffer temp-buffer))))