scsh-conservatory
/
scsh-install-lib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- added --version option, 

- added --phases option (which subsumes --install-only and
  --build-only),
This commit is contained in:
michel-schinz 2004-11-05 18:16:08 +00:00
parent 2632b372c8
commit 929849b330
1 changed files with 70 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
scheme/install-lib/install-lib.scm
View File

@ -1,5 +1,5 @@
;;; Installation library for scsh modules.
;;; $Id: install-lib.scm,v 1.21 2004/11/04 14:48:45 michel-schinz Exp $
;;; $Id: install-lib.scm,v 1.22 2004/11/05 18:16:08 michel-schinz Exp $
;; TODO
;; - think about --build: does it make sense?
@ -262,6 +262,31 @@
(define (version>? v1 v2) (eq? (version-compare v1 v2) 'greater))
(define (version=? v1 v2) (eq? (version-compare v1 v2) 'equal))
;;
;; Phases
;;
(define all-phases '(build install))
(define all-phases-str (string-join (map symbol->string all-phases) ", "))
(define (valid-phase? thing)
(member thing all-phases))
(define (active-phase? phase)
(assert (valid-phase? phase) "invalid phase" phase)
(member phase (get-option-value 'phases)))
(define (parse-phase str)
(let ((phase (string->symbol str)))
(if (valid-phase? phase)
phase
(display-error-and-exit "invalid phase "str" "
"(valid ones are: "all-phases-str")"))))
(define (parse-phases str)
(map parse-phase ((infix-splitter ",") str)))
;;
;; Layouts
;;
@ -286,9 +311,9 @@
;; installed in it.
(define (active-location? location)
(assert (valid-location? location) "invalid location" location)
(member location (if (get-option-value 'non-shared-only)
non-shared-locations
all-locations)))
(and (active-phase? 'install)
(or (not (get-option-value 'non-shared-only))
(member location non-shared-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
@ -552,14 +577,12 @@
;; package's loading script (in the install directory). During a dry
;; run, or when only non-shared data has to be installed, do nothing.
(define (with-output-to-load-script* thunk)
(if (and (not (get-option-value 'dry-run)) (active-location? 'base))
(let* ((dir (get-directory 'base #t))
(file (absolute-file-name load-script-name dir)))
(-create-directory&parents dir)
(if (not (or (get-option-value 'dry-run)
(get-option-value 'non-shared-only)))
(begin
(delete-file-or-fail file)
(with-output-to-file file thunk)))))
(with-output-to-file file thunk))))
;; Sugar for with-output-to-load-script*.
(define-syntax with-output-to-load-script
@ -579,13 +602,14 @@
;; Perform all actions required to make the given version of the
;; package active (i.e. the default version for that package).
(define (activate-package layout pkg)
(if (active-location? 'active)
(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 (layout-dir layout 'base)
(file-name-directory lnk-name))
lnk-name)))
lnk-name))))
(define (install-thing% layout name-or-pair location target-rel-dir perms)
(let* ((target-dir (absolute-file-name target-rel-dir
@ -706,7 +730,6 @@
(dest-prefix (and prefix (string-append dest-dir prefix)))
(layout-fn (resolve-layout (alist-get 'layout 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))))
(let-fluids *options-values* options-values
(lambda ()
@ -716,7 +739,7 @@
(layout (absolute-layout rel-layout prefix))
(i-layout (absolute-layout rel-layout dest-prefix)))
(install-package layout i-layout pkg)
(if (and activate? (not non-shared-only?))
(if activate?
(activate-package i-layout pkg))))
packages)))))
@ -750,6 +773,7 @@
;; this order is used when displaying available options to the user.
(define options-usage
`(("help" #f "display this help message, then exit")
("version" #f "display version of install-lib, then exit")
("prefix" "dir" "specify directory where files are installed")
("layout" "layout" ("specify layout of installation directory"
,(string-append "(predefined: "
@ -760,15 +784,16 @@
("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")
("non-shared-only" #f "only install platform-dependent files, if any")
("non-shared-only" #f "only build/install platform-dependent files")
("force" #f "overwrite existing files during installation")
("no-user-defaults" #f "don't read defaults from ~/.scsh-pkg-defaults.scm")
;; advanced
("phases" "phases" ,(string-append "perform only the given phase(s) "
"("all-phases-str")"))
("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)"))))
("dest-dir" "dir" ("specify prefix to use during installation"
"(use only for staged installations!)"))))
(define (sort-options options)
(filter-map (lambda (name)
@ -837,11 +862,17 @@
(define usage-string #f)
;; Display the usage string, then exit with an error code of 1.
;; Display the usage string, then exit successfully.
(define (display-usage-and-exit)
(display usage-string)
(newline)
(exit 1))
(exit))
(define (display-version-and-exit)
(display-all "scsh-install-lib version "
(version->string install-lib-version)
"\n")
(exit))
;; Display a hint about how to use the just-installed PACKAGES,
;; assuming they were laid out according to LAYOUT and PREFIX.
@ -923,17 +954,20 @@
(define (get-option-value key)
(alist-get key (fluid *options-values*)))
(define (alist-arg-updater key)
(define (alist-updater key parser)
(lambda (opt name arg alist)
(alist-replace key arg alist)))
(alist-replace key (parser arg) alist)))
(define (alist-arg-updater key)
(alist-updater key identity))
(define (alist-boolean-updater key)
(lambda (opt name arg alist)
(alist-replace key (or (not arg) (parse-boolean arg)) alist)))
(alist-updater key (lambda (arg) (or (not arg) (parse-boolean arg)))))
(define common-options
(list
(option '(#\h "help") #f #f (lambda args (display-usage-and-exit)))
(option '(#\v "version") #f #f (lambda args (display-version-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))
@ -946,7 +980,8 @@
(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))))
(option '("no-user-defaults") #f #f (lambda (opt name arg alist) alist))
(option '("phases") #t #f (alist-updater 'phases parse-phases))))
(define lib-options
(list
@ -1004,6 +1039,7 @@
(dry-run . #f)
(verbose . #f)
(force . #f)
(phases . ,all-phases)
(exclude . ,(lambda args #f))))
;; Partition PACKAGES in two sets: the ones which are not installed
@ -1033,6 +1069,7 @@
(options-defaults 'library))
(map pkg-opt-key&default all-pkg-opts)))
(options-values (parse-options args all-opts all-dfts))
(phases (alist-get 'phases options-values))
(prefix (alist-get 'prefix options-values))
(layout (alist-get 'layout options-values))
(force? (alist-get 'force options-values)))
@ -1054,7 +1091,7 @@
(receive (pkgs-install pkgs-skip)
(partition-packages prefix resolved-layout packages force?)
(install-packages pkgs-install options-values)
(if display-hint?
(if (and display-hint? (member 'install phases))
(display-use-hint prefix
resolved-layout
pkgs-install