packages: Add 'package-input-rewriting/spec'.

* guix/packages.scm (package-input-rewriting/spec): New procedure.
* tests/packages.scm ("package-input-rewriting/spec")
("package-input-rewriting/spec, partial match"): New tests.
* doc/guix.texi (Defining Packages): Document it.
This commit is contained in:
Ludovic Courtès 2019-03-12 21:39:48 +01:00
parent 880916ac52
commit f258d88628
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 112 additions and 0 deletions

View file

@ -5241,6 +5241,29 @@ with @var{libressl}. Then we use it to define a @dfn{variant} of the
This is exactly what the @option{--with-input} command-line option does This is exactly what the @option{--with-input} command-line option does
(@pxref{Package Transformation Options, @option{--with-input}}). (@pxref{Package Transformation Options, @option{--with-input}}).
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.
@end deffn
The example above could be rewritten this way:
@example
(define libressl-instead-of-openssl
;; Replace all the packages called "openssl" with LibreSSL.
(package-input-rewriting/spec `(("openssl" . ,(const libressl)))))
@end example
The key difference here is that, this time, packages are matched by spec and
not by identity. In other words, any package in the graph that is called
@code{openssl} will be replaced.
A more generic procedure to rewrite a package dependency graph is A more generic procedure to rewrite a package dependency graph is
@code{package-mapping}: it supports arbitrary changes to nodes in the @code{package-mapping}: it supports arbitrary changes to nodes in the
graph. graph.

View file

@ -102,6 +102,7 @@ (define-module (guix packages)
package-transitive-supported-systems package-transitive-supported-systems
package-mapping package-mapping
package-input-rewriting package-input-rewriting
package-input-rewriting/spec
package-source-derivation package-source-derivation
package-derivation package-derivation
package-cross-derivation package-cross-derivation
@ -869,6 +870,43 @@ (define (rewrite p)
(package-mapping rewrite (cut assq <> replacements))) (package-mapping rewrite (cut assq <> replacements)))
(define (package-input-rewriting/spec replacements)
"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."
(define table
(fold (lambda (replacement table)
(match replacement
((spec . proc)
(let-values (((name version)
(package-name->name+version spec)))
(vhash-cons name (list version proc) table)))))
vlist-null
replacements))
(define (find-replacement package)
(vhash-fold* (lambda (item proc)
(or proc
(match item
((#f proc)
proc)
((version proc)
(and (version-prefix? version
(package-version package))
proc)))))
#f
(package-name package)
table))
(define (rewrite package)
(match (find-replacement package)
(#f package)
(proc (proc package))))
(package-mapping rewrite find-replacement))
(define-syntax-rule (package/inherit p overrides ...) (define-syntax-rule (package/inherit p overrides ...)
"Like (package (inherit P) OVERRIDES ...), except that the same "Like (package (inherit P) OVERRIDES ...), except that the same
transformation is done to the package replacement, if any. P must be a bare transformation is done to the package replacement, if any. P must be a bare

View file

@ -981,6 +981,57 @@ (define read-at
((("x" dep)) ((("x" dep))
(eq? dep findutils))))))))) (eq? dep findutils)))))))))
(test-assert "package-input-rewriting/spec"
(let* ((dep (dummy-package "chbouib"
(native-inputs `(("x" ,grep)))))
(p0 (dummy-package "example"
(inputs `(("foo" ,coreutils)
("bar" ,grep)
("baz" ,dep)))))
(rewrite (package-input-rewriting/spec
`(("coreutils" . ,(const sed))
("grep" . ,(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)
((("foo" dep1) ("bar" dep2) ("baz" dep3))
(and (string=? (package-full-name dep1)
(package-full-name sed))
(string=? (package-full-name dep2)
(package-full-name findutils))
(string=? (package-name dep3) "chbouib")
(eq? dep3 (rewrite dep)) ;memoization
(match (package-native-inputs dep3)
((("x" dep))
(string=? (package-full-name dep)
(package-full-name findutils))))))))))
(test-assert "package-input-rewriting/spec, partial match"
(let* ((dep (dummy-package "chbouib"
(version "1")
(native-inputs `(("x" ,grep)))))
(p0 (dummy-package "example"
(inputs `(("foo" ,coreutils)
("bar" ,dep)))))
(rewrite (package-input-rewriting/spec
`(("chbouib@123" . ,(const sed)) ;not matched
("grep" . ,(const findutils)))))
(p1 (rewrite p0)))
(and (not (eq? p1 p0))
(string=? "example" (package-name p1))
(match (package-inputs p1)
((("foo" dep1) ("bar" dep2))
(and (string=? (package-full-name dep1)
(package-full-name coreutils))
(eq? dep2 (rewrite dep)) ;memoization
(match (package-native-inputs dep2)
((("x" dep))
(string=? (package-full-name dep)
(package-full-name findutils))))))))))
(test-equal "package-patched-vulnerabilities" (test-equal "package-patched-vulnerabilities"
'(("CVE-2015-1234") '(("CVE-2015-1234")
("CVE-2016-1234" "CVE-2018-4567") ("CVE-2016-1234" "CVE-2018-4567")