From 76d6af4f05acacd4ca88857cbfef2fef78e3cb1a Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 13 Sep 1995 23:01:05 +0000
Subject: [PATCH] Changes dealing with encoded files:

1. Appending to an encoded file works by reading the file into a
   temporary buffer, appending the text, and writing it back out.

2. Line translation is handled for encoded files the same way it is
   for unencoded files.

3. Doing I/O to non-encoded files, if the file doesn't exist, an
   encoded file is used in its place if available.
---
 v7/src/edwin/dos.scm     |   4 +-
 v7/src/edwin/filcom.scm  |  11 ++-
 v7/src/edwin/fileio.scm  | 198 ++++++++++++++++++++++++---------------
 v7/src/edwin/os2.scm     |  41 ++++----
 v7/src/edwin/process.scm |  15 ++-
 v7/src/edwin/unix.scm    | 101 ++++++++++----------
 6 files changed, 223 insertions(+), 147 deletions(-)

diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm
index d0c574dc0..ca1ffc808 100644
--- a/v7/src/edwin/dos.scm
+++ b/v7/src/edwin/dos.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: dos.scm,v 1.26 1995/07/11 23:10:41 cph Exp $
+;;;	$Id: dos.scm,v 1.27 1995/09/13 23:00:53 cph Exp $
 ;;;
 ;;;	Copyright (c) 1992-95 Massachusetts Institute of Technology
 ;;;
@@ -319,8 +319,8 @@ Includes the new backup.  Must be > 0."
 	     pathname))))
 
 (define (os/read-file-methods) '())
-
 (define (os/write-file-methods) '())
+(define (os/alternate-pathnames group pathname) group pathname '())
 
 ;;;; Dired customization
 
diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm
index 3d54f4d23..af5dc97c4 100644
--- a/v7/src/edwin/filcom.scm
+++ b/v7/src/edwin/filcom.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: filcom.scm,v 1.186 1995/07/11 23:19:30 cph Exp $
+;;;	$Id: filcom.scm,v 1.187 1995/09/13 23:00:55 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-95 Massachusetts Institute of Technology
 ;;;
@@ -131,10 +131,17 @@ invocation."
 			    (ref-variable find-file-not-found-hooks buffer)
 			    (cdr hooks)))
 			  ((or (null? hooks)
-			       ((car hooks) buffer)))))
+			       ((car hooks) buffer))))
+		      (maybe-change-buffer-name! buffer pathname))
 		  (after-find-file buffer error? warn?))
 		buffer))))))
 
+(define (maybe-change-buffer-name! buffer pathname)
+  (let ((name (pathname->buffer-name pathname))
+	(name* (pathname->buffer-name (buffer-pathname buffer))))
+    (if (not (string=? name name*))
+	(rename-buffer buffer (new-buffer-name name*)))))
+
 (define (after-find-file buffer error? warn?)
   (let ((pathname (or (buffer-truename buffer) (buffer-pathname buffer))))
     (let ((buffer-read-only?
diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm
index 551ced68c..76639092c 100644
--- a/v7/src/edwin/fileio.scm
+++ b/v7/src/edwin/fileio.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: fileio.scm,v 1.128 1995/09/13 03:57:14 cph Exp $
+;;;	$Id: fileio.scm,v 1.129 1995/09/13 23:00:58 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-95 Massachusetts Institute of Technology
 ;;;
@@ -46,15 +46,70 @@
 
 (declare (usual-integrations))
 
+;;;; Special File I/O Methods
+
+(define (r/w-file-methods? objects)
+  (and (list? objects)
+       (for-all? objects
+	 (lambda (object)
+	   (and (pair? object)
+		(procedure? (car object))
+		(procedure? (cdr object)))))))
+
+(define-variable read-file-methods
+  "List of alternate methods to be used for reading a file into a buffer.
+Each method is a pair of a predicate and a procedure.  The methods are
+tried, in order, until one of the predicates is satisfied, at which
+point the corresponding procedure is used to read the file.  If none
+of the predicates is satisfied, the file is read in the usual way."
+  (os/read-file-methods)
+  r/w-file-methods?)
+
+(define-variable write-file-methods
+  "List of alternate methods to be used for writing a file into a buffer.
+Each method is a pair of a predicate and a procedure.  The methods are
+tried, in order, until one of the predicates is satisfied, at which
+point the corresponding procedure is used to write the file.  If none
+of the predicates is satisfied, the file is written in the usual way."
+  (os/write-file-methods)
+  r/w-file-methods?)
+
+(define (read-file-method group pathname)
+  (let loop ((methods (ref-variable read-file-methods group)))
+    (and (not (null? methods))
+	 (if ((caar methods) group pathname)
+	     (cdar methods)
+	     (loop (cdr methods))))))
+
+(define (write-file-method group pathname)
+  (let loop ((methods (ref-variable write-file-methods group)))
+    (and (not (null? methods))
+	 (if ((caar methods) group pathname)
+	     (cdar methods)
+	     (loop (cdr methods))))))
+
+(define (get-pathname-or-alternate group pathname)
+  (if (file-exists? pathname)
+      pathname
+      (let loop ((alternates (os/alternate-pathnames group pathname)))
+	(cond ((null? alternates)
+	       pathname)
+	      ((file-exists? (car alternates))
+	       (car alternates))
+	      (else
+	       (loop (cdr alternates)))))))
+
 ;;;; Input
 
 (define (read-buffer buffer pathname visit?)
   (set-buffer-writable! buffer)
   (let ((truename false)
-	(file-error false))
+	(file-error false)
+	(group (buffer-group buffer)))
     ;; Set modified so that file supercession check isn't done.
-    (set-group-modified?! (buffer-group buffer) true)
+    (set-group-modified?! group true)
     (region-delete! (buffer-unclipped-region buffer))
+    (set! pathname (get-pathname-or-alternate group pathname))
     (call-with-current-continuation
      (lambda (continuation)
        (bind-condition-handler (list condition-type:file-error)
@@ -64,13 +119,11 @@
 	     (continuation unspecific))
 	 (lambda ()
 	   (set! truename (->truename pathname))
-	   (if truename
-	       (begin
-		 (%insert-file (buffer-start buffer) truename visit?)
-		 (if visit?
-		     (set-buffer-modification-time!
-		      buffer
-		      (file-modification-time truename)))))))))
+	   (%insert-file (buffer-start buffer) truename visit?)
+	   (if visit?
+	       (set-buffer-modification-time!
+		buffer
+		(file-modification-time truename)))))))
     (set-buffer-point! buffer (buffer-start buffer))
     (if visit?
 	(begin
@@ -91,7 +144,7 @@
 	 condition
 	 (editor-error "File " (->namestring filename) " not found"))
      (lambda ()
-       (->truename filename)))
+       (->truename (get-pathname-or-alternate (mark-group mark) filename))))
    false))
 
 (define-variable read-file-message
@@ -99,17 +152,6 @@
   false
   boolean?)
 
-(define-variable read-file-methods
-  "List of procedures to be called before reading a file into a buffer.
-The procedures are called in order; if one of them returns true the file
-is considered already read and the rest are not called.
-Each procedure is called with three arguments:
- the pathname of the file to be read,
- the mark at which the file's contents should be inserted, and
- a flag that is true iff the buffer being filled is visiting the file."
-  (os/read-file-methods)
-  list?)
-
 (define-variable translate-file-data-on-input
   "If true (the default), end-of-line translation is done on file input."
   #t
@@ -118,13 +160,12 @@ Each procedure is called with three arguments:
 (define (%insert-file mark truename visit?)
   (let ((do-it
 	 (lambda ()
-	   (let loop ((methods (ref-variable read-file-methods mark)))
-	     (cond ((null? methods)
-		    (group-insert-file! (mark-group mark)
-					(mark-index mark)
-					truename))
-		   ((not ((car methods) truename mark visit?))
-		    (loop (cdr methods))))))))
+	   (let ((method (read-file-method (mark-group mark) truename)))
+	     (if method
+		 (method truename mark visit?)
+		 (group-insert-file! (mark-group mark)
+				     (mark-index mark)
+				     truename))))))
     (if (ref-variable read-file-message)
 	(let ((msg
 	       (string-append "Reading file \""
@@ -406,17 +447,6 @@ and the rest are not called."
   '()
   list?)
 
-(define-variable write-file-methods
-  "List of procedures to be called before writing a region to a file.
-The procedures are called in order; if one of them returns true the file
-is considered already written and the rest are not called.
-Each procedure is called with three arguments:
- the region that should be written to the file,
- the pathname of the file to be written, and
- a flag that is true iff the buffer being written is visiting the file."
-  (os/write-file-methods)
-  list?)
-
 (define-variable enable-emacs-write-file-message
   "If true, generate Emacs-style message when writing files.
 Otherwise, a message is written both before and after long file writes."
@@ -525,42 +555,62 @@ Otherwise, a message is written both before and after long file writes."
   (write-region* region pathname message? true))
 
 (define (write-region* region pathname message? append?)
-  (let ((translation
-	 (and (ref-variable translate-file-data-on-output
-			    (region-group region))
-	      (pathname-newline-translation pathname)))
-	(filename (->namestring pathname))
-	(group (region-group region))
+  (let ((group (region-group region))
 	(start (region-start-index region))
-	(end (region-end-index region)))
-    (let ((do-it
-	   (if append?
-	       (lambda ()
-		 (group-append-to-file translation group start end filename))
-	       (lambda ()
-		 (let ((visit? (eq? 'VISIT message?)))
-		   (let loop
-		       ((methods (ref-variable write-file-methods group)))
-		     (cond ((null? methods)
-			    (group-write-to-file translation group start end
-						 filename))
-			   ((not ((car methods) region pathname visit?))
-			    (loop (cdr methods))))))))))
-      (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)
+	(end (region-end-index region))
+	(pathname (get-pathname-or-alternate (region-group region) pathname)))
+    (let ((translation
+	   (and (ref-variable translate-file-data-on-output group)
+		(pathname-newline-translation pathname)))
+	  (filename (->namestring pathname)))
+      (let ((do-it
+	     (let ((method (write-file-method group pathname)))
+	       (if append?
+		   (lambda ()
+		     (if method
+			 (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))))
+			 (group-append-to-file translation group start end
+					       filename)))
+		   (lambda ()
+		     (if method
+			 (method region pathname (eq? 'VISIT message?))
+			 (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 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))
+	       (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/os2.scm b/v7/src/edwin/os2.scm
index 1e0ae6b07..51ae72938 100644
--- a/v7/src/edwin/os2.scm
+++ b/v7/src/edwin/os2.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: os2.scm,v 1.20 1995/07/24 22:08:39 cph Exp $
+;;;	$Id: os2.scm,v 1.21 1995/09/13 23:01:01 cph Exp $
 ;;;
 ;;;	Copyright (c) 1994-95 Massachusetts Institute of Technology
 ;;;
@@ -620,9 +620,24 @@ Includes the new backup.  Must be > 0."
 
 ;;;; Compressed Files
 
-(define (os/read-file-methods) (list maybe-read-compressed-file))
-
-(define (os/write-file-methods) (list maybe-write-compressed-file))
+(define (os/read-file-methods)
+  `((,read/write-compressed-file?
+     . ,(lambda (pathname mark visit?)
+	  visit?
+	  (read-compressed-file "gzip -d" pathname mark)))))
+
+(define (os/write-file-methods)
+  `((,read/write-compressed-file?
+     . ,(lambda (region pathname visit?)
+	  visit?
+	  (write-compressed-file "gzip" region pathname)))))
+
+(define (os/alternate-pathnames group pathname)
+  (if (and (ref-variable enable-compressed-files group)
+	   (os2/fs-long-filenames? pathname)
+	   (not (equal? "gz" (pathname-type pathname))))
+      (list (string-append (->namestring pathname) ".gz"))
+      '()))
 
 (define-variable enable-compressed-files
   "If true, compressed files are automatically uncompressed when read,
@@ -631,13 +646,9 @@ filename suffix \".gz\"."
   #t
   boolean?)
 
-(define (maybe-read-compressed-file pathname mark visit?)
-  visit?
-  (and (ref-variable enable-compressed-files mark)
-       (equal? "gz" (pathname-type pathname))
-       (begin
-	 (read-compressed-file "gzip -d" pathname mark)
-	 #t)))
+(define (read/write-compressed-file? group pathname)
+  (and (ref-variable enable-compressed-files group)
+       (equal? "gz" (pathname-type pathname))))
 
 (define (read-compressed-file program pathname mark)
   (let ((do-it
@@ -666,14 +677,6 @@ filename suffix \".gz\"."
 	  (do-it)
 	  (append-message "done")))))
 
-(define (maybe-write-compressed-file region pathname visit?)
-  visit?
-  (and (ref-variable enable-compressed-files (region-start region))
-       (equal? "gz" (pathname-type pathname))
-       (begin
-	 (write-compressed-file "gzip" region pathname)
-	 #t)))
-
 (define (write-compressed-file program region pathname)
   (if (not (equal? '(EXITED . 0)
 		   (shell-command region
diff --git a/v7/src/edwin/process.scm b/v7/src/edwin/process.scm
index 8112c2831..b5719feaa 100644
--- a/v7/src/edwin/process.scm
+++ b/v7/src/edwin/process.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: process.scm,v 1.37 1995/04/10 16:50:04 cph Exp $
+;;;	$Id: process.scm,v 1.38 1995/09/13 23:01:03 cph Exp $
 ;;;
 ;;;	Copyright (c) 1991-95 Massachusetts Institute of Technology
 ;;;
@@ -581,6 +581,19 @@ after the listing is made.)"
 	  (cons status reason))))))
 
 (define (synchronous-process-wait process input-region output-mark)
+  ;; Initialize the subprocess line-translation appropriately.
+  ;; Buffers that disable translation should have it disabled for
+  ;; subprocess I/O as well as normal file I/O, since subprocesses are
+  ;; used for reading and writing compressed files and such.
+  (subprocess-i/o-port process
+		       (and (or (not output-mark)
+				(ref-variable translate-file-data-on-input
+					      output-mark))
+			    'DEFAULT)
+		       (and (or (not input-region)
+				(ref-variable translate-file-data-on-output
+					      (region-start input-region)))
+			    'DEFAULT))
   (if input-region
       (call-with-protected-continuation
        (lambda (continuation)
diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm
index 4d893c804..e012b6ac3 100644
--- a/v7/src/edwin/unix.scm
+++ b/v7/src/edwin/unix.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: unix.scm,v 1.52 1995/07/11 23:10:49 cph Exp $
+;;;	$Id: unix.scm,v 1.53 1995/09/13 23:01:05 cph Exp $
 ;;;
 ;;;	Copyright (c) 1989-95 Massachusetts Institute of Technology
 ;;;
@@ -371,12 +371,43 @@ Includes the new backup.  Must be > 0."
        (string-find-next-char filename #\#)))
 
 (define (os/read-file-methods)
-  (list maybe-read-compressed-file
-	maybe-read-encrypted-file))
+  `((,read/write-compressed-file?
+     . ,(lambda (pathname mark visit?)
+	  visit?
+	  (let ((type (pathname-type pathname)))
+	    (cond ((equal? "gz" type)
+		   (read-compressed-file "gzip -d" pathname mark))
+		  ((equal? "Z" type)
+		   (read-compressed-file "uncompress" pathname mark))))))
+    (,read/write-encrypted-file?
+     . ,(lambda (pathname mark visit?)
+	  visit?
+	  (read-encrypted-file pathname mark)))))
 
 (define (os/write-file-methods)
-  (list maybe-write-compressed-file
-	maybe-write-encrypted-file))
+  `((,read/write-compressed-file?
+     . ,(lambda (region pathname visit?)
+	  visit?
+	  (let ((type (pathname-type pathname)))
+	    (cond ((equal? "gz" type)
+		   (write-compressed-file "gzip" region pathname))
+		  ((equal? "Z" type)
+		   (write-compressed-file "compress" region pathname))))))
+    (,read/write-encrypted-file?
+     . ,(lambda (region pathname visit?)
+	  visit?
+	  (write-encrypted-file region pathname)))))
+
+(define (os/alternate-pathnames group pathname)
+  (let ((filename (->namestring pathname)))
+    `(,@(if (ref-variable enable-compressed-files group)
+	    (map (lambda (suffix) (string-append filename "." suffix))
+		 unix/compressed-file-suffixes)
+	    '())
+      ,@(if (ref-variable enable-encrypted-files group)
+	    (map (lambda (suffix) (string-append filename "." suffix))
+		 unix/encrypted-file-suffixes)
+	    '()))))
 
 ;;;; Compressed Files
 
@@ -387,27 +418,21 @@ of the filename suffixes \".gz\" or \".Z\"."
   true
   boolean?)
 
-(define (maybe-read-compressed-file pathname mark visit?)
-  visit?
-  (and (ref-variable enable-compressed-files mark)
-       (let ((type (pathname-type pathname)))
-	 (cond ((equal? "gz" type)
-		(read-compressed-file "gunzip" pathname mark)
-		#t)
-	       ((equal? "Z" type)
-		(read-compressed-file "uncompress" pathname mark)
-		#t)
-	       (else
-		#f)))))
+(define (read/write-compressed-file? group pathname)
+  (and (ref-variable enable-compressed-files group)
+       (member (pathname-type pathname) unix/compressed-file-suffixes)))
+
+(define unix/compressed-file-suffixes
+  '("gz" "Z"))
 
 (define (read-compressed-file program pathname mark)
   (let ((do-it
 	 (lambda ()
 	   (if (not (equal? '(EXITED . 0)
-			    (shell-command false
+			    (shell-command #f
 					   mark
 					   (directory-pathname pathname)
-					   false
+					   #f
 					   (string-append
 					    program
 					    " < "
@@ -427,25 +452,12 @@ of the filename suffixes \".gz\" or \".Z\"."
 	  (do-it)
 	  (append-message "done")))))
 
-(define (maybe-write-compressed-file region pathname visit?)
-  visit?
-  (and (ref-variable enable-compressed-files (region-start region))
-       (let ((type (pathname-type pathname)))
-	 (cond ((equal? "gz" type)
-		(write-compressed-file "gzip" region pathname)
-		#t)
-	       ((equal? "Z" type)
-		(write-compressed-file "compress" region pathname)
-		#t)
-	       (else
-		#f)))))
-
 (define (write-compressed-file program region pathname)
   (if (not (equal? '(EXITED . 0)
 		   (shell-command region
-				  false
+				  #f
 				  (directory-pathname pathname)
-				  false
+				  #f
 				  (string-append program
 						 " > "
 						 (file-namestring pathname)))))
@@ -465,13 +477,12 @@ filename suffix \".KY\"."
   true
   boolean?)
 
-(define (maybe-read-encrypted-file pathname mark visit?)
-  visit?
-  (and (ref-variable enable-encrypted-files mark)
-       (equal? "KY" (pathname-type pathname))
-       (begin
-	 (read-encrypted-file pathname mark)
-	 true)))
+(define (read/write-encrypted-file? group pathname)
+  (and (ref-variable enable-encrypted-files group)
+       (member (pathname-type pathname) unix/encrypted-file-suffixes)))
+
+(define unix/encrypted-file-suffixes
+  '("KY"))
 
 (define (read-encrypted-file pathname mark)
   (let ((the-encrypted-file
@@ -497,14 +508,6 @@ filename suffix \".KY\"."
 	(ref-variable-object auto-save-default)
       #f)))
 
-(define (maybe-write-encrypted-file region pathname visit?)
-  visit?
-  (and (ref-variable enable-encrypted-files (region-start region))
-       (equal? "KY" (pathname-type pathname))
-       (begin
-	 (write-encrypted-file region pathname)
-	 true)))
-
 (define (write-encrypted-file region pathname)
   (let* ((password 
 	  (prompt-for-confirmed-password))
-- 
2.25.1