diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm index 76d06b5..25044e9 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.20 2004/07/08 12:15:30 michel-schinz Exp $ +;;; $Id: install-lib.scm,v 1.21 2004/11/04 14:48:45 michel-schinz Exp $ ;; TODO ;; - think about --build: does it make sense? @@ -53,6 +53,9 @@ (define default-perms #o755) +;; Function composition (for functions with one argument) +(define (compose f g) (lambda (x) (f (g x)))) + ;; Fail if CONDITION is not true, displaying ERROR-MSG with ARGUMENTS. (define (assert condition error-msg . arguments) (if (not condition) @@ -74,9 +77,9 @@ (define (create-directory&parents fname . rest) (let-optionals rest ((perms default-perms)) (let ((parent (parent-directory fname))) - (if (not (file-exists? parent)) + (if (file-not-exists? parent) (apply create-directory&parents parent rest)) - (if (not (file-exists? fname)) + (if (file-not-exists? fname) (create-directory fname (get-perms perms (absolute-file-name fname))))))) @@ -153,14 +156,18 @@ ((not (null? rest)) (first rest)) (else (error "cannot find key in alist" key alist)))) +;; Display all arguments on the current output port. +(define (display-all . args) + (for-each display args)) + ;; Convert all arguments to strings using DISPLAY and concatenate the ;; result in a single string which is returned. (define (as-string . args) (call-with-string-output-port - (lambda (port) (for-each (lambda (arg) (display arg port)) args)))) + (lambda (port) (with-current-output-port port (apply display-all args))))) -;; Return a string of max(M,N) white spaces. -(define (spaces m n) (make-string (max m n) #\space)) +;; Return a string of N white spaces. +(define (spaces n) (make-string n #\space)) ;; ;; Support for dry runs / verbose operation. @@ -698,7 +705,6 @@ (dest-dir (alist-get 'dest-dir options-values)) (dest-prefix (and prefix (string-append dest-dir prefix))) (layout-fn (resolve-layout (alist-get 'layout options-values))) - (layout-to (alist-get 'layout-to 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)))) @@ -709,11 +715,6 @@ (let* ((rel-layout (layout-fn pkg)) (layout (absolute-layout rel-layout prefix)) (i-layout (absolute-layout rel-layout dest-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 (and activate? (not non-shared-only?)) (activate-package i-layout pkg)))) @@ -745,104 +746,100 @@ (newline) (exit 1)) -(define 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 - --inactive don't activate package after installing it - --non-shared-only only install platform-dependent files, if any - --force overwrite existing files during installation - --no-user-defaults don't read user default from ~~/.scsh-pkg-defaults.scm + ("non-shared-only" #f "only install platform-dependent files, if any") + ("force" #f "overwrite existing files during installation") + ("no-user-defaults" #f "don't read defaults from ~/.scsh-pkg-defaults.scm") + ;; advanced + ("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)")))) -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) +(define (sort-options options) + (filter-map (lambda (name) + (find (lambda (opt) (string=? (option-long-name opt) name)) + options)) + (map first options-usage))) -END -) +;; Return the long name of the given OPTION. It is an error if that +;; option doesn't have a long name. +(define (option-long-name option) + (first (filter string? (option-names option)))) -(define program-usage #<") ""))) -options: - -h, --help display this help message, then exit - --prefix 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 +;; Return the usage list for the given SRFI-37 OPTION. +(define (srfi-37-opt-usage option) + (let ((raw-usage (assoc (option-long-name option) options-usage))) + (cons (option/arg-usage (first raw-usage) (second raw-usage)) + (third raw-usage)))) -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) +;; Return the usage list for the given package OPTION. +(define (pkg-opt-usage option) + (cons (option/arg-usage (pkg-opt-name option) (pkg-opt-arg-help option)) + (string-append + (pkg-opt-help option) + " [" ((pkg-opt-show option) (pkg-opt-default option)) "]"))) -END -) +;; Return a complete usage string, considering the fact that the +;; script is called PROG-NAME and takes options BASE-OPTS (a list of +;; SRFI-37 options), and the package takes options PKG-OPTS (a list of +;; pkg-option records). +(define (build-usage-string prog-name base-opts pkg-opts) + (let* ((base-usages (map srfi-37-opt-usage (sort-options base-opts))) + (pkg-usages (map pkg-opt-usage pkg-opts)) + (max-arg-len (apply max (map (compose string-length car) + (append base-usages pkg-usages))))) + (with-current-output-port (make-string-output-port) + (display-all "Usage: "prog-name" [options]\n\n" + "options:\n") + (let ((format-usage + (lambda (usage-pair) + (let ((arg (car usage-pair)) (msg (cdr usage-pair))) + (display-all " " + arg + (spaces (+ 1 (- max-arg-len + (string-length arg)))) + (if (list? msg) (first msg) msg) + #\newline) + (if (list? msg) + (for-each (lambda (line) + (display-all (spaces (+ 3 max-arg-len)) + line + #\newline)) + (cdr msg))))))) + (for-each format-usage base-usages) + (if (not (null? pkg-usages)) + (begin + (display "\npackage-specific options:\n") + (for-each format-usage pkg-usages))) + (string-output-port-output (current-output-port)))))) -(define usage-descr-col 26) -(define program-usage-descr-col 26) +(define usage-string #f) -;; Complete the above USAGE string to include information about the -;; package options PKG-OPTS. -(define (complete-usage! pkg-opts) - (let ((usage-port (make-string-output-port))) - (write-string 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 (- 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! 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 usage . msgs) - (format #t - usage - (car (command-line)) - (string-join (map car predefined-layouts) ", ")) - (for-each display msgs) +;; Display the usage string, then exit with an error code of 1. +(define (display-usage-and-exit) + (display usage-string) (newline) (exit 1)) @@ -926,75 +923,55 @@ END (define (get-option-value key) (alist-get key (fluid *options-values*))) -(define 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 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 '("build") #t #f (alist-arg-updater 'build)) - (option '("non-shared-only") #f #t - (alist-boolean-updater 'non-shared-only)) - (option '("inactive") #f #t (alist-boolean-updater 'inactive)) - (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 (alist-arg-updater key) + (lambda (opt name arg alist) + (alist-replace key arg alist))) -(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 (alist-boolean-updater key) + (lambda (opt name arg alist) + (alist-replace key (or (not arg) (parse-boolean arg)) alist))) + +(define common-options + (list + (option '(#\h "help") #f #f (lambda args (display-usage-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)) + (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 '("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)))) + +(define lib-options + (list + (option '("build") #t #f (alist-arg-updater 'build)) + (option '("non-shared-only") #f #t + (alist-boolean-updater 'non-shared-only)) + (option '("inactive") #f #t (alist-boolean-updater 'inactive)))) (define no-user-defaults-option "--no-user-defaults") -(define (parse-options usage args options defaults) +(define (options pkg-kind) + (append (if (kind-lib? pkg-kind) lib-options '()) + common-options)) + +(define (parse-options args options defaults) (args-fold args options (lambda (option name . rest) - (display-usage-and-exit usage "Unknown option "name)) + (display-error-and-exit "Unknown option "name"\n" + "(use --help to get a list of " + "valid options)")) (lambda (operand . rest) - (display-usage-and-exit usage - "Don't know what to do with " - operand)) + (display-error-and-exit "Don't know what to do with "operand"\n" + "(use --help to get a list of " + "valid options)")) defaults)) ;; Return user-specific defaults. @@ -1012,27 +989,18 @@ END (eval (list 'quasiquote defaults) (interaction-environment))))) '()))) -(define options-defaults - `((prefix . #f) - (dest-dir . "") - (layout . "scsh") - (layout-to . #f) - (build . ,(host)) - (non-shared-only . #f) - (inactive . #f) - (dry-run . #f) - (verbose . #f) - (force . #f) - (exclude . ,(lambda args #f)))) +(define (kind-lib? pkg-kind) + (cond ((eq? pkg-kind 'library) #t) + ((eq? pkg-kind 'program) #f) + (else (error "invalid package kind" pkg-kind)))) -(define program-options-defaults - `((prefix . "/usr/local") +(define (options-defaults pkg-kind) + `((prefix . ,(if (kind-lib? pkg-kind) #f "/usr/local")) (dest-dir . "") - (layout . "fhs-program") - (layout-to . #f) + (layout . ,(if (kind-lib? pkg-kind) "scsh" "fhs-program")) (build . ,(host)) (non-shared-only . #f) - (inactive . #t) + (inactive . ,(not (kind-lib? pkg-kind))) (dry-run . #f) (verbose . #f) (force . #f) @@ -1049,29 +1017,29 @@ END packages)) (define (install-main-internal cmd-line display-hint?) - (let* ((packages (load&check-packages)) + (let* ((prog (file-name-nondirectory (car cmd-line))) + (args (cdr cmd-line)) + (packages (load&check-packages)) (all-pkg-opts (all-package-options packages))) - (if (not (null? all-pkg-opts)) - (complete-usage! all-pkg-opts)) - (let* ((all-opts (append options (map pkg-opt->option all-pkg-opts))) + (set! usage-string (build-usage-string prog + (options 'library) + all-pkg-opts)) + (let* ((all-opts (append (options 'library) + (map pkg-opt->option all-pkg-opts))) (all-dfts (append (alist-combine - (if (member no-user-defaults-option cmd-line) + (if (member no-user-defaults-option args) '() (read-user-defaults)) - options-defaults) + (options-defaults 'library)) (map pkg-opt-key&default all-pkg-opts))) - (options-values (parse-options usage - (delete no-user-defaults-option - (cdr cmd-line)) - all-opts - all-dfts)) + (options-values (parse-options args all-opts all-dfts)) (prefix (alist-get 'prefix options-values)) (layout (alist-get 'layout options-values)) (force? (alist-get 'force options-values))) (if (null? packages) (display-error-and-exit "no package to install" - (if (not (file-exists? package-definition-file)) + (if (file-not-exists? package-definition-file) (as-string "\n(cannot find file called \"" package-definition-file "\" in current directory)") @@ -1099,24 +1067,23 @@ END (install-main-internal cmd-line #t)) (define (install-program-main cmd-line) - (let* ((packages (cell-ref (fluid *packages*))) + (let* ((prog (file-name-nondirectory (car cmd-line))) + (args (cdr cmd-line)) + (packages (cell-ref (fluid *packages*))) (all-pkg-opts (all-package-options packages))) + (set! usage-string (build-usage-string prog + (options 'program) + all-pkg-opts)) (for-each check-package packages) - (if (not (null? all-pkg-opts)) - (complete-program-usage! all-pkg-opts)) - (let* ((all-opts (append program-options + (let* ((all-opts (append (options 'program) (map pkg-opt->option all-pkg-opts))) (all-dfts (append (alist-combine - (if (member no-user-defaults-option cmd-line) + (if (member no-user-defaults-option args) '() (read-user-defaults)) - program-options-defaults) + (options-defaults 'program)) (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)) + (options-values (parse-options args all-opts all-dfts)) (prefix (alist-get 'prefix options-values)) (layout (alist-get 'layout options-values)) (force? (alist-get 'force options-values)))