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

- 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.
This commit is contained in:
michel-schinz 2004-11-13 20:14:57 +00:00
parent 9acbc237e0
commit 5ebaf0692c
1 changed files with 26 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,5 +1,5 @@
;;; Installation library for scsh modules. ;;; 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 ;; TODO
;; - think about --build: does it make sense? ;; - think about --build: does it make sense?
@ -486,6 +486,10 @@
((define-program name version extensions body ...) ((define-program name version extensions body ...)
(define-package 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 ;; Load (and evaluate the contents of) the file "pkg-def.scm" in the
;; current directory and return the packages it defines. ;; current directory and return the packages it defines.
(define (load-packages) (define (load-packages)
@ -498,8 +502,7 @@
;; Check that the given package does not require a more recent version ;; Check that the given package does not require a more recent version
;; of the installation library, and fail if it is the case. ;; of the installation library, and fail if it is the case.
(define (check-package pkg) (define (check-package pkg)
(and-let* ((req-lst (package-extension pkg 'install-lib-version)) (and-let* ((req (package-version-requirement pkg))
(req (first req-lst))
((or (not (= (version-major req) ((or (not (= (version-major req)
(version-major install-lib-version))) (version-major install-lib-version)))
(> (version-minor req) (> (version-minor req)
@ -751,7 +754,6 @@
(dest-dir (alist-get 'dest-dir options-values)) (dest-dir (alist-get 'dest-dir options-values))
(dest-prefix (and prefix (string-append dest-dir prefix))) (dest-prefix (and prefix (string-append dest-dir prefix)))
(layout-fn (resolve-layout (alist-get 'layout options-values))) (layout-fn (resolve-layout (alist-get 'layout options-values)))
(build (alist-get 'build options-values))
(activate? (not (alist-get 'inactive options-values)))) (activate? (not (alist-get 'inactive options-values))))
(let-fluids *options-values* options-values (let-fluids *options-values* options-values
(lambda () (lambda ()
@ -784,8 +786,7 @@
;; Error handling ;; Error handling
;; ;;
;; Display all the MSGS on the error port, then exit with an error ;; Display all the MSGS, then exit with an error code of 1.
;; code of 1.
(define (display-error-and-exit . msgs) (define (display-error-and-exit . msgs)
(for-each display (cons "Error: " msgs)) (for-each display (cons "Error: " msgs))
(newline) (newline)
@ -1055,11 +1056,14 @@
;; Partition PACKAGES in two sets: the ones which are not installed ;; Partition PACKAGES in two sets: the ones which are not installed
;; yet, and the ones which are already. If FORCE? is true, pretend ;; yet, and the ones which are already. If FORCE? is true, pretend
;; that all packages are not installed yet. ;; 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) (partition (lambda (pkg)
(or force? (or force?
(let ((abs-layout (absolute-layout (layout pkg) prefix)))
(file-not-exists? (file-not-exists?
(layout-dir (absolute-layout (layout pkg) prefix) 'base)))) (if non-shared-only?
(paths->file-name (layout-dir abs-layout 'lib) (host))
(layout-dir abs-layout 'base))))))
packages)) packages))
(define (install-main-internal cmd-line display-hint?) (define (install-main-internal cmd-line display-hint?)
@ -1082,7 +1086,8 @@
(phases (alist-get 'phases options-values)) (phases (alist-get 'phases options-values))
(prefix (alist-get 'prefix options-values)) (prefix (alist-get 'prefix options-values))
(layout (alist-get 'layout 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) (if (null? packages)
(display-error-and-exit (display-error-and-exit
"no package to install" "no package to install"
@ -1098,8 +1103,18 @@
(let ((resolved-layout (resolve-layout layout))) (let ((resolved-layout (resolve-layout layout)))
(if (not resolved-layout) (if (not resolved-layout)
(display-error-and-exit "invalid layout "layout)) (display-error-and-exit "invalid layout "layout))
(if (and (not (lset= eq? phases all-phases))
(any (lambda (req) (version<? req '(1 2 0)))
(filter-map package-version-requirement packages)))
(display-error-and-exit
"at least one of the packages about to be installed might not\n"
"understand the --phases option. Re-run without using --phases."))
(receive (pkgs-install pkgs-skip) (receive (pkgs-install pkgs-skip)
(partition-packages prefix resolved-layout packages force?) (partition-packages prefix
resolved-layout
packages
force?
non-shared-only?)
(install-packages pkgs-install options-values) (install-packages pkgs-install options-values)
(if (and display-hint? (member 'install phases)) (if (and display-hint? (member 'install phases))
(display-use-hint prefix (display-use-hint prefix