diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm index 008f175..16b6577 100755 --- a/scheme/install-lib/install-lib.scm +++ b/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) - (paths->file-name "share" - scsh-version-dir - "modules")))) + (base (paths->file-name "share" + scsh-version-dir + "modules" + (package-full-name pkg)))) `((base . ,base) (misc-shared . ,base) (scheme . ,(absolute-file-name "scheme" base)) - (lib . ,(absolute-file-name (package-full-name pkg) - (paths->file-name - "lib" scsh-version-dir "modules"))) - (doc . ,(absolute-file-name (package-full-name pkg) - (paths->file-name - "share" "doc" scsh-version-dir))) - (active . ,(paths->file-name - "share" scsh-version-dir "modules"))))) + (lib . ,(paths->file-name "lib" + scsh-version-dir + "modules" + (package-full-name pkg))) + (doc . ,(paths->file-name "share" + "doc" + scsh-version-dir + (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-alt" . ,scsh-layout-2) - ("fhs" . ,fhs-layout))) + `(("scsh" . ,scsh-layout-1) + ("scsh-alt" . ,scsh-layout-2) + ("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 -;; packages require a more recent version of the installation library, -;; and fail if it is the case. +;; Check that the given package does not require a more recent version +;; of the installation library, 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))) - (for-each (lambda (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) ")"))) - pkgs) - pkgs)) + (and-let* ((pkgs (load-packages)) + ((for-each check-package 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 #< specify directory where files are installed + --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 of platform for which to build + --layout-from load layout of installation directory from file + --layout-to output layout to given file + --dest-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)))))