upgraded to new install-lib version

configure.scm

@@ -0,0 +1,27 @@
+;;; Library to obtain information about the underlying platform.
+;;; $Id: configure.scm,v 1.1 2003/12/16 16:44:40 frese Exp $
+
+(define-structure configure (export host)
+  (open scheme-with-scsh
+        srfi-13)
+  (begin
+    (define (canonical-machine uname-record)
+      (let* ((machine (uname:machine uname-record))
+             (os (uname:os-name uname-record)))
+        (cond
+         ((member machine '("i386" "i486" "i586" "i686")) "i386")
+         ((or (string=? machine "Power Macintosh")
+              (and (string=? os "AIX")
+                   (regexp-search? (rx (: "00" (= 6 digit) any any "00"))
+                                   machine)))
+          "powerpc")
+         (else machine))))
+
+    (define (canonical-os-name uname-record)
+      (string-downcase (uname:os-name uname-record)))
+
+    (define (host)
+      (let ((uname-record (uname)))
+        (string-append (canonical-machine uname-record)
+                       "-"
+                       (canonical-os-name uname-record))))))

install-lib-module.scm

@@ -1,3 +1,6 @@
+;;; Installation library for scsh modules.
+;;; $Id: install-lib-module.scm,v 1.2 2003/12/16 16:44:40 frese Exp $
+
 ;;; Interfaces
 
 (define-interface install-interface
@@ -8,21 +11,16 @@
           version>?
           version=?
 
-          installed-packages
-          active-packages
-          installed-packages&versions
-          active-packages&versions
-          active-version
-
           (define-package :syntax)
 
           install-file
           install-files
           install-directory
           install-directories
+          install-directory-contents
+
+          get-directory
 
-          package-installation-dir
-          package-installation-staging-dir
           with-optional-part?
           is-running-dry?
 
@@ -37,5 +35,6 @@
         srfi-1
         srfi-9
         srfi-13
-        srfi-37)
+        srfi-37
+        configure)
   (files install-lib))

install-lib.scm

@@ -1,15 +1,14 @@
-;; Time-stamp: <2003-11-27 11:06:57 schinz>
+;;; Installation library for scsh modules.
+;;; $Id: install-lib.scm,v 1.2 2003/12/16 16:44:40 frese Exp $
 
 ;; TODO
-;; - copy symbolic links as such, do not duplicate contents,
-;; - add function to copy a directory contents,
 ;; - add support for image creation,
 ;; - add support to maintain a documentation index,
 ;; - add "--mode" option to specify permissions for files/directories.
 ;; - add "--verbose" to show whats being done.
 ;; - add "--log" option to specify a log file.
 ;; - decide what to do when target files already exist
-;; - find out how to perform installation for several architectures
+;; - allow installation of platform-specific files only
 
 ;;
 ;; Utilities
@@ -42,16 +41,17 @@
       (path-list->file-name (append (make-list (- (length dir-pl) cp-len) "..")
                                     (drop abs-pl cp-len))))))
 
-(define (copy-file src target perms)
+;; Copy file/symlink SOURCE to TARGET and set the permisions of TARGET
-  (run (cp ,src ,target))
+;; to PERMS. TARGET must be the name of a non-existing file (i.e. it
-  (set-file-mode target perms))
+;; cannot be the name of a directory).
-
+(define (copy-file source target perms)
-(define (permissions->string perms)
+  (if (file-exists? target)
-  (let ((decode (lambda (mask str)
+      (error "copy-file: target file exists" target))
-                  (if (zero? (bitwise-and perms mask)) "-" str))))
+  (if (file-symlink? source)
-    (string-append (decode #o400 "r") (decode #o200 "w") (decode #o100 "x")
+      (create-symlink (read-symlink source) target)
-                   (decode #o040 "r") (decode #o020 "w") (decode #o010 "x")
+      (begin
-                   (decode #o004 "r") (decode #o002 "w") (decode #o001 "x"))))
+        (run (cp ,source ,target))
+        (set-file-mode target perms))))
 
 ;; Like "load" but without printing anything.
 (define load-quietly
@@ -60,6 +60,13 @@
       (call-with-input-file file-name
         (lambda (port) (port-fold port read eval #f))))))
 
+(define (permissions->string perms)
+  (let ((decode (lambda (mask str)
+                  (if (zero? (bitwise-and perms mask)) "-" str))))
+    (string-append (decode #o400 "r") (decode #o200 "w") (decode #o100 "x")
+                   (decode #o040 "r") (decode #o020 "w") (decode #o010 "x")
+                   (decode #o004 "r") (decode #o002 "w") (decode #o001 "x"))))
+
 ;;
 ;; Support for dry runs.
 ;;
@@ -103,17 +110,6 @@
   (wrap-for-dry-run delete-file
                     (lambda (fname) (dry-run-print "deleting file ~a" fname))))
 
-;;
-;; Regular expressions to match package names
-;;
-
-(define number-rx (rx (+ digit)))
-(define version-rx (rx ,number-rx (* "." ,number-rx)))
-(define package-name-rx (rx (+ (| alphanum ("_")))))
-(define package-full-name-rx (rx (submatch ,package-name-rx)
-                                 "-"
-                                 (submatch ,version-rx)))
-
 ;;
 ;; Versions
 ;;
@@ -141,6 +137,78 @@
 (define (version>? v1 v2) (eq? (version-compare v1 v2) 'greater))
 (define (version=? v1 v2) (eq? (version-compare v1 v2) 'equal))
 
+;;
+;; Layouts
+;;
+
+(define parse-layout
+  (let ((split-defs (infix-splitter ","))
+        (split-sides (infix-splitter "=")))
+    (lambda (str)
+      (map (lambda (name&value)
+             (let ((name/value (split-sides name&value)))
+               (cons (string->symbol (first name/value)) (second name/value))))
+           (split-defs str)))))
+
+;; Combine layouts L1 and L2 by adding to L1 all the additional
+;; mappings found in L2.
+(define (combine-layouts l1 l2)
+  (fold (lambda (key/value layout)
+          (if (assoc (car key/value) layout) layout (cons key/value layout)))
+        l1
+        l2))
+
+;; Return an absolute version of LAYOUT by prepending PREFIX to all
+;; its components (which must be relative).
+(define (absolute-layout layout prefix)
+  (map (lambda (key/value)
+         (cons (car key/value) (absolute-file-name (cdr key/value) prefix)))
+       layout))
+
+(define (layout-dir layout dir)
+  (cond ((assoc dir layout) => cdr)
+        (else #f)))
+
+;; Predefined layouts
+
+(define (scsh-layout platform base)
+  `((base        . ,base)
+    (misc-shared . ,base)
+    (scheme      . ,(absolute-file-name "scheme" base))
+    (lib         . ,(absolute-file-name
+                     (path-list->file-name (list "lib" platform))
+                     base))
+    (doc         . ,(absolute-file-name "doc" base))))
+
+(define (scsh-layout-1 platform pkg)
+  (combine-layouts '((active . "."))
+                   (scsh-layout platform (package-full-name pkg))))
+
+(define (scsh-layout-2 platform pkg)
+  (combine-layouts
+   '((active . "active"))
+   (scsh-layout platform
+                (path-list->file-name
+                 (list "installed"
+                       (package-name pkg)
+                       (version->string (package-version pkg)))))))
+
+(define (fhs-layout platform pkg)
+  (let ((base (absolute-file-name (package-full-name pkg)
+                                  "share/scsh/modules")))
+    `((base        . ,base)
+      (misc-shared . ,base)
+      (scheme      . ,(absolute-file-name "scheme" base))
+      (lib         . ,(absolute-file-name (package-full-name pkg)
+                                          "lib/scsh/modules"))
+      (doc         . ,(absolute-file-name (package-full-name pkg) "share/doc"))
+      (active      . "share/scsh/modules"))))
+
+(define predefined-layouts
+  `(("scsh"     . ,scsh-layout-1)
+    ("scsh-alt" . ,scsh-layout-2)
+    ("fhs"      . ,fhs-layout)))
+
 ;;
 ;; Packages
 ;;
@@ -148,10 +216,14 @@
 (define-record-type package
   (make-package name version extensions install-thunk)
   package?
-  (name package:name)
+  (name package-name)
-  (version package:version)
+  (version package-version)
-  (extensions package:extensions)
+  (extensions package-extensions)
-  (install-thunk package:install-thunk))
+  (install-thunk package-install-thunk))
+
+(define (package-full-name pkg)
+  (string-append
+   (package-name pkg) "-" (version->string (package-version pkg))))
 
 ;; List of all defined packages
 (define packages '())
@@ -168,174 +240,95 @@
 				(quote extensions)
                                 (lambda () body ...))))))
 
-;;
-;; Names of various directories/links
-;;
-
-;; Directory in which active versions of packages are "remembered".
-(define (active-directory root)
-  (absolute-file-name "active" root))
-
-;; Directory in which packages are installed.
-(define (installed-directory root)
-  (absolute-file-name "installed" root))
-
-(define (package-dir-name root pkg)
-  (absolute-file-name (package:name pkg) (installed-directory root)))
-
-(define (package-version-dir-name root pkg)
-  (absolute-file-name (version->string (package:version pkg))
-                      (package-dir-name root pkg)))
-
-(define (active-link-name root pkg)
-  (absolute-file-name (package:name pkg) (active-directory root)))
-
-;;
-;; Queries
-;;
-
-(define (packages-of dir)
-  (with-cwd dir (filter file-directory? (directory-files))))
-
-;; Get the name of all installed packages (without versions) as a list
-;; of strings.
-(define (installed-packages root)
-  (packages-of (installed-directory root)))
-
-;; Get the name of all active packages (without versions) as a list of
-;; strings.
-(define (active-packages root)
-  (packages-of (active-directory root)))
-
-;; Return the list of all installed packages and their version(s), as
-;; a list of pairs. The CAR of each pair contains the name of the
-;; package, the CDR contains the list of all available versions.
-(define (installed-packages&versions root)
-  (with-cwd (installed-directory root)
-            (map (lambda (pkg-dir)
-                   (cons pkg-dir
-                         (map string->version (directory-files pkg-dir))))
-                 (directory-files))))
-
-(define (read-version pkg-link)
-  (string->version (file-name-nondirectory (read-symlink pkg-link))))
-
-;; Return the list of all active packages and their version, as a list
-;; of pairs. The CAR of each pair contains the name of the package,
-;; and the CDR contains the active version.
-(define (active-packages&versions root)
-  (with-cwd (active-directory root)
-            (map (lambda (pkg-dir)
-                   (cons pkg-dir (read-version pkg-dir)))
-                 (directory-files))))
-
-;; Return the active version of package NAME.
-(define (active-version root name)
-  (read-version (absolute-file-name name (active-directory root))))
-
 ;;
 ;; Actions
 ;;
 
 ;; Perform all actions required to make the given version of the
 ;; package active (i.e. the default version for that package).
-(define (activate-package root pkg)
+(define (activate-package layout pkg)
-  (let ((lnk-name (active-link-name root pkg)))
+  (let ((lnk-name (absolute-file-name (package-name pkg)
+                                      (layout-dir layout 'active))))
     (if (and (file-exists? lnk-name) (file-symlink? lnk-name))
         (-delete-file lnk-name))
-    (-create-symlink (relative-file-name (package-version-dir-name root pkg)
+    (-create-symlink (relative-file-name (layout-dir layout 'base)
                                          (file-name-directory lnk-name))
                      lnk-name)))
 
-(define (target-absolute-dir root pkg dir)
+(define (install-thing% layout name-or-pair location target-rel-dir perms)
-  (absolute-file-name (directory-as-file-name dir)
+  (let* ((target-dir (absolute-file-name target-rel-dir
-                      (package-version-dir-name root pkg)))
+                                         (layout-dir layout location)))
+         (source (if (pair? name-or-pair) (car name-or-pair) name-or-pair))
+         (target-name (file-name-nondirectory (if (pair? name-or-pair)
+                                                  (cdr name-or-pair)
+                                                  name-or-pair)))
+         (target (absolute-file-name target-name target-dir)))
+    (create-directory&parents target-dir perms)
+    (cond ((or (file-regular? source) (file-symlink? source))
+           (-copy-file source target perms))
+          ((file-directory? source)
+           (create-directory target perms)
+           (install-directory-contents% layout
+                                        source
+                                        location
+                                        (absolute-file-name target-name
+                                                            target-rel-dir)
+                                        perms))
+          (else (error "cannot install file-system object" source)))))
 
-(define (re-root-file file dir)
+(define (install-directory-contents% layout name location target-rel-dir perms)
-  (absolute-file-name (file-name-nondirectory (directory-as-file-name file))
+  (for-each (lambda (thing)
-                      dir))
+              (install-thing% layout thing location target-rel-dir perms))
+            (map (lambda (f) (absolute-file-name f name))
+                 (directory-files name #t))))
 
-;; Copy the list of FILES to the TARGET-DIR and set their permission
+(define (install-thing name-or-pair location . rest)
-;; to PERMS. The TARGET-DIR (default ".") is relative to the package
+  (let-optionals rest ((target-rel-dir ".") (perms default-perms))
-;; directory given by ROOT, NAME and VERSION.
+    (install-thing% (fluid *install-layout*)
-(define (install-files% root pkg files . rest)
+                    name-or-pair
-  (let-optionals rest ((target-dir ".") (perms default-perms))
+                    location
-    (let* ((target-abs-dir (target-absolute-dir root pkg target-dir)))
+                    target-rel-dir
-      (create-directory&parents target-abs-dir perms)
+                    perms)))
-      (for-each (lambda (file)
-                  (-copy-file file (re-root-file file target-abs-dir) perms))
-                files))))
 
-;; Copy SRC-DIR and all its contents in TARGET-DIR, and set the
+(define (install-things names-or-pairs . rest)
-;; permission for everything to PERMS. The TARGET-DIR (default ".") is
+  (for-each (lambda (name-or-pair)
-;; relative to the package directory given by ROOT, NAME and VERSION.
+              (apply install-thing name-or-pair rest))
-(define (install-directory% root pkg src-dir . rest)
+            names-or-pairs))
-  (let-optionals rest ((target-dir ".") (perms default-perms))
-    (let* ((src-dir-name (file-name-nondirectory
-                          (directory-as-file-name src-dir)))
-           (full-target-dir (absolute-file-name src-dir-name target-dir))
-           (target-abs-dir (target-absolute-dir root pkg full-target-dir)))
-      (create-directory&parents target-abs-dir perms)
-      (for-each
-       (lambda (file)
-         (let ((abs-file (absolute-file-name file src-dir)))
-           (cond ((file-regular? abs-file)
-                  (-copy-file abs-file
-                              (absolute-file-name file target-abs-dir)
-                              perms))
-                 ((file-directory? abs-file)
-                  (install-directory% root pkg abs-file full-target-dir perms))
-                 (else
-                  (display-error-and-exit "don't know what to do with file ~a"
-                                          abs-file)))))
-       (directory-files src-dir #t)))))
 
-(define (install-empty-directory% root pkg target-dir . rest)
+(define install-file install-thing)
+(define install-files install-things)
+(define install-directory install-thing)
+(define install-directories install-things)
+
+(define (install-directory-contents name location . rest)
+  (let-optionals rest ((target-rel-dir ".") (perms default-perms))
+    (install-directory-contents% (fluid *install-layout*)
+                                 name
+                                 location
+                                 target-rel-dir
+                                 perms)))
+
+(define (install-empty-directory% layout name location dir . rest)
   (let-optionals rest ((perms default-perms))
-    (-create-directory (target-absolute-dir root pkg target-dir) perms)))
+    (-create-directory (absolute-file-name dir (layout-dir layout location))
+                       perms)))
 
-(define (install-empty-directory&parents% root pkg target-dir . rest)
+(define (install-empty-directory&parents% layout name location dir . rest)
   (let-optionals rest ((perms default-perms))
-    (create-directory&parents (target-absolute-dir root pkg target-dir)
+    (create-directory&parents
-                              perms)))
+     (absolute-file-name dir (layout-dir layout location))
+     perms)))
 
-(define *root* (make-fluid #f))
+(define *layout* (make-fluid #f))
-(define *dest-root* (make-fluid #f))
+(define *install-layout* (make-fluid #f))
-(define *package* (make-fluid #f))
 
-(define (package-installation-dir)
+(define (get-directory location install?)
-  (package-version-dir-name (fluid *root*) (fluid *package*)))
+  (layout-dir (fluid (if install? *install-layout* *layout*)) location))
-(define (package-installation-staging-dir)
-  (package-version-dir-name (fluid *dest-root*) (fluid *package*)))
 
-(define (forward-args-prepend-fluids target-fn args)
+(define (install-package layout install-layout pkg)
-  (apply target-fn (fluid *dest-root*) (fluid *package*) args))
+  (let-fluids *layout* layout
-
+              *install-layout* install-layout
-(define (install-file file . rest)
+              (package-install-thunk pkg)))
-  (apply install-files (list file) rest))
-
-(define (install-files . args)
-  (forward-args-prepend-fluids install-files% args))
-
-(define (install-empty-directory . args)
-  (forward-args-prepend-fluids install-empty-directory% args))
-
-(define (install-empty-directory&parents . args)
-  (forward-args-prepend-fluids install-empty-directory&parents% args))
-
-(define (install-directory . args)
-  (forward-args-prepend-fluids install-directory% args))
-
-(define (install-directories src-dirs . rest)
-  (for-each (lambda (src-dir)
-              (apply install-directory src-dir rest))
-            src-dirs))
-
-(define (install-package root dest-root pkg)
-  (let-fluids *root* root
-              *dest-root* dest-root
-              *package* pkg
-              (package:install-thunk pkg)))
 
 ;;
 ;; Error handling
@@ -348,63 +341,62 @@
 
 (define usage #<<END
 Usage: ~a [options]
-  -h, --help             display this help message, then exit
+
-  -r, --root <dir>       specify root directory
+options:
-  -n, --dry-run          don't do anything, print what would have been done
+  -h, --help           display this help message, then exit
-  -i, --inactive         don't activate package after installing it
+  --prefix <dir>       specify directory where files are installed
+  --layout <layout>    specify layout of installation directory
+                       (predefined: ~a)
+  --dry-run            don't do anything, print what would have been done
+  --inactive           don't activate package after installing it
 
 advanced options:
-  -d, --dest-root <dir>  specify staging root directory
+  --build <name>          name of platform for which to build
+  --layout-from <file>    load layout of installation directory from file
+  --layout-to <file>      output layout to given file
+  --install-prefix <dir>  specify prefix to used during installation
+                          (to be used only during staged installations)
 
 END
 )
 
+(define usage-description-column 26)
+
+(define (complete-usage! optional-parts)
+  (let ((usage-port (make-string-output-port)))
+    (write-string usage usage-port)
+    (write-string "\noptional parts:\n" usage-port)
+    (for-each
+     (lambda (part)
+       (let* ((sname (symbol->string (optional-part:name part)))
+              (pf (string-append "  --with-" sname "=[yes|no]")))
+         (format usage-port
+                 "~a~a~a [~a]\n"
+                 pf
+                 (spaces 2 (- usage-description-column
+                              (string-length pf)))
+                 (optional-part:description part)
+                 (unbooleanize (optional-part:default part)))))
+     optional-parts)
+    (set! usage (string-output-port-output usage-port))))
+
 (define (display-usage-and-exit msg . args)
   (if msg (begin (apply format #t msg args) (newline)))
-  (format #t usage (car (command-line)))
+  (format #t
-  (display-optional-parts-usage)
+          usage
+          (car (command-line))
+          (string-join (map car predefined-layouts) ", "))
   (exit 1))
 
-(define (check-root-directory root)
-  (for-each (lambda (dir)
-              (if (not (and (file-exists? dir) (file-directory? dir)))
-                  (display-error-and-exit
-                   (string-append
-                    "directory ~a does not exist or is not a directory.\n"
-                    "It should be created before installing packages.")
-                   dir)))
-            (list root (active-directory root) (installed-directory root))))
-
 ;;
 ;; Command line parsing
 ;;
 
-(define options
- (list (option '(#\h "help") #f #f
-               (lambda args
-                 (display-usage-and-exit #f)))
-       (option '(#\r "root") #t #f
-               (lambda (option name arg root dest-root activate? dry-run? opt-parts)
-                 (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? opt-parts)
-                 (values root arg activate? dry-run? opt-parts)))
-       (option '(#\n "dry-run") #f #f
-               (lambda (option name arg root dest-root activate? dry-run? opt-parts)
-                 (values root dest-root activate? #t opt-parts)))
-       (option '(#\i "inactive") #f #f
-               (lambda (option name arg root dest-root activate? dry-run? opt-parts)
-                 (values root dest-root #f dry-run? opt-parts)))))
-
-;;
-;; optional parts stuff
-;;
-
 (define (booleanize s)
-  (cond
+  (cond ((string=? s "yes") #t)
-   ((string=? s "yes") #t)
+        ((string=? s "no") #f)
-   ((string=? s "no") #f)
+        (else (display-error-and-exit
-   (else (display-error-and-exit "unknown boolean value '~a'. Use 'yes' or 'no'." s))))
+               "unknown boolean value '~a'. Use 'yes' or 'no'." s))))
 
 (define (unbooleanize b)
   (if b "yes" "no"))
@@ -416,7 +408,7 @@ END
   (if (null? packages)
       '()
       (let* ((p (car packages))
-             (ext (package:extensions p))
+             (ext (package-extensions p))
              (op (assq 'optional-parts ext)))
         (append (if op (cdr op) '())
                 (get-all-optional-parts (cdr packages))))))
@@ -429,11 +421,9 @@ END
 (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
+           (option (list (string-append "with-" (symbol->string part-name)))
-                   (lambda (option name arg root dest-root activate? dry-run? opt-parts)
+                   #t #f
-                     (values root dest-root activate? dry-run?
+                   (optional-part-processor part-name))))
-                             (cons (cons part-name (booleanize arg))
-                                   opt-parts))))))
        parts))
 
 (define (optional-parts-defaults parts)
@@ -441,27 +431,90 @@ END
          (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 (process-option opt
+                        name
+                        arg
+                        prefix
+                        i-prefix
+                        layout
+                        layout-file
+                        build
+                        activate?
+                        dry-run?
+                        opt-parts)
+  (case (cdr (assoc opt options/keys))
+    ((prefix)
+     (values arg i-prefix layout layout-file build activate? dry-run? opt-parts))
+    ((i-prefix)
+     (values prefix arg layout layout-file build activate? dry-run? opt-parts))
+    ((layout)
+     (values prefix
+             i-prefix
+             (cond ((assoc arg predefined-layouts) => cdr)
+                   (else (parse-layout arg)))
+             layout-file
+             build
+             activate?
+             dry-run?
+             opt-parts))
+    ((layout-from)
+     (values prefix
+             i-prefix
+             (let ((layout (call-with-input-file arg read)))
+               (lambda args layout))
+             layout-file
+             build
+             activate?
+             dry-run?
+             opt-parts))
+    ((layout-to)
+     (values prefix i-prefix layout arg build activate? dry-run? opt-parts))
+    ((build)
+     (values prefix i-prefix layout layout-file arg activate? dry-run? opt-parts))
+    ((inactive)
+     (values prefix i-prefix layout layout-file build #f dry-run? opt-parts))
+    ((dry-run)
+     (values prefix i-prefix layout layout-file build activate? #t opt-parts))
+    ((help)
+     (display-usage-and-exit #f))))
+
+(define (optional-part-processor part-name)
+  (lambda (opt
+           name
+           arg
+           prefix
+           i-prefix
+           layout
+           layout-file
+           build
+           activate?
+           dry-run?
+           opt-parts)
+    (values prefix
+            i-prefix
+            layout
+            layout-file
+            build
+            activate?
+            dry-run?
+            (alist-cons part-name (booleanize arg) opt-parts))))
+
+(define options/keys
+  (list
+   (cons (option '(#\h "help")       #f #f process-option) 'help)
+   (cons (option '("prefix")         #t #f process-option) 'prefix)
+   (cons (option '("install-prefix") #t #f process-option) 'i-prefix)
+   (cons (option '("layout")         #t #f process-option) 'layout)
+   (cons (option '("layout-from")    #t #f process-option) 'layout-from)
+   (cons (option '("layout-to")      #t #f process-option) 'layout-to)
+   (cons (option '("build")          #t #f process-option) 'build)
+   (cons (option '("inactive")       #f #f process-option) 'inactive)
+   (cons (option '("dry-run")        #f #f process-option) 'dry-run)))
 
 (define package-definition-file "pkg-def.scm")
 
@@ -469,40 +522,52 @@ END
   (fluid *dry-run*))
 
 (define (install-main cmd-line)
-  (let ((prog (car cmd-line))
+  (if (not (file-exists? package-definition-file))
-        (args (cdr cmd-line)))
+      (display-error-and-exit "cannot find package definition file (~a)"
-    (if (not (file-exists? package-definition-file))
+                              package-definition-file))
-        (display-error-and-exit
+  (load-quietly package-definition-file)
-         "cannot find package definition file (~a)"
+  (let ((all-optional-parts (get-all-optional-parts packages)))
-         package-definition-file))
+    (if (not (null? all-optional-parts))
-    (load-quietly package-definition-file)
+        (complete-usage! all-optional-parts))
-    (set-fluid! *all-optional-parts* (get-all-optional-parts packages))
+    (receive (prefix maybe-i-prefix layout-fn layout-to build activate? dry-run? opt-parts)
-    (receive (root maybe-dest-root activate? dry-run? opt-parts)
+             (args-fold (cdr cmd-line)
-             (args-fold args
+                        (append (map car options/keys)
-                        (append options
+                                (optional-parts->options all-optional-parts))
-                                (optional-parts->options (fluid *all-optional-parts*)))
+                        (lambda (option name . rest)
-                        (lambda (option name arg . seeds)
                           (display-usage-and-exit "Unknown option ~a" name))
-                        (lambda (operand . seeds) ; operand
+                        (lambda (operand . rest)
                           (display-usage-and-exit
                            "Don't know what to do with ~a"
                            operand))
-                        #f              ; default root
+                        #f                ; default prefix
-                        #f              ; default dest-root
+                        #f                ; default install-prefix
-                        #t              ; default activation
+                        scsh-layout-1     ; default layout-fn
-                        #f              ; default dry run
+                        #f                ; default layout-to
-			(optional-parts-defaults (fluid *all-optional-parts*)))
+                        (host)            ; default build platform
-             (if (not root)
+                        #t                ; default activation
-                 (display-error-and-exit
+                        #f                ; default dry run
-                  "No package root specified (use --root option)"))
+                        (optional-parts-defaults all-optional-parts))
-             (let ((dest-root (or maybe-dest-root root)))
+
-               (check-root-directory dest-root)
+      (if (not prefix)
-               (let-fluids *dry-run* dry-run?
+          (display-error-and-exit "no prefix specified (use --prefix option)"))
-                           *optional-parts-alist* opt-parts
+      (let ((i-prefix (or maybe-i-prefix prefix)))
-                           (lambda ()
+        (if (not (and (file-exists? i-prefix) (file-directory? i-prefix)))
-                             (for-each
+            (display-error-and-exit "install prefix directory ~a doesn't exist"
-                              (lambda (pkg)
+                                    i-prefix))
-                                (install-package root dest-root pkg)
+        (let-fluids *dry-run* dry-run?
-                                (if activate?
+                    *optional-parts-alist* opt-parts
-                                    (activate-package dest-root pkg)))
+          (lambda ()
-                              packages)))))))
+            (for-each
+             (lambda (pkg)
+               (let* ((rel-layout (layout-fn build pkg))
+                      (layout (absolute-layout rel-layout prefix))
+                      (i-layout (absolute-layout rel-layout i-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 activate? (activate-package i-layout pkg))))
+             packages)))))))

install-pkg

@@ -1,3 +1,3 @@
 #!/bin/sh
-exec scsh -lm install-lib-module.scm -o install -e install-main -s "$0" "$@"
+exec scsh -lm configure.scm -lm install-lib-module.scm -o install -e install-main -s "$0" "$@"
 !#