Skip to content
Snippets Groups Projects
Commit ef8993e2 authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

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.
parent fa747b27
No related branches found
No related tags found
No related merge requests found
...@@ -53,6 +53,7 @@ (define-module (guix profiles) ...@@ -53,6 +53,7 @@ (define-module (guix profiles)
manifest-remove manifest-remove
manifest-add manifest-add
manifest-lookup
manifest-installed? manifest-installed?
manifest-matching-entries manifest-matching-entries
...@@ -237,11 +238,16 @@ (define (same-entry? entry name output) ...@@ -237,11 +238,16 @@ (define (same-entry? entry name output)
(manifest-entries manifest) (manifest-entries manifest)
entries)))) 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) (define (manifest-installed? manifest pattern)
"Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern), "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
#f otherwise." #f otherwise."
(->bool (find (entry-predicate pattern) (->bool (manifest-lookup manifest pattern)))
(manifest-entries manifest))))
(define (manifest-matching-entries manifest patterns) (define (manifest-matching-entries manifest patterns)
"Return all the entries of MANIFEST that match one of the PATTERNS." "Return all the entries of MANIFEST that match one of the PATTERNS."
...@@ -271,7 +277,9 @@ (define-record-type* <manifest-transaction> manifest-transaction ...@@ -271,7 +277,9 @@ (define-record-type* <manifest-transaction> manifest-transaction
(define (manifest-transaction-effects manifest transaction) (define (manifest-transaction-effects manifest transaction)
"Compute the effect of applying TRANSACTION to MANIFEST. Return 3 values: "Compute the effect of applying TRANSACTION to MANIFEST. Return 3 values:
the list of packages that would be removed, installed, or upgraded when 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) (define (manifest-entry->pattern entry)
(manifest-pattern (manifest-pattern
(name (manifest-entry-name entry)) (name (manifest-entry-name entry))
...@@ -292,10 +300,12 @@ (define (manifest-entry->pattern entry) ...@@ -292,10 +300,12 @@ (define (manifest-entry->pattern entry)
;; XXX: When the exact same output directory is installed, we're not ;; XXX: When the exact same output directory is installed, we're not
;; really upgrading anything. Add a check for that case. ;; really upgrading anything. Add a check for that case.
(let* ((pattern (manifest-entry->pattern entry)) (let* ((pattern (manifest-entry->pattern entry))
(upgrade? (manifest-installed? manifest pattern))) (previous (manifest-lookup manifest pattern)))
(loop rest (loop rest
(if upgrade? install (cons entry install)) (if previous install (cons entry install))
(if upgrade? (cons entry upgrade) upgrade))))))) (if previous
(alist-cons previous entry upgrade)
upgrade)))))))
(define (manifest-perform-transaction manifest transaction) (define (manifest-perform-transaction manifest transaction)
"Perform TRANSACTION on MANIFEST and return new manifest." "Perform TRANSACTION on MANIFEST and return new manifest."
...@@ -304,6 +314,20 @@ (define (manifest-perform-transaction manifest transaction) ...@@ -304,6 +314,20 @@ (define (manifest-perform-transaction manifest transaction)
(manifest-add (manifest-remove manifest remove) (manifest-add (manifest-remove manifest remove)
install))) 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 (define* (manifest-show-transaction store manifest transaction
#:key dry-run?) #:key dry-run?)
"Display what will/would be installed/removed from MANIFEST by TRANSACTION." "Display what will/would be installed/removed from MANIFEST by TRANSACTION."
...@@ -315,6 +339,17 @@ (define (package-strings name version output item) ...@@ -315,6 +339,17 @@ (define (package-strings name version output item)
item))) item)))
name version output 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) (let-values (((remove install upgrade)
(manifest-transaction-effects manifest transaction))) (manifest-transaction-effects manifest transaction)))
(match remove (match remove
...@@ -334,9 +369,11 @@ (define (package-strings name version output item) ...@@ -334,9 +369,11 @@ (define (package-strings name version output item)
remove)))) remove))))
(_ #f)) (_ #f))
(match upgrade (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)) (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? (if dry-run?
(format (current-error-port) (format (current-error-port)
(N_ "The following package would be upgraded:~%~{~a~%~}~%" (N_ "The following package would be upgraded:~%~{~a~%~}~%"
......
...@@ -26,6 +26,7 @@ (define-module (test-profiles) ...@@ -26,6 +26,7 @@ (define-module (test-profiles)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (gnu packages bootstrap) #:use-module (gnu packages bootstrap)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-64)) #:use-module (srfi srfi-64))
...@@ -153,7 +154,24 @@ (define glibc ...@@ -153,7 +154,24 @@ (define glibc
(manifest-transaction-effects m0 t))) (manifest-transaction-effects m0 t)))
(and (null? remove) (and (null? remove)
(equal? (list glibc) install) (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" (test-assert "profile-derivation"
(run-with-store %store (run-with-store %store
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment