Browse Source

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.
wip-grafts
Ludovic Courtès 8 years ago
parent
commit
ef8993e2dc
  1. 53
      guix/profiles.scm
  2. 20
      tests/profiles.scm

53
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~%~}~%"

20
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

Loading…
Cancel
Save