- added layouts, which means:
- removed query functions, which do not belong to the installation
library anyway, and which will have to be redone for layouts,
- replaced functions "package-installation-dir" and
"package-installation-staging-dir" by "get-directory",
- changed "install-file" & friends for layouts,
- added "install-directory-contents",
- rewrote option parsing code,
- slightly adapted David Frese's code.
This commit is contained in:
michel-schinz
parent
d6e62d6c6e
commit
c7eae30444
|
|
@ -1,16 +1,14 @@
|
|||
;;; Installation library for scsh modules.
|
||||
;;; $Id: install-lib.scm,v 1.2 2003/12/14 12:33:59 michel-schinz Exp $
|
||||
;;; $Id: install-lib.scm,v 1.3 2003/12/14 14:45:20 michel-schinz Exp $
|
||||
|
||||
;; TODO
|
||||
;; - copy symbolic links as such, do not duplicate contents,
|
||||
;; - add function to copy a directory contents,
|
||||
;; - 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
|
||||
;; - find out how to perform installation for several architectures
|
||||
;; - allow installation of platform-specific files only
|
||||
|
||||
;;
|
||||
;; Utilities
|
||||
|
|
@ -43,16 +41,17 @@
|
|||
(path-list->file-name (append (make-list (- (length dir-pl) cp-len) "..")
|
||||
(drop abs-pl cp-len))))))
|
||||
|
||||
(define (copy-file src target perms)
|
||||
(run (cp ,src ,target))
|
||||
(set-file-mode target perms))
|
||||
|
||||
(define (permissions->string perms)
|
||||
(let ((decode (lambda (mask str)
|
||||
(if (zero? (bitwise-and perms mask)) "-" str))))
|
||||
(string-append (decode #o400 "r") (decode #o200 "w") (decode #o100 "x")
|
||||
(decode #o040 "r") (decode #o020 "w") (decode #o010 "x")
|
||||
(decode #o004 "r") (decode #o002 "w") (decode #o001 "x"))))
|
||||
;; 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).
|
||||
(define (copy-file source target perms)
|
||||
(if (file-exists? target)
|
||||
(error "copy-file: target file exists" target))
|
||||
(if (file-symlink? source)
|
||||
(create-symlink (read-symlink source) target)
|
||||
(begin
|
||||
(run (cp ,source ,target))
|
||||
(set-file-mode target perms))))
|
||||
|
||||
;; Like "load" but without printing anything.
|
||||
(define load-quietly
|
||||
|
|
@ -61,6 +60,13 @@
|
|||
(call-with-input-file file-name
|
||||
(lambda (port) (port-fold port read eval #f))))))
|
||||
|
||||
(define (permissions->string perms)
|
||||
(let ((decode (lambda (mask str)
|
||||
(if (zero? (bitwise-and perms mask)) "-" str))))
|
||||
(string-append (decode #o400 "r") (decode #o200 "w") (decode #o100 "x")
|
||||
(decode #o040 "r") (decode #o020 "w") (decode #o010 "x")
|
||||
(decode #o004 "r") (decode #o002 "w") (decode #o001 "x"))))
|
||||
|
||||
;;
|
||||
;; Support for dry runs.
|
||||
;;
|
||||
|
|
@ -104,17 +110,6 @@
|
|||
(wrap-for-dry-run delete-file
|
||||
(lambda (fname) (dry-run-print "deleting file ~a" fname))))
|
||||
|
||||
;;
|
||||
;; Regular expressions to match package names
|
||||
;;
|
||||
|
||||
(define number-rx (rx (+ digit)))
|
||||
(define version-rx (rx ,number-rx (* "." ,number-rx)))
|
||||
(define package-name-rx (rx (+ (| alphanum ("_")))))
|
||||
(define package-full-name-rx (rx (submatch ,package-name-rx)
|
||||
"-"
|
||||
(submatch ,version-rx)))
|
||||
|
||||
;;
|
||||
;; Versions
|
||||
;;
|
||||
|
|
@ -142,6 +137,78 @@
|
|||
(define (version>? v1 v2) (eq? (version-compare v1 v2) 'greater))
|
||||
(define (version=? v1 v2) (eq? (version-compare v1 v2) 'equal))
|
||||
|
||||
;;
|
||||
;; Layouts
|
||||
;;
|
||||
|
||||
(define parse-layout
|
||||
(let ((split-defs (infix-splitter ","))
|
||||
(split-sides (infix-splitter "=")))
|
||||
(lambda (str)
|
||||
(map (lambda (name&value)
|
||||
(let ((name/value (split-sides name&value)))
|
||||
(cons (string->symbol (first name/value)) (second name/value))))
|
||||
(split-defs str)))))
|
||||
|
||||
;; Combine layouts L1 and L2 by adding to L1 all the additional
|
||||
;; mappings found in L2.
|
||||
(define (combine-layouts l1 l2)
|
||||
(fold (lambda (key/value layout)
|
||||
(if (assoc (car key/value) layout) layout (cons key/value layout)))
|
||||
l1
|
||||
l2))
|
||||
|
||||
;; Return an absolute version of LAYOUT by prepending PREFIX to all
|
||||
;; its components (which must be relative).
|
||||
(define (absolute-layout layout prefix)
|
||||
(map (lambda (key/value)
|
||||
(cons (car key/value) (absolute-file-name (cdr key/value) prefix)))
|
||||
layout))
|
||||
|
||||
(define (layout-dir layout dir)
|
||||
(cond ((assoc dir layout) => cdr)
|
||||
(else #f)))
|
||||
|
||||
;; Predefined layouts
|
||||
|
||||
(define (scsh-layout platform base)
|
||||
`((base . ,base)
|
||||
(misc-shared . ,base)
|
||||
(scheme . ,(absolute-file-name "scheme" base))
|
||||
(lib . ,(absolute-file-name
|
||||
(path-list->file-name (list "lib" platform))
|
||||
base))
|
||||
(doc . ,(absolute-file-name "doc" base))))
|
||||
|
||||
(define (scsh-layout-1 platform pkg)
|
||||
(combine-layouts '((active . "."))
|
||||
(scsh-layout platform (package-full-name pkg))))
|
||||
|
||||
(define (scsh-layout-2 platform pkg)
|
||||
(combine-layouts
|
||||
'((active . "active"))
|
||||
(scsh-layout platform
|
||||
(path-list->file-name
|
||||
(list "installed"
|
||||
(package-name pkg)
|
||||
(version->string (package-version pkg)))))))
|
||||
|
||||
(define (fhs-layout platform pkg)
|
||||
(let ((base (absolute-file-name (package-full-name pkg)
|
||||
"share/scsh/modules")))
|
||||
`((base . ,base)
|
||||
(misc-shared . ,base)
|
||||
(scheme . ,(absolute-file-name "scheme" base))
|
||||
(lib . ,(absolute-file-name (package-full-name pkg)
|
||||
"lib/scsh/modules"))
|
||||
(doc . ,(absolute-file-name (package-full-name pkg) "share/doc"))
|
||||
(active . "share/scsh/modules"))))
|
||||
|
||||
(define predefined-layouts
|
||||
`(("scsh" . ,scsh-layout-1)
|
||||
("scsh-alt" . ,scsh-layout-2)
|
||||
("fhs" . ,fhs-layout)))
|
||||
|
||||
;;
|
||||
;; Packages
|
||||
;;
|
||||
|
|
@ -149,10 +216,14 @@
|
|||
(define-record-type package
|
||||
(make-package name version extensions install-thunk)
|
||||
package?
|
||||
(name package:name)
|
||||
(version package:version)
|
||||
(extensions package:extensions)
|
||||
(install-thunk package:install-thunk))
|
||||
(name package-name)
|
||||
(version package-version)
|
||||
(extensions package-extensions)
|
||||
(install-thunk package-install-thunk))
|
||||
|
||||
(define (package-full-name pkg)
|
||||
(string-append
|
||||
(package-name pkg) "-" (version->string (package-version pkg))))
|
||||
|
||||
;; List of all defined packages
|
||||
(define packages '())
|
||||
|
|
@ -169,174 +240,95 @@
|
|||
(quote extensions)
|
||||
(lambda () body ...))))))
|
||||
|
||||
;;
|
||||
;; Names of various directories/links
|
||||
;;
|
||||
|
||||
;; Directory in which active versions of packages are "remembered".
|
||||
(define (active-directory root)
|
||||
(absolute-file-name "active" root))
|
||||
|
||||
;; Directory in which packages are installed.
|
||||
(define (installed-directory root)
|
||||
(absolute-file-name "installed" root))
|
||||
|
||||
(define (package-dir-name root pkg)
|
||||
(absolute-file-name (package:name pkg) (installed-directory root)))
|
||||
|
||||
(define (package-version-dir-name root pkg)
|
||||
(absolute-file-name (version->string (package:version pkg))
|
||||
(package-dir-name root pkg)))
|
||||
|
||||
(define (active-link-name root pkg)
|
||||
(absolute-file-name (package:name pkg) (active-directory root)))
|
||||
|
||||
;;
|
||||
;; Queries
|
||||
;;
|
||||
|
||||
(define (packages-of dir)
|
||||
(with-cwd dir (filter file-directory? (directory-files))))
|
||||
|
||||
;; Get the name of all installed packages (without versions) as a list
|
||||
;; of strings.
|
||||
(define (installed-packages root)
|
||||
(packages-of (installed-directory root)))
|
||||
|
||||
;; Get the name of all active packages (without versions) as a list of
|
||||
;; strings.
|
||||
(define (active-packages root)
|
||||
(packages-of (active-directory root)))
|
||||
|
||||
;; Return the list of all installed packages and their version(s), as
|
||||
;; a list of pairs. The CAR of each pair contains the name of the
|
||||
;; package, the CDR contains the list of all available versions.
|
||||
(define (installed-packages&versions root)
|
||||
(with-cwd (installed-directory root)
|
||||
(map (lambda (pkg-dir)
|
||||
(cons pkg-dir
|
||||
(map string->version (directory-files pkg-dir))))
|
||||
(directory-files))))
|
||||
|
||||
(define (read-version pkg-link)
|
||||
(string->version (file-name-nondirectory (read-symlink pkg-link))))
|
||||
|
||||
;; Return the list of all active packages and their version, as a list
|
||||
;; of pairs. The CAR of each pair contains the name of the package,
|
||||
;; and the CDR contains the active version.
|
||||
(define (active-packages&versions root)
|
||||
(with-cwd (active-directory root)
|
||||
(map (lambda (pkg-dir)
|
||||
(cons pkg-dir (read-version pkg-dir)))
|
||||
(directory-files))))
|
||||
|
||||
;; Return the active version of package NAME.
|
||||
(define (active-version root name)
|
||||
(read-version (absolute-file-name name (active-directory root))))
|
||||
|
||||
;;
|
||||
;; Actions
|
||||
;;
|
||||
|
||||
;; Perform all actions required to make the given version of the
|
||||
;; package active (i.e. the default version for that package).
|
||||
(define (activate-package root pkg)
|
||||
(let ((lnk-name (active-link-name root pkg)))
|
||||
(define (activate-package layout pkg)
|
||||
(let ((lnk-name (absolute-file-name (package-name pkg)
|
||||
(layout-dir layout 'active))))
|
||||
(if (and (file-exists? lnk-name) (file-symlink? lnk-name))
|
||||
(-delete-file lnk-name))
|
||||
(-create-symlink (relative-file-name (package-version-dir-name root pkg)
|
||||
(-create-symlink (relative-file-name (layout-dir layout 'base)
|
||||
(file-name-directory lnk-name))
|
||||
lnk-name)))
|
||||
|
||||
(define (target-absolute-dir root pkg dir)
|
||||
(absolute-file-name (directory-as-file-name dir)
|
||||
(package-version-dir-name root pkg)))
|
||||
(define (install-thing% layout name-or-pair location target-rel-dir perms)
|
||||
(let* ((target-dir (absolute-file-name target-rel-dir
|
||||
(layout-dir layout location)))
|
||||
(source (if (pair? name-or-pair) (car name-or-pair) name-or-pair))
|
||||
(target-name (file-name-nondirectory (if (pair? name-or-pair)
|
||||
(cdr name-or-pair)
|
||||
name-or-pair)))
|
||||
(target (absolute-file-name target-name target-dir)))
|
||||
(create-directory&parents target-dir perms)
|
||||
(cond ((or (file-regular? source) (file-symlink? source))
|
||||
(-copy-file source target perms))
|
||||
((file-directory? source)
|
||||
(create-directory target perms)
|
||||
(install-directory-contents% layout
|
||||
source
|
||||
location
|
||||
(absolute-file-name target-name
|
||||
target-rel-dir)
|
||||
perms))
|
||||
(else (error "cannot install file-system object" source)))))
|
||||
|
||||
(define (re-root-file file dir)
|
||||
(absolute-file-name (file-name-nondirectory (directory-as-file-name file))
|
||||
dir))
|
||||
(define (install-directory-contents% layout name location target-rel-dir perms)
|
||||
(for-each (lambda (thing)
|
||||
(install-thing% layout thing location target-rel-dir perms))
|
||||
(map (lambda (f) (absolute-file-name f name))
|
||||
(directory-files name #t))))
|
||||
|
||||
;; Copy the list of FILES to the TARGET-DIR and set their permission
|
||||
;; to PERMS. The TARGET-DIR (default ".") is relative to the package
|
||||
;; directory given by ROOT, NAME and VERSION.
|
||||
(define (install-files% root pkg files . rest)
|
||||
(let-optionals rest ((target-dir ".") (perms default-perms))
|
||||
(let* ((target-abs-dir (target-absolute-dir root pkg target-dir)))
|
||||
(create-directory&parents target-abs-dir perms)
|
||||
(for-each (lambda (file)
|
||||
(-copy-file file (re-root-file file target-abs-dir) perms))
|
||||
files))))
|
||||
(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)))
|
||||
|
||||
;; Copy SRC-DIR and all its contents in TARGET-DIR, and set the
|
||||
;; permission for everything to PERMS. The TARGET-DIR (default ".") is
|
||||
;; relative to the package directory given by ROOT, NAME and VERSION.
|
||||
(define (install-directory% root pkg src-dir . rest)
|
||||
(let-optionals rest ((target-dir ".") (perms default-perms))
|
||||
(let* ((src-dir-name (file-name-nondirectory
|
||||
(directory-as-file-name src-dir)))
|
||||
(full-target-dir (absolute-file-name src-dir-name target-dir))
|
||||
(target-abs-dir (target-absolute-dir root pkg full-target-dir)))
|
||||
(create-directory&parents target-abs-dir perms)
|
||||
(for-each
|
||||
(lambda (file)
|
||||
(let ((abs-file (absolute-file-name file src-dir)))
|
||||
(cond ((file-regular? abs-file)
|
||||
(-copy-file abs-file
|
||||
(absolute-file-name file target-abs-dir)
|
||||
perms))
|
||||
((file-directory? abs-file)
|
||||
(install-directory% root pkg abs-file full-target-dir perms))
|
||||
(else
|
||||
(display-error-and-exit "don't know what to do with file ~a"
|
||||
abs-file)))))
|
||||
(directory-files src-dir #t)))))
|
||||
(define (install-things names-or-pairs . rest)
|
||||
(for-each (lambda (name-or-pair)
|
||||
(apply install-thing name-or-pair rest))
|
||||
names-or-pairs))
|
||||
|
||||
(define (install-empty-directory% root pkg target-dir . rest)
|
||||
(define install-file install-thing)
|
||||
(define install-files install-things)
|
||||
(define install-directory install-thing)
|
||||
(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)))
|
||||
|
||||
(define (install-empty-directory% layout name location dir . rest)
|
||||
(let-optionals rest ((perms default-perms))
|
||||
(-create-directory (target-absolute-dir root pkg target-dir) perms)))
|
||||
(-create-directory (absolute-file-name dir (layout-dir layout location))
|
||||
perms)))
|
||||
|
||||
(define (install-empty-directory&parents% root pkg target-dir . rest)
|
||||
(define (install-empty-directory&parents% layout name location dir . rest)
|
||||
(let-optionals rest ((perms default-perms))
|
||||
(create-directory&parents (target-absolute-dir root pkg target-dir)
|
||||
perms)))
|
||||
(create-directory&parents
|
||||
(absolute-file-name dir (layout-dir layout location))
|
||||
perms)))
|
||||
|
||||
(define *root* (make-fluid #f))
|
||||
(define *dest-root* (make-fluid #f))
|
||||
(define *package* (make-fluid #f))
|
||||
(define *layout* (make-fluid #f))
|
||||
(define *install-layout* (make-fluid #f))
|
||||
|
||||
(define (package-installation-dir)
|
||||
(package-version-dir-name (fluid *root*) (fluid *package*)))
|
||||
(define (package-installation-staging-dir)
|
||||
(package-version-dir-name (fluid *dest-root*) (fluid *package*)))
|
||||
(define (get-directory location install?)
|
||||
(layout-dir (fluid (if install? *install-layout* *layout*)) location))
|
||||
|
||||
(define (forward-args-prepend-fluids target-fn args)
|
||||
(apply target-fn (fluid *dest-root*) (fluid *package*) args))
|
||||
|
||||
(define (install-file file . rest)
|
||||
(apply install-files (list file) rest))
|
||||
|
||||
(define (install-files . args)
|
||||
(forward-args-prepend-fluids install-files% args))
|
||||
|
||||
(define (install-empty-directory . args)
|
||||
(forward-args-prepend-fluids install-empty-directory% args))
|
||||
|
||||
(define (install-empty-directory&parents . args)
|
||||
(forward-args-prepend-fluids install-empty-directory&parents% args))
|
||||
|
||||
(define (install-directory . args)
|
||||
(forward-args-prepend-fluids install-directory% args))
|
||||
|
||||
(define (install-directories src-dirs . rest)
|
||||
(for-each (lambda (src-dir)
|
||||
(apply install-directory src-dir rest))
|
||||
src-dirs))
|
||||
|
||||
(define (install-package root dest-root pkg)
|
||||
(let-fluids *root* root
|
||||
*dest-root* dest-root
|
||||
*package* pkg
|
||||
(package:install-thunk pkg)))
|
||||
(define (install-package layout install-layout pkg)
|
||||
(let-fluids *layout* layout
|
||||
*install-layout* install-layout
|
||||
(package-install-thunk pkg)))
|
||||
|
||||
;;
|
||||
;; Error handling
|
||||
|
|
@ -349,63 +341,62 @@
|
|||
|
||||
(define usage #<<END
|
||||
Usage: ~a [options]
|
||||
-h, --help display this help message, then exit
|
||||
-r, --root <dir> specify root directory
|
||||
-n, --dry-run don't do anything, print what would have been done
|
||||
-i, --inactive 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
|
||||
--inactive don't activate package after installing it
|
||||
|
||||
advanced options:
|
||||
-d, --dest-root <dir> specify staging root directory
|
||||
--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
|
||||
--install-prefix <dir> specify prefix to used during installation
|
||||
(to be used only during staged installations)
|
||||
|
||||
END
|
||||
)
|
||||
|
||||
(define usage-description-column 26)
|
||||
|
||||
(define (complete-usage! optional-parts)
|
||||
(let ((usage-port (make-string-output-port)))
|
||||
(write-string usage usage-port)
|
||||
(write-string "\noptional parts:\n" usage-port)
|
||||
(for-each
|
||||
(lambda (part)
|
||||
(let* ((sname (symbol->string (optional-part:name part)))
|
||||
(pf (string-append " --with-" sname "=[yes|no]")))
|
||||
(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)
|
||||
(set! usage (string-output-port-output usage-port))))
|
||||
|
||||
(define (display-usage-and-exit msg . args)
|
||||
(if msg (begin (apply format #t msg args) (newline)))
|
||||
(format #t usage (car (command-line)))
|
||||
(display-optional-parts-usage)
|
||||
(format #t
|
||||
usage
|
||||
(car (command-line))
|
||||
(string-join (map car predefined-layouts) ", "))
|
||||
(exit 1))
|
||||
|
||||
(define (check-root-directory root)
|
||||
(for-each (lambda (dir)
|
||||
(if (not (and (file-exists? dir) (file-directory? dir)))
|
||||
(display-error-and-exit
|
||||
(string-append
|
||||
"directory ~a does not exist or is not a directory.\n"
|
||||
"It should be created before installing packages.")
|
||||
dir)))
|
||||
(list root (active-directory root) (installed-directory root))))
|
||||
|
||||
;;
|
||||
;; Command line parsing
|
||||
;;
|
||||
|
||||
(define options
|
||||
(list (option '(#\h "help") #f #f
|
||||
(lambda args
|
||||
(display-usage-and-exit #f)))
|
||||
(option '(#\r "root") #t #f
|
||||
(lambda (option name arg root dest-root activate? dry-run? opt-parts)
|
||||
(values arg dest-root activate? dry-run? opt-parts)))
|
||||
(option '(#\d "dest-root") #t #f
|
||||
(lambda (option name arg root dest-root activate? dry-run? opt-parts)
|
||||
(values root arg activate? dry-run? opt-parts)))
|
||||
(option '(#\n "dry-run") #f #f
|
||||
(lambda (option name arg root dest-root activate? dry-run? opt-parts)
|
||||
(values root dest-root activate? #t opt-parts)))
|
||||
(option '(#\i "inactive") #f #f
|
||||
(lambda (option name arg root dest-root activate? dry-run? opt-parts)
|
||||
(values root dest-root #f dry-run? opt-parts)))))
|
||||
|
||||
;;
|
||||
;; optional parts stuff
|
||||
;;
|
||||
|
||||
(define (booleanize s)
|
||||
(cond
|
||||
((string=? s "yes") #t)
|
||||
((string=? s "no") #f)
|
||||
(else (display-error-and-exit "unknown boolean value '~a'. Use 'yes' or 'no'." 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)
|
||||
(if b "yes" "no"))
|
||||
|
|
@ -417,7 +408,7 @@ END
|
|||
(if (null? packages)
|
||||
'()
|
||||
(let* ((p (car packages))
|
||||
(ext (package:extensions p))
|
||||
(ext (package-extensions p))
|
||||
(op (assq 'optional-parts ext)))
|
||||
(append (if op (cdr op) '())
|
||||
(get-all-optional-parts (cdr packages))))))
|
||||
|
|
@ -430,11 +421,9 @@ END
|
|||
(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
|
||||
(lambda (option name arg root dest-root activate? dry-run? opt-parts)
|
||||
(values root dest-root activate? dry-run?
|
||||
(cons (cons part-name (booleanize arg))
|
||||
opt-parts))))))
|
||||
(option (list (string-append "with-" (symbol->string part-name)))
|
||||
#t #f
|
||||
(optional-part-processor part-name))))
|
||||
parts))
|
||||
|
||||
(define (optional-parts-defaults parts)
|
||||
|
|
@ -442,27 +431,90 @@ END
|
|||
(cons (optional-part:name part) (optional-part:default part)))
|
||||
parts))
|
||||
|
||||
(define *all-optional-parts* (make-fluid '()))
|
||||
(define *optional-parts-alist* (make-fluid '()))
|
||||
|
||||
(define *usage-description-column* 25)
|
||||
|
||||
(define (display-optional-parts-usage)
|
||||
(display "\noptionals parts:\n")
|
||||
(map (lambda (part)
|
||||
(let* ((sname (symbol->string (optional-part:name part)))
|
||||
(pf (string-append " --with-" sname"=[yes|no]")))
|
||||
(display pf)
|
||||
(display (spaces 2 (- *usage-description-column* (string-length pf))))
|
||||
(display (optional-part:description part))
|
||||
(display (string-append " [" (unbooleanize (optional-part:default part)) "]"))
|
||||
(newline)))
|
||||
(fluid *all-optional-parts*)))
|
||||
|
||||
(define (with-optional-part? name)
|
||||
(cdr (assq name (fluid *optional-parts-alist*))))
|
||||
|
||||
;; main
|
||||
(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)))
|
||||
|
||||
(define package-definition-file "pkg-def.scm")
|
||||
|
||||
|
|
@ -470,40 +522,52 @@ END
|
|||
(fluid *dry-run*))
|
||||
|
||||
(define (install-main cmd-line)
|
||||
(let ((prog (car cmd-line))
|
||||
(args (cdr 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)
|
||||
(set-fluid! *all-optional-parts* (get-all-optional-parts packages))
|
||||
(receive (root maybe-dest-root activate? dry-run? opt-parts)
|
||||
(args-fold args
|
||||
(append options
|
||||
(optional-parts->options (fluid *all-optional-parts*)))
|
||||
(lambda (option name arg . seeds)
|
||||
(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 . seeds) ; operand
|
||||
(lambda (operand . rest)
|
||||
(display-usage-and-exit
|
||||
"Don't know what to do with ~a"
|
||||
operand))
|
||||
#f ; default root
|
||||
#f ; default dest-root
|
||||
#t ; default activation
|
||||
#f ; default dry run
|
||||
(optional-parts-defaults (fluid *all-optional-parts*)))
|
||||
(if (not root)
|
||||
(display-error-and-exit
|
||||
"No package root specified (use --root option)"))
|
||||
(let ((dest-root (or maybe-dest-root root)))
|
||||
(check-root-directory dest-root)
|
||||
(let-fluids *dry-run* dry-run?
|
||||
*optional-parts-alist* opt-parts
|
||||
(lambda ()
|
||||
(for-each
|
||||
(lambda (pkg)
|
||||
(install-package root dest-root pkg)
|
||||
(if activate?
|
||||
(activate-package dest-root pkg)))
|
||||
packages)))))))
|
||||
#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))
|
||||
|
||||
(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)))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue