diff options
| -rw-r--r-- | guix/scripts/package.scm | 100 | ||||
| -rw-r--r-- | tests/packages.scm | 29 |
2 files changed, 87 insertions, 42 deletions
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 14a0895b43..dc5fcba922 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -261,25 +261,30 @@ synopsis or description matches all of REGEXPS." ((<) #t) (else #f))))) -(define (upgraded-manifest-entry entry) - "Return either a <manifest-entry> corresponding to an upgrade of ENTRY, or -#f if no upgrade was found." +(define (transaction-upgrade-entry entry transaction) + "Return a variant of TRANSACTION that accounts for the upgrade of ENTRY, a +<manifest-entry>." (match entry (($ <manifest-entry> name version output (? string? path)) (match (vhash-assoc name (find-newest-available-packages)) ((_ candidate-version pkg . rest) (case (version-compare candidate-version version) ((>) - (package->manifest-entry pkg output)) + (manifest-transaction-install-entry + (package->manifest-entry pkg output) + transaction)) ((<) - #f) + transaction) ((=) (let ((candidate-path (derivation->output-path (package-derivation (%store) pkg)))) - (and (not (string=? path candidate-path)) - (package->manifest-entry pkg output)))))) + (if (string=? path candidate-path) + transaction + (manifest-transaction-install-entry + (package->manifest-entry pkg output) + transaction)))))) (#f - #f))))) + transaction))))) ;;; @@ -559,17 +564,20 @@ upgrading, #f otherwise." (output #f) (item item)))) -(define (options->installable opts manifest) +(define (options->installable opts manifest transaction) "Given MANIFEST, the current manifest, and OPTS, the result of 'args-fold', -return the new list of manifest entries." +return an variant of TRANSACTION that accounts for the specified installations +and upgrades." (define upgrade? (options->upgrade-predicate opts)) - (define to-upgrade - (filter-map (lambda (entry) - (and (upgrade? (manifest-entry-name entry)) - (upgraded-manifest-entry entry))) - (manifest-entries manifest))) + (define upgraded + (fold (lambda (entry transaction) + (if (upgrade? (manifest-entry-name entry)) + (transaction-upgrade-entry entry transaction) + transaction)) + transaction + (manifest-entries manifest))) (define to-install (filter-map (match-lambda @@ -586,23 +594,29 @@ return the new list of manifest entries." (_ #f)) opts)) - (append to-upgrade to-install)) - -(define (options->removable options manifest) - "Given options, return the list of manifest patterns of packages to be -removed from MANIFEST." - (filter-map (match-lambda - (('remove . spec) - (call-with-values - (lambda () - (package-specification->name+version+output spec)) - (lambda (name version output) - (manifest-pattern - (name name) - (version version) - (output output))))) - (_ #f)) - options)) + (fold manifest-transaction-install-entry + upgraded + to-install)) + +(define (options->removable options manifest transaction) + "Given options, return a variant of TRANSACTION augmented with the list of +patterns of packages to remove." + (fold (lambda (opt transaction) + (match opt + (('remove . spec) + (call-with-values + (lambda () + (package-specification->name+version+output spec)) + (lambda (name version output) + (manifest-transaction-remove-pattern + (manifest-pattern + (name name) + (version version) + (output output)) + transaction)))) + (_ transaction))) + transaction + options)) (define (register-gc-root store profile) "Register PROFILE, a profile generation symlink, as a GC root, unless it @@ -813,16 +827,18 @@ processed, #f otherwise." opts) ;; Then, process normal package installation/removal/upgrade. - (let* ((manifest (profile-manifest profile)) - (install (options->installable opts manifest)) - (remove (options->removable opts manifest)) - (transaction (manifest-transaction - (install (map transform-entry install)) - (remove remove))) - (new (manifest-perform-transaction manifest transaction))) - - (unless (and (null? install) (null? remove)) - (show-manifest-transaction store manifest transaction + (let* ((manifest (profile-manifest profile)) + (step1 (options->installable opts manifest + (manifest-transaction))) + (step2 (options->removable opts manifest step1)) + (step3 (manifest-transaction + (inherit step2) + (install (map transform-entry + (manifest-transaction-install step2))))) + (new (manifest-perform-transaction manifest step3))) + + (unless (manifest-transaction-null? step3) + (show-manifest-transaction store manifest step3 #:dry-run? dry-run?) (build-and-use-profile store profile new #:bootstrap? bootstrap? diff --git a/tests/packages.scm b/tests/packages.scm index daceea5d62..456e691962 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -49,6 +49,7 @@ #:use-module (srfi srfi-35) #:use-module (srfi srfi-64) #:use-module (rnrs io ports) + #:use-module (ice-9 vlist) #:use-module (ice-9 regex) #:use-module (ice-9 match)) @@ -83,6 +84,34 @@ (and (hidden-package? (hidden-package (dummy-package "foo"))) (not (hidden-package? (dummy-package "foo"))))) +(test-assert "transaction-upgrade-entry, zero upgrades" + (let* ((old (dummy-package "foo" (version "1"))) + (tx (mock ((gnu packages) find-newest-available-packages + (const vlist-null)) + ((@@ (guix scripts package) transaction-upgrade-entry) + (manifest-entry + (inherit (package->manifest-entry old)) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction))))) + (manifest-transaction-null? tx))) + +(test-assert "transaction-upgrade-entry, one upgrade" + (let* ((old (dummy-package "foo" (version "1"))) + (new (dummy-package "foo" (version "2"))) + (tx (mock ((gnu packages) find-newest-available-packages + (const (vhash-cons "foo" (list "2" new) vlist-null))) + ((@@ (guix scripts package) transaction-upgrade-entry) + (manifest-entry + (inherit (package->manifest-entry old)) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction))))) + (and (match (manifest-transaction-install tx) + ((($ <manifest-entry> "foo" "2" "out" item)) + (eq? item new))) + (null? (manifest-transaction-remove tx))))) + (test-assert "package-field-location" (let () (define (goto port line column) |