- incorporated the rest of Martin's changes: the library can now be

used to install programs (although the internals still have to be
  cleaned, and the new features documented),

scheme/install-lib/install-lib.scm

@@ -1,5 +1,5 @@
 ;;; Installation library for scsh modules.
-;;; $Id: install-lib.scm,v 1.16 2004/05/12 18:39:04 michel-schinz Exp $
+;;; $Id: install-lib.scm,v 1.17 2004/05/16 14:33:12 michel-schinz Exp $
 
 ;; TODO
 ;; - think about --build: does it make sense?
@@ -302,7 +302,7 @@
 
 ;; Names of all non-shared (i.e. platform-dependent) locations.
 (define non-shared-locations
-  '(lib))
+  '(lib bin))
 
 ;; All locations defined for a layout.
 (define all-locations (append shared-locations non-shared-locations))
@@ -378,26 +378,38 @@
 
 (define (fhs-layout pkg)
   (let* ((scsh-version-dir (string-append "scsh-" scsh-version-string))
-         (base (absolute-file-name (package-full-name pkg)
+         (base (paths->file-name "share"
-                                   (paths->file-name "share"
+                                 scsh-version-dir
-                                                     scsh-version-dir
+                                 "modules"
-                                                     "modules"))))
+                                 (package-full-name pkg))))
     `((base        . ,base)
       (misc-shared . ,base)
       (scheme      . ,(absolute-file-name "scheme" base))
-      (lib         . ,(absolute-file-name (package-full-name pkg)
+      (lib         . ,(paths->file-name "lib"
-                                          (paths->file-name
+                                        scsh-version-dir
-                                           "lib" scsh-version-dir "modules")))
+                                        "modules"
-      (doc         . ,(absolute-file-name (package-full-name pkg)
+                                        (package-full-name pkg)))
-                                          (paths->file-name
+      (doc         . ,(paths->file-name "share"
-                                           "share" "doc" scsh-version-dir)))
+                                        "doc"
-      (active      . ,(paths->file-name
+                                        scsh-version-dir
-                       "share" scsh-version-dir "modules")))))
+                                        (package-full-name pkg)))
+      (active      . ,(paths->file-name "share"
+                                        scsh-version-dir
+                                        "modules")))))
+
+(define (fhs-program-layout pkg)
+  (let* ((pkg-share (paths->file-name "share" (package-full-name pkg))))
+    `((bin        . "bin")
+      (scheme     . ,(paths->file-name pkg-share "scheme"))
+      (doc        . ,(paths->file-name "share"
+                                       "doc"
+                                       (package-full-name pkg))))))
 
 (define predefined-layouts
-  `(("scsh"     . ,scsh-layout-1)
+  `(("scsh"        . ,scsh-layout-1)
-    ("scsh-alt" . ,scsh-layout-2)
+    ("scsh-alt"    . ,scsh-layout-2)
-    ("fhs"      . ,fhs-layout)))
+    ("fhs"         . ,fhs-layout)
+    ("fhs-program" . ,fhs-program-layout)))
 
 ;; If NAME-OR-LAYOUT refers to a predefined layout, return it.
 ;; Otherwise, if NAME-OR-LAYOUT is a valid layout definition, parse
@@ -430,7 +442,7 @@
   (alist-get ext (package-extensions pkg) #f))
 
 ;; List of all defined packages
-(define *packages* (make-fluid #f))
+(define *packages* (make-fluid (make-cell '())))
 
 ;; Add PKG to the above list of all defined packages.
 (define (add-package pkg)
@@ -446,6 +458,11 @@
                                 (cwd)
                                 (lambda () body ...))))))
 
+(define-syntax define-program
+  (syntax-rules ()
+    ((define-program name version extensions body ...)
+     (define-package name version extensions body ...))))
+
 ;; Load (and evaluate the contents of) the file "pkg-def.scm" in the
 ;; current directory and return the packages it defines.
 (define (load-packages)
@@ -455,25 +472,25 @@
                    (load-quietly package-definition-file))
                (cell-ref (fluid *packages*)))))
 
-;; Like load-package but check additionally that none of the loaded
+;; Check that the given package does not require a more recent version
-;; packages require a more recent version of the installation library,
+;; of the installation library, and fail if it is the case.
-;; and fail if it is the case.
+(define (check-package pkg)
+  (and-let* ((req-lst (package-extension pkg 'install-lib-version))
+             (req (first req-lst))
+             ((or (not (= (version-major req)
+                          (version-major install-lib-version)))
+                  (> (version-minor req)
+                     (version-minor install-lib-version)))))
+            (display-error-and-exit
+             "package "(package-name pkg)" needs a newer "
+             "version of install-lib: "(version->string req)"\n"
+             "(installed: " (version->string install-lib-version) ")")))
+
+;; Like load-package but additionally check loaded packages.
 (define (load&check-packages)
-  (let ((pkgs (load-packages)))
+  (and-let* ((pkgs (load-packages))
-    (for-each (lambda (pkg)
+             ((for-each check-package pkgs)))
-                (and-let*
+            pkgs))
-                 ((req-lst (package-extension pkg 'install-lib-version))
-                  (req (first req-lst))
-                  ((or (not (= (version-major req)
-                               (version-major install-lib-version)))
-                       (> (version-minor req)
-                          (version-minor install-lib-version)))))
-                 (display-error-and-exit
-                  "package "(package-name pkg)" needs a newer "
-                  "version of install-lib: "(version->string req)"\n"
-                  "(installed: " (version->string install-lib-version) ")")))
-              pkgs)
-    pkgs))
 
 (define (load-package-in dir)
   (with-cwd dir (load-quietly package-definition-file)))
@@ -784,7 +801,31 @@ advanced options:
 END
 )
 
+(define program-usage #<<END
+Usage: ~a [options]
+
+options:
+  -h, --help           display this help message, then exit
+  --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
+  --verbose            print messages about what is being done
+  --force              overwrite existing files during installation
+  --no-user-defaults   don't read user default from ~~/.scsh-pkg-defaults.scm
+
+advanced options:
+  --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
+  --dest-dir <dir>     specify prefix to used during installation
+                       (to be used only during staged installations)
+
+END
+)
+
 (define usage-descr-col 26)
+(define program-usage-descr-col 26)
 
 ;; Complete the above USAGE string to include information about the
 ;; package options PKG-OPTS.
@@ -806,9 +847,27 @@ END
      pkg-opts)
     (set! usage (string-output-port-output usage-port))))
 
+(define (complete-program-usage! pkg-opts)
+  (let ((usage-port (make-string-output-port)))
+    (write-string program-usage usage-port)
+    (write-string "\npackage-specific options:\n" usage-port)
+    (for-each
+     (lambda (pkg-opt)
+       (let ((option/arg (format #f "--~a ~a"
+                                 (pkg-opt-name pkg-opt)
+                                 (pkg-opt-arg-help pkg-opt))))
+         (format usage-port
+                 "  ~a~a~a [~a]\n"
+                 option/arg
+                 (spaces 2 (- program-usage-descr-col (string-length option/arg)))
+                 (pkg-opt-help pkg-opt)
+                 ((pkg-opt-show pkg-opt) (pkg-opt-default pkg-opt)))))
+     pkg-opts)
+    (set! program-usage (string-output-port-output usage-port))))
+
 ;; Display the usage string, then all MSGS on the standard output
 ;; port, then exit with an error code of 1.
-(define (display-usage-and-exit . msgs)
+(define (display-usage-and-exit usage . msgs)
   (format #t
           usage
           (car (command-line))
@@ -897,7 +956,7 @@ END
                                                   alist)))))
     (list
      (option '(#\h "help") #f #f
-             (lambda args (display-usage-and-exit)))
+             (lambda args (display-usage-and-exit usage)))
      (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))
@@ -916,15 +975,42 @@ END
      (option '("verbose") #f #t (alist-boolean-updater 'verbose))
      (option '("force") #f #t (alist-boolean-updater 'force)))))
 
+(define program-options
+  (let ((alist-arg-updater (lambda (key)
+                             (lambda (opt name arg alist)
+                               (alist-replace key arg alist))))
+        (alist-boolean-updater (lambda (key)
+                                 (lambda (opt name arg alist)
+                                   (alist-replace key
+                                                  (or (not arg)
+                                                      (parse-boolean arg))
+                                                  alist)))))
+    (list
+     (option '(#\h "help") #f #f
+             (lambda args (display-usage-and-exit program-usage)))
+     (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-to") #t #f (alist-arg-updater 'layout-to))
+     (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)))))
+
 (define no-user-defaults-option "--no-user-defaults")
 
-(define (parse-options args options defaults)
+(define (parse-options usage args options defaults)
   (args-fold args
              options
              (lambda (option name . rest)
-               (display-usage-and-exit "Unknown option "name))
+               (display-usage-and-exit usage "Unknown option "name))
              (lambda (operand . rest)
-               (display-usage-and-exit "Don't know what to do with " operand))
+               (display-usage-and-exit usage "Don't know what to do with " operand))
              defaults))
 
 ;; Return user-specific defaults.
@@ -955,6 +1041,19 @@ END
     (force           . #f)
     (exclude         . ,(lambda args #f))))
 
+(define program-options-defaults
+  `((prefix          . "/usr/local")
+    (dest-dir        . "/")
+    (layout          . "fhs-program")
+    (layout-to       . #f)
+    (build           . ,(host))
+    (non-shared-only . #f)
+    (inactive        . #t)
+    (dry-run         . #f)
+    (verbose         . #f)
+    (force           . #f)
+    (exclude         . ,(lambda args #f))))
+
 (define (install-main cmd-line)
   (let* ((packages (load&check-packages))
          (all-pkg-opts (all-package-options packages)))
@@ -967,7 +1066,8 @@ END
                                   (read-user-defaults))
                               options-defaults)
                              (map pkg-opt-key&default all-pkg-opts)))
-           (options-values (parse-options (delete no-user-defaults-option
+           (options-values (parse-options usage
+                                          (delete no-user-defaults-option
                                                   (cdr cmd-line))
                                           all-opts
                                           all-dfts))
@@ -990,3 +1090,34 @@ END
             (display-error-and-exit "invalid layout "layout))
         (install-packages packages options-values)
         (display-use-hint prefix resolved-layout packages)))))
+
+(define (install-program-main cmd-line)
+  (let* ((packages (cell-ref (fluid *packages*)))
+         (all-pkg-opts (all-package-options packages)))
+    (for-each check-package packages)
+    (if (not (null? all-pkg-opts))
+        (complete-program-usage! all-pkg-opts))
+    (let* ((all-opts (append program-options
+                             (map pkg-opt->option all-pkg-opts)))
+           (all-dfts (append (alist-combine
+                              (if (member no-user-defaults-option cmd-line)
+                                  '()
+                                  (read-user-defaults))
+                              program-options-defaults)
+                             (map pkg-opt-key&default all-pkg-opts)))
+           (options-values (parse-options program-usage
+                                          (delete no-user-defaults-option
+                                                  (cdr cmd-line))
+                                          all-opts
+                                          all-dfts))
+           (prefix (alist-get 'prefix options-values))
+           (layout (alist-get 'layout options-values)))
+      (if (null? packages)
+          (display-error-and-exit
+           "no package to install"))
+      (if (not (file-name-absolute? prefix))
+          (display-error-and-exit "prefix must be an absolute path"))
+      (let ((resolved-layout (resolve-layout layout)))
+        (if (not resolved-layout)
+            (display-error-and-exit "invalid layout "layout))
+        (install-packages packages options-values)))))