scsh-conservatory
/
scsh-install-lib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- added "--force" option

This commit is contained in:
michel-schinz 2004-02-10 20:25:47 +00:00
parent 9c2e376bf7
commit 87f1a912ff
1 changed files with 24 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
scheme/install-lib/install-lib.scm
View File

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