summary refs log tree commit diff
diff options
context:
space:
mode:
authorMark H Weaver <mhw@netris.org>2013-02-12 01:24:21 -0500
committerMark H Weaver <mhw@netris.org>2013-02-13 22:05:19 -0500
commitdc5669cd654019994fa59ab26db59c292332ae55 (patch)
treec288dbbba737db6b71ca42da37b700b28caa6fac
parentc2868b1e0c4155fbeffac9860d69a1ed6041156a (diff)
downloadguix-dc5669cd654019994fa59ab26db59c292332ae55.tar.gz
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.

* doc/guix.texi (Invoking guix-package): In the description of --install,
  mention that if no version number is specified, the newest available
  version will be selected.
-rw-r--r--doc/guix.texi7
-rw-r--r--gnu/packages.scm26
-rw-r--r--guix-build.in20
-rw-r--r--guix-package.in73
4 files changed, 106 insertions, 20 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index 9cb1431bf1..80149326c1 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -491,9 +491,10 @@ Install @var{package}.
 
 @var{package} may specify either a simple package name, such as
 @code{guile}, or a package name followed by a hyphen and version number,
-such as @code{guile-1.8.8}.  In addition, @var{package} may contain a
-colon, followed by the name of one of the outputs of the package, as in
-@code{gcc:doc} or @code{binutils-2.22:lib}.
+such as @code{guile-1.8.8}.  If no version number is specified, the
+newest available version will be selected.  In addition, @var{package}
+may contain a colon, followed by the name of one of the outputs of the
+package, as in @code{gcc:doc} or @code{binutils-2.22:lib}.
 
 @cindex propagated inputs
 Sometimes packages have @dfn{propagated inputs}: these are dependencies
diff --git a/gnu/packages.scm b/gnu/packages.scm
index f2f98de476..b639541788 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -22,6 +22,7 @@
   #: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)
@@ -30,7 +31,8 @@
             %patch-directory
             %bootstrap-binaries-path
             fold-packages
-            find-packages-by-name))
+            find-packages-by-name
+            find-newest-available-packages))
 
 ;;; Commentary:
 ;;;
@@ -153,3 +155,25 @@ then only return packages whose version is equal to VERSION."
                        (cons package result)
                        result))
                  '()))
+
+(define (find-newest-available-packages)
+  "Return a vhash keyed by package names, and with
+associated values of the form
+
+  (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 f8c7115999..35ddb00861 100644
--- a/guix-build.in
+++ b/guix-build.in
@@ -13,6 +13,7 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
 !#
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -37,12 +38,14 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$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
@@ -196,13 +199,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 ae3d2cd70e..584481acd5 100644
--- a/guix-package.in
+++ b/guix-package.in
@@ -14,6 +14,7 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -42,6 +43,7 @@ exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$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)
@@ -346,6 +348,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)))
@@ -421,9 +426,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)
@@ -441,7 +457,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)))
@@ -458,6 +474,21 @@ 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's a version of package NAME newer than
+    ;; CURRENT-VERSION, or if the newest available version is equal to
+    ;; CURRENT-VERSION but would have an output path different than
+    ;; 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.
 
@@ -510,13 +541,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)
@@ -553,10 +603,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)