From b2a4c813125e593975d3abdd93a0d3ba0aff5aed Mon Sep 17 00:00:00 2001 From: michel-schinz Date: Sun, 14 Mar 2004 14:10:25 +0000 Subject: [PATCH] - modified layouts so that scsh's major and minor versions appear explicitely in all paths, - check locations given by the package installation script, and fail if one is unknown, - added "install-lib-version" extension, so that package installation scripts can explicitely specify which version of install-lib they need, - added a message which is printed at the end of a successful installation and indicates how to set SCSH_LIB_DIRS, - provided a way to "turn off" boolean options like --force, by providing an explicit "=no", - replaced a few calls to "error" by calls to "display-error-and-exit", to try to be consistent and use "error" only for "internal" errors not due to the end user, - removed "platform" parameter from layouts, not needed anymore since the "lib" location was made platform-independent a long time ago, - documented --no-user-defaults. --- scheme/install-lib/install-lib.scm | 197 +++++++++++++++++++++++------ 1 file changed, 161 insertions(+), 36 deletions(-) diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm index 679fc33..ac017c1 100755 --- a/scheme/install-lib/install-lib.scm +++ b/scheme/install-lib/install-lib.scm @@ -1,12 +1,41 @@ ;;; Installation library for scsh modules. -;;; $Id: install-lib.scm,v 1.12 2004/02/23 20:11:40 michel-schinz Exp $ +;;; $Id: install-lib.scm,v 1.13 2004/03/14 14:10:25 michel-schinz Exp $ ;; TODO +;; - think about --host: does it make sense? +;; - get-directory should get 'install or 'final instead of #f #t ;; - add a "--debug" option ;; - add support for communication between configure and pkg-def.scm ;; - add support for image creation ;; - add support to maintain a documentation index +;; +;; Version of the installation library +;; +;; The versioning scheme is as follows: a version is composed of three +;; integers called (from left to right) "major", "minor" and +;; "revision". +;; +;; Two versions which share a "major" and "minor" number must be fully +;; compatible in that one should be exchangeable for the other without +;; (important) change in behaviour. +;; +;; Two versions which share a "major" number must be compatible in an +;; ascendent fashion: the features offered by the version with the +;; greatest "minor" number must be a superset of those offered by the +;; other. +;; +;; Two versions which do not even share a "major" number can be +;; mutually incompatible. +;; +;; Clients using the installation library must specify which "major" +;; and "minor" number they need --- if the above scheme is respected, +;; the "revision" should not matter. This need is satisfied if the +;; requested "major" number matches the one of the library, and the +;; requested "minor" is smaller or equal to the one of the library. + +(define install-lib-version '(1 0 0)) + ;; ;; Support code templates ;; @@ -52,6 +81,14 @@ (define default-perms-fn (lambda (name) #o755)) +;; Fail if CONDITION is not true, displaying ERROR-MSG with ARGUMENTS. +(define (assert condition error-msg . arguments) + (if (not condition) + (apply error error-msg arguments))) + +;; True iff LIST has more than one element. +(define (many? list) (> (length list) 1)) + ;; Return the name of the parent directory of FNAME. (define (parent-directory fname) (file-name-directory (directory-as-file-name fname))) @@ -93,12 +130,17 @@ (path-list->file-name (append new-root-pl (cdr fname-pl))) (error "no root to replace in relative file name" fname)))) +;; Similar to path-list->file-name, but take all arguments as +;; components of the path. +(define (paths->file-name . paths) + (path-list->file-name paths)) + ;; If FILE exists, fail if --force was not given, delete it otherwise. (define (delete-file-or-fail file) (if (file-exists? file) (if (get-option-value 'force) (-delete-file file) - (error "target file exists" file)))) + (display-error-and-exit "target file already exists: " file)))) ;; Copy file/symlink SOURCE to TARGET. TARGET must be the name of a ;; non-existing file (i.e. it cannot be the name of a directory). @@ -141,7 +183,7 @@ (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)))) + (else (error "cannot find key in alist" key alist)))) ;; Convert all arguments to strings using DISPLAY and concatenate the ;; result in a single string which is returned. @@ -191,6 +233,14 @@ ;; Versions are represented as lists of integers, the most significant ;; being at the head. +;; Return major/minor parts of a version. +(define version-major first) +(define version-minor second) + +;; Return true iff OBJECT can be interpreted as a version. +(define (version? object) + (and (list? object) (every integer? object))) + ;; Return the printed representation of VERSION. (define (version->string version) (string-join (map number->string version) ".")) @@ -234,9 +284,14 @@ ;; 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. +;; Return true iff LOCATION is valid. +(define (valid-location? location) + (member location all-locations)) + +;; Return true iff LOCATION is "active", that is if files should be +;; 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))) @@ -268,40 +323,53 @@ ;; Return the directory associated with the LOCATION in LAYOUT. (define (layout-dir layout location) + (assert (valid-location? location) "invalid location" location) (alist-get location layout #f)) ;; Predefined layouts -(define (scsh-layout platform base) +;; Directory corresponding to the current major and minor version of +;; scsh. +(define scsh-version-string + (version->string (list scsh-major-version scsh-minor-version))) + +(define (scsh-layout base) `((base . ,base) (misc-shared . ,base) (scheme . ,(absolute-file-name "scheme" base)) (lib . ,(absolute-file-name "lib" base)) (doc . ,(absolute-file-name "doc" base)))) -(define (scsh-layout-1 platform pkg) - (alist-combine '((active . ".")) - (scsh-layout platform (package-full-name pkg)))) +(define (scsh-layout-1 pkg) + (alist-combine `((active . ,scsh-version-string)) + (scsh-layout (paths->file-name scsh-version-string + (package-full-name pkg))))) -(define (scsh-layout-2 platform pkg) +(define (scsh-layout-2 pkg) (alist-combine - '((active . "active")) - (scsh-layout platform - (path-list->file-name - (list "installed" - (package-name pkg) - (version->string (package-version pkg))))))) + `((active . ,(paths->file-name scsh-version-string "active"))) + (scsh-layout (paths->file-name scsh-version-string + "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"))) +(define (fhs-layout pkg) + (let* ((scsh-version-dir (string-append "scsh-" scsh-version-string)) + (base (absolute-file-name (package-full-name pkg) + (paths->file-name "share" + scsh-version-dir + "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")))) + (paths->file-name + "lib" scsh-version-dir "modules"))) + (doc . ,(absolute-file-name (package-full-name pkg) + (paths->file-name + "share" "doc" scsh-version-dir))) + (active . ,(paths->file-name + "share" scsh-version-dir "modules"))))) (define predefined-layouts `(("scsh" . ,scsh-layout-1) @@ -363,6 +431,26 @@ (load-quietly package-definition-file) (cell-ref (fluid *packages*))))) +;; Like load-package but check additionally that none of the loaded +;; packages require a more recent version of the installation library, +;; and fail if it is the case. +(define (load&check-packages) + (let ((pkgs (load-packages))) + (for-each (lambda (pkg) + (and-let* + ((req-lst (package-extension pkg 'install-lib-version)) + (req (first req-lst)) + ((or (not (= (version-major req) + (version-major install-lib-version))) + (> (version-minor req) + (version-minor install-lib-version))))) + (display-error-and-exit + "package "(package-name pkg)" needs a newer " + "version of install-lib: "(version->string req)"\n" + "(installed: " (version->string install-lib-version) ")"))) + pkgs) + pkgs)) + (define (load-package-in dir) (with-cwd dir (load-quietly package-definition-file))) @@ -494,7 +582,16 @@ (cond ((or (file-regular? source) (file-symlink? source)) (-copy-file source target)) ((file-directory? source) - (-create-directory target (file-mode source)) + (if (file-exists? target) + (if (file-directory? target) + (if (get-option-value 'force) + (set-file-mode target (file-mode source)) + (display-error-and-exit + "target directory already exists: " target)) + (begin + (delete-file-or-fail target) + (-create-directory target (file-mode source)))) + (-create-directory target (file-mode source))) (install-directory-contents% layout source location @@ -502,7 +599,8 @@ target-name target-rel-dir) perms-fn)) - (else (error "cannot install file-system object" source))))))) + (else (display-error-and-exit + "cannot install file-system object: " source))))))) (define (install-directory-contents% layout name @@ -594,7 +692,7 @@ (lambda () (for-each (lambda (pkg) - (let* ((rel-layout (layout-fn build pkg)) + (let* ((rel-layout (layout-fn pkg)) (layout (absolute-layout rel-layout prefix)) (i-layout (absolute-layout rel-layout dest-prefix))) (if layout-to @@ -611,7 +709,7 @@ (let-optionals rest ((options-diff '())) (with-cwd dir (install-packages - (load-packages) + (load&check-packages) (fold (lambda (diff options) (cond ((pair? diff) (cons diff (alist-delete (car diff) options))) @@ -646,6 +744,7 @@ options: --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 advanced options: --build name of platform for which to build @@ -721,7 +820,10 @@ END (alist-replace key arg alist)))) (alist-boolean-updater (lambda (key) (lambda (opt name arg alist) - (alist-replace key #t alist))))) + (alist-replace key + (or (not arg) + (parse-boolean arg)) + alist))))) (list (option '(#\h "help") #f #f (lambda args (display-usage-and-exit))) @@ -736,12 +838,12 @@ END 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 + (option '("non-shared-only") #f #t (alist-boolean-updater 'non-shared-only)) - (option '("inactive") #f #f (alist-boolean-updater 'inactive)) - (option '("dry-run") #f #f (alist-boolean-updater 'dry-run)) - (option '("verbose") #f #f (alist-boolean-updater 'verbose)) - (option '("force") #f #f (alist-boolean-updater 'force))))) + (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 no-user-defaults-option "--no-user-defaults") @@ -786,7 +888,7 @@ END (if (not (file-exists? package-definition-file)) (display-error-and-exit "cannot find package definition file" "("package-definition-file")")) - (let* ((packages (load-packages)) + (let* ((packages (load&check-packages)) (all-pkg-opts (all-package-options packages))) (if (not (null? all-pkg-opts)) (complete-usage! all-pkg-opts)) @@ -807,6 +909,29 @@ END (display-error-and-exit "no prefix specified (use --prefix option)")) (if (not (file-name-absolute? prefix)) (display-error-and-exit "prefix must be an absolute path")) - (if (not (resolve-layout layout)) - (display-error-and-exit "invalid layout "layout)) - (install-packages packages options-values)))) + (let ((resolved-layout (resolve-layout layout))) + (if (not resolved-layout) + (display-error-and-exit "invalid layout "layout)) + (install-packages packages options-values) + (let ((active-locations + (delete-duplicates + (map (lambda (pkg) + (string-append "\"" + (layout-dir (absolute-layout + (resolved-layout pkg) + prefix) + 'active) + "\"")) + packages) + string=?))) + (display + (as-string + "The following scsh package" (if (many? packages) "s were" " was") + " installed successfully:\n" + " "(string-join (map package-full-name packages) ", ")"\n" + "In order to use "(if (many? packages) "them" "it")", " + "make sure to add the following value" + (if (many? active-locations) "s" "")"\n" + "to the environment variable SCSH_LIB_DIRS (quotes included):\n" + " " (string-join active-locations " ") + "\n")))))))