- added "install-sub-package" function

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

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 for image creation
-;; - add support to maintain a documentation index,
+;; - 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* ((packages (load-packages package-definition-file))
-  (let ((all-pkg-opts (all-package-options packages)))
+         (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))
+           (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))))
       (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
+      (install-packages packages 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))))))