mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2026-05-28 03:51:53 +02:00
Merge branch 'master' into core-updates
This commit is contained in:
Mark H Weaver
@@ -218,4 +218,66 @@
|
||||
(let ((out (derivation->output-path grafted)))
|
||||
(file-is-directory? (string-append out "/" repl))))))
|
||||
|
||||
(test-assert "graft-derivation, grafts are not shadowed"
|
||||
;; We build a DAG as below, where dotted arrows represent replacements and
|
||||
;; solid arrows represent dependencies:
|
||||
;;
|
||||
;; P1 ·············> P1R
|
||||
;; |\__________________.
|
||||
;; v v
|
||||
;; P2 ·············> P2R
|
||||
;; |
|
||||
;; v
|
||||
;; P3
|
||||
;;
|
||||
;; We want to make sure that the two grafts we want to apply to P3 are
|
||||
;; honored and not shadowed by other computed grafts.
|
||||
(let* ((p1 (build-expression->derivation
|
||||
%store "p1"
|
||||
'(mkdir (assoc-ref %outputs "out"))))
|
||||
(p1r (build-expression->derivation
|
||||
%store "P1"
|
||||
'(let ((out (assoc-ref %outputs "out")))
|
||||
(mkdir out)
|
||||
(call-with-output-file (string-append out "/replacement")
|
||||
(const #t)))))
|
||||
(p2 (build-expression->derivation
|
||||
%store "p2"
|
||||
`(let ((out (assoc-ref %outputs "out")))
|
||||
(mkdir out)
|
||||
(chdir out)
|
||||
(symlink (assoc-ref %build-inputs "p1") "p1"))
|
||||
#:inputs `(("p1" ,p1))))
|
||||
(p2r (build-expression->derivation
|
||||
%store "P2"
|
||||
`(let ((out (assoc-ref %outputs "out")))
|
||||
(mkdir out)
|
||||
(chdir out)
|
||||
(symlink (assoc-ref %build-inputs "p1") "p1")
|
||||
(call-with-output-file (string-append out "/replacement")
|
||||
(const #t)))
|
||||
#:inputs `(("p1" ,p1))))
|
||||
(p3 (build-expression->derivation
|
||||
%store "p3"
|
||||
`(let ((out (assoc-ref %outputs "out")))
|
||||
(mkdir out)
|
||||
(chdir out)
|
||||
(symlink (assoc-ref %build-inputs "p2") "p2"))
|
||||
#:inputs `(("p2" ,p2))))
|
||||
(p1g (graft
|
||||
(origin p1)
|
||||
(replacement p1r)))
|
||||
(p2g (graft
|
||||
(origin p2)
|
||||
(replacement (graft-derivation %store p2r (list p1g)))))
|
||||
(p3d (graft-derivation %store p3 (list p1g p2g))))
|
||||
(and (build-derivations %store (list p3d))
|
||||
(let ((out (derivation->output-path (pk p3d))))
|
||||
;; Make sure OUT refers to the replacement of P2, which in turn
|
||||
;; refers to the replacement of P1, as specified by P1G and P2G.
|
||||
;; It used to be the case that P2G would be shadowed by a simple
|
||||
;; P2->P2R graft, which is not what we want.
|
||||
(and (file-exists? (string-append out "/p2/replacement"))
|
||||
(file-exists? (string-append out "/p2/p1/replacement")))))))
|
||||
|
||||
(test-end)
|
||||
|
||||
@@ -232,6 +232,28 @@ edges."
|
||||
(list out txt))
|
||||
(equal? edges `((,out ,txt)))))))))))
|
||||
|
||||
(test-assert "referrer DAG"
|
||||
(let-values (((backend nodes+edges) (make-recording-backend)))
|
||||
(run-with-store %store
|
||||
(mlet* %store-monad ((txt (text-file "referrer-node" (random-text)))
|
||||
(drv (gexp->derivation "referrer"
|
||||
#~(symlink #$txt #$output)))
|
||||
(out -> (derivation->output-path drv)))
|
||||
;; We should see only TXT and OUT, with an edge from the former to the
|
||||
;; latter.
|
||||
(mbegin %store-monad
|
||||
(built-derivations (list drv))
|
||||
(export-graph (list txt) 'port
|
||||
#:node-type %referrer-node-type
|
||||
#:backend backend)
|
||||
(let-values (((nodes edges) (nodes+edges)))
|
||||
(return
|
||||
(and (equal? (match nodes
|
||||
(((ids labels) ...)
|
||||
ids))
|
||||
(list txt out))
|
||||
(equal? edges `((,txt ,out)))))))))))
|
||||
|
||||
(test-assert "node-edges"
|
||||
(run-with-store %store
|
||||
(let ((packages (fold-packages cons '())))
|
||||
|
||||
+90
-16
@@ -662,22 +662,25 @@
|
||||
(origin (package-derivation %store dep))
|
||||
(replacement (package-derivation %store new)))))))
|
||||
|
||||
(test-assert "package-grafts, indirect grafts, cross"
|
||||
(let* ((new (dummy-package "dep"
|
||||
(arguments '(#:implicit-inputs? #f))))
|
||||
(dep (package (inherit new) (version "0.0")))
|
||||
(dep* (package (inherit dep) (replacement new)))
|
||||
(dummy (dummy-package "dummy"
|
||||
(arguments '(#:implicit-inputs? #f))
|
||||
(inputs `(("dep" ,dep*)))))
|
||||
(target "mips64el-linux-gnu"))
|
||||
;; XXX: There might be additional grafts, for instance if the distro
|
||||
;; defines replacements for core packages like Perl.
|
||||
(member (graft
|
||||
(origin (package-cross-derivation %store dep target))
|
||||
(replacement
|
||||
(package-cross-derivation %store new target)))
|
||||
(package-grafts %store dummy #:target target))))
|
||||
;; XXX: This test would require building the cross toolchain just to see if it
|
||||
;; needs grafting, which is obviously too expensive, and thus disabled.
|
||||
;;
|
||||
;; (test-assert "package-grafts, indirect grafts, cross"
|
||||
;; (let* ((new (dummy-package "dep"
|
||||
;; (arguments '(#:implicit-inputs? #f))))
|
||||
;; (dep (package (inherit new) (version "0.0")))
|
||||
;; (dep* (package (inherit dep) (replacement new)))
|
||||
;; (dummy (dummy-package "dummy"
|
||||
;; (arguments '(#:implicit-inputs? #f))
|
||||
;; (inputs `(("dep" ,dep*)))))
|
||||
;; (target "mips64el-linux-gnu"))
|
||||
;; ;; XXX: There might be additional grafts, for instance if the distro
|
||||
;; ;; defines replacements for core packages like Perl.
|
||||
;; (member (graft
|
||||
;; (origin (package-cross-derivation %store dep target))
|
||||
;; (replacement
|
||||
;; (package-cross-derivation %store new target)))
|
||||
;; (package-grafts %store dummy #:target target))))
|
||||
|
||||
(test-assert "package-grafts, indirect grafts, propagated inputs"
|
||||
(let* ((new (dummy-package "dep"
|
||||
@@ -719,6 +722,77 @@
|
||||
(replacement #f))))
|
||||
(replacement (package-derivation %store new)))))))
|
||||
|
||||
(test-assert "replacement also grafted"
|
||||
;; We build a DAG as below, where dotted arrows represent replacements and
|
||||
;; solid arrows represent dependencies:
|
||||
;;
|
||||
;; P1 ·············> P1R
|
||||
;; |\__________________.
|
||||
;; v v
|
||||
;; P2 ·············> P2R
|
||||
;; |
|
||||
;; v
|
||||
;; P3
|
||||
;;
|
||||
;; We want to make sure that:
|
||||
;; grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R)))
|
||||
;; where:
|
||||
;; (A,B) is a graft to replace A by B
|
||||
;; grafted(DRV,G) denoted DRV with graft G applied
|
||||
(let* ((p1r (dummy-package "P1"
|
||||
(build-system trivial-build-system)
|
||||
(arguments
|
||||
`(#:guile ,%bootstrap-guile
|
||||
#:builder (let ((out (assoc-ref %outputs "out")))
|
||||
(mkdir out)
|
||||
(call-with-output-file
|
||||
(string-append out "/replacement")
|
||||
(const #t)))))))
|
||||
(p1 (package
|
||||
(inherit p1r) (name "p1") (replacement p1r)
|
||||
(arguments
|
||||
`(#:guile ,%bootstrap-guile
|
||||
#:builder (mkdir (assoc-ref %outputs "out"))))))
|
||||
(p2r (dummy-package "P2"
|
||||
(build-system trivial-build-system)
|
||||
(inputs `(("p1" ,p1)))
|
||||
(arguments
|
||||
`(#:guile ,%bootstrap-guile
|
||||
#:builder (let ((out (assoc-ref %outputs "out")))
|
||||
(mkdir out)
|
||||
(chdir out)
|
||||
(symlink (assoc-ref %build-inputs "p1") "p1")
|
||||
(call-with-output-file (string-append out "/replacement")
|
||||
(const #t)))))))
|
||||
(p2 (package
|
||||
(inherit p2r) (name "p2") (replacement p2r)
|
||||
(arguments
|
||||
`(#:guile ,%bootstrap-guile
|
||||
#:builder (let ((out (assoc-ref %outputs "out")))
|
||||
(mkdir out)
|
||||
(chdir out)
|
||||
(symlink (assoc-ref %build-inputs "p1")
|
||||
"p1"))))))
|
||||
(p3 (dummy-package "p3"
|
||||
(build-system trivial-build-system)
|
||||
(inputs `(("p2" ,p2)))
|
||||
(arguments
|
||||
`(#:guile ,%bootstrap-guile
|
||||
#:builder (let ((out (assoc-ref %outputs "out")))
|
||||
(mkdir out)
|
||||
(chdir out)
|
||||
(symlink (assoc-ref %build-inputs "p2")
|
||||
"p2")))))))
|
||||
(lset= equal?
|
||||
(package-grafts %store p3)
|
||||
(list (graft
|
||||
(origin (package-derivation %store p1 #:graft? #f))
|
||||
(replacement (package-derivation %store p1r)))
|
||||
(graft
|
||||
(origin (package-derivation %store p2 #:graft? #f))
|
||||
(replacement
|
||||
(package-derivation %store p2r #:graft? #t)))))))
|
||||
|
||||
;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
|
||||
;;; find out about their run-time dependencies, so this test is no longer
|
||||
;;; applicable since it would trigger a full rebuild.
|
||||
|
||||
Reference in New Issue
Block a user