- added "--force" option

scheme/install-lib/install-lib.scm

@@ -1,11 +1,10 @@
 ;;; Installation library for scsh modules.
-;;; $Id: install-lib.scm,v 1.8 2004/02/08 09:50:14 michel-schinz Exp $
+;;; $Id: install-lib.scm,v 1.9 2004/02/10 20:25:47 michel-schinz Exp $
 
 ;; TODO
 ;; - add support for communication between configure and pkg-def.scm
 ;; - add support for image creation,
 ;; - add support to maintain a documentation index,
-;; - maybe add a "--force" option to overwrite existing files
 
 ;;
 ;; Support code templates
@@ -93,11 +92,17 @@
         (path-list->file-name (append new-root-pl (cdr fname-pl)))
         (error "no root to replace in relative file name" fname))))
 
+;; If FILE exists, fail if --force was not given, delete it otherwise.
+(define (delete-file-or-fail file)
+  (if (file-exists? file)
+      (if (get-option-value 'force)
+          (-delete-file file)
+          (error "target file exists" file))))
+
 ;; Copy file/symlink SOURCE to TARGET. TARGET must be the name of a
 ;; non-existing file (i.e. it cannot be the name of a directory).
 (define (copy-file source target)
-  (if (file-exists? target)
-      (error "copy-file: target file exists" target))
+  (delete-file-or-fail target)
   (if (file-symlink? source)
       (create-symlink (read-symlink source) target)
       (begin
@@ -418,12 +423,14 @@
 ;; package's loading script (in the install directory). During a dry
 ;; run, or when only non-shared data has to be installed, do nothing.
 (define (with-output-to-load-script* thunk)
-  (let ((dir (get-directory 'base #t)))
+  (let* ((dir (get-directory 'base #t))
+         (file (absolute-file-name "load.scm" dir)))
     (create-directory&parents dir)
     (if (not (or (get-option-value 'dry-run)
                  (get-option-value 'non-shared-only)))
-        (with-output-to-file (absolute-file-name "load.scm" dir)
-          thunk))))
+        (begin
+          (delete-file-or-fail file)
+          (with-output-to-file file thunk)))))
 
 ;; Sugar for with-output-to-load-script*.
 (define-syntax with-output-to-load-script
@@ -511,10 +518,12 @@
                                      perms-fn))))
 
 (define (install-string% layout str target-name location target-rel-dir)
-  (let ((target-dir (absolute-file-name target-rel-dir
-                                        (layout-dir layout location))))
+  (let* ((target-dir (absolute-file-name target-rel-dir
+                                         (layout-dir layout location)))
+         (target-full-name (absolute-file-name target-name target-dir)))
     (create-directory&parents target-dir)
-    (call-with-output-file (absolute-file-name target-name target-dir)
+    (delete-file-or-fail target-full-name)
+    (call-with-output-file target-full-name
       (lambda (port) (write-string str port)))))
 
 (define (install-string str target-name location . rest)
@@ -568,6 +577,7 @@ options:
   --verbose            print messages about what is being done
   --inactive           don't activate package after installing it
   --non-shared-only    only install platform-dependent files, if any
+  --force              overwrite existing files during installation
 
 advanced options:
   --build <name>          name of platform for which to build
@@ -669,7 +679,8 @@ END
              (alist-boolean-updater 'non-shared-only))
      (option '("inactive") #f #f (alist-boolean-updater 'inactive))
      (option '("dry-run") #f #f (alist-boolean-updater 'dry-run))
-     (option '("verbose") #f #f (alist-boolean-updater 'verbose)))))
+     (option '("verbose") #f #f (alist-boolean-updater 'verbose))
+     (option '("force") #f #f (alist-boolean-updater 'force)))))
 
 (define options-defaults
   `((prefix          . #f)
@@ -680,7 +691,8 @@ END
     (non-shared-only . #f)
     (inactive        . #f)
     (dry-run         . #f)
-    (verbose         . #f)))
+    (verbose         . #f)
+    (force           . #f)))
 
 (define (parse-options args options defaults)
   (args-fold args