From cef7a9016883f25a6e7a1452dad2a7f77cf75319 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 26 Apr 1989 18:50:31 +0000 Subject: [PATCH] Change `find-file' and friends to check file-modification-time when a buffer already exists for that file, and offer to revert the buffer if the time is not consistent. --- v7/src/edwin/filcom.scm | 45 +++++++++++++++++++++++++++-------------- v7/src/edwin/fileio.scm | 29 +++++++++++--------------- v7/src/edwin/make.scm | 4 ++-- v7/src/edwin/tagutl.scm | 8 ++++---- 4 files changed, 48 insertions(+), 38 deletions(-) diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index 678601c22..ad68aa19c 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.134 1989/04/20 08:14:57 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.135 1989/04/26 18:49:35 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -42,17 +42,32 @@ (declare (usual-integrations)) (define (find-file filename) - (select-buffer (find-file-noselect filename))) + (select-buffer (find-file-noselect filename true))) (define (find-file-other-window filename) - (select-buffer-other-window (find-file-noselect filename))) + (select-buffer-other-window (find-file-noselect filename true))) -(define (find-file-noselect filename) +(define (find-file-noselect filename warn?) (let ((pathname (pathname->absolute-pathname (->pathname filename)))) (if (file-directory? pathname) (make-dired-buffer (pathname-as-directory pathname)) (let ((buffer (pathname->buffer pathname))) - (or buffer + (if buffer + (begin + (if (and warn? + (not (verify-visited-file-modification-time? buffer))) + (cond ((not (file-exists? pathname)) + (editor-error "File " + (pathname->string pathname) + " no longer exists!")) + ((prompt-for-yes-or-no? + (string-append + "File has changed since last visited or saved. " + (if (buffer-modified? buffer) + "Flush your changes" + "Read from disk"))) + (revert-buffer buffer true true)))) + buffer) (let ((buffer (new-buffer (pathname->buffer-name pathname)))) (after-find-file buffer @@ -152,9 +167,9 @@ Like \\[kill-buffer] followed by \\[find-file]." (save-buffer-prepare-version buffer) (set-visited-pathname buffer (prompt-for-pathname - (string-append "Write buffer '" + (string-append "Write buffer " (buffer-name buffer) - "' to file") + " to file") false))) (if (memv exponent '(2 3)) (set-buffer-backed-up?! buffer false)) (write-buffer-interactive buffer) @@ -326,12 +341,12 @@ If a file with the new name already exists, confirmation is requested first." (lambda (old new) (if (or (not (file-exists? new)) (prompt-for-yes-or-no? - (string-append "File '" + (string-append "File " (pathname->string new) - "' already exists; copy anyway"))) + " already exists; copy anyway"))) (begin (copy-file old new) - (message "Copied '" (pathname->string old) - "' => '" (pathname->string new) "'"))))) + (message "Copied " (pathname->string old) + " => " (pathname->string new)))))) (define-command rename-file "Rename a file; the old and new names are read in the typein window. @@ -345,13 +360,13 @@ If a file with the new name already exists, confirmation is requested first." (let ((do-it (lambda () (rename-file old new) - (message "Renamed '" (pathname->string old) - "' => '" (pathname->string new) "'")))) + (message "Renamed " (pathname->string old) + " => " (pathname->string new))))) (if (file-exists? new) (if (prompt-for-yes-or-no? - (string-append "File '" + (string-append "File " (pathname->string new) - "' already exists; rename anyway")) + " already exists; rename anyway")) (begin (delete-file new) (do-it))) (do-it))))) diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm index 41079b9d3..23147a8b2 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.89 1989/04/15 00:49:27 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.90 1989/04/26 18:49:53 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -289,18 +289,17 @@ Otherwise asks confirmation." false) (define (write-buffer-interactive buffer) - ;; Need to check for correct modification time here. (let ((truename (pathname->output-truename (buffer-pathname buffer)))) (let ((writable? (file-writable? truename))) (if (or writable? (prompt-for-yes-or-no? - (string-append "File \"" + (string-append "File " (pathname-name-string truename) - "\" is write-protected; try to save anyway")) + " is write-protected; try to save anyway")) (editor-error "Attempt to save to a file which you aren't allowed to write")) (begin - (if (not (or (verify-visited-file-modification-time buffer) + (if (not (or (verify-visited-file-modification-time? buffer) (not (file-exists? truename)) (prompt-for-yes-or-no? "Disk file has changed since visited or saved. Save anyway"))) @@ -323,17 +322,14 @@ Otherwise asks confirmation." (lambda () (set-file-modes! truename modes)))))))))) -(define (verify-visited-file-modification-time buffer) +(define (verify-visited-file-modification-time? buffer) (let ((truename (buffer-truename buffer)) - (modification-time (buffer-modification-time buffer))) + (buffer-time (buffer-modification-time buffer))) (or (not truename) - (not modification-time) - (let ((new-time (file-modification-time truename))) - (and new-time - (or (= modification-time new-time) - (and (positive? modification-time) - (positive? new-time) - (= 1 (abs (- modification-time new-time)))))))))) + (not buffer-time) + (let ((file-time (file-modification-time truename))) + (and file-time + (< (abs (- buffer-time file-time)) 2)))))) (define (write-buffer buffer) (let ((truename @@ -393,9 +389,8 @@ Otherwise asks confirmation." (lambda () (let ((filename (os/default-backup-filename))) (temporary-message - "Cannot write backup file; backing up in \"" - filename - "\"") + "Cannot write backup file; backing up in " + filename) (copy-file truename (string->pathname filename)) false)) diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index bd52e47ff..0982f34ab 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.7 1989/04/25 02:08:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.8 1989/04/26 18:50:31 cph Exp $ Copyright (c) 1989 Massachusetts Institute of Technology @@ -37,4 +37,4 @@ MIT in each case. |# (declare (usual-integrations)) (package/system-loader "edwin" '() 'QUERY) -(add-system! (make-system "Edwin" 3 7 '())) \ No newline at end of file +(add-system! (make-system "Edwin" 3 8 '())) \ No newline at end of file diff --git a/v7/src/edwin/tagutl.scm b/v7/src/edwin/tagutl.scm index 4e133809b..2d8697bb3 100644 --- a/v7/src/edwin/tagutl.scm +++ b/v7/src/edwin/tagutl.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tagutl.scm,v 1.32 1989/04/15 00:53:18 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/tagutl.scm,v 1.33 1989/04/26 18:50:06 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology ;;; @@ -248,11 +248,11 @@ See documentation of variable tags-file-name." (if (not (ref-variable tags-table-pathname)) (dispatch-on-command (ref-command-object visit-tags-table))) (let ((pathname (ref-variable tags-table-pathname))) - (let ((buffer (find-file-noselect pathname))) - (if (and (not (verify-visited-file-modification-time buffer)) + (let ((buffer (find-file-noselect pathname false))) + (if (and (not (verify-visited-file-modification-time? buffer)) (prompt-for-yes-or-no? "Tags file has changed, read new contents")) - (revert-buffer true true)) + (revert-buffer buffer true true)) (if (not (eqv? (extract-right-char (buffer-start buffer)) #\Page)) (editor-error "File " (pathname->string pathname) -- 2.25.1