;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
#:use-module (guix monads)
#:use-module (guix grafts)
#:use-module ((guix gexp) #:select (local-file local-file-file))
- #:use-module ((guix utils)
+ #:use-module (guix utils)
+ #:use-module ((guix diagnostics)
;; Rename the 'location' binding to allow proper syntax
;; matching when setting the 'location' field of a package.
#:renamer (lambda (name)
(cond ((eq? name 'location) 'make-location)
(else name))))
- #:use-module (gcrypt hash)
+ #:use-module ((gcrypt hash) #:prefix gcrypt:)
#:use-module (guix derivations)
#:use-module (guix packages)
#:use-module (guix grafts)
#: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)
+ #:use-module (guix sets)
#:use-module (gnu packages)
#: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)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-64)
+ #:use-module (srfi srfi-71)
+ #:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (ice-9 vlist)
#:use-module (ice-9 regex)
(let* ((old (dummy-package "foo" (version "1")))
(tx (mock ((gnu packages) find-best-packages-by-name
(const '()))
- ((@@ (guix scripts package) transaction-upgrade-entry)
+ (transaction-upgrade-entry
+ #f ;no store access needed
(manifest-entry
(inherit (package->manifest-entry old))
(item (string-append (%store-prefix) "/"
(manifest-transaction)))))
(manifest-transaction-null? tx)))
+(test-assert "transaction-upgrade-entry, zero upgrades, equivalent package"
+ (let* ((old (dummy-package "foo" (version "1")))
+ (drv (package-derivation %store old))
+ (tx (mock ((gnu packages) find-best-packages-by-name
+ (const (list old)))
+ (transaction-upgrade-entry
+ %store
+ (manifest-entry
+ (inherit (package->manifest-entry old))
+ (item (derivation->output-path drv)))
+ (manifest-transaction)))))
+ (manifest-transaction-null? tx)))
+
+(test-assert "transaction-upgrade-entry, zero upgrades, propagated inputs"
+ ;; Properly detect equivalent packages even when they have propagated
+ ;; inputs. See <https://bugs.gnu.org/35872>.
+ (let* ((dep (dummy-package "dep" (version "2")))
+ (old (dummy-package "foo" (version "1")
+ (propagated-inputs `(("dep" ,dep)))))
+ (drv (package-derivation %store old))
+ (tx (mock ((gnu packages) find-best-packages-by-name
+ (const (list old)))
+ (transaction-upgrade-entry
+ %store
+ (manifest-entry
+ (inherit (package->manifest-entry old))
+ (item (derivation->output-path drv))
+ (dependencies
+ (list (manifest-entry
+ (inherit (package->manifest-entry dep))
+ (item (derivation->output-path
+ (package-derivation %store dep)))))))
+ (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-best-packages-by-name
(const (list new)))
- ((@@ (guix scripts package) transaction-upgrade-entry)
+ (transaction-upgrade-entry
+ #f ;no store access needed
(manifest-entry
(inherit (package->manifest-entry old))
(item (string-append (%store-prefix) "/"
(dep (deprecated-package "foo" new))
(tx (mock ((gnu packages) find-best-packages-by-name
(const (list dep)))
- ((@@ (guix scripts package) transaction-upgrade-entry)
+ (transaction-upgrade-entry
+ #f ;no store access needed
(manifest-entry
(inherit (package->manifest-entry old))
(item (string-append (%store-prefix) "/"
(string=? (manifest-pattern-version pattern) "1")
(string=? (manifest-pattern-output pattern) "out")))))))
+(test-equal "transaction-upgrade-entry, transformation options preserved"
+ (derivation-file-name (package-derivation %store grep))
+
+ (let* ((old (dummy-package "emacs" (version "1")))
+ (props '((transformations . ((with-input . "emacs=grep")))))
+ (tx (transaction-upgrade-entry
+ %store
+ (manifest-entry
+ (inherit (package->manifest-entry old))
+ (properties props)
+ (item (string-append (%store-prefix) "/"
+ (make-string 32 #\e) "-foo-1")))
+ (manifest-transaction))))
+ (match (manifest-transaction-install tx)
+ (((? manifest-entry? entry))
+ (and (string=? (manifest-entry-version entry)
+ (package-version grep))
+ (string=? (manifest-entry-name entry)
+ (package-name grep))
+ (equal? (manifest-entry-properties entry) props)
+ (derivation-file-name
+ (package-derivation %store (manifest-entry-item entry))))))))
+
+(test-assert "transaction-upgrade-entry, grafts"
+ ;; Ensure that, when grafts are enabled, 'transaction-upgrade-entry' doesn't
+ ;; try to build stuff.
+ (with-build-handler (const 'failed!)
+ (parameterize ((%graft? #t))
+ (let* ((old (dummy-package "foo" (version "1")))
+ (bar (dummy-package "bar" (version "0")
+ (replacement old)))
+ (new (dummy-package "foo" (version "1")
+ (inputs `(("bar" ,bar)))))
+ (tx (mock ((gnu packages) find-best-packages-by-name
+ (const (list new)))
+ (transaction-upgrade-entry
+ %store
+ (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" "1" "out" item))
+ (eq? item new)))
+ (null? (manifest-transaction-remove tx)))))))
+
(test-assert "package-field-location"
(let ()
(define (goto port line column)
(build-system gnu-build-system)
(supported-systems
`("does-not-exist" "foobar" ,@%supported-systems)))))
- (invalidate-memoization! package-transitive-supported-systems)
(parameterize ((%current-system "armhf-linux")) ; a traditionally-bootstrapped architecture
(package-transitive-supported-systems p))))
(build-system gnu-build-system)
(supported-systems
`("does-not-exist" "foobar" ,@%supported-systems)))))
- (invalidate-memoization! package-transitive-supported-systems)
(parameterize ((%current-system "x86_64-linux"))
(package-transitive-supported-systems p))))
(test-assert "supported-package?"
- (let ((p (dummy-package "foo"
- (build-system gnu-build-system)
- (supported-systems '("x86_64-linux" "does-not-exist")))))
+ (let* ((d (dummy-package "dep"
+ (build-system trivial-build-system)
+ (supported-systems '("x86_64-linux"))))
+ (p (dummy-package "foo"
+ (build-system gnu-build-system)
+ (inputs `(("d" ,d)))
+ (supported-systems '("x86_64-linux" "armhf-linux")))))
+ (and (supported-package? p "x86_64-linux")
+ (not (supported-package? p "i686-linux"))
+ (not (supported-package? p "armhf-linux")))))
+
+(test-assert "supported-package? vs. system-dependent graph"
+ ;; The inputs of a package can depend on (%current-system). Thus,
+ ;; 'supported-package?' must make sure that it binds (%current-system)
+ ;; appropriately before traversing the dependency graph. In the example
+ ;; below, 'supported-package?' must thus return true for both systems.
+ (let* ((p0a (dummy-package "foo-arm"
+ (build-system trivial-build-system)
+ (supported-systems '("armhf-linux"))))
+ (p0b (dummy-package "foo-x86_64"
+ (build-system trivial-build-system)
+ (supported-systems '("x86_64-linux"))))
+ (p (dummy-package "bar"
+ (build-system trivial-build-system)
+ (inputs
+ (if (string=? (%current-system) "armhf-linux")
+ `(("foo" ,p0a))
+ `(("foo" ,p0b)))))))
(and (supported-package? p "x86_64-linux")
- (not (supported-package? p "does-not-exist"))
- (not (supported-package? p "i686-linux")))))
+ (supported-package? p "armhf-linux"))))
(test-skip (if (not %store) 8 0))
(search-path %load-path "guix/base32.scm")
get-bytevector-all)))))
+(test-equal "package-source-derivation, origin, sha512"
+ "hello"
+ (let* ((bash (search-bootstrap-binary "bash" (%current-system)))
+ (builder (add-text-to-store %store "my-fixed-builder.sh"
+ "echo -n hello > $out" '()))
+ (method (lambda* (url hash-algo hash #:optional name
+ #:rest rest)
+ (and (eq? hash-algo 'sha512)
+ (raw-derivation name bash (list builder)
+ #:sources (list builder)
+ #:hash hash
+ #:hash-algo hash-algo))))
+ (source (origin
+ (method method)
+ (uri "unused://")
+ (file-name "origin-sha512")
+ (hash (content-hash
+ (gcrypt:bytevector-hash (string->utf8 "hello")
+ (gcrypt:lookup-hash-algorithm
+ 'sha512))
+ sha512))))
+ (drv (package-source-derivation %store source))
+ (output (derivation->output-path drv)))
+ (build-derivations %store (list drv))
+ (call-with-input-file output get-string-all)))
+
+(test-equal "package-source-derivation, origin, sha3-512"
+ "hello, sha3"
+ (let* ((bash (search-bootstrap-binary "bash" (%current-system)))
+ (builder (add-text-to-store %store "my-fixed-builder.sh"
+ "echo -n hello, sha3 > $out" '()))
+ (method (lambda* (url hash-algo hash #:optional name
+ #:rest rest)
+ (and (eq? hash-algo 'sha3-512)
+ (raw-derivation name bash (list builder)
+ #:sources (list builder)
+ #:hash hash
+ #:hash-algo hash-algo))))
+ (source (origin
+ (method method)
+ (uri "unused://")
+ (file-name "origin-sha3")
+ (hash (content-hash
+ (gcrypt:bytevector-hash (string->utf8 "hello, sha3")
+ (gcrypt:lookup-hash-algorithm
+ 'sha3-512))
+ sha3-512))))
+ (drv (package-source-derivation %store source))
+ (output (derivation->output-path drv)))
+ (build-derivations %store (list drv))
+ (call-with-input-file output get-string-all)))
+
(unless (network-reachable?) (test-skip 1))
(test-equal "package-source-derivation, snippet"
"OK"
(string=? (derivation->output-path drv)
(package-output %store package "out")))))
-(test-assert "patch not found yields a run-time error"
- (guard (c ((condition-has-type? c &message)
- (and (string-contains (condition-message c)
- "does-not-exist.patch")
- (string-contains (condition-message c)
- "not found"))))
+(test-equal "patch not found yields a run-time error"
+ '("~a: patch not found\n" "does-not-exist.patch")
+ (guard (c ((formatted-message? c)
+ (cons (formatted-message-string c)
+ (formatted-message-arguments c))))
(let ((p (package
(inherit (dummy-package "p"))
(source (origin
(replacement #f))))
(replacement (package-derivation %store new)))))))
+(test-assert "package-grafts, dependency on several outputs"
+ ;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
+ (letrec* ((p0 (dummy-package "p0"
+ (version "1.0")
+ (replacement p0*)
+ (arguments '(#:implicit-inputs? #f))
+ (outputs '("out" "lib"))))
+ (p0* (package (inherit p0) (version "1.1")))
+ (p1 (dummy-package "p1"
+ (arguments '(#:implicit-inputs? #f))
+ (inputs `(("p0" ,p0)
+ ("p0:lib" ,p0 "lib"))))))
+ (lset= equal? (pk (package-grafts %store p1))
+ (list (graft
+ (origin (package-derivation %store p0))
+ (origin-output "out")
+ (replacement (package-derivation %store p0*))
+ (replacement-output "out"))
+ (graft
+ (origin (package-derivation %store p0))
+ (origin-output "lib")
+ (replacement (package-derivation %store p0*))
+ (replacement-output "lib"))))))
+
(test-assert "replacement also grafted"
;; We build a DAG as below, where dotted arrows represent replacements and
;; solid arrows represent dependencies:
(assoc-ref (bag-build-inputs bag) "libc")
(assoc-ref (bag-build-inputs bag) "coreutils"))))
+(test-assert "package->bag, sensitivity to %current-target-system"
+ ;; https://bugs.gnu.org/41713
+ (let* ((lower (lambda* (name #:key system target inputs native-inputs
+ #:allow-other-keys)
+ (and (not target)
+ (bag (name name) (system system) (target target)
+ (build-inputs native-inputs)
+ (host-inputs inputs)
+ (build (lambda* (store name inputs
+ #:key system target
+ #:allow-other-keys)
+ (build-expression->derivation
+ store "foo" '(mkdir %output))))))))
+ (bs (build-system
+ (name 'build-system-without-cross-compilation)
+ (description "Does not support cross compilation.")
+ (lower lower)))
+ (dep (dummy-package "dep" (build-system bs)))
+ (pkg (dummy-package "example"
+ (native-inputs `(("dep" ,dep)))))
+ (do-not-build (lambda (continue store lst . _) lst)))
+ (equal? (with-build-handler do-not-build
+ (parameterize ((%current-target-system "powerpc64le-linux-gnu")
+ (%graft? #t))
+ (package-cross-derivation %store pkg
+ (%current-target-system)
+ #:graft? #t)))
+ (with-build-handler do-not-build
+ (package-cross-derivation %store
+ (package (inherit pkg))
+ "powerpc64le-linux-gnu"
+ #:graft? #t)))))
+
(test-equal "package->bag, cross-compilation"
`(,(%current-system) "foo86-hurd"
(,(package-source gnu-make))
(("dep" package)
(eq? package dep)))))
+(test-assert "package->bag, sensitivity to %current-system"
+ (let* ((dep (dummy-package "dep"
+ (propagated-inputs (if (string=? (%current-system)
+ "i586-gnu")
+ `(("libxml2" ,libxml2))
+ '()))))
+ (pkg (dummy-package "foo"
+ (native-inputs `(("dep" ,dep)))))
+ (bag (package->bag pkg (%current-system) "i586-gnu")))
+ (equal? (parameterize ((%current-system "x86_64-linux"))
+ (bag-transitive-inputs bag))
+ (parameterize ((%current-system "i586-gnu"))
+ (bag-transitive-inputs bag)))))
+
+(test-assert "package->bag, sensitivity to %current-target-system"
+ (let* ((dep (dummy-package "dep"
+ (propagated-inputs (if (%current-target-system)
+ `(("libxml2" ,libxml2))
+ '()))))
+ (pkg (dummy-package "foo"
+ (native-inputs `(("dep" ,dep)))))
+ (bag (package->bag pkg (%current-system) "foo86-hurd")))
+ (equal? (parameterize ((%current-target-system "foo64-gnu"))
+ (bag-transitive-inputs bag))
+ (parameterize ((%current-target-system #f))
+ (bag-transitive-inputs bag)))))
+
(test-assert "bag->derivation"
(parameterize ((%graft? #f))
(let ((bag (package->bag gnu-make))
(let* ((dep (dummy-package "chbouib"
(native-inputs `(("x" ,grep)))))
(p0 (dummy-package "example"
+ (source 77)
(inputs `(("foo" ,coreutils)
("bar" ,grep)
("baz" ,dep)))))
(transform (lambda (p)
(package (inherit p) (source 42))))
(rewrite (package-mapping transform))
- (p1 (rewrite p0)))
+ (p1 (rewrite p0))
+ (bag0 (package->bag p0))
+ (bag1 (package->bag p1)))
(and (eq? p1 (rewrite p0))
(eqv? 42 (package-source p1))
+
+ ;; Implicit inputs should be left unchanged (skip "source", "foo",
+ ;; "bar", and "baz" in this comparison).
+ (equal? (drop (bag-direct-inputs bag0) 4)
+ (drop (bag-direct-inputs bag1) 4))
+
(match (package-inputs p1)
((("foo" dep1) ("bar" dep2) ("baz" dep3))
(and (eq? dep1 (rewrite coreutils)) ;memoization
(and (eq? dep (rewrite grep))
(package-source dep))))))))))
+(test-equal "package-mapping, deep"
+ '(42)
+ (let* ((p0 (dummy-package "example"
+ (inputs `(("foo" ,coreutils)
+ ("bar" ,grep)))))
+ (transform (lambda (p)
+ (package (inherit p) (source 42))))
+ (rewrite (package-mapping transform #:deep? #t))
+ (p1 (rewrite p0))
+ (bag (package->bag p1)))
+ (and (eq? p1 (rewrite p0))
+ (match (bag-direct-inputs bag)
+ ((("source" 42) ("foo" dep1) ("bar" dep2) rest ..1)
+ (and (eq? dep1 (rewrite coreutils)) ;memoization
+ (eq? dep2 (rewrite grep))
+ (= 42 (package-source dep1))
+ (= 42 (package-source dep2))
+
+ ;; Check that implicit inputs of P0 also got rewritten.
+ (delete-duplicates
+ (map (match-lambda
+ ((_ package . _)
+ (package-source package)))
+ rest))))))))
+
(test-assert "package-input-rewriting"
(let* ((dep (dummy-package "chbouib"
(native-inputs `(("x" ,grep)))))
("baz" ,dep)))))
(rewrite (package-input-rewriting `((,coreutils . ,sed)
(,grep . ,findutils))
- (cut string-append "r-" <>)))
+ (cut string-append "r-" <>)
+ #:deep? #f))
(p1 (rewrite p0))
(p2 (rewrite p0)))
(and (not (eq? p1 p0))
(eq? dep3 (rewrite dep)) ;memoization
(match (package-native-inputs dep3)
((("x" dep))
- (eq? dep findutils)))))))))
+ (eq? dep 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-eq "package-input-rewriting, deep"
+ (derivation-file-name (package-derivation %store sed))
+ (let* ((p0 (dummy-package "chbouib"
+ (build-system python-build-system)
+ (arguments `(#:python ,python))))
+ (rewrite (package-input-rewriting `((,python . ,sed))))
+ (p1 (rewrite p0)))
+ (match (bag-direct-inputs (package->bag p1))
+ ((("python" python) _ ...)
+ (derivation-file-name (package-derivation %store python))))))
(test-assert "package-input-rewriting/spec"
(let* ((dep (dummy-package "chbouib"
("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))
(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"
("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))
(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-input-rewriting/spec, graft"
+ (derivation-file-name (package-derivation %store sed))
+
+ ;; Make sure replacements are rewritten.
+ (let* ((dep0 (dummy-package "dep"
+ (version "1")
+ (build-system trivial-build-system)
+ (inputs `(("coreutils" ,coreutils)))))
+ (dep1 (dummy-package "dep"
+ (version "0")
+ (build-system trivial-build-system)
+ (replacement dep0)))
+ (p0 (dummy-package "p"
+ (build-system trivial-build-system)
+ (inputs `(("dep" ,dep1)))))
+ (rewrite (package-input-rewriting/spec
+ `(("coreutils" . ,(const sed)))))
+ (p1 (rewrite p0)))
+ (match (package-inputs p1)
+ ((("dep" dep))
+ (match (package-inputs (package-replacement dep))
+ ((("coreutils" coreutils))
+ ;; COREUTILS is not 'eq?' to SED, so the most reliable way to check
+ ;; for equality is to lower to a derivation.
+ (derivation-file-name
+ (package-derivation %store coreutils))))))))
+
+(test-assert "package-with-c-toolchain"
+ (let* ((dep (dummy-package "chbouib"
+ (build-system gnu-build-system)
+ (native-inputs `(("x" ,grep)))))
+ (p0 (dummy-package "thingie"
+ (build-system gnu-build-system)
+ (inputs `(("foo" ,grep)
+ ("bar" ,dep)))))
+ (tc (dummy-package "my-toolchain"))
+ (p1 (package-with-c-toolchain p0 `(("toolchain" ,tc)))))
+ (define toolchain-packages
+ '("gcc" "binutils" "glibc" "ld-wrapper"))
+
+ (match (bag-build-inputs (package->bag p1))
+ ((("foo" foo) ("bar" bar) (_ (= package-name packages) . _) ...)
+ (and (not (any (cut member <> packages) toolchain-packages))
+ (member "my-toolchain" packages)
+ (eq? foo grep)
+ (eq? bar dep))))))
+
+(test-assert "package-input-rewriting/spec, identity"
+ ;; Make sure that 'package-input-rewriting/spec' doesn't gratuitously
+ ;; introduce variants. In this case, the LIBFFI propagated input should not
+ ;; be duplicated when passing GOBJECT through REWRITE.
+ ;; See <https://issues.guix.gnu.org/43890>.
+ (let* ((libffi (dummy-package "libffi"
+ (build-system trivial-build-system)))
+ (glib (dummy-package "glib"
+ (build-system trivial-build-system)
+ (propagated-inputs `(("libffi" ,libffi)))))
+ (gobject (dummy-package "gobject-introspection"
+ (build-system trivial-build-system)
+ (inputs `(("glib" ,glib)))
+ (propagated-inputs `(("libffi" ,libffi)))))
+ (rewrite (package-input-rewriting/spec
+ `(("glib" . ,identity)))))
+ (and (= (length (package-transitive-inputs gobject))
+ (length (package-transitive-inputs (rewrite gobject))))
+ (string=? (derivation-file-name
+ (package-derivation %store (rewrite gobject)))
+ (derivation-file-name
+ (package-derivation %store gobject))))))
+
+(test-assert "package-input-rewriting, identity"
+ ;; Similar to the test above, but with 'package-input-rewriting'.
+ ;; See <https://issues.guix.gnu.org/43890>.
+ (let* ((libffi (dummy-package "libffi"
+ (build-system trivial-build-system)))
+ (glib (dummy-package "glib"
+ (build-system trivial-build-system)
+ (propagated-inputs `(("libffi" ,libffi)))))
+ (gobject (dummy-package "gobject-introspection"
+ (build-system trivial-build-system)
+ (inputs `(("glib" ,glib)))
+ (propagated-inputs `(("libffi" ,libffi)))))
+ (rewrite (package-input-rewriting `((,glib . ,glib)))))
+ (and (= (length (package-transitive-inputs gobject))
+ (length (package-transitive-inputs (rewrite gobject))))
+ (string=? (derivation-file-name
+ (package-derivation %store (rewrite gobject)))
+ (derivation-file-name
+ (package-derivation %store gobject))))))
+
(test-equal "package-patched-vulnerabilities"
'(("CVE-2015-1234")
("CVE-2016-1234" "CVE-2018-4567")
result))
'()))))))
- (and (equal? (delete-duplicates from-cache) from-cache)
- (lset= equal? no-cache from-cache))))
+ (define (list->set* lst)
+ ;; Return two values: LST represented as a set and the list of
+ ;; duplicates in LST.
+ (let loop ((lst lst)
+ (duplicates '())
+ (seen (set)))
+ (match lst
+ (()
+ (values seen duplicates))
+ ((head . tail)
+ (if (set-contains? seen head)
+ (loop tail (cons head duplicates) seen)
+ (loop tail duplicates (set-insert head seen)))))))
+
+ ;; Compare FROM-CACHE and NO-CACHE but avoid 'lset=', which exhibits
+ ;; exponential behavior.
+ (let ((set1 duplicates1 (list->set* from-cache))
+ (set2 duplicates2 (list->set* no-cache)))
+ (and (null? duplicates1) (null? duplicates2)
+ (every (cut set-contains? set1 <>) no-cache)
+ (every (cut set-contains? set2 <>) from-cache)))))
(test-assert "find-packages-by-name"
(match (find-packages-by-name "hello")
HCoop / jackhill / guix / guix.git / blobdiff