From mboxrd@z Thu Jan 1 00:00:00 1970 From: Mark H Weaver Subject: Re: [PATCH] Build newest versions unless specified, and upgrades. Date: Wed, 13 Feb 2013 06:40:55 -0500 Message-ID: <87zjz8h260.fsf@tines.lan> References: <87vc9yxcre.fsf@tines.lan> <8738x1xrek.fsf@tines.lan> <87vc9xqpd6.fsf@tines.lan> <201302122204.54359.andreas@enge.fr> <87liatp5tl.fsf@gnu.org> <87d2w4iit9.fsf_-_@tines.lan> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" Return-path: Received: from eggs.gnu.org ([208.118.235.92]:56954) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1U5aiC-0000Xx-8r for bug-guix@gnu.org; Wed, 13 Feb 2013 06:41:18 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1U5aiA-0002Sn-1z for bug-guix@gnu.org; Wed, 13 Feb 2013 06:41:16 -0500 In-Reply-To: <87d2w4iit9.fsf_-_@tines.lan> (Mark H. Weaver's message of "Wed, 13 Feb 2013 05:56:02 -0500") List-Id: Bug reports for GNU Guix List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guix-bounces+gcggb-bug-guix=m.gmane.org@gnu.org Sender: bug-guix-bounces+gcggb-bug-guix=m.gmane.org@gnu.org To: Ludovic =?utf-8?Q?Court=C3=A8s?= Cc: bug-guix@gnu.org --=-=-= Content-Type: text/plain I wrote: > Here's a preliminary patch that does two things: > > * Changes 'guix-build' and 'guix-package --install' so that only the > newest packages will be considered (unless a version number is > specified). > > * Implements 'guix-package --upgrade'. > > Although I'm not aware of any functional problems with this code, I'm > not entirely pleased with its organization. Nonetheless, I wanted to > make it available for early testing and comments. > > I welcome suggestions on how to improve this code. Sorry, that patch had a problem in guix-build. Here's a fixed version. Mark --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-Build-newest-versions-unless-specified-and-implement.patch Content-Description: [PATCH] Build newest versions unless specified, and implement upgrades >From c3820d291cdc40cc58abebf8ca10332e51ebead1 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 | 19 ++++++++++++--- guix-package.in | 71 ++++++++++++++++++++++++++++++++++++++++++++---------- 3 files changed, 97 insertions(+), 17 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..607a4bd 100644 --- a/guix-build.in +++ b/guix-build.in @@ -47,12 +47,14 @@ 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) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) - #:autoload (gnu packages) (find-packages-by-name) + #:autoload (gnu packages) (find-packages-by-name + find-newest-available-packages) #:export (guix-build)) (define %store @@ -206,13 +208,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 --=-=-=--