Make backup-by-copying of symbolic link be dependent on a variable.

diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm
index c1df0b91dc03cc1ab359a4a0ac9c00e7f891cb89..1dac18ba6bcc45bc6ab5529ea2ba1309dfa61b25 100644 (file)
--- 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)))
 \f
-(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 5a1a817aa0114eec119ec9460d57e52e26b909a5..78b28a74e6be845b0a4bf80c7716397edc31814c 100644 (file)
--- 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 3b8f2da8cdac9573ff92af5e8aea804d39f157a4..48f72a0f3dc07384936be82e94dc810273ac57d8 100644 (file)
--- 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))
 \f
+(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)))
 \f
-(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))))))))
+\f
 (define (os/buffer-backup-pathname truename)
   (with-values
       (lambda ()