Change `find-file', `read-buffer', and related procedures to separate

out certain functionality in new procedure `after-find-file'.  This
new procedure sets the read-only bit, puts up any special messages
regarding the read/write status of the file, and does mode
initialization.  In addition, `find-file' now catches file errors and
recovers from them in a reasonably graceful way.

diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm
index 26939fa266a87ada6f1406573c5c5f862b592ff0..752aa9b197fe5416ed31e4ddd214058ddfa66e80 100644 (file)
--- a/v7/src/edwin/filcom.scm
+++ b/v7/src/edwin/filcom.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.131 1989/03/15 19:13:05 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.132 1989/04/05 18:19:16 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -79,22 +79,43 @@ Like \\[Kill Buffer] followed by \\[Find File]."
            (kill-buffer buffer*))
          (kernel)))))
 \f
-(define ((file-finder select-buffer) pathname)
-  (let ((buffer (pathname->buffer pathname)))
-    (if buffer
-       (select-buffer buffer)
-       (let ((buffer (new-buffer (pathname->buffer-name pathname))))
-         (read-buffer buffer pathname)
-         (select-buffer buffer)))))
-
-(define find-file
-  (file-finder select-buffer))
+(define (find-file pathname)
+  (select-buffer (find-file-noselect pathname)))
 
-(define find-file-other-window
-  (file-finder select-buffer-other-window))
+(define (find-file-other-window pathname)
+  (select-buffer-other-window (find-file-noselect pathname)))
 
-(define find-file-noselect
-  (file-finder identity-procedure))
+(define (find-file-noselect pathname)
+  (let ((buffer (pathname->buffer pathname)))
+    (or buffer
+       (let ((buffer (new-buffer (pathname->buffer-name pathname))))
+         (after-find-file
+          buffer
+          (catch-file-errors (lambda () true)
+                             (lambda () (not (read-buffer buffer pathname)))))
+         buffer))))
+
+(define (after-find-file buffer error?)
+  (let ((pathname (or (buffer-truename buffer) (buffer-pathname buffer))))
+    (if (or (not pathname) (file-writable? pathname))
+       (set-buffer-writeable! buffer)
+       (set-buffer-read-only! buffer)))
+  (let ((msg
+        (cond ((not (buffer-read-only? buffer))
+               (and error? "(New file)"))
+              ((not error?)
+               "File is write protected")
+              ((file-attributes (buffer-pathname buffer))
+               "File exists, but is read-protected.")
+              ((file-attributes
+                (pathname-directory-path (buffer-pathname buffer)))
+               "File not found and directory write-protected")
+              (else
+               "File not found and directory doesn't exist"))))
+    (if msg
+       (message msg)))
+  (setup-buffer-auto-save! buffer)
+  (initialize-buffer! buffer))
 
 (define (pathname->buffer pathname)
   (or (list-search-positive (buffer-list)
@@ -207,11 +228,12 @@ The next time the buffer is saved it will go in the newly specified file. "
   (set-buffer-pathname! buffer pathname)
   (set-buffer-truename! buffer false)
   (if pathname
-      (begin (let ((name (pathname->buffer-name pathname)))
-              (if (not (find-buffer name))
-                  (rename-buffer buffer name)))
-            (setup-buffer-auto-save! buffer)
-            (buffer-modified! buffer))
+      (begin
+       (let ((name (pathname->buffer-name pathname)))
+        (if (not (find-buffer name))
+            (rename-buffer buffer name)))
+       (setup-buffer-auto-save! buffer)
+       (buffer-modified! buffer))
       (disable-buffer-auto-save! buffer)))
 
 (define-command ("Write File")
@@ -268,7 +290,8 @@ Leaves point at the beginning, mark at the end."
                 (let ((where (mark-index (buffer-point buffer))))
                   (read-buffer buffer pathname)
                   (set-current-point!
-                   (mark+ (buffer-start buffer) where 'LIMIT)))))))))
+                   (mark+ (buffer-start buffer) where 'LIMIT))
+                  (after-find-file buffer false))))))))
 \f
 (define-command ("Copy File")
   "Copy a file; the old and new names are read in the typein window.

diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm
index 14477462b4fea11918de086ad7a4ce7a2f6a4e54..6480de854eb4409d96308f7b9912c4c526409721 100644 (file)
--- a/v7/src/edwin/fileio.scm
+++ b/v7/src/edwin/fileio.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.87 1989/03/15 19:14:13 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.88 1989/04/05 18:19:54 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989 Massachusetts Institute of Technology
 ;;;
@@ -44,6 +44,8 @@
 ;;;; Input
 
 (define (read-buffer buffer pathname)
+  (set-buffer-writeable! buffer)
+  (set-buffer-pathname! buffer pathname)
   (let ((truename (pathname->input-truename pathname)))
     (if truename
        (begin
@@ -52,18 +54,12 @@
           (region-insert! (buffer-start buffer) region))
         (set-buffer-point! buffer (buffer-start buffer))
         (set-buffer-modification-time! buffer
-                                       (file-modification-time truename))
-        (if (file-writable? truename)
-            (set-buffer-writeable! buffer)
-            (set-buffer-read-only! buffer)))
-       (temporary-message "(New File)"))
+                                       (file-modification-time truename))))
     (set-buffer-truename! buffer truename))
-  (set-buffer-pathname! buffer pathname)
-  (setup-buffer-auto-save! buffer)
   (set-buffer-save-length! buffer)
   (buffer-not-modified! buffer)
   (undo-done! (buffer-point buffer))
-  (initialize-buffer! buffer))
+  (buffer-truename buffer))
 
 (define (initialize-buffer! buffer)
   (initialize-buffer-modes! buffer)
@@ -372,56 +368,63 @@ Otherwise asks confirmation."
                  (insert-newline end))))))))
 
 (define (backup-buffer! buffer truename)
-  (let (;; This isn't the correct set of types, but it will do for now.
-       (error-types (list (microcode-error-type 'EXTERNAL-RETURN)))
-       (continue-with-false
-        (lambda (condition) ((condition/continuation condition) false))))
+  (let ((continue-with-false (lambda () false)))
     (and truename
         (ref-variable "Make Backup Files")
         (not (buffer-backed-up? buffer))
         (file-exists? truename)
         (os/backup-buffer? truename)
-        (bind-condition-handler error-types continue-with-false
-          (lambda ()
-            (with-values (lambda () (os/buffer-backup-pathname truename))
-              (lambda (backup-pathname targets)
-                (let ((modes
-                       (bind-condition-handler error-types
-                           (lambda (condition)
-                             (let ((filename (os/default-backup-filename)))
-                               (temporary-message
-                                "Cannot write backup file; backing up in \""
-                                filename
-                                "\"")
-                               (copy-file truename
-                                          (string->pathname filename))
-                               (continue-with-false condition)))
-                         (lambda ()
-                           (if (or (file-symbolic-link? truename)
-                                   (ref-variable "Backup By Copying")
-                                   (os/backup-by-copying? truename))
-                               (begin
-                                 (copy-file truename backup-pathname)
-                                 false)
-                               (begin
-                                 (bind-condition-handler error-types
-                                     continue-with-false
-                                   (lambda ()
-                                     (delete-file backup-pathname)))
-                                 (rename-file truename backup-pathname)
-                                 (file-modes backup-pathname)))))))
-                  (set-buffer-backed-up?! buffer true)
-                  (if (and (not (null? targets))
-                           (or (ref-variable "Trim Versions Without Asking")
-                               (prompt-for-confirmation?
-                                (string-append
-                                 "Delete excess backup versions of "
-                                 (pathname->string
-                                  (buffer-pathname buffer))))))
-                      (for-each (lambda (target)
-                                  (bind-condition-handler error-types
-                                      continue-with-false
-                                    (lambda ()
-                                      (delete-file target))))
-                                targets))
-                  modes))))))))
\ No newline at end of file
+        (catch-file-errors
+         continue-with-false
+         (lambda ()
+           (with-values (lambda () (os/buffer-backup-pathname truename))
+             (lambda (backup-pathname targets)
+               (let ((modes
+                      (catch-file-errors
+                       (lambda ()
+                         (let ((filename (os/default-backup-filename)))
+                           (temporary-message
+                            "Cannot write backup file; backing up in \""
+                            filename
+                            "\"")
+                           (copy-file truename
+                                      (string->pathname filename))
+                           false))
+                       (lambda ()
+                         (if (or (file-symbolic-link? truename)
+                                 (ref-variable "Backup By Copying")
+                                 (os/backup-by-copying? truename))
+                             (begin
+                               (copy-file truename backup-pathname)
+                               false)
+                             (begin
+                               (catch-file-errors
+                                (lambda () false)
+                                (lambda ()
+                                  (delete-file backup-pathname)))
+                               (rename-file truename backup-pathname)
+                               (file-modes backup-pathname)))))))
+                 (set-buffer-backed-up?! buffer true)
+                 (if (and (not (null? targets))
+                          (or (ref-variable "Trim Versions Without Asking")
+                              (prompt-for-confirmation?
+                               (string-append
+                                "Delete excess backup versions of "
+                                (pathname->string
+                                 (buffer-pathname buffer))))))
+                     (for-each (lambda (target)
+                                 (catch-file-errors continue-with-false
+                                                    (lambda ()
+                                                      (delete-file target))))
+                               targets))
+                 modes))))))))
+
+(define (catch-file-errors if-error thunk)
+  (call-with-current-continuation
+   (lambda (continuation)
+     (bind-condition-handler
+        (list error-type:file)
+        (lambda (condition)
+          condition
+          (continuation (if-error)))
+       thunk))))
\ No newline at end of file