diff options
| -rw-r--r-- | guix/profiles.scm | 53 | ||||
| -rw-r--r-- | tests/profiles.scm | 20 |
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 |