From 16cf486524502c1caebbd8831a8f6802640aeace Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 12 Feb 2013 01:24:21 -0500 Subject: [PATCH] Build newest versions unless specified, and implement upgrades. * gnu/packages.scm (find-newest-available-packages): New exported procedure. * guix-build.in (newest-available-packages, find-best-packages-by-name): New procedures. (find-package): Use find-best-packages-by-name, to guarantee that if a version number is not specified, only the newest versions will be considered. * guix-package.in (%options): Add --upgrade/-u option. (newest-available-packages, find-best-packages-by-name, upgradeable?): New procedures. (find-package): Use find-best-packages-by-name, to guarantee that if a version number is not specified, only the newest versions will be considered. (process-actions): Implement upgrade option. --- gnu/packages.scm | 24 +++++++++++++++++- guix-build.in | 16 ++++++++++-- guix-package.in | 71 ++++++++++++++++++++++++++++++++++++++++++++---------- 3 files changed, 95 insertions(+), 16 deletions(-) diff --git a/gnu/packages.scm b/gnu/packages.scm index 792fe44..04ca840 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -20,6 +20,8 @@ #:use-module (guix packages) #:use-module (guix utils) #:use-module (ice-9 ftw) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-39) @@ -28,7 +30,8 @@ %patch-directory %bootstrap-binaries-path fold-packages - find-packages-by-name)) + find-packages-by-name + find-newest-available-packages)) ;;; Commentary: ;;; @@ -137,3 +140,22 @@ then only return packages whose version is equal to VERSION." (cons package result) result)) '())) + +(define (find-newest-available-packages) + "Return a vhash with elements of the form + (name newest-version newest-package ...) +where the preferred package is listed first." + + ;; FIXME: Currently, the preferred package is whichever one + ;; was found last by 'fold-packages'. Find a better solution. + (fold-packages (lambda (p r) + (let ((name (package-name p)) + (version (package-version p))) + (match (vhash-assoc name r) + ((_ newest-so-far . pkgs) + (case (version-compare version newest-so-far) + ((>) (vhash-cons name `(,version ,p) r)) + ((=) (vhash-cons name `(,version ,p ,@pkgs) r)) + ((<) r))) + (#f (vhash-cons name `(,version ,p) r))))) + vlist-null)) diff --git a/guix-build.in b/guix-build.in index 29241c7..3bfddeb 100644 --- a/guix-build.in +++ b/guix-build.in @@ -47,6 +47,7 @@ exec "${GUILE-@GUILE@}" -c "$startup" "@guilemoduledir@" "$0" "$@" #:use-module (guix utils) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -206,13 +207,24 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) root (strerror (system-error-errno args))) (exit 1))))) + (define newest-available-packages + (memoize find-newest-available-packages)) + + (define (find-best-packages-by-name name version) + (if version + (find-packages-by-name name version) + (match (vhash-assoc name (newest-available-packages)) + ((_ version pkgs ...) pkgs) + (#f '())))) + (define (find-package request) ;; Return a package matching REQUEST. REQUEST may be a package ;; name, or a package name followed by a hyphen and a version - ;; number. + ;; number. If the version number is not present, return the + ;; preferred newest version. (let-values (((name version) (package-name->name+version request))) - (match (find-packages-by-name name version) + (match (find-best-packages-by-name name version) ((p) ; one match p) ((p x ...) ; several matches diff --git a/guix-package.in b/guix-package.in index 32d9afd..28b919f 100644 --- a/guix-package.in +++ b/guix-package.in @@ -52,6 +52,7 @@ exec "${GUILE-@GUILE@}" -c "$startup" "@guilemoduledir@" "$0" "$@" #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -356,6 +357,9 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (option '(#\r "remove") #t #f (lambda (opt name arg result) (alist-cons 'remove arg result))) + (option '(#\u "upgrade") #t #f + (lambda (opt name arg result) + (alist-cons 'upgrade arg result))) (option '("roll-back") #f #f (lambda (opt name arg result) (alist-cons 'roll-back? #t result))) @@ -431,9 +435,20 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (length req*)) (null? req*) req*)))) + (define newest-available-packages + (memoize find-newest-available-packages)) + + (define (find-best-packages-by-name name version) + (if version + (find-packages-by-name name version) + (match (vhash-assoc name (newest-available-packages)) + ((_ version pkgs ...) pkgs) + (#f '())))) + (define (find-package name) ;; Find the package NAME; NAME may contain a version number and a - ;; sub-derivation name. + ;; sub-derivation name. If the version number is not present, + ;; return the preferred newest version. (define request name) (define (ensure-output p sub-drv) @@ -451,7 +466,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (substring name (+ 1 colon)))))) ((name version) (package-name->name+version name))) - (match (find-packages-by-name name version) + (match (find-best-packages-by-name name version) ((p) (list name (package-version p) sub-drv (ensure-output p sub-drv) (package-transitive-propagated-inputs p))) @@ -468,6 +483,20 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (() (leave (_ "~a: package not found~%") request))))) + (define (upgradeable? name current-version current-path) + ;; Return #t if there is a newer version available, or if the + ;; newest version if the same as the current one but the + ;; output path would be different than the current path. + (match (vhash-assoc name (newest-available-packages)) + ((_ candidate-version pkg . rest) + (case (version-compare candidate-version current-version) + ((>) #t) + ((<) #f) + ((=) (let ((candidate-path (derivation-path->output-path + (package-derivation (%store) pkg)))) + (not (string=? current-path candidate-path)))))) + (#f #f))) + (define (ensure-default-profile) ;; Ensure the default profile symlink and directory exist. @@ -520,13 +549,32 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (begin (roll-back profile) (process-actions (alist-delete 'roll-back? opts))) - (let* ((install (filter-map (match-lambda - (('install . (? store-path?)) - #f) - (('install . package) - (find-package package)) - (_ #f)) - opts)) + (let* ((installed (manifest-packages (profile-manifest profile))) + (upgrade-regexps (filter-map (match-lambda + (('upgrade . regexp) + (make-regexp regexp)) + (_ #f)) + opts)) + (upgrade (if (null? upgrade-regexps) + '() + (let ((newest (find-newest-available-packages))) + (filter-map (match-lambda + ((name version output path _) + (and (any (cut regexp-exec <> name) + upgrade-regexps) + (upgradeable? name version path) + (find-package name))) + (_ #f)) + installed)))) + (install (append + upgrade + (filter-map (match-lambda + (('install . (? store-path?)) + #f) + (('install . package) + (find-package package)) + (_ #f)) + opts))) (drv (filter-map (match-lambda ((name version sub-drv (? package? package) @@ -563,10 +611,7 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n")) (match package ((name _ ...) (alist-delete name result)))) - (fold alist-delete - (manifest-packages - (profile-manifest profile)) - remove) + (fold alist-delete installed remove) install*)))) (when (equal? profile %current-profile) -- 1.7.10.4