- removed --layout-to,
- factored most of the code shared between program and "standard" installers
This commit is contained in:
michel-schinz
parent
4076ef436c
commit
2632b372c8
|
|
@ -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 #<<END
|
||||
Usage: ~a [options]
|
||||
;; Usage for all options. This also defines an order on options, and
|
||||
;; this order is used when displaying available options to the user.
|
||||
(define options-usage
|
||||
`(("help" #f "display this help message, then exit")
|
||||
("prefix" "dir" "specify directory where files are installed")
|
||||
("layout" "layout" ("specify layout of installation directory"
|
||||
,(string-append "(predefined: "
|
||||
(string-join
|
||||
(map car predefined-layouts)
|
||||
", ")
|
||||
")")))
|
||||
("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")
|
||||
|
||||
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
|
||||
--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> 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)
|
||||
(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 #<<END
|
||||
Usage: ~a [options]
|
||||
;; Return the usage string for an option with OPT-NAME as long name,
|
||||
;; and OPT-ARG as argument template. If OPT-ARG is #f, the option
|
||||
;; doesn't take an argument.
|
||||
(define (option/arg-usage opt-name opt-arg)
|
||||
(string-append "--" opt-name
|
||||
(if opt-arg (string-append " <" opt-arg ">") "")))
|
||||
|
||||
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
|
||||
;; 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> 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)
|
||||
;; 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,19 +923,17 @@ END
|
|||
(define (get-option-value key)
|
||||
(alist-get key (fluid *options-values*)))
|
||||
|
||||
(define options
|
||||
(let ((alist-arg-updater (lambda (key)
|
||||
(define (alist-arg-updater key)
|
||||
(lambda (opt name arg alist)
|
||||
(alist-replace key arg alist))))
|
||||
(alist-boolean-updater (lambda (key)
|
||||
(alist-replace key arg alist)))
|
||||
|
||||
(define (alist-boolean-updater key)
|
||||
(lambda (opt name arg alist)
|
||||
(alist-replace key
|
||||
(or (not arg)
|
||||
(parse-boolean 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 usage)))
|
||||
(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))
|
||||
|
|
@ -948,53 +943,35 @@ END
|
|||
(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))
|
||||
(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))
|
||||
(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 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)))))
|
||||
(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)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue