upgraded to newest install-lib version
This commit is contained in:
frese
parent
c4e7388406
commit
2eccfa3034
|
|
@ -1,5 +1,5 @@
|
|||
;;; Installation library for scsh modules.
|
||||
;;; $Id: install-lib-module.scm,v 1.2 2003/12/16 16:44:40 frese Exp $
|
||||
;;; $Id: install-lib-module.scm,v 1.3 2004/01/04 14:34:32 frese Exp $
|
||||
|
||||
;;; Interfaces
|
||||
|
||||
|
|
@ -19,10 +19,12 @@
|
|||
install-directories
|
||||
install-directory-contents
|
||||
|
||||
get-directory
|
||||
identity
|
||||
parse-boolean
|
||||
show-boolean
|
||||
|
||||
with-optional-part?
|
||||
is-running-dry?
|
||||
get-directory
|
||||
get-option-value
|
||||
|
||||
install-main))
|
||||
|
||||
|
|
|
|||
479
install-lib.scm
479
install-lib.scm
|
|
@ -1,14 +1,12 @@
|
|||
;;; Installation library for scsh modules.
|
||||
;;; $Id: install-lib.scm,v 1.2 2003/12/16 16:44:40 frese Exp $
|
||||
;;; $Id: install-lib.scm,v 1.3 2004/01/04 14:34:32 frese Exp $
|
||||
|
||||
;; TODO
|
||||
;; - add support for image creation,
|
||||
;; - add support to maintain a documentation index,
|
||||
;; - add "--mode" option to specify permissions for files/directories.
|
||||
;; - add "--verbose" to show whats being done.
|
||||
;; - add "--log" option to specify a log file.
|
||||
;; - decide what to do when target files already exist
|
||||
;; - allow installation of platform-specific files only
|
||||
|
||||
;;
|
||||
;; Utilities
|
||||
|
|
@ -16,9 +14,11 @@
|
|||
|
||||
(define default-perms #o755)
|
||||
|
||||
;; Return the name of the parent directory of FNAME.
|
||||
(define (parent-directory fname)
|
||||
(file-name-directory (directory-as-file-name fname)))
|
||||
|
||||
;; Create directory FNAME and all its parents, as needed.
|
||||
(define (create-directory&parents fname . rest)
|
||||
(let-optionals rest ((perms default-perms))
|
||||
(let ((parent (parent-directory fname)))
|
||||
|
|
@ -27,12 +27,16 @@
|
|||
(if (not (file-exists? fname))
|
||||
(-create-directory fname perms)))))
|
||||
|
||||
;; Return the length of the longest prefix common to lists L1 and L2,
|
||||
;; by comparing elements using PRED (defaults to EQUAL?).
|
||||
(define (common-prefix-length l1 l2 . rest)
|
||||
(let-optionals rest ((pred equal?))
|
||||
(if (or (null? l1) (null? l2) (not (pred (first l1) (first l2))))
|
||||
0
|
||||
(+ 1 (apply common-prefix-length (cdr l1) (cdr l2) rest)))))
|
||||
|
||||
;; Return the name of file NAME relative to DIR (defaults to current
|
||||
;; directory).
|
||||
(define (relative-file-name name . rest)
|
||||
(let-optionals rest ((dir (cwd)))
|
||||
(let* ((abs-pl (split-file-name (absolute-file-name name)))
|
||||
|
|
@ -41,6 +45,15 @@
|
|||
(path-list->file-name (append (make-list (- (length dir-pl) cp-len) "..")
|
||||
(drop abs-pl cp-len))))))
|
||||
|
||||
;; Return the name of FNAME, which must be absolute, with NEW-ROOT as
|
||||
;; root.
|
||||
(define (re-root-file-name fname new-root)
|
||||
(let ((fname-pl (split-file-name fname))
|
||||
(new-root-pl (split-file-name new-root)))
|
||||
(if (string=? (first fname-pl) "")
|
||||
(path-list->file-name (append new-root-pl (cdr fname-pl)))
|
||||
(error "no root to replace in relative file name" fname))))
|
||||
|
||||
;; Copy file/symlink SOURCE to TARGET and set the permisions of TARGET
|
||||
;; to PERMS. TARGET must be the name of a non-existing file (i.e. it
|
||||
;; cannot be the name of a directory).
|
||||
|
|
@ -67,15 +80,27 @@
|
|||
(decode #o040 "r") (decode #o020 "w") (decode #o010 "x")
|
||||
(decode #o004 "r") (decode #o002 "w") (decode #o001 "x"))))
|
||||
|
||||
;; Replace all bindings of KEY in ALIST with one binding KEY to DATUM.
|
||||
(define (alist-replace key datum alist)
|
||||
(alist-cons key datum (alist-delete key alist)))
|
||||
|
||||
;; Return the value associated with KEY in ALIST. If none exists,
|
||||
;; return DEFAULT, or signal an error if no DEFAULT was given.
|
||||
(define (alist-get key alist . rest)
|
||||
(cond ((assoc key alist) => cdr)
|
||||
((not (null? rest)) (first rest))
|
||||
(else (error "internal error: cannot find key in alist" key alist))))
|
||||
|
||||
;; Return a string of max(M,N) white spaces.
|
||||
(define (spaces m n) (make-string (max m n) #\space))
|
||||
|
||||
;;
|
||||
;; Support for dry runs.
|
||||
;;
|
||||
|
||||
(define *dry-run* (make-fluid #f))
|
||||
|
||||
(define (wrap-for-dry-run real-fn dry-fn)
|
||||
(lambda args
|
||||
(apply (if (fluid *dry-run*) dry-fn real-fn) args)))
|
||||
(apply (if (get-option-value 'dry-run) dry-fn real-fn) args)))
|
||||
|
||||
(define (dry-run-print msg . args)
|
||||
(apply format #t msg args) (newline))
|
||||
|
|
@ -116,14 +141,20 @@
|
|||
;; Versions are represented as lists of integers, the most significant
|
||||
;; being at the head.
|
||||
|
||||
;; Return the printed representation of VERSION.
|
||||
(define (version->string version)
|
||||
(string-join (map number->string version) "."))
|
||||
|
||||
;; Convert the printed representation of a version found in
|
||||
;; VERSION-STRING to the version it represents.
|
||||
(define string->version
|
||||
(let ((split-version (infix-splitter ".")))
|
||||
(lambda (version-string)
|
||||
(map string->number (split-version version-string)))))
|
||||
|
||||
;; Compare two versions lexicographically and return the symbol
|
||||
;; 'smaller if the first is strictly smaller than the second, 'equal
|
||||
;; if both are equal, and 'greater otherwise.
|
||||
(define (version-compare v1 v2)
|
||||
(cond ((and (null? v1) (null? v2)) 'equal)
|
||||
((null? v1) 'smaller)
|
||||
|
|
@ -141,6 +172,28 @@
|
|||
;; Layouts
|
||||
;;
|
||||
|
||||
;; Names of all shared locations (i.e. the ones which do not depend on
|
||||
;; the platform).
|
||||
(define shared-locations
|
||||
'(active base misc-shared scheme doc))
|
||||
|
||||
;; Names of all non-shared (i.e. platform-dependent) locations.
|
||||
(define non-shared-locations
|
||||
'(lib))
|
||||
|
||||
;; All locations defined for a layout.
|
||||
(define all-locations (append shared-locations non-shared-locations))
|
||||
|
||||
;; Return true iff the given location is "active", that is if files
|
||||
;; should be installed in it.
|
||||
(define (active-location? location)
|
||||
(member location (if (get-option-value 'non-shared-only)
|
||||
non-shared-locations
|
||||
all-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
|
||||
;; sign and the name of the directory to associate to the location.
|
||||
(define parse-layout
|
||||
(let ((split-defs (infix-splitter ","))
|
||||
(split-sides (infix-splitter "=")))
|
||||
|
|
@ -165,9 +218,9 @@
|
|||
(cons (car key/value) (absolute-file-name (cdr key/value) prefix)))
|
||||
layout))
|
||||
|
||||
(define (layout-dir layout dir)
|
||||
(cond ((assoc dir layout) => cdr)
|
||||
(else #f)))
|
||||
;; Return the directory associated with the LOCATION in LAYOUT.
|
||||
(define (layout-dir layout location)
|
||||
(alist-get location layout #f))
|
||||
|
||||
;; Predefined layouts
|
||||
|
||||
|
|
@ -175,9 +228,7 @@
|
|||
`((base . ,base)
|
||||
(misc-shared . ,base)
|
||||
(scheme . ,(absolute-file-name "scheme" base))
|
||||
(lib . ,(absolute-file-name
|
||||
(path-list->file-name (list "lib" platform))
|
||||
base))
|
||||
(lib . ,(absolute-file-name "lib" base))
|
||||
(doc . ,(absolute-file-name "doc" base))))
|
||||
|
||||
(define (scsh-layout-1 platform pkg)
|
||||
|
|
@ -221,14 +272,20 @@
|
|||
(extensions package-extensions)
|
||||
(install-thunk package-install-thunk))
|
||||
|
||||
;; Return the full name of PKG.
|
||||
(define (package-full-name pkg)
|
||||
(string-append
|
||||
(package-name pkg) "-" (version->string (package-version pkg))))
|
||||
|
||||
;; Return the value of extension called EXT for PKG. If such an
|
||||
;; extension doesn't exist, return #f.
|
||||
(define (package-extension pkg ext)
|
||||
(alist-get ext (package-extensions pkg) #f))
|
||||
|
||||
;; List of all defined packages
|
||||
(define packages '())
|
||||
|
||||
;; Add a package to the above list
|
||||
;; Add PKG to the above list of all defined packages.
|
||||
(define (add-package pkg)
|
||||
(set! packages (cons pkg packages)))
|
||||
|
||||
|
|
@ -237,9 +294,80 @@
|
|||
((define-package name version extensions body ...)
|
||||
(add-package (make-package name
|
||||
(quote version)
|
||||
(quote extensions)
|
||||
(quasiquote extensions)
|
||||
(lambda () body ...))))))
|
||||
|
||||
;;
|
||||
;; Package options
|
||||
;;
|
||||
|
||||
(define-record-type pkg-opt
|
||||
(really-make-pkg-opt key
|
||||
help
|
||||
arg-help
|
||||
required-arg?
|
||||
optional-arg?
|
||||
default
|
||||
parse
|
||||
show
|
||||
transform)
|
||||
pkg-opt?
|
||||
(key pkg-opt-key)
|
||||
(help pkg-opt-help)
|
||||
(arg-help pkg-opt-arg-help)
|
||||
(required-arg? pkg-opt-required-arg?)
|
||||
(optional-arg? pkg-opt-optional-arg?)
|
||||
(default pkg-opt-default)
|
||||
(parse pkg-opt-parse)
|
||||
(show pkg-opt-show)
|
||||
(transform pkg-opt-transform))
|
||||
|
||||
(define (make-pkg-opt key help arg-help req-arg? opt-arg? default . rest)
|
||||
(let-optionals rest ((parse identity)
|
||||
(show identity)
|
||||
(transform (lambda (old new) new)))
|
||||
(really-make-pkg-opt key
|
||||
help
|
||||
arg-help
|
||||
req-arg?
|
||||
opt-arg?
|
||||
default
|
||||
parse
|
||||
show
|
||||
transform)))
|
||||
|
||||
;; Return the name of PKG-OPT
|
||||
(define (pkg-opt-name pkg-opt)
|
||||
(symbol->string (pkg-opt-key pkg-opt)))
|
||||
|
||||
;; Convert PKG-OPT into an SRFI-37 option.
|
||||
(define (pkg-opt->option pkg-opt)
|
||||
(let ((key (pkg-opt-key pkg-opt))
|
||||
(transform (pkg-opt-transform pkg-opt))
|
||||
(parse (pkg-opt-parse pkg-opt)))
|
||||
(option (list (pkg-opt-name pkg-opt))
|
||||
(pkg-opt-required-arg? pkg-opt)
|
||||
(pkg-opt-optional-arg? pkg-opt)
|
||||
(lambda (opt name arg alist)
|
||||
(alist-replace key
|
||||
(transform (alist-get key alist) (parse arg))
|
||||
alist)))))
|
||||
|
||||
;; Return a pair (key, default) which associates the default value of
|
||||
;; PKG-OPT to its key.
|
||||
(define (pkg-opt-key&default pkg-opt)
|
||||
(cons (pkg-opt-key pkg-opt) (pkg-opt-default pkg-opt)))
|
||||
|
||||
;; Return the list of all package options of the PACKAGES.
|
||||
(define (all-package-options packages)
|
||||
(append-map
|
||||
(lambda (pkg)
|
||||
(cond ((package-extension pkg 'options)
|
||||
=> (lambda (opts)
|
||||
(map (lambda (args) (apply make-pkg-opt args)) opts)))
|
||||
(else '())))
|
||||
packages))
|
||||
|
||||
;;
|
||||
;; Actions
|
||||
;;
|
||||
|
|
@ -267,7 +395,7 @@
|
|||
(cond ((or (file-regular? source) (file-symlink? source))
|
||||
(-copy-file source target perms))
|
||||
((file-directory? source)
|
||||
(create-directory target perms)
|
||||
(-create-directory target perms)
|
||||
(install-directory-contents% layout
|
||||
source
|
||||
location
|
||||
|
|
@ -283,12 +411,13 @@
|
|||
(directory-files name #t))))
|
||||
|
||||
(define (install-thing name-or-pair location . rest)
|
||||
(let-optionals rest ((target-rel-dir ".") (perms default-perms))
|
||||
(install-thing% (fluid *install-layout*)
|
||||
name-or-pair
|
||||
location
|
||||
target-rel-dir
|
||||
perms)))
|
||||
(if (active-location? location)
|
||||
(let-optionals rest ((target-rel-dir ".") (perms default-perms))
|
||||
(install-thing% (fluid *install-layout*)
|
||||
name-or-pair
|
||||
location
|
||||
target-rel-dir
|
||||
perms))))
|
||||
|
||||
(define (install-things names-or-pairs . rest)
|
||||
(for-each (lambda (name-or-pair)
|
||||
|
|
@ -301,12 +430,13 @@
|
|||
(define install-directories install-things)
|
||||
|
||||
(define (install-directory-contents name location . rest)
|
||||
(let-optionals rest ((target-rel-dir ".") (perms default-perms))
|
||||
(install-directory-contents% (fluid *install-layout*)
|
||||
name
|
||||
location
|
||||
target-rel-dir
|
||||
perms)))
|
||||
(if (active-location? location)
|
||||
(let-optionals rest ((target-rel-dir ".") (perms default-perms))
|
||||
(install-directory-contents% (fluid *install-layout*)
|
||||
name
|
||||
location
|
||||
target-rel-dir
|
||||
perms))))
|
||||
|
||||
(define (install-empty-directory% layout name location dir . rest)
|
||||
(let-optionals rest ((perms default-perms))
|
||||
|
|
@ -322,9 +452,17 @@
|
|||
(define *layout* (make-fluid #f))
|
||||
(define *install-layout* (make-fluid #f))
|
||||
|
||||
;; Return the directory identified by LOCATION in the current layout.
|
||||
;; If INSTALL? is true, return the directory valid during the
|
||||
;; installation of the package, otherwise return the directory valid
|
||||
;; after installation (i.e. during package use).
|
||||
(define (get-directory location install?)
|
||||
(layout-dir (fluid (if install? *install-layout* *layout*)) location))
|
||||
|
||||
;; Perform all actions to install PKG in INSTALL-LAYOUT. If LAYOUT is
|
||||
;; not the same as INSTALL-LAYOUT, assume that some external tool will
|
||||
;; move the installed files so that they are laid out according to
|
||||
;; LAYOUT.
|
||||
(define (install-package layout install-layout pkg)
|
||||
(let-fluids *layout* layout
|
||||
*install-layout* install-layout
|
||||
|
|
@ -334,6 +472,8 @@
|
|||
;; Error handling
|
||||
;;
|
||||
|
||||
;; Display MSG (a format string with ARGS as arguments) on the error
|
||||
;; port, then exit with an error code of 1.
|
||||
(define (display-error-and-exit msg . args)
|
||||
(apply format (current-error-port) (string-append "Error: " msg) args)
|
||||
(newline)
|
||||
|
|
@ -349,6 +489,7 @@ options:
|
|||
(predefined: ~a)
|
||||
--dry-run don't do anything, print what would have been done
|
||||
--inactive don't activate package after installing it
|
||||
--non-shared-only only install platform-dependent files, if any
|
||||
|
||||
advanced options:
|
||||
--build <name> name of platform for which to build
|
||||
|
|
@ -360,214 +501,150 @@ advanced options:
|
|||
END
|
||||
)
|
||||
|
||||
(define usage-description-column 26)
|
||||
(define usage-descr-col 26)
|
||||
|
||||
(define (complete-usage! optional-parts)
|
||||
;; 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 "\noptional parts:\n" usage-port)
|
||||
(write-string "\npackage-specific options:\n" usage-port)
|
||||
(for-each
|
||||
(lambda (part)
|
||||
(let* ((sname (symbol->string (optional-part:name part)))
|
||||
(pf (string-append " --with-" sname "=[yes|no]")))
|
||||
(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"
|
||||
pf
|
||||
(spaces 2 (- usage-description-column
|
||||
(string-length pf)))
|
||||
(optional-part:description part)
|
||||
(unbooleanize (optional-part:default part)))))
|
||||
optional-parts)
|
||||
" ~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))))
|
||||
|
||||
;; Display the usage string, then MSG (a format string with ARGS as
|
||||
;; arguments) on the standard output port, then exit with an error
|
||||
;; code of 1.
|
||||
(define (display-usage-and-exit msg . args)
|
||||
(if msg (begin (apply format #t msg args) (newline)))
|
||||
(format #t
|
||||
usage
|
||||
(car (command-line))
|
||||
(string-join (map car predefined-layouts) ", "))
|
||||
(if msg (begin (apply format #t msg args) (newline)))
|
||||
(exit 1))
|
||||
|
||||
;;
|
||||
;; Command line parsing
|
||||
;;
|
||||
|
||||
(define (booleanize s)
|
||||
;; Predefined parsers/unparsers
|
||||
(define (parse-boolean s)
|
||||
(cond ((string=? s "yes") #t)
|
||||
((string=? s "no") #f)
|
||||
(else (display-error-and-exit
|
||||
"unknown boolean value '~a'. Use 'yes' or 'no'." s))))
|
||||
|
||||
(define (unbooleanize b)
|
||||
(define (show-boolean b)
|
||||
(if b "yes" "no"))
|
||||
|
||||
(define (spaces min n)
|
||||
(make-string (if (< n min) min n) #\space))
|
||||
;; The identity function, sometimes useful for parsers/unparsers.
|
||||
(define (identity x) x)
|
||||
|
||||
(define (get-all-optional-parts packages)
|
||||
(if (null? packages)
|
||||
'()
|
||||
(let* ((p (car packages))
|
||||
(ext (package-extensions p))
|
||||
(op (assq 'optional-parts ext)))
|
||||
(append (if op (cdr op) '())
|
||||
(get-all-optional-parts (cdr packages))))))
|
||||
|
||||
(define optional-part:name car)
|
||||
(define optional-part:description cadr)
|
||||
(define (optional-part:default part)
|
||||
(if (null? (cddr part)) #f (caddr part)))
|
||||
|
||||
(define (optional-parts->options parts)
|
||||
(map (lambda (part)
|
||||
(let ((part-name (optional-part:name part)))
|
||||
(option (list (string-append "with-" (symbol->string part-name)))
|
||||
#t #f
|
||||
(optional-part-processor part-name))))
|
||||
parts))
|
||||
|
||||
(define (optional-parts-defaults parts)
|
||||
(map (lambda (part)
|
||||
(cons (optional-part:name part) (optional-part:default part)))
|
||||
parts))
|
||||
|
||||
(define *optional-parts-alist* (make-fluid '()))
|
||||
|
||||
(define (with-optional-part? name)
|
||||
(cdr (assq name (fluid *optional-parts-alist*))))
|
||||
|
||||
(define (process-option opt
|
||||
name
|
||||
arg
|
||||
prefix
|
||||
i-prefix
|
||||
layout
|
||||
layout-file
|
||||
build
|
||||
activate?
|
||||
dry-run?
|
||||
opt-parts)
|
||||
(case (cdr (assoc opt options/keys))
|
||||
((prefix)
|
||||
(values arg i-prefix layout layout-file build activate? dry-run? opt-parts))
|
||||
((i-prefix)
|
||||
(values prefix arg layout layout-file build activate? dry-run? opt-parts))
|
||||
((layout)
|
||||
(values prefix
|
||||
i-prefix
|
||||
(cond ((assoc arg predefined-layouts) => cdr)
|
||||
(else (parse-layout arg)))
|
||||
layout-file
|
||||
build
|
||||
activate?
|
||||
dry-run?
|
||||
opt-parts))
|
||||
((layout-from)
|
||||
(values prefix
|
||||
i-prefix
|
||||
(let ((layout (call-with-input-file arg read)))
|
||||
(lambda args layout))
|
||||
layout-file
|
||||
build
|
||||
activate?
|
||||
dry-run?
|
||||
opt-parts))
|
||||
((layout-to)
|
||||
(values prefix i-prefix layout arg build activate? dry-run? opt-parts))
|
||||
((build)
|
||||
(values prefix i-prefix layout layout-file arg activate? dry-run? opt-parts))
|
||||
((inactive)
|
||||
(values prefix i-prefix layout layout-file build #f dry-run? opt-parts))
|
||||
((dry-run)
|
||||
(values prefix i-prefix layout layout-file build activate? #t opt-parts))
|
||||
((help)
|
||||
(display-usage-and-exit #f))))
|
||||
|
||||
(define (optional-part-processor part-name)
|
||||
(lambda (opt
|
||||
name
|
||||
arg
|
||||
prefix
|
||||
i-prefix
|
||||
layout
|
||||
layout-file
|
||||
build
|
||||
activate?
|
||||
dry-run?
|
||||
opt-parts)
|
||||
(values prefix
|
||||
i-prefix
|
||||
layout
|
||||
layout-file
|
||||
build
|
||||
activate?
|
||||
dry-run?
|
||||
(alist-cons part-name (booleanize arg) opt-parts))))
|
||||
|
||||
(define options/keys
|
||||
(list
|
||||
(cons (option '(#\h "help") #f #f process-option) 'help)
|
||||
(cons (option '("prefix") #t #f process-option) 'prefix)
|
||||
(cons (option '("install-prefix") #t #f process-option) 'i-prefix)
|
||||
(cons (option '("layout") #t #f process-option) 'layout)
|
||||
(cons (option '("layout-from") #t #f process-option) 'layout-from)
|
||||
(cons (option '("layout-to") #t #f process-option) 'layout-to)
|
||||
(cons (option '("build") #t #f process-option) 'build)
|
||||
(cons (option '("inactive") #f #f process-option) 'inactive)
|
||||
(cons (option '("dry-run") #f #f process-option) 'dry-run)))
|
||||
;; Fluid containing the value of all options.
|
||||
(define *options-values* (make-fluid #f))
|
||||
|
||||
(define package-definition-file "pkg-def.scm")
|
||||
|
||||
(define (is-running-dry?)
|
||||
(fluid *dry-run*))
|
||||
(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 #t alist)))))
|
||||
(list
|
||||
(option '(#\h "help") #f #f
|
||||
(lambda args (display-usage-and-exit #f)))
|
||||
(option '("prefix") #t #f (alist-arg-updater 'prefix))
|
||||
(option '("dest-dir") #t #f (alist-arg-updater 'dest-dir))
|
||||
(option '("layout") #t #f
|
||||
(lambda (opt name arg alist)
|
||||
(alist-replace 'layout
|
||||
(cond ((assoc arg predefined-layouts) => cdr)
|
||||
(else (parse-layout arg)))
|
||||
alist)))
|
||||
(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 #f
|
||||
(alist-boolean-updater 'non-shared-only))
|
||||
(option '("inactive") #f #f (alist-boolean-updater 'inactive))
|
||||
(option '("dry-run") #f #f (alist-boolean-updater 'dry-run)))))
|
||||
|
||||
(define options-defaults
|
||||
`((prefix . #f)
|
||||
(dest-dir . "/")
|
||||
(layout . ,scsh-layout-1)
|
||||
(layout-to . #f)
|
||||
(build . ,(host))
|
||||
(non-shared-only . #f)
|
||||
(inactive . #f)
|
||||
(dry-run . #f)))
|
||||
|
||||
(define (parse-options args options defaults)
|
||||
(args-fold args
|
||||
options
|
||||
(lambda (option name . rest)
|
||||
(display-usage-and-exit "Unknown option ~a" name))
|
||||
(lambda (operand . rest)
|
||||
(display-usage-and-exit "Don't know what to do with ~a"
|
||||
operand))
|
||||
defaults))
|
||||
|
||||
(define (install-main cmd-line)
|
||||
(if (not (file-exists? package-definition-file))
|
||||
(display-error-and-exit "cannot find package definition file (~a)"
|
||||
package-definition-file))
|
||||
(load-quietly package-definition-file)
|
||||
(let ((all-optional-parts (get-all-optional-parts packages)))
|
||||
(if (not (null? all-optional-parts))
|
||||
(complete-usage! all-optional-parts))
|
||||
(receive (prefix maybe-i-prefix layout-fn layout-to build activate? dry-run? opt-parts)
|
||||
(args-fold (cdr cmd-line)
|
||||
(append (map car options/keys)
|
||||
(optional-parts->options all-optional-parts))
|
||||
(lambda (option name . rest)
|
||||
(display-usage-and-exit "Unknown option ~a" name))
|
||||
(lambda (operand . rest)
|
||||
(display-usage-and-exit
|
||||
"Don't know what to do with ~a"
|
||||
operand))
|
||||
#f ; default prefix
|
||||
#f ; default install-prefix
|
||||
scsh-layout-1 ; default layout-fn
|
||||
#f ; default layout-to
|
||||
(host) ; default build platform
|
||||
#t ; default activation
|
||||
#f ; default dry run
|
||||
(optional-parts-defaults all-optional-parts))
|
||||
|
||||
(let ((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)))
|
||||
(all-dfts (append options-defaults
|
||||
(map pkg-opt-key&default all-pkg-opts)))
|
||||
(options-values (parse-options (cdr cmd-line) all-opts all-dfts))
|
||||
(prefix (alist-get 'prefix options-values))
|
||||
(dest-dir (alist-get 'dest-dir options-values))
|
||||
(dest-prefix (and prefix (re-root-file-name prefix dest-dir)))
|
||||
(layout-fn (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))))
|
||||
(if (not prefix)
|
||||
(display-error-and-exit "no prefix specified (use --prefix option)"))
|
||||
(let ((i-prefix (or maybe-i-prefix prefix)))
|
||||
(if (not (and (file-exists? i-prefix) (file-directory? i-prefix)))
|
||||
(display-error-and-exit "install prefix directory ~a doesn't exist"
|
||||
i-prefix))
|
||||
(let-fluids *dry-run* dry-run?
|
||||
*optional-parts-alist* opt-parts
|
||||
(lambda ()
|
||||
(for-each
|
||||
(lambda (pkg)
|
||||
(let* ((rel-layout (layout-fn build pkg))
|
||||
(layout (absolute-layout rel-layout prefix))
|
||||
(i-layout (absolute-layout rel-layout i-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 activate? (activate-package i-layout pkg))))
|
||||
packages)))))))
|
||||
(let-fluids *options-values* options-values
|
||||
(lambda ()
|
||||
(for-each
|
||||
(lambda (pkg)
|
||||
(let* ((rel-layout (layout-fn build 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))))
|
||||
packages))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue