From: Mark H Weaver <mhw@netris.org>
To: "Ludovic Courtès" <ludo@gnu.org>
Cc: bug-guix@gnu.org
Subject: [PATCH] Build newest versions unless specified, and upgrades.
Date: Wed, 13 Feb 2013 05:56:02 -0500 [thread overview]
Message-ID: <87d2w4iit9.fsf_-_@tines.lan> (raw)
In-Reply-To: <87liatp5tl.fsf@gnu.org> ("Ludovic \=\?utf-8\?Q\?Court\=C3\=A8s\=22'\?\= \=\?utf-8\?Q\?s\?\= message of "Tue, 12 Feb 2013 22:42:30 +0100")
[-- Attachment #1: Type: text/plain, Size: 507 bytes --]
Hello all,
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.
Mark
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: [PATCH] Build newest versions unless specified, and implement upgrades --]
[-- Type: text/x-diff, Size: 10635 bytes --]
From 16cf486524502c1caebbd8831a8f6802640aeace Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
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
next prev parent reply other threads:[~2013-02-13 10:56 UTC|newest]
Thread overview: 15+ messages / expand[flat|nested] mbox.gz Atom feed top
2013-02-12 6:33 [PATCH] Implement guix-package --upgrade Mark H Weaver
2013-02-12 9:50 ` Ludovic Courtès
2013-02-12 10:04 ` Andreas Enge
2013-02-12 10:08 ` Ludovic Courtès
2013-02-12 14:27 ` Mark H Weaver
2013-02-12 15:16 ` Ludovic Courtès
2013-02-12 19:29 ` Mark H Weaver
2013-02-12 19:55 ` Mark H Weaver
2013-02-12 21:04 ` Andreas Enge
2013-02-12 21:42 ` Ludovic Courtès
2013-02-13 10:56 ` Mark H Weaver [this message]
2013-02-13 11:40 ` [PATCH] Build newest versions unless specified, and upgrades Mark H Weaver
2013-02-13 21:04 ` Ludovic Courtès
2013-02-14 4:57 ` Mark H Weaver
2013-02-12 21:41 ` [PATCH] Implement guix-package --upgrade Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87d2w4iit9.fsf_-_@tines.lan \
--to=mhw@netris.org \
--cc=bug-guix@gnu.org \
--cc=ludo@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.