From 929849b3307bb645932f4b45a2b6dc5596fd7cb9 Mon Sep 17 00:00:00 2001 From: michel-schinz Date: Fri, 5 Nov 2004 18:16:08 +0000 Subject: [PATCH] - added --version option, - added --phases option (which subsumes --install-only and --build-only), --- scheme/install-lib/install-lib.scm | 103 ++++++++++++++++++++--------- 1 file changed, 70 insertions(+), 33 deletions(-) diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm index 25044e9..b5fd400 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.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) - (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))))) + (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) + (delete-file-or-fail file) + (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) - (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))) + (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)))) (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