diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm index f0d0da1..d0e9cac 100755 --- a/scheme/install-lib/install-lib.scm +++ b/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 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