From: Chris Hanson Date: Fri, 3 Jan 1997 04:07:00 +0000 (+0000) Subject: Change output procedures to ignore translate-file-data-on-output in X-Git-Tag: 20090517-FFI~5279 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6cc097020431f6f5bea3937c56f2ee1b5a0b1678;p=mit-scheme.git 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 ec5a4b5db..4d9f8c325 100644 --- 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 99c1061dd..64a25496e 100644 --- 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 f0d09b920..234346618 100644 --- 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)) (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 bf238dc40..d2557a1df 100644 --- 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))))) (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 ec873b53a..7b873a4cb 100644 --- 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))))