From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 24 Dec 1996 22:33:27 +0000 (+0000)
Subject: Modify BACKUP-BUFFER to chase through symbolic links so that the
X-Git-Tag: 20090517-FFI~5292
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0435ef5157ff62bec7c494f4d0aae844b042551d;p=mit-scheme.git

Modify BACKUP-BUFFER to chase through symbolic links so that the
backup operates on the file rather than the link.
---

diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm
index 1feaa669c..f0d09b920 100644
--- a/v7/src/edwin/fileio.scm
+++ b/v7/src/edwin/fileio.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: fileio.scm,v 1.138 1996/05/15 19:10:52 cph Exp $
+;;;	$Id: fileio.scm,v 1.139 1996/12/24 22:33:27 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-96 Massachusetts Institute of Technology
 ;;;
@@ -690,39 +690,50 @@ Otherwise, a message is written both before and after long file writes."
        truename
        (file-exists? truename)
        (os/backup-buffer? truename)
-       (catch-file-errors
-	(lambda () false)
-	(lambda ()
-	  (with-values (lambda () (os/buffer-backup-pathname truename buffer))
-	    (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 filename)
-			  false))
-		      (lambda ()
-			(if (or (ref-variable file-precious-flag buffer)
-				(ref-variable backup-by-copying buffer)
-				(os/backup-by-copying? truename buffer))
-			    (begin
-			      (copy-file truename backup-pathname)
-			      false)
-			    (begin
-			      (delete-file-no-errors backup-pathname)
-			      (rename-file truename backup-pathname)
-			      (file-modes backup-pathname)))))))
-		(set-buffer-backed-up?!
-		 buffer
-		 (not (memv backup-mode '(BACKUP-NEXT BACKUP-BOTH))))
-		(if (and (not (null? targets))
-			 (or (ref-variable trim-versions-without-asking buffer)
-			     (prompt-for-confirmation?
-			      (string-append
-			       "Delete excess backup versions of "
-			       (->namestring (buffer-pathname buffer))))))
-		    (for-each delete-file-no-errors targets))
-		modes)))))))
\ No newline at end of file
+       (let ((truename (file-chase-links truename)))
+	 (catch-file-errors
+	  (lambda () false)
+	  (lambda ()
+	    (call-with-values
+		(lambda () (os/buffer-backup-pathname truename buffer))
+	      (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 filename)
+			    false))
+			(lambda ()
+			  (if (or (ref-variable file-precious-flag buffer)
+				  (ref-variable backup-by-copying buffer)
+				  (os/backup-by-copying? truename buffer))
+			      (begin
+				(copy-file truename backup-pathname)
+				false)
+			      (begin
+				(delete-file-no-errors backup-pathname)
+				(rename-file truename backup-pathname)
+				(file-modes backup-pathname)))))))
+		  (set-buffer-backed-up?!
+		   buffer
+		   (not (memv backup-mode '(BACKUP-NEXT BACKUP-BOTH))))
+		  (if (and (not (null? targets))
+			   (or (ref-variable trim-versions-without-asking
+					     buffer)
+			       (prompt-for-confirmation?
+				(string-append
+				 "Delete excess backup versions of "
+				 (->namestring (buffer-pathname buffer))))))
+		      (for-each delete-file-no-errors targets))
+		  modes))))))))
+
+(define (file-chase-links pathname)
+  (let ((contents (file-symbolic-link? pathname)))
+    (if contents
+	(file-chase-links
+	 (pathname-simplify
+	  (merge-pathnames contents (directory-pathname pathname))))
+	pathname)))
\ No newline at end of file