From 5ebaf0692c0817f3f58eeec794088b6449382d54 Mon Sep 17 00:00:00 2001 From: michel-schinz Date: Sat, 13 Nov 2004 20:14:57 +0000 Subject: [PATCH] - bug fix: when --non-shared-only is specified, only check if the non-shared part of the package is already present to decide whether to install the package or not (reported by Eric Knauel), - fail with an error if --phases is used but the package requires a version older than 1.2.0 of install-lib. --- scheme/install-lib/install-lib.scm | 37 +++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/scheme/install-lib/install-lib.scm b/scheme/install-lib/install-lib.scm index 99dc4de..45bfe98 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.23 2004/11/08 19:56:28 michel-schinz Exp $ +;;; $Id: install-lib.scm,v 1.24 2004/11/13 20:14:57 michel-schinz Exp $ ;; TODO ;; - think about --build: does it make sense? @@ -486,6 +486,10 @@ ((define-program name version extensions body ...) (define-package name version extensions body ...)))) +(define (package-version-requirement pkg) + (and-let* ((req-lst (package-extension pkg 'install-lib-version))) + (first req-lst))) + ;; Load (and evaluate the contents of) the file "pkg-def.scm" in the ;; current directory and return the packages it defines. (define (load-packages) @@ -498,8 +502,7 @@ ;; Check that the given package does not require a more recent version ;; of the installation library, and fail if it is the case. (define (check-package pkg) - (and-let* ((req-lst (package-extension pkg 'install-lib-version)) - (req (first req-lst)) + (and-let* ((req (package-version-requirement pkg)) ((or (not (= (version-major req) (version-major install-lib-version))) (> (version-minor req) @@ -751,7 +754,6 @@ (dest-dir (alist-get 'dest-dir options-values)) (dest-prefix (and prefix (string-append dest-dir prefix))) (layout-fn (resolve-layout (alist-get 'layout options-values))) - (build (alist-get 'build options-values)) (activate? (not (alist-get 'inactive options-values)))) (let-fluids *options-values* options-values (lambda () @@ -784,8 +786,7 @@ ;; Error handling ;; -;; Display all the MSGS on the error port, then exit with an error -;; code of 1. +;; Display all the MSGS, then exit with an error code of 1. (define (display-error-and-exit . msgs) (for-each display (cons "Error: " msgs)) (newline) @@ -1055,11 +1056,14 @@ ;; Partition PACKAGES in two sets: the ones which are not installed ;; yet, and the ones which are already. If FORCE? is true, pretend ;; that all packages are not installed yet. -(define (partition-packages prefix layout packages force?) +(define (partition-packages prefix layout packages force? non-shared-only?) (partition (lambda (pkg) (or force? - (file-not-exists? - (layout-dir (absolute-layout (layout pkg) prefix) 'base)))) + (let ((abs-layout (absolute-layout (layout pkg) prefix))) + (file-not-exists? + (if non-shared-only? + (paths->file-name (layout-dir abs-layout 'lib) (host)) + (layout-dir abs-layout 'base)))))) packages)) (define (install-main-internal cmd-line display-hint?) @@ -1082,7 +1086,8 @@ (phases (alist-get 'phases options-values)) (prefix (alist-get 'prefix options-values)) (layout (alist-get 'layout options-values)) - (force? (alist-get 'force options-values))) + (force? (alist-get 'force options-values)) + (non-shared-only? (alist-get 'non-shared-only options-values))) (if (null? packages) (display-error-and-exit "no package to install" @@ -1098,8 +1103,18 @@ (let ((resolved-layout (resolve-layout layout))) (if (not resolved-layout) (display-error-and-exit "invalid layout "layout)) + (if (and (not (lset= eq? phases all-phases)) + (any (lambda (req) (version