diff --git a/scheme/install-lib/install-lib-module.scm b/scheme/install-lib/install-lib-module.scm index d2d9bf5..b760f0f 100644 --- a/scheme/install-lib/install-lib-module.scm +++ b/scheme/install-lib/install-lib-module.scm @@ -1,5 +1,5 @@ ;;; Installation library for scsh modules. -;;; $Id: install-lib-module.scm,v 1.6 2004/02/08 09:50:47 michel-schinz Exp $ +;;; $Id: install-lib-module.scm,v 1.7 2004/02/19 07:29:16 michel-schinz Exp $ ;;; Interfaces @@ -21,6 +21,7 @@ install-directories install-directory-contents install-string + install-sub-package identity parse-boolean @@ -38,6 +39,7 @@ (define-structure install install-interface (open scheme-with-scsh + cells fluids let-opt srfi-1 diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm index d0e9cac..c10515b 100755 --- a/scheme/install-lib/install-lib.scm +++ b/scheme/install-lib/install-lib.scm @@ -1,10 +1,11 @@ ;;; Installation library for scsh modules. -;;; $Id: install-lib.scm,v 1.9 2004/02/10 20:25:47 michel-schinz Exp $ +;;; $Id: install-lib.scm,v 1.10 2004/02/19 07:29:16 michel-schinz Exp $ ;; TODO +;; - add a "--debug" option ;; - add support for communication between configure and pkg-def.scm -;; - add support for image creation, -;; - add support to maintain a documentation index, +;; - add support for image creation +;; - add support to maintain a documentation index ;; ;; Support code templates @@ -330,11 +331,12 @@ (alist-get ext (package-extensions pkg) #f)) ;; List of all defined packages -(define packages '()) +(define *packages* (make-fluid #f)) ;; Add PKG to the above list of all defined packages. (define (add-package pkg) - (set! packages (cons pkg packages))) + (cell-set! (fluid *packages*) + (cons pkg (cell-ref (fluid *packages*))))) (define-syntax define-package (syntax-rules () @@ -344,6 +346,14 @@ (quasiquote extensions) (lambda () body ...)))))) +;; Load (and evaluate the contents of) the FILE and return the list of +;; packages it defines. +(define (load-packages file) + (let-fluid *packages* (make-cell '()) + (lambda () + (load-quietly file) + (cell-ref (fluid *packages*))))) + ;; ;; Package options ;; @@ -554,6 +564,48 @@ *install-layout* install-layout (package-install-thunk pkg))) +;; Install all PACKAGES with the given OPTIONS-VALUES. +(define (install-packages packages options-values) + (let* ((prefix (alist-get 'prefix options-values)) + (dest-dir (alist-get 'dest-dir options-values)) + (dest-prefix (and prefix (re-root-file-name prefix dest-dir))) + (layout-fn (alist-get 'layout options-values)) + (layout-to (alist-get 'layout-to options-values)) + (build (alist-get 'build options-values)) + (non-shared-only? (alist-get 'non-shared-only options-values)) + (activate? (not (alist-get 'inactive options-values)))) + (let-fluids *options-values* options-values + (lambda () + (for-each + (lambda (pkg) + (let* ((rel-layout (layout-fn build pkg)) + (layout (absolute-layout rel-layout prefix)) + (i-layout (absolute-layout rel-layout dest-prefix))) + (if layout-to + (call-with-output-file + (string-append layout-to "_" (package-full-name pkg)) + (lambda (port) + (write rel-layout port) (newline port)))) + (install-package layout i-layout pkg) + (if (and activate? (not non-shared-only?)) + (activate-package i-layout pkg)))) + packages))))) + +(define (install-sub-package dir . rest) + (let-optionals rest ((options-diff '())) + (with-cwd dir + (install-packages + (load-packages package-definition-file) + (fold (lambda (diff options) + (cond ((pair? diff) + (cons diff (alist-delete (car diff) options))) + ((symbol? diff) + (alist-delete diff options)) + (else + (error "invalid option difference" diff)))) + (fluid *options-values*) + options-diff))))) + ;; ;; Error handling ;; @@ -708,39 +760,17 @@ END (if (not (file-exists? package-definition-file)) (display-error-and-exit "cannot find package definition file (~a)" package-definition-file)) - (load-quietly package-definition-file) - (let ((all-pkg-opts (all-package-options packages))) + (let* ((packages (load-packages package-definition-file)) + (all-pkg-opts (all-package-options packages))) (if (not (null? all-pkg-opts)) (complete-usage! all-pkg-opts)) (let* ((all-opts (append options (map pkg-opt->option all-pkg-opts))) (all-dfts (append options-defaults (map pkg-opt-key&default all-pkg-opts))) (options-values (parse-options (cdr cmd-line) all-opts all-dfts)) - (prefix (alist-get 'prefix options-values)) - (dest-dir (alist-get 'dest-dir options-values)) - (dest-prefix (and prefix (re-root-file-name prefix dest-dir))) - (layout-fn (alist-get 'layout options-values)) - (layout-to (alist-get 'layout-to options-values)) - (build (alist-get 'build options-values)) - (non-shared-only? (alist-get 'non-shared-only options-values)) - (activate? (not (alist-get 'inactive options-values)))) + (prefix (alist-get 'prefix options-values))) (if (not prefix) (display-error-and-exit "no prefix specified (use --prefix option)")) (if (not (file-name-absolute? prefix)) (display-error-and-exit "prefix must be an absolute path")) - (let-fluids *options-values* options-values - (lambda () - (for-each - (lambda (pkg) - (let* ((rel-layout (layout-fn build pkg)) - (layout (absolute-layout rel-layout prefix)) - (i-layout (absolute-layout rel-layout dest-prefix))) - (if layout-to - (call-with-output-file - (string-append layout-to "_" (package-full-name pkg)) - (lambda (port) - (write rel-layout port) (newline port)))) - (install-package layout i-layout pkg) - (if (and activate? (not non-shared-only?)) - (activate-package i-layout pkg)))) - packages)))))) + (install-packages packages options-values))))