aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/scripts/package.scm100
-rw-r--r--tests/packages.scm29
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)