- renamed active-phase? to phase-active?

- both --layout and --layout-from now expect a layout specified as a
  Scheme function mapping a package to a layout (the old syntax for
  layouts is not recognised anymore)

scheme/install-lib/install-lib.scm

@@ -1,5 +1,5 @@
 ;;; Installation library for scsh modules.
-;;; $Id: install-lib.scm,v 1.22 2004/11/05 18:16:08 michel-schinz Exp $
+;;; $Id: install-lib.scm,v 1.23 2004/11/08 19:56:28 michel-schinz Exp $
 
 ;; TODO
 ;; - think about --build: does it make sense?
@@ -130,6 +130,27 @@
       (call-with-input-file file-name
         (lambda (port) (port-fold port read eval #f))))))
 
+;; Load the contents of FILE-NAME which should contain exactly one
+;; s-expression. Complain if it is not the case.
+(define (load-single-sexp file-name)
+  (if (file-not-exists? file-name)
+      (display-error-and-exit "file "file-name" doesn't exist")
+      (call-with-input-file file-name
+        (lambda (port)
+          (read-single-sexp port (string-append "file "file-name))))))
+
+;; Read the contents of PORT which should contain exactly one
+;; s-expression. Complain if it is not the case, using SOURCE to
+;; identify the source of data.
+(define (read-single-sexp port source)
+  (let ((sexp (read port)))
+    (if (eof-object? sexp)
+        (display-error-and-exit source" is empty"))
+    (if (not (eof-object? (read port)))
+        (display-error-and-exit
+         "more than one s-expression found in "source))
+    sexp))
+
 (define (permissions->string perms)
   (let ((decode (lambda (mask str)
                   (if (zero? (bitwise-and perms mask)) "-" str))))
@@ -273,7 +294,7 @@
 (define (valid-phase? thing)
   (member thing all-phases))
 
-(define (active-phase? phase)
+(define (phase-active? phase)
   (assert (valid-phase? phase) "invalid phase" phase)
   (member phase (get-option-value 'phases)))
 
@@ -311,28 +332,29 @@
 ;; installed in it.
 (define (active-location? location)
   (assert (valid-location? location) "invalid location" location)
-  (and (active-phase? 'install)
+  (and (phase-active? 'install)
        (or (not (get-option-value 'non-shared-only))
            (member location non-shared-locations))))
 
-;; Parse a layout given as a string of comma-separated bindings. A
-;; binding consists of the name of a location, followed by an equal
-;; sign and the name of the directory to associate to the location.
-;; Return #f if parsing fails.
-(define parse-layout
-  (let ((split-defs (infix-splitter ","))
-        (split-sides (infix-splitter "=")))
-    (lambda (str)
-      (call-with-current-continuation
-       (lambda (return)
-         (lambda (pkg)
-           (map (lambda (name&value)
-                  (let ((name/value (split-sides name&value)))
-                    (if (= 2 (length name/value))
-                        (cons (string->symbol (first name/value))
-                              (second name/value))
-                        (return #f))))
-                (split-defs str))))))))
+;; Parse a layout given as an s-expression evaluating to a procedure.
+(define (parse-layout str)
+  (let ((layout (eval (read-single-sexp (make-string-input-port str)
+                                        "--layout argument")
+                      (interaction-environment))))
+    (if (procedure? layout)
+        layout
+        (display-error-and-exit
+         "--layout argument doesn't specify a valid layout"
+         layout))))
+
+;; Load layout from FILE-NAME, which must contain exactly one
+;; s-expression evaluating to a procedure.
+(define (load-layout file-name)
+  (let ((layout (eval (load-single-sexp file-name) (interaction-environment))))
+    (if (procedure? layout)
+        layout
+        (display-error-and-exit
+         "file "file-name" doesn't contain a valid layout"))))
 
 ;; Return an absolute version of LAYOUT by prepending PREFIX to all
 ;; its components (which must be relative).
@@ -971,12 +993,7 @@
    (option '("prefix") #t #f (alist-arg-updater 'prefix))
    (option '("dest-dir") #t #f (alist-arg-updater 'dest-dir))
    (option '("layout") #t #f (alist-arg-updater 'layout))
-   (option '("layout-from") #t #f
-           (lambda (opt name arg alist)
-             (alist-replace 'layout
-                            (let ((layout (call-with-input-file arg read)))
-                              (lambda args layout))
-                            alist)))
+   (option '("layout-from") #t #f (alist-updater 'layout load-layout))
    (option '("dry-run") #f #t (alist-boolean-updater 'dry-run))
    (option '("verbose") #f #t (alist-boolean-updater 'verbose))
    (option '("force") #f #t (alist-boolean-updater 'force))
@@ -1013,15 +1030,8 @@
 (define (read-user-defaults)
   (let ((file (expand-file-name "~/.scsh-pkg-defaults.scm")))
     (if (file-exists? file)
-        (call-with-input-file file
-          (lambda (port)
-            (let ((defaults (read port)))
-              (if (or (eof-object? defaults))
-                  (display-error-and-exit "no valid defaults found in "file))
-              (if (not (eof-object? (read port)))
-                  (display-error-and-exit
-                   "more than one expression found in "file))
-              (eval (list 'quasiquote defaults) (interaction-environment)))))
+        (let ((defaults (load-single-sexp file)))
+          (eval (list 'quasiquote defaults) (interaction-environment)))
         '())))
 
 (define (kind-lib? pkg-kind)