aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-09-02 21:12:59 +0200
committerLudovic Courtès <ludo@gnu.org>2014-09-02 21:12:59 +0200
commitef8993e2dc90fd5d63d016fc45912ad451bf787c (patch)
tree704a6fb13d942006779a36c7fa43cf8f1a7587fc
parentfa747b27fc972240ca3f00a1a4d36e6601d0450e (diff)
downloadguix-ef8993e2dc90fd5d63d016fc45912ad451bf787c.tar
guix-ef8993e2dc90fd5d63d016fc45912ad451bf787c.tar.gz
profiles: Report the old and new version number in upgrades.
* guix/profiles.scm (manifest-lookup): New procedure. (manifest-installed?): Use it. (manifest-transaction-effects): Return a pair of entries for upgrades. (right-arrow): New procedure. (manifest-show-transaction)[upgrade-string, →]: New variables. Report upgrades using 'upgrade-string'. * tests/profiles.scm ("manifest-show-transaction"): New test. ("manifest-transaction-effects"): Match UPGRADE against a pair.
-rw-r--r--guix/profiles.scm53
-rw-r--r--tests/profiles.scm20
2 files changed, 64 insertions, 9 deletions
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 843040156c..52bd5bc332 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -53,6 +53,7 @@
manifest-remove
manifest-add
+ manifest-lookup
manifest-installed?
manifest-matching-entries
@@ -237,11 +238,16 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
(manifest-entries manifest)
entries))))
+(define (manifest-lookup manifest pattern)
+ "Return the first item of MANIFEST that matches PATTERN, or #f if there is
+no match.."
+ (find (entry-predicate pattern)
+ (manifest-entries manifest)))
+
(define (manifest-installed? manifest pattern)
"Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
#f otherwise."
- (->bool (find (entry-predicate pattern)
- (manifest-entries manifest))))
+ (->bool (manifest-lookup manifest pattern)))
(define (manifest-matching-entries manifest patterns)
"Return all the entries of MANIFEST that match one of the PATTERNS."
@@ -271,7 +277,9 @@ Remove MANIFEST entries that have the same name and output as ENTRIES."
(define (manifest-transaction-effects manifest transaction)
"Compute the effect of applying TRANSACTION to MANIFEST. Return 3 values:
the list of packages that would be removed, installed, or upgraded when
-applying TRANSACTION to MANIFEST."
+applying TRANSACTION to MANIFEST. Upgrades are represented as pairs where the
+head is the entry being upgraded and the tail is the entry that will replace
+it."
(define (manifest-entry->pattern entry)
(manifest-pattern
(name (manifest-entry-name entry))
@@ -292,10 +300,12 @@ applying TRANSACTION to MANIFEST."
;; XXX: When the exact same output directory is installed, we're not
;; really upgrading anything. Add a check for that case.
(let* ((pattern (manifest-entry->pattern entry))
- (upgrade? (manifest-installed? manifest pattern)))
+ (previous (manifest-lookup manifest pattern)))
(loop rest
- (if upgrade? install (cons entry install))
- (if upgrade? (cons entry upgrade) upgrade)))))))
+ (if previous install (cons entry install))
+ (if previous
+ (alist-cons previous entry upgrade)
+ upgrade)))))))
(define (manifest-perform-transaction manifest transaction)
"Perform TRANSACTION on MANIFEST and return new manifest."
@@ -304,6 +314,20 @@ applying TRANSACTION to MANIFEST."
(manifest-add (manifest-remove manifest remove)
install)))
+(define (right-arrow port)
+ "Return either a string containing the 'RIGHT ARROW' character, or an ASCII
+replacement if PORT is not Unicode-capable."
+ (with-fluids ((%default-port-encoding (port-encoding port)))
+ (let ((arrow "→"))
+ (catch 'encoding-error
+ (lambda ()
+ (with-fluids ((%default-port-conversion-strategy 'error))
+ (with-output-to-string
+ (lambda ()
+ (display arrow)))))
+ (lambda (key . args)
+ ">")))))
+
(define* (manifest-show-transaction store manifest transaction
#:key dry-run?)
"Display what will/would be installed/removed from MANIFEST by TRANSACTION."
@@ -315,6 +339,17 @@ applying TRANSACTION to MANIFEST."
item)))
name version output item))
+ (define → ;an arrow that can be represented on stderr
+ (right-arrow (current-error-port)))
+
+ (define (upgrade-string name old-version new-version output item)
+ (format #f " ~a\t~a ~a ~a\t~a\t~a" name
+ old-version → new-version
+ output
+ (if (package? item)
+ (package-output store item output)
+ item)))
+
(let-values (((remove install upgrade)
(manifest-transaction-effects manifest transaction)))
(match remove
@@ -334,9 +369,11 @@ applying TRANSACTION to MANIFEST."
remove))))
(_ #f))
(match upgrade
- ((($ <manifest-entry> name version output item _) ..1)
+ (((($ <manifest-entry> name old-version)
+ . ($ <manifest-entry> _ new-version output item)) ..1)
(let ((len (length name))
- (upgrade (package-strings name version output item)))
+ (upgrade (map upgrade-string
+ name old-version new-version output item)))
(if dry-run?
(format (current-error-port)
(N_ "The following package would be upgraded:~%~{~a~%~}~%"
diff --git a/tests/profiles.scm b/tests/profiles.scm
index d88def32fd..879f71073f 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -26,6 +26,7 @@
#:use-module (guix derivations)
#:use-module (gnu packages bootstrap)
#:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-64))
@@ -153,7 +154,24 @@
(manifest-transaction-effects m0 t)))
(and (null? remove)
(equal? (list glibc) install)
- (equal? (list guile-2.0.9) upgrade)))))
+ (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
+
+(test-assert "manifest-show-transaction"
+ (let* ((m (manifest (list guile-1.8.8)))
+ (t (manifest-transaction (install (list guile-2.0.9)))))
+ (let-values (((remove install upgrade)
+ (manifest-transaction-effects m t)))
+ (with-store store
+ (and (string-match "guile\t1.8.8 → 2.0.9"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (with-error-to-string
+ (lambda ()
+ (manifest-show-transaction store m t)))))
+ (string-match "guile\t1.8.8 > 2.0.9"
+ (with-fluids ((%default-port-encoding "ISO-8859-1"))
+ (with-error-to-string
+ (lambda ()
+ (manifest-show-transaction store m t))))))))))
(test-assert "profile-derivation"
(run-with-store %store