- added --version option,

- added --phases option (which subsumes --install-only and
  --build-only),

scheme/install-lib/install-lib.scm

@@ -1,5 +1,5 @@
 ;;; Installation library for scsh modules.
-;;; $Id: install-lib.scm,v 1.21 2004/11/04 14:48:45 michel-schinz Exp $
+;;; $Id: install-lib.scm,v 1.22 2004/11/05 18:16:08 michel-schinz Exp $
 
 ;; TODO
 ;; - think about --build: does it make sense?
@@ -262,6 +262,31 @@
 (define (version>? v1 v2) (eq? (version-compare v1 v2) 'greater))
 (define (version=? v1 v2) (eq? (version-compare v1 v2) 'equal))
 
+;;
+;; Phases
+;;
+
+(define all-phases '(build install))
+
+(define all-phases-str (string-join (map symbol->string all-phases) ", "))
+
+(define (valid-phase? thing)
+  (member thing all-phases))
+
+(define (active-phase? phase)
+  (assert (valid-phase? phase) "invalid phase" phase)
+  (member phase (get-option-value 'phases)))
+
+(define (parse-phase str)
+  (let ((phase (string->symbol str)))
+    (if (valid-phase? phase)
+        phase
+        (display-error-and-exit "invalid phase "str" "
+                                "(valid ones are: "all-phases-str")"))))
+
+(define (parse-phases str)
+  (map parse-phase ((infix-splitter ",") str)))
+
 ;;
 ;; Layouts
 ;;
@@ -286,9 +311,9 @@
 ;; installed in it.
 (define (active-location? location)
   (assert (valid-location? location) "invalid location" location)
-  (member location (if (get-option-value 'non-shared-only)
-                       non-shared-locations
-                       all-locations)))
+  (and (active-phase? '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
@@ -552,14 +577,12 @@
 ;; package's loading script (in the install directory). During a dry
 ;; run, or when only non-shared data has to be installed, do nothing.
 (define (with-output-to-load-script* thunk)
-  (let* ((dir (get-directory 'base #t))
-         (file (absolute-file-name load-script-name dir)))
-    (-create-directory&parents dir)
-    (if (not (or (get-option-value 'dry-run)
-                 (get-option-value 'non-shared-only)))
-        (begin
-          (delete-file-or-fail file)
-          (with-output-to-file file thunk)))))
+  (if (and (not (get-option-value 'dry-run)) (active-location? 'base))
+      (let* ((dir (get-directory 'base #t))
+             (file (absolute-file-name load-script-name dir)))
+        (-create-directory&parents dir)
+        (delete-file-or-fail file)
+        (with-output-to-file file thunk))))
 
 ;; Sugar for with-output-to-load-script*.
 (define-syntax with-output-to-load-script
@@ -579,13 +602,14 @@
 ;; Perform all actions required to make the given version of the
 ;; package active (i.e. the default version for that package).
 (define (activate-package layout 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 (layout-dir layout 'base)
-                                         (file-name-directory lnk-name))
-                     lnk-name)))
+  (if (active-location? 'active)
+      (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 (layout-dir layout 'base)
+                                             (file-name-directory lnk-name))
+                         lnk-name))))
 
 (define (install-thing% layout name-or-pair location target-rel-dir perms)
   (let* ((target-dir (absolute-file-name target-rel-dir
@@ -706,7 +730,6 @@
          (dest-prefix (and prefix (string-append dest-dir prefix)))
          (layout-fn (resolve-layout (alist-get 'layout 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 ()
@@ -716,7 +739,7 @@
                   (layout (absolute-layout rel-layout prefix))
                   (i-layout (absolute-layout rel-layout dest-prefix)))
              (install-package layout i-layout pkg)
-             (if (and activate? (not non-shared-only?))
+             (if activate?
                  (activate-package i-layout pkg))))
          packages)))))
 
@@ -750,6 +773,7 @@
 ;; this order is used when displaying available options to the user.
 (define options-usage
   `(("help" #f "display this help message, then exit")
+    ("version" #f "display version of install-lib, then exit")
     ("prefix" "dir" "specify directory where files are installed")
     ("layout" "layout" ("specify layout of installation directory"
                         ,(string-append "(predefined: "
@@ -760,15 +784,16 @@
     ("dry-run" #f "don't do anything, print what would have been done")
     ("verbose" #f "print messages about what is being done")
     ("inactive" #f "don't activate package after installing it")
-
-    ("non-shared-only" #f "only install platform-dependent files, if any")
+    ("non-shared-only" #f "only build/install platform-dependent files")
     ("force" #f "overwrite existing files during installation")
     ("no-user-defaults" #f "don't read defaults from ~/.scsh-pkg-defaults.scm")
     ;; advanced
+    ("phases" "phases" ,(string-append "perform only the given phase(s) "
+                                       "("all-phases-str")"))
     ("build" "name" "name of platform for which to build")
     ("layout-from" "file" "load layout of installation directory from file")
-    ("dest-dir" "dir" ("specify prefix to used during installation"
-                       "(to be used only during staged installations)"))))
+    ("dest-dir" "dir" ("specify prefix to use during installation"
+                       "(use only for staged installations!)"))))
 
 (define (sort-options options)
   (filter-map (lambda (name)
@@ -837,11 +862,17 @@
 
 (define usage-string #f)
 
-;; Display the usage string, then exit with an error code of 1.
+;; Display the usage string, then exit successfully.
 (define (display-usage-and-exit)
   (display usage-string)
   (newline)
-  (exit 1))
+  (exit))
+
+(define (display-version-and-exit)
+  (display-all "scsh-install-lib version "
+               (version->string install-lib-version)
+               "\n")
+  (exit))
 
 ;; Display a hint about how to use the just-installed PACKAGES,
 ;; assuming they were laid out according to LAYOUT and PREFIX.
@@ -923,17 +954,20 @@
 (define (get-option-value key)
   (alist-get key (fluid *options-values*)))
 
-(define (alist-arg-updater key)
+(define (alist-updater key parser)
   (lambda (opt name arg alist)
-    (alist-replace key arg alist)))
+    (alist-replace key (parser arg) alist)))
+
+(define (alist-arg-updater key)
+  (alist-updater key identity))
 
 (define (alist-boolean-updater key)
-  (lambda (opt name arg alist)
-    (alist-replace key (or (not arg) (parse-boolean arg)) alist)))
+  (alist-updater key (lambda (arg) (or (not arg) (parse-boolean arg)))))
 
 (define common-options
   (list
    (option '(#\h "help") #f #f (lambda args (display-usage-and-exit)))
+   (option '(#\v "version") #f #f (lambda args (display-version-and-exit)))
    (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))
@@ -946,7 +980,8 @@
    (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))
-   (option '("no-user-defaults") #f #f (lambda (opt name arg alist) alist))))
+   (option '("no-user-defaults") #f #f (lambda (opt name arg alist) alist))
+   (option '("phases") #t #f (alist-updater 'phases parse-phases))))
 
 (define lib-options
   (list
@@ -1004,6 +1039,7 @@
     (dry-run         . #f)
     (verbose         . #f)
     (force           . #f)
+    (phases          . ,all-phases)
     (exclude         . ,(lambda args #f))))
 
 ;; Partition PACKAGES in two sets: the ones which are not installed
@@ -1033,6 +1069,7 @@
                               (options-defaults 'library))
                              (map pkg-opt-key&default all-pkg-opts)))
            (options-values (parse-options args all-opts all-dfts))
+           (phases (alist-get 'phases options-values))
            (prefix (alist-get 'prefix options-values))
            (layout (alist-get 'layout options-values))
            (force? (alist-get 'force options-values)))
@@ -1054,7 +1091,7 @@
         (receive (pkgs-install pkgs-skip)
                  (partition-packages prefix resolved-layout packages force?)
                  (install-packages pkgs-install options-values)
-                 (if display-hint?
+                 (if (and display-hint? (member 'install phases))
                      (display-use-hint prefix
                                        resolved-layout
                                        pkgs-install