summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/guix.texi13
-rw-r--r--guix/packages.scm55
-rw-r--r--tests/guix-build.sh11
-rw-r--r--tests/packages.scm66
-rw-r--r--tests/scripts-build.scm12
5 files changed, 125 insertions, 32 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index 054449d8d6..e72e1ec130 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6272,12 +6272,13 @@ This is exactly what the @option{--with-input} command-line option does
The following variant of @code{package-input-rewriting} can match packages to
be replaced by name rather than by identity.
-@deffn {Scheme Procedure} package-input-rewriting/spec @var{replacements}
-Return a procedure that, given a package, applies the given @var{replacements} to
-all the package graph (excluding implicit inputs). @var{replacements} is a list of
-spec/procedures pair; each spec is a package specification such as @code{"gcc"} or
-@code{"guile@@2"}, and each procedure takes a matching package and returns a
-replacement for that package.
+@deffn {Scheme Procedure} package-input-rewriting/spec @var{replacements} [#:deep? #t]
+Return a procedure that, given a package, applies the given
+@var{replacements} to all the package graph, including implicit inputs
+unless @var{deep?} is false. @var{replacements} is a list of
+spec/procedures pair; each spec is a package specification such as
+@code{"gcc"} or @code{"guile@@2"}, and each procedure takes a matching
+package and returns a replacement for that package.
@end deffn
The example above could be rewritten this way:
diff --git a/guix/packages.scm b/guix/packages.scm
index 171fd048ef..f696945e30 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -422,6 +422,16 @@ name of its URI."
package)
16)))))
+(define-syntax-rule (package/inherit p overrides ...)
+ "Like (package (inherit P) OVERRIDES ...), except that the same
+transformation is done to the package replacement, if any. P must be a bare
+identifier, and will be bound to either P or its replacement when evaluating
+OVERRIDES."
+ (let loop ((p p))
+ (package (inherit p)
+ overrides ...
+ (replacement (and=> (package-replacement p) loop)))))
+
(define (package-upstream-name package)
"Return the upstream name of PACKAGE, which could be different from the name
it has in Guix."
@@ -1051,12 +1061,12 @@ package and returns its new name after rewrite."
(package-mapping rewrite (cut assq <> replacements)))
-(define (package-input-rewriting/spec replacements)
+(define* (package-input-rewriting/spec replacements #:key (deep? #t))
"Return a procedure that, given a package, applies the given REPLACEMENTS to
-all the package graph (excluding implicit inputs). REPLACEMENTS is a list of
-spec/procedures pair; each spec is a package specification such as \"gcc\" or
-\"guile@2\", and each procedure takes a matching package and returns a
-replacement for that package."
+all the package graph, including implicit inputs unless DEEP? is false.
+REPLACEMENTS is a list of spec/procedures pair; each spec is a package
+specification such as \"gcc\" or \"guile@2\", and each procedure takes a
+matching package and returns a replacement for that package."
(define table
(fold (lambda (replacement table)
(match replacement
@@ -1081,22 +1091,27 @@ replacement for that package."
(package-name package)
table))
- (define (rewrite package)
- (match (find-replacement package)
- (#f package)
- (proc (proc package))))
-
- (package-mapping rewrite find-replacement))
+ (define replacement-property
+ (gensym " package-replacement"))
-(define-syntax-rule (package/inherit p overrides ...)
- "Like (package (inherit P) OVERRIDES ...), except that the same
-transformation is done to the package replacement, if any. P must be a bare
-identifier, and will be bound to either P or its replacement when evaluating
-OVERRIDES."
- (let loop ((p p))
- (package (inherit p)
- overrides ...
- (replacement (and=> (package-replacement p) loop)))))
+ (define (rewrite p)
+ (if (assq-ref (package-properties p) replacement-property)
+ p
+ (match (find-replacement p)
+ (#f p)
+ (proc
+ (let ((new (proc p)))
+ ;; Mark NEW as already processed.
+ (package/inherit new
+ (properties `((,replacement-property . #t)
+ ,@(package-properties new)))))))))
+
+ (define (cut? p)
+ (or (assq-ref (package-properties p) replacement-property)
+ (find-replacement p)))
+
+ (package-mapping rewrite cut?
+ #:deep? deep?))
;;;
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index 6c08857358..ec2f736ccb 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -259,6 +259,17 @@ drv1=`guix build guile -d`
drv2=`guix build guile --with-input=gimp=ruby -d`
test "$drv1" = "$drv2"
+# See <https://bugs.gnu.org/42156>.
+drv1=`guix build glib -d`
+drv2=`guix build glib -d --with-input=libreoffice=inkscape`
+test "$drv1" = "$drv2"
+
+# Rewriting implicit inputs.
+drv1=`guix build hello -d`
+drv2=`guix build hello -d --with-input=gcc=gcc-toolchain`
+test "$drv1" != "$drv2"
+guix gc -R "$drv2" | grep `guix build -d gcc-toolchain`
+
if guix build guile --with-input=libunistring=something-really-silly
then false; else true; fi
diff --git a/tests/packages.scm b/tests/packages.scm
index f33332a461..6fa4ad2f1b 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -38,6 +38,7 @@
#:use-module (guix build-system)
#:use-module (guix build-system trivial)
#:use-module (guix build-system gnu)
+ #:use-module (guix build-system python)
#:use-module (guix memoization)
#:use-module (guix profiles)
#:use-module (guix scripts package)
@@ -45,6 +46,7 @@
#:use-module (gnu packages base)
#:use-module (gnu packages guile)
#:use-module (gnu packages bootstrap)
+ #:use-module (gnu packages python)
#:use-module (gnu packages version-control)
#:use-module (gnu packages xml)
#:use-module (srfi srfi-1)
@@ -1262,7 +1264,8 @@
("baz" ,dep)))))
(rewrite (package-input-rewriting/spec
`(("coreutils" . ,(const sed))
- ("grep" . ,(const findutils)))))
+ ("grep" . ,(const findutils)))
+ #:deep? #f))
(p1 (rewrite p0))
(p2 (rewrite p0)))
(and (not (eq? p1 p0))
@@ -1279,7 +1282,11 @@
(match (package-native-inputs dep3)
((("x" dep))
(string=? (package-full-name dep)
- (package-full-name findutils))))))))))
+ (package-full-name findutils)))))))
+
+ ;; Make sure implicit inputs were left unchanged.
+ (equal? (drop (bag-direct-inputs (package->bag p1)) 3)
+ (drop (bag-direct-inputs (package->bag p0)) 3)))))
(test-assert "package-input-rewriting/spec, partial match"
(let* ((dep (dummy-package "chbouib"
@@ -1290,7 +1297,8 @@
("bar" ,dep)))))
(rewrite (package-input-rewriting/spec
`(("chbouib@123" . ,(const sed)) ;not matched
- ("grep" . ,(const findutils)))))
+ ("grep" . ,(const findutils)))
+ #:deep? #f))
(p1 (rewrite p0)))
(and (not (eq? p1 p0))
(string=? "example" (package-name p1))
@@ -1304,6 +1312,58 @@
(string=? (package-full-name dep)
(package-full-name findutils))))))))))
+(test-assert "package-input-rewriting/spec, deep"
+ (let* ((dep (dummy-package "chbouib"))
+ (p0 (dummy-package "example"
+ (build-system gnu-build-system)
+ (inputs `(("dep" ,dep)))))
+ (rewrite (package-input-rewriting/spec
+ `(("tar" . ,(const sed))
+ ("gzip" . ,(const findutils)))))
+ (p1 (rewrite p0))
+ (p2 (rewrite p0)))
+ (and (not (eq? p1 p0))
+ (eq? p1 p2) ;memoization
+ (string=? "example" (package-name p1))
+ (match (package-inputs p1)
+ ((("dep" dep1))
+ (and (string=? (package-full-name dep1)
+ (package-full-name dep))
+ (eq? dep1 (rewrite dep))))) ;memoization
+
+ ;; Make sure implicit inputs were replaced.
+ (match (bag-direct-inputs (package->bag p1))
+ ((("dep" dep1) ("tar" tar) ("gzip" gzip) _ ...)
+ (and (eq? dep1 (rewrite dep))
+ (string=? (package-full-name tar)
+ (package-full-name sed))
+ (string=? (package-full-name gzip)
+ (package-full-name findutils))))))))
+
+(test-assert "package-input-rewriting/spec, no duplicates"
+ ;; Ensure that deep input rewriting does not forget implicit inputs. Doing
+ ;; so could lead to duplicates in a package's inputs: in the example below,
+ ;; P0's transitive inputs would contain one rewritten "python" and one
+ ;; original "python". These two "python" packages are thus not 'eq?' but
+ ;; they lower to the same derivation. See <https://bugs.gnu.org/42156>,
+ ;; which can be reproduced by passing #:deep? #f.
+ (let* ((dep0 (dummy-package "dep0"
+ (build-system trivial-build-system)
+ (propagated-inputs `(("python" ,python)))))
+ (p0 (dummy-package "chbouib"
+ (build-system python-build-system)
+ (arguments `(#:python ,python))
+ (inputs `(("dep0" ,dep0)))))
+ (rewrite (package-input-rewriting/spec '() #:deep? #t))
+ (p1 (rewrite p0))
+ (bag1 (package->bag p1))
+ (pythons (filter-map (match-lambda
+ (("python" python) python)
+ (_ #f))
+ (bag-transitive-inputs bag1))))
+ (match (delete-duplicates pythons eq?)
+ ((p) (eq? p (rewrite python))))))
+
(test-equal "package-patched-vulnerabilities"
'(("CVE-2015-1234")
("CVE-2016-1234" "CVE-2018-4567")
diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm
index 12114fc8f5..5f91360953 100644
--- a/tests/scripts-build.scm
+++ b/tests/scripts-build.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -19,6 +19,7 @@
(define-module (test-scripts-build)
#:use-module (guix tests)
#:use-module (guix store)
+ #:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix git-download)
#:use-module (guix scripts build)
@@ -163,11 +164,16 @@
((("foo" dep1) ("bar" dep2))
(and (string=? (package-full-name dep1)
(package-full-name grep))
- (eq? (package-replacement dep1) findutils)
+ (string=? (package-full-name (package-replacement dep1))
+ (package-full-name findutils))
(string=? (package-name dep2) "chbouib")
(match (package-native-inputs dep2)
((("x" dep))
- (eq? (package-replacement dep) findutils)))))))))))
+ (with-store store
+ (string=? (derivation-file-name
+ (package-derivation store findutils))
+ (derivation-file-name
+ (package-derivation store dep))))))))))))))
(test-equal "options->transformation, with-branch"
(git-checkout (url "https://example.org")