From 4bb890ac09e237f20662b48735a2bae6212f9764 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 13 Nov 1992 22:54:37 +0000
Subject: [PATCH] Make backup-by-copying of symbolic link be dependent on a
 variable.

---
 v7/src/edwin/dos.scm    |  6 +++---
 v7/src/edwin/fileio.scm |  7 +++----
 v7/src/edwin/unix.scm   | 38 ++++++++++++++++++++++++++++++--------
 3 files changed, 36 insertions(+), 15 deletions(-)

diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm
index c1df0b91d..1dac18ba6 100644
--- a/v7/src/edwin/dos.scm
+++ b/v7/src/edwin/dos.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: dos.scm,v 1.4 1992/09/30 04:00:09 jinx Exp $
+;;;	$Id: dos.scm,v 1.5 1992/11/13 22:54:28 cph Exp $
 ;;;
 ;;;	Copyright (c) 1992 Massachusetts Institute of Technology
 ;;;
@@ -208,8 +208,8 @@ Includes the new backup.  Must be > 0."
 	  result)
 	filename)))
 
-(define (os/backup-by-copying? truename) 
-  truename
+(define (os/backup-by-copying? truename buffer) 
+  truename buffer
   false)
 	
 (define (os/buffer-backup-pathname truename)
diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm
index 5a1a817aa..78b28a74e 100644
--- a/v7/src/edwin/fileio.scm
+++ b/v7/src/edwin/fileio.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: fileio.scm,v 1.110 1992/11/12 18:00:30 cph Exp $
+;;;	$Id: fileio.scm,v 1.111 1992/11/13 22:54:37 cph Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-1992 Massachusetts Institute of Technology
 ;;;
@@ -377,7 +377,7 @@ backup-by-copying-when-mismatch ."
 (define-variable backup-by-copying
   "True means always use copying to create backup files.
 See documentation of variable  make-backup-files."
- false
+  false
   boolean?)
 
 (define-variable file-precious-flag
@@ -647,9 +647,8 @@ Otherwise, a message is written both before and after long file writes."
 			  false))
 		      (lambda ()
 			(if (or (ref-variable file-precious-flag buffer)
-				(file-symbolic-link? truename)
 				(ref-variable backup-by-copying buffer)
-				(os/backup-by-copying? truename))
+				(os/backup-by-copying? truename buffer))
 			    (begin
 			      (copy-file truename backup-pathname)
 			      false)
diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm
index 3b8f2da8c..48f72a0f3 100644
--- a/v7/src/edwin/unix.scm
+++ b/v7/src/edwin/unix.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: unix.scm,v 1.28 1992/10/30 00:33:08 arthur Exp $
+;;;	$Id: unix.scm,v 1.29 1992/11/13 22:54:18 cph Exp $
 ;;;
 ;;;	Copyright (c) 1989-1992 Massachusetts Institute of Technology
 ;;;
@@ -46,6 +46,13 @@
 
 (declare (usual-integrations))
 
+(define-variable backup-by-copying-when-symlink
+  "True means use copying to create backups for a symbolic name.
+This causes the actual names to refer to the latest version as edited.
+'QUERY means ask whether to backup by copying and write through, or rename.
+This variable is relevant only if  backup-by-copying  is false."
+  false)
+
 (define-variable backup-by-copying-when-linked
   "True means use copying to create backups for files with multiple names.
 This causes the alternate names to refer to the latest version as edited.
@@ -156,14 +163,29 @@ Includes the new backup.  Must be > 0."
 	  result)
 	filename)))
 
-(define (os/backup-by-copying? truename)
+(define (os/backup-by-copying? truename buffer)
   (let ((attributes (file-attributes truename)))
-    (and (ref-variable backup-by-copying-when-linked)
-	 (> (file-attributes/n-links attributes) 1))
-    (and (ref-variable backup-by-copying-when-mismatch)
-	 (not (and (= (file-attributes/uid attributes) (unix/current-uid))
-		   (= (file-attributes/gid attributes) (unix/current-gid)))))))
-
+    (or (and (ref-variable backup-by-copying-when-linked buffer)
+	     (> (file-attributes/n-links attributes) 1))
+	(let ((flag (ref-variable backup-by-copying-when-symlink buffer)))
+	  (and flag
+	       (string? (file-attributes/type attributes))
+	       (or (not (eq? flag 'QUERY))
+		   (prompt-for-confirmation?
+		    (string-append "Write through symlink to "
+				   (->namestring
+				    (enough-pathname
+				     (pathname-simplify
+				      (merge-pathnames
+				       (file-attributes/type attributes)
+				       (buffer-pathname buffer)))
+				     (buffer-default-directory buffer))))))))
+	(and (ref-variable backup-by-copying-when-mismatch buffer)
+	     (not (and (= (file-attributes/uid attributes)
+			  (unix/current-uid))
+		       (= (file-attributes/gid attributes)
+			  (unix/current-gid))))))))
+
 (define (os/buffer-backup-pathname truename)
   (with-values
       (lambda ()
-- 
2.25.1