From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 15 Nov 1992 21:59:17 +0000 (+0000)
Subject: Redesign AFTER-FIND-FILE and related procedures to be more like GNU
X-Git-Tag: 20090517-FFI~8769
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1817c6c8de2815b07fd5272df948a8c685e585d8;p=mit-scheme.git

Redesign AFTER-FIND-FILE and related procedures to be more like GNU
Emacs.  Implement M-x recover-file.
---

diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm
index b5bb04869..22edfb4f3 100644
--- a/v7/src/edwin/filcom.scm
+++ b/v7/src/edwin/filcom.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: filcom.scm,v 1.170 1992/11/12 18:00:27 cph Exp $
+;;;	$Id: filcom.scm,v 1.171 1992/11/15 21:58:24 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-92 Massachusetts Institute of Technology
 ;;;
@@ -49,15 +49,69 @@
 (define (find-file filename)
   (select-buffer (find-file-noselect filename true)))
 
+(define-command find-file
+  "Visit a file in its own buffer.
+If the file is already in some buffer, select that buffer.
+Otherwise, visit the file in a buffer named after the file."
+  "FFind file"
+  find-file)
+
 (define (find-file-other-window filename)
   (select-buffer-other-window (find-file-noselect filename true)))
 
+(define-command find-file-other-window
+  "Visit a file in another window.
+May create a window, or reuse one."
+  "FFind file in other window"
+  find-file-other-window)
+
 (define (find-file-other-screen filename)
   (select-buffer-other-screen (find-file-noselect filename true)))
 
+(define-command find-file-other-screen
+  "Visit a file in another screen."
+  "FFind file in other screen"
+  find-file-other-screen)
+
+(define-command find-alternate-file
+  "Find file FILENAME, select its buffer, kill previous buffer.
+If the current buffer now contains an empty file that you just visited
+\(presumably by mistake), use this command to visit the file you really want."
+  "FFind alternate file"
+  (lambda (filename)
+    (let ((buffer (current-buffer)))
+      (let ((do-it
+	     (lambda ()
+	       (kill-buffer-interactive buffer)
+	       (find-file filename))))
+	(if (other-buffer buffer)
+	    (do-it)
+	    (let ((buffer* (new-buffer "*dummy*")))
+	      (do-it)
+	      (kill-buffer buffer*)))))))
+
+(define-variable find-file-run-dired
+  "True says run dired if find-file is given the name of a directory."
+  true
+  boolean?)
+
+(define-variable find-file-not-found-hooks
+  "List of procedures to be called for find-file on nonexistent file.
+These functions are called as soon as the error is detected.
+The functions are called in the order given,
+until one of them returns non-false."
+  '()
+  list?)
+
+(define-variable find-file-hooks
+  "Event distributor to be invoked after a buffer is loaded from a file.
+The buffer's local variables (if any) will have been processed before the
+invocation."
+  (make-event-distributor))
+
 (define (find-file-noselect filename warn?)
   (let ((pathname (pathname-simplify (merge-pathnames filename))))
-    (if (file-directory? pathname)
+    (if (file-test-no-errors file-directory? pathname)
 	(if (ref-variable find-file-run-dired)
 	    (make-dired-buffer (pathname-as-directory pathname))
 	    (editor-error (->namestring pathname) " is a directory."))
@@ -67,14 +121,118 @@
 		(if warn? (find-file-revert buffer))
 		buffer)
 	      (let ((buffer (new-buffer (pathname->buffer-name pathname))))
-		(visit-file buffer pathname)
+		(let ((error?
+		       (not
+			(catch-file-errors
+			 (lambda () false)
+			 (lambda () (read-buffer buffer pathname true))))))
+		  (if error?
+		      (do ((hooks
+			    (ref-variable find-file-not-found-hooks buffer)
+			    (cdr hooks)))
+			  ((or (null? hooks)
+			       ((car hooks) buffer)))))
+		  (after-find-file buffer error? warn?))
 		buffer))))))
 
-(define-variable find-file-run-dired
-  "True says run dired if find-file is given the name of a directory."
-  true
-  boolean?)
+(define (after-find-file buffer error? warn?)
+  (let ((pathname (or (buffer-truename buffer) (buffer-pathname buffer))))
+    (let ((buffer-read-only?
+	   (not (file-test-no-errors file-writable? pathname))))
+      (if buffer-read-only?
+	  (set-buffer-read-only! buffer)
+	  (set-buffer-writable! buffer))
+      (setup-buffer-auto-save! buffer)
+      (let ((serious-message
+	     (lambda (msg)
+	       (message msg)
+	       (sit-for 1))))
+	(cond ((not buffer-read-only?)
+	       (cond ((and warn?
+			   (file-newer-than-file?
+			    (buffer-auto-save-pathname buffer)
+			    pathname))
+		      (serious-message
+		       "Auto save file is newer; consider M-x recover-file"))
+		     (error?
+		      (message "(New file)"))))
+	      ((not error?)
+	       (message "File is write protected"))
+	      (else
+	       (serious-message
+		(if (file-test-no-errors file-exists? pathname)
+		    "File exists, but is read-protected."
+		    (string-append
+		     "File not found and directory "
+		     (let ((directory
+			    (directory-pathname-as-file
+			     (directory-pathname
+			      (buffer-pathname buffer)))))
+		       (if (file-test-no-errors file-exists? directory)
+			   "write-protected"
+			   "doesn't exist")))))))))
+    (normal-mode buffer true)
+    (event-distributor/invoke! (ref-variable find-file-hooks buffer))
+    (load-find-file-initialization buffer pathname)))
+
+(define (file-test-no-errors test pathname)
+  (catch-file-errors (lambda () false)
+		     (lambda () (test pathname))))
+
+(define (file-newer-than-file? a b)
+  (let ((a (file-modification-time-indirect a)))
+    (and a
+	 (let ((b (file-modification-time-indirect b)))
+	   (or (not b)
+	       (< a b))))))
+
+(define (load-find-file-initialization buffer pathname)
+  (let ((pathname
+	 (catch-file-errors
+	  (lambda () false)
+	  (lambda () (os/find-file-initialization-filename pathname)))))
+    (if pathname
+	(let ((database
+	       (with-output-to-transcript-buffer
+		(lambda ()
+		  (bind-condition-handler (list condition-type:error)
+		      evaluation-error-handler
+		    (lambda ()
+		      (catch-file-errors (lambda () false)
+			(lambda ()
+			  (fluid-let ((load/suppress-loading-message? true))
+			    (load pathname
+				  '(EDWIN)
+				  edwin-syntax-table))))))))))
+	  (if (and (procedure? database)
+		   (procedure-arity-valid? database 0))
+	      (add-buffer-initialization! buffer database)
+	      (message
+	       "Ill-formed find-file initialization file: "
+	       (os/pathname->display-string pathname)))))))
 
+(define (standard-scheme-find-file-initialization database)
+  ;; DATABASE -must- be a vector whose elements are all three element
+  ;; lists.  The car of each element must be a string, and the
+  ;; elements must be sorted on those strings.
+  (lambda ()
+    (let ((entry
+	   (let ((pathname (buffer-pathname (current-buffer))))
+	     (and pathname
+		  (equal? "scm" (pathname-type pathname))
+		  (let ((name (pathname-name pathname)))
+		    (and name
+			 (vector-binary-search database
+					       string<?
+					       car
+					       name)))))))
+      (if entry
+	  (begin
+	    (local-set-variable! scheme-environment (cadr entry))
+	    (local-set-variable! scheme-syntax-table (caddr entry))
+	    (local-set-variable! evaluate-in-inferior-repl false)
+	    (local-set-variable! run-light false))))))
+
 (define (find-file-revert buffer)
   (if (not (verify-visited-file-modification-time? buffer))
       (let ((pathname (buffer-pathname buffer)))
@@ -90,41 +248,6 @@
 		     "Read from disk")))
 	       (revert-buffer buffer true true))))))
 
-(define-command find-file
-  "Visit a file in its own buffer.
-If the file is already in some buffer, select that buffer.
-Otherwise, visit the file in a buffer named after the file."
-  "FFind file"
-  find-file)
-
-(define-command find-file-other-window
-  "Visit a file in another window.
-May create a window, or reuse one."
-  "FFind file in other window"
-  find-file-other-window)
-
-(define-command find-alternate-file
-  "Find file FILENAME, select its buffer, kill previous buffer.
-If the current buffer now contains an empty file that you just visited
-\(presumably by mistake), use this command to visit the file you really want."
-  "FFind alternate file"
-  (lambda (filename)
-    (let ((buffer (current-buffer)))
-      (let ((do-it
-	     (lambda ()
-	       (kill-buffer-interactive buffer)
-	       (find-file filename))))
-	(if (other-buffer buffer)
-	    (do-it)
-	    (let ((buffer* (new-buffer "*dummy*")))
-	      (do-it)
-	      (kill-buffer buffer*)))))))
-
-(define-command find-file-other-screen
-  "Visit a file in another screen."
-  "FFind file in other screen"
-  find-file-other-screen)
-
 (define-command revert-buffer
   "Replace the buffer text with the text of the visited file on disk.
 This undoes all changes since the file was visited or saved.
@@ -136,8 +259,7 @@ Argument means don't offer to use auto-save file."
     (revert-buffer (current-buffer) argument false)))
 
 (define (revert-buffer buffer dont-use-auto-save? dont-confirm?)
-  ((or (buffer-get buffer 'REVERT-BUFFER-METHOD)
-       revert-buffer-default)
+  ((or (buffer-get buffer 'REVERT-BUFFER-METHOD) revert-buffer-default)
    buffer dont-use-auto-save? dont-confirm?))
 
 (define (revert-buffer-default buffer dont-use-auto-save? dont-confirm?)
@@ -173,7 +295,8 @@ Argument means don't offer to use auto-save file."
 	     (let ((where (mark-index (buffer-point buffer)))
 		   (group (buffer-group buffer))
 		   (do-it
-		    (lambda () (visit-file buffer pathname (not auto-save?)))))
+		    (lambda ()
+		      (read-buffer buffer pathname (not auto-save?)))))
 	       (if (group-undo-data group)
 		   (begin
 		     ;; Throw away existing undo data.
@@ -183,111 +306,43 @@ Argument means don't offer to use auto-save file."
 		   (do-it))
 	       (set-buffer-point!
 		buffer
-		(make-mark (buffer-group buffer)
-			   (min where (buffer-length buffer))))))))))
+		(make-mark group (min where (buffer-length buffer))))
+	       (after-find-file buffer false false)))))))
 
-(define (visit-file buffer pathname #!optional visit?)
-  (after-find-file
-   buffer
-   (or (read-buffer-interactive buffer
-				pathname
-				(or (default-object? visit?) visit?))
-       pathname)))
-
-(define (read-buffer-interactive buffer pathname visit?)
-  (let ((truename
-	 (catch-file-errors (lambda () false)
-			    (lambda () (read-buffer buffer pathname visit?)))))
-    (define (finish msg)
-      (if msg
-	  (message msg))
-      truename)
-
-    (cond (truename
-	   (finish (and (not (file-writable? truename))
-			"File is write protected")))
-	  ((file-attributes pathname)
-	   (finish "File exists, but is read-protected."))
-	  (else
-	   (let loop ((hooks (if (not visit?)
-				 '()
-				 (ref-variable find-file-not-found-hooks buffer))))
-	     (if (null? hooks)
-		 (finish (cond ((file-writable? pathname)
-				"(New file)")
-			       ((file-attributes (directory-pathname pathname))
-				"File not found and directory write-protected")
-			       (else
-				"File not found and directory doesn't exist")))
-		 (and (not ((car hooks) buffer))
-		      (loop (cdr hooks)))))))))
-
-(define-variable find-file-not-found-hooks
-  "List of procedures to be called for find-file on nonexistent file.
-These functions are called as soon as the error is detected.
-The functions are called in the order given,
-until one of them returns non-false."
-  '()
-  list?)
-
-(define (after-find-file buffer pathname)
-  (if (file-writable? pathname)
-      (set-buffer-writable! buffer)
-      (set-buffer-read-only! buffer))
-  (setup-buffer-auto-save! buffer)
-  (normal-mode buffer true)
-  (event-distributor/invoke! (ref-variable find-file-hooks buffer))
-  (load-find-file-initialization buffer pathname))
-
-(define-variable find-file-hooks
-  "Event distributor to be invoked after a buffer is loaded from a file.
-The buffer's local variables (if any) will have been processed before the
-invocation."
-  (make-event-distributor))
-
-(define (load-find-file-initialization buffer pathname)
-  (let ((pathname (os/find-file-initialization-filename pathname)))
-    (if pathname
-	(let ((database
-	       (with-output-to-transcript-buffer
-		(lambda ()
-		  (bind-condition-handler (list condition-type:error)
-		      evaluation-error-handler
-		    (lambda ()
-		      (catch-file-errors (lambda () false)
-			(lambda ()
-			  (fluid-let ((load/suppress-loading-message? true))
-			    (load pathname
-				  '(EDWIN)
-				  edwin-syntax-table))))))))))
-	  (if (and (procedure? database)
-		   (procedure-arity-valid? database 0))
-	      (add-buffer-initialization! buffer database)
-	      (message
-	       "Ill-formed find-file initialization file: "
-	       (os/pathname->display-string pathname)))))))
-
-(define (standard-scheme-find-file-initialization database)
-  ;; DATABASE -must- be a vector whose elements are all three element
-  ;; lists.  The car of each element must be a string, and the
-  ;; elements must be sorted on those strings.
-  (lambda ()
-    (let ((entry
-	   (let ((pathname (buffer-pathname (current-buffer))))
-	     (and pathname
-		  (equal? "scm" (pathname-type pathname))
-		  (let ((name (pathname-name pathname)))
-		    (and name
-			 (vector-binary-search database
-					       string<?
-					       car
-					       name)))))))
-      (if entry
-	  (begin
-	    (local-set-variable! scheme-environment (cadr entry))
-	    (local-set-variable! scheme-syntax-table (caddr entry))
-	    (local-set-variable! evaluate-in-inferior-repl false)
-	    (local-set-variable! run-light false))))))
+(define-command recover-file
+  "Visit file FILE, but get contents from its last auto-save file."
+  "FRecover file"
+  (lambda (filename)
+    (let ((pathname (pathname-simplify (merge-pathnames filename))))
+      (let ((filename (->namestring pathname)))
+	(if (os/auto-save-filename? filename)
+	    (editor-error filename " is an auto-save file")))
+      (let ((auto-save-pathname (os/auto-save-pathname pathname false)))
+	(let ((auto-save-filename (->namestring auto-save-pathname)))
+	  (if (not (file-newer-than-file? auto-save-pathname pathname))
+	      (editor-error "Auto-save file "
+			    auto-save-filename
+			    " not current"))
+	  (if (not (call-with-temporary-buffer "*Directory*"
+		     (lambda (buffer)
+		       (read-directory pathname "-l" (buffer-end buffer))
+		       (read-directory auto-save-pathname
+				       "-l"
+				       (buffer-end buffer))
+		       (set-buffer-point! buffer (buffer-start buffer))
+		       (buffer-not-modified! buffer)
+		       (pop-up-buffer buffer false)
+		       (prompt-for-yes-or-no?
+			(string-append "Recover auto save file "
+				       auto-save-filename)))))
+	      (editor-error "Recover-file cancelled."))
+	  (let ((buffer (find-file-noselect pathname false)))
+	    (read-buffer buffer auto-save-pathname false)
+	    (after-find-file buffer false false)
+	    (disable-buffer-auto-save! buffer)
+	    (message
+	     "Auto-save off in this buffer till you do M-x auto-save-mode.")
+	    (select-buffer buffer)))))))
 
 (define-command save-buffer
   "Save current buffer in visited file if modified.  Versions described below.
diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm
index 78b28a74e..340516359 100644
--- a/v7/src/edwin/fileio.scm
+++ b/v7/src/edwin/fileio.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: fileio.scm,v 1.111 1992/11/13 22:54:37 cph Exp $
+;;;	$Id: fileio.scm,v 1.112 1992/11/15 21:58:51 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-1992 Massachusetts Institute of Technology
 ;;;
@@ -50,39 +50,48 @@
 
 (define (read-buffer buffer pathname visit?)
   (set-buffer-writable! buffer)
-  (let ((truename
-	 (catch-file-errors (lambda () false)
-			    (lambda () (->truename pathname)))))
-    (if truename
-	(begin
-	  ;; Set modified so that file supercession check isn't done.
-	  (set-group-modified! (buffer-group buffer) true)
-	  (region-delete! (buffer-unclipped-region buffer))
-	  (%insert-file (buffer-start buffer) truename visit?)
-	  (set-buffer-point! buffer (buffer-start buffer))))
+  (let ((truename false)
+	(file-error false))
+    ;; Set modified so that file supercession check isn't done.
+    (set-group-modified! (buffer-group buffer) true)
+    (region-delete! (buffer-unclipped-region buffer))
+    (call-with-current-continuation
+     (lambda (continuation)
+       (bind-condition-handler (list condition-type:file-error)
+	   (lambda (condition)
+	     (set! truename false)
+	     (set! file-error condition)
+	     (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)))))))))
+    (set-buffer-point! buffer (buffer-start buffer))
     (if visit?
 	(begin
-	  (if truename
-	      (set-buffer-modification-time!
-	       buffer
-	       (file-modification-time truename)))
 	  (set-buffer-pathname! buffer pathname)
 	  (set-buffer-truename! buffer truename)
 	  (set-buffer-save-length! buffer)
 	  (buffer-not-modified! buffer)
 	  (undo-done! (buffer-point buffer))))
+    (if file-error
+	(signal-condition file-error))
     truename))
 
 (define (insert-file mark filename)
   (%insert-file
    mark 
-   (bind-condition-handler
-    (list condition-type:file-error)
-    (lambda (condition)
-      condition
-      (editor-error "File " (->namestring filename) " not found"))
-    (lambda ()
-      (->truename filename)))
+   (bind-condition-handler (list condition-type:file-error)
+       (lambda (condition)
+	 condition
+	 (editor-error "File " (->namestring filename) " not found"))
+     (lambda ()
+       (->truename filename)))
    false))
 
 (define-variable read-file-message
diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm
index 7377fc2d8..c1d438d30 100644
--- a/v7/src/edwin/rmail.scm
+++ b/v7/src/edwin/rmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/rmail.scm,v 1.21 1992/11/12 19:36:15 bal Exp $
+;;;	$Id: rmail.scm,v 1.22 1992/11/15 21:59:17 cph Exp $
 ;;;
 ;;;	Copyright (c) 1991-92 Massachusetts Institute of Technology
 ;;;
@@ -331,8 +331,8 @@ but does not copy any new mail into the file."
 			      (<= n (msg-memo/number (msg-memo/last memo)))
 			      n))))))
 
-(define (rmail-after-find-file buffer pathname)
-  pathname
+(define (rmail-after-find-file buffer error? warn?)
+  error? warn?
   ;; No need to auto save RMAIL files.
   (disable-buffer-auto-save! buffer)
   (convert-buffer-to-babyl-format buffer)