From: Chris Hanson Date: Wed, 5 Apr 1989 18:19:54 +0000 (+0000) Subject: Change `find-file', `read-buffer', and related procedures to separate X-Git-Tag: 20090517-FFI~12195 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=42ec8b8e19f81fd0740ea6e54fe4062c36df31ab;p=mit-scheme.git 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 26939fa26..752aa9b19 100644 --- 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))))) -(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)))))))) (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 14477462b..6480de854 100644 --- 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