From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 21 Jul 1997 04:38:48 +0000 (+0000)
Subject: Fix bug in AFTER-FIND-FILE: code was assuming that every buffer had an
X-Git-Tag: 20090517-FFI~5036
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7ee716c10aeef24e952a06ebb5564e6ebdbda8c9;p=mit-scheme.git

Fix bug in AFTER-FIND-FILE: code was assuming that every buffer had an
AUTO-SAVE-PATHNAME.

Add new commands to encrypt and decrypt files using blowfish.
---

diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm
index 64a25496e..fcf486807 100644
--- a/v7/src/edwin/filcom.scm
+++ b/v7/src/edwin/filcom.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: filcom.scm,v 1.189 1997/01/03 04:06:46 cph Exp $
+;;;	$Id: filcom.scm,v 1.190 1997/07/21 04:38:48 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-97 Massachusetts Institute of Technology
 ;;;
@@ -158,9 +158,9 @@ invocation."
 	       (sit-for 1))))
 	(cond ((not buffer-read-only?)
 	       (cond ((and warn?
-			   (file-newer-than-file?
-			    (buffer-auto-save-pathname buffer)
-			    pathname))
+			   (let ((asp (buffer-auto-save-pathname buffer)))
+			     (and asp
+				  (file-newer-than-file? asp pathname))))
 		      (serious-message
 		       "Auto save file is newer; consider M-x recover-file"))
 		     (error?
@@ -183,7 +183,7 @@ invocation."
     (normal-mode buffer true)
     (event-distributor/invoke! (ref-variable find-file-hooks buffer) buffer)
     (load-find-file-initialization buffer pathname)))
-
+
 (define (file-test-no-errors test pathname)
   (catch-file-errors (lambda () false)
 		     (lambda () (test pathname))))
@@ -194,7 +194,7 @@ invocation."
 	 (let ((b (file-modification-time-indirect b)))
 	   (or (not b)
 	       (> a b))))))
-
+
 (define (load-find-file-initialization buffer pathname)
   (let ((pathname
 	 (catch-file-errors
@@ -552,9 +552,9 @@ If a file with the new name already exists, confirmation is requested first."
 	     (string-append "File "
 			    (->namestring new)
 			    " already exists; copy anyway")))
-	(begin (copy-file old new)
-	       (message "Copied " (->namestring old)
-			" => " (->namestring new))))))
+	(begin
+	  (copy-file old new)
+	  (message "Copied " (->namestring old) " => " (->namestring new))))))
 
 (define-command rename-file
   "Rename a file; the old and new names are read in the typein window.
@@ -608,6 +608,47 @@ If a file with the new name already exists, confirmation is requested first."
 			": Permission denied"))
       (set-buffer-default-directory! buffer directory))))
 
+(define-command encrypt-file
+  "Encrypt a file with the blowfish encryption algorithm.
+Prompts for a filename; the encrypted file is written with a \".bf\" suffix.
+Deletes the plaintext file after encryption."
+  "fEncrypt File"
+  (lambda (filename)
+    (if (not (blowfish-available?))
+	(editor-error "Blowfish encryption not supported on this system"))
+    (if (equal? "bf" (pathname-type filename))
+	(editor-error (->namestring filename) " is already encrypted"))
+    (if (copy-file-through-buffer filename
+				  (string-append (->namestring filename)
+						 ".bf"))
+	(delete-file filename))))
+
+(define-command decrypt-file
+  "Decrypt a file with the blowfish encryption algorithm.
+Prompts for a filename, which must end with a \".bf\" suffix."
+  "fDecrypt File"
+  (lambda (filename)
+    (if (not (blowfish-available?))
+	(editor-error "Blowfish encryption not supported on this system"))
+    (if (not (equal? "bf" (pathname-type filename)))
+	(editor-error (->namestring filename) " does not have \".bf\" suffix"))
+    (copy-file-through-buffer filename (pathname-new-type filename #f))))
+
+(define (copy-file-through-buffer input output)
+  (if (or (not (file-exists? output))
+	  (prompt-for-yes-or-no?
+	   (string-append "File "
+			  (->namestring output)
+			  " already exists; overwrite")))
+      (begin
+	(call-with-temporary-buffer " *copy-file*"
+	  (lambda (buffer)
+	    (local-set-variable! translate-file-data-on-input #f buffer)
+	    (insert-file (buffer-start buffer) input)
+	    (write-region (buffer-region buffer) output #t #f)))
+	#t)
+      #f))
+
 ;;;; Prompting
 
 (define (prompt-for-file prompt default)
@@ -728,7 +769,7 @@ If a file with the new name already exists, confirmation is requested first."
 	     (if (null? filenames)
 		 (if-not-found)
 		 (loop directory filenames)))))))
-
+
 (define (filename-completions-list pathname)
   (let ((directory (directory-namestring pathname)))
     (canonicalize-filename-completions