Incorporated changes by David Frese:

- added support for optional parts
- added is-running-dry? function

scheme/install-lib/install-lib-module.scm

@@ -1,5 +1,5 @@
 ;;; Installation library for scsh modules.
-;;; $Id: install-lib-module.scm,v 1.1 2003/12/14 12:23:36 michel-schinz Exp $
+;;; $Id: install-lib-module.scm,v 1.2 2003/12/14 12:33:59 michel-schinz Exp $
 
 ;;; Interfaces
 
@@ -26,6 +26,8 @@
 
           package-installation-dir
           package-installation-staging-dir
+          with-optional-part?
+          is-running-dry?
 
           install-main))
 

scheme/install-lib/install-lib.scm

@@ -1,5 +1,5 @@
 ;;; Installation library for scsh modules.
-;;; $Id: install-lib.scm,v 1.1 2003/12/14 12:23:36 michel-schinz Exp $
+;;; $Id: install-lib.scm,v 1.2 2003/12/14 12:33:59 michel-schinz Exp $
 
 ;; TODO
 ;; - copy symbolic links as such, do not duplicate contents,
@@ -147,10 +147,11 @@
 ;;
 
 (define-record-type package
-  (make-package name version install-thunk)
+  (make-package name version extensions install-thunk)
   package?
   (name package:name)
   (version package:version)
+  (extensions package:extensions)
   (install-thunk package:install-thunk))
 
 ;; List of all defined packages
@@ -162,9 +163,10 @@
 
 (define-syntax define-package
   (syntax-rules ()
-    ((define-package name version body ...)
+    ((define-package name version extensions body ...)
      (add-package (make-package name
                                 (quote version)
+				(quote extensions)
                                 (lambda () body ...))))))
 
 ;;
@@ -347,10 +349,10 @@
 
 (define usage #<<END
 Usage: ~a [options]
-  -h, --help        display this help message, then exit
+  -h, --help             display this help message, then exit
-  -r, --root <dir>  specify root directory
+  -r, --root <dir>       specify root directory
-  -n, --dry-run     don't do anything, print what would have been done
+  -n, --dry-run          don't do anything, print what would have been done
-  -i, --inactive    don't activate package after installing it
+  -i, --inactive         don't activate package after installing it
 
 advanced options:
   -d, --dest-root <dir>  specify staging root directory
@@ -361,6 +363,7 @@ END
 (define (display-usage-and-exit msg . args)
   (if msg (begin (apply format #t msg args) (newline)))
   (format #t usage (car (command-line)))
+  (display-optional-parts-usage)
   (exit 1))
 
 (define (check-root-directory root)
@@ -382,47 +385,121 @@ END
                (lambda args
                  (display-usage-and-exit #f)))
        (option '(#\r "root") #t #f
-               (lambda (option name arg root dest-root activate? dry-run?)
+               (lambda (option name arg root dest-root activate? dry-run? opt-parts)
-                 (values arg dest-root activate? dry-run?)))
+                 (values arg dest-root activate? dry-run? opt-parts)))
        (option '(#\d "dest-root") #t #f
-               (lambda (option name arg root dest-root activate? dry-run?)
+               (lambda (option name arg root dest-root activate? dry-run? opt-parts)
-                 (values root arg activate? dry-run?)))
+                 (values root arg activate? dry-run? opt-parts)))
        (option '(#\n "dry-run") #f #f
-               (lambda (option name arg root dest-root activate? dry-run?)
+               (lambda (option name arg root dest-root activate? dry-run? opt-parts)
-                 (values root dest-root activate? #t)))
+                 (values root dest-root activate? #t opt-parts)))
        (option '(#\i "inactive") #f #f
-               (lambda (option name arg root dest-root activate? dry-run?)
+               (lambda (option name arg root dest-root activate? dry-run? opt-parts)
-                 (values root dest-root #f dry-run?)))))
+                 (values root dest-root #f dry-run? opt-parts)))))
+
+;;
+;; optional parts stuff
+;;
+
+(define (booleanize s)
+  (cond
+   ((string=? s "yes") #t)
+   ((string=? s "no") #f)
+   (else (display-error-and-exit "unknown boolean value '~a'. Use 'yes' or 'no'." s))))
+
+(define (unbooleanize b)
+  (if b "yes" "no"))
+
+(define (spaces min n)
+  (make-string (if (< n min) min n) #\space))
+
+(define (get-all-optional-parts packages)
+  (if (null? packages)
+      '()
+      (let* ((p (car packages))
+             (ext (package:extensions p))
+             (op (assq 'optional-parts ext)))
+        (append (if op (cdr op) '())
+                (get-all-optional-parts (cdr packages))))))
+
+(define optional-part:name car)
+(define optional-part:description cadr)
+(define (optional-part:default part)
+  (if (null? (cddr part)) #f (caddr part)))
+
+(define (optional-parts->options parts)
+  (map (lambda (part)
+         (let ((part-name (optional-part:name part)))
+           (option (list (string-append "with-" (symbol->string part-name))) #t #f
+                   (lambda (option name arg root dest-root activate? dry-run? opt-parts)
+                     (values root dest-root activate? dry-run?
+                             (cons (cons part-name (booleanize arg))
+                                   opt-parts))))))
+       parts))
+
+(define (optional-parts-defaults parts)
+  (map (lambda (part)
+         (cons (optional-part:name part) (optional-part:default part)))
+       parts))
+
+(define *all-optional-parts* (make-fluid '()))
+(define *optional-parts-alist* (make-fluid '()))
+
+(define *usage-description-column* 25)
+
+(define (display-optional-parts-usage)
+  (display "\noptionals parts:\n")
+  (map (lambda (part)
+         (let* ((sname (symbol->string (optional-part:name part)))
+                (pf (string-append "  --with-" sname"=[yes|no]")))
+         (display pf)
+         (display (spaces 2 (- *usage-description-column* (string-length pf))))
+         (display (optional-part:description part))
+         (display (string-append " [" (unbooleanize (optional-part:default part)) "]"))
+         (newline)))
+       (fluid *all-optional-parts*)))
+
+(define (with-optional-part? name)
+  (cdr (assq name (fluid *optional-parts-alist*))))
+
+;; main
 
 (define package-definition-file "pkg-def.scm")
 
+(define (is-running-dry?)
+  (fluid *dry-run*))
+
 (define (install-main cmd-line)
   (let ((prog (car cmd-line))
         (args (cdr cmd-line)))
-    (receive (root maybe-dest-root activate? dry-run?)
+    (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)
+    (set-fluid! *all-optional-parts* (get-all-optional-parts packages))
+    (receive (root maybe-dest-root activate? dry-run? opt-parts)
              (args-fold args
-                        options
+                        (append options
+                                (optional-parts->options (fluid *all-optional-parts*)))
                         (lambda (option name arg . seeds)
                           (display-usage-and-exit "Unknown option ~a" name))
-                        (lambda (operand root activate?) ; operand
+                        (lambda (operand . seeds) ; operand
                           (display-usage-and-exit
                            "Don't know what to do with ~a"
                            operand))
                         #f              ; default root
                         #f              ; default dest-root
                         #t              ; default activation
-                        #f)             ; default dry run
+                        #f              ; default dry run
-             (if (not (file-exists? package-definition-file))
+			(optional-parts-defaults (fluid *all-optional-parts*)))
-                 (display-error-and-exit
-                  "cannot find package definition file (~a)"
-                  package-definition-file))
-             (load-quietly package-definition-file)
              (if (not root)
                  (display-error-and-exit
                   "No package root specified (use --root option)"))
              (let ((dest-root (or maybe-dest-root root)))
                (check-root-directory dest-root)
                (let-fluids *dry-run* dry-run?
+                           *optional-parts-alist* opt-parts
                            (lambda ()
                              (for-each
                               (lambda (pkg)