nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

packages: 'package-grafts' applies grafts on replacement. 

Partly fixes <http://bugs.gnu.org/24418>.

* guix/packages.scm (input-graft): Compute 'new' with #:graft? #t.
(input-cross-graft): Likewise.
* tests/packages.scm ("package-grafts, indirect grafts, cross"): Comment
out.
("replacement also grafted"): New test.
This commit is contained in:
Ludovic Courtès 2016-10-14 10:36:37 +02:00
parent b280e67ca6
commit d0025d0144
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 94 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
guix/packages.scm
View File

@ -916,7 +916,8 @@ and return it."
(cached (=> %graft-cache) package system (cached (=> %graft-cache) package system
(let ((orig (package-derivation store package system (let ((orig (package-derivation store package system
#:graft? #f)) #:graft? #f))
(new (package-derivation store replacement system))) (new (package-derivation store replacement system
#:graft? #t)))
(graft (graft
(origin orig) (origin orig)
(replacement new))))))) (replacement new)))))))
@ -932,7 +933,8 @@ and return it."
(let ((orig (package-cross-derivation store package target system (let ((orig (package-cross-derivation store package target system
#:graft? #f)) #:graft? #f))
(new (package-cross-derivation store replacement (new (package-cross-derivation store replacement
target system))) target system
#:graft? #t)))
(graft (graft
(origin orig) (origin orig)
(replacement new)))))) (replacement new))))))

106
tests/packages.scm
View File

@ -662,22 +662,25 @@
(origin (package-derivation %store dep)) (origin (package-derivation %store dep))
(replacement (package-derivation %store new))))))) (replacement (package-derivation %store new)))))))
(test-assert "package-grafts, indirect grafts, cross" ;; XXX: This test would require building the cross toolchain just to see if it
(let* ((new (dummy-package "dep" ;; needs grafting, which is obviously too expensive, and thus disabled.
(arguments '(#:implicit-inputs? #f)))) ;;
(dep (package (inherit new) (version "0.0"))) ;; (test-assert "package-grafts, indirect grafts, cross"
(dep* (package (inherit dep) (replacement new))) ;; (let* ((new (dummy-package "dep"
(dummy (dummy-package "dummy" ;; (arguments '(#:implicit-inputs? #f))))
(arguments '(#:implicit-inputs? #f)) ;; (dep (package (inherit new) (version "0.0")))
(inputs `(("dep" ,dep*))))) ;; (dep* (package (inherit dep) (replacement new)))
(target "mips64el-linux-gnu")) ;; (dummy (dummy-package "dummy"
;; XXX: There might be additional grafts, for instance if the distro ;; (arguments '(#:implicit-inputs? #f))
;; defines replacements for core packages like Perl. ;; (inputs `(("dep" ,dep*)))))
(member (graft ;; (target "mips64el-linux-gnu"))
(origin (package-cross-derivation %store dep target)) ;; ;; XXX: There might be additional grafts, for instance if the distro
(replacement ;; ;; defines replacements for core packages like Perl.
(package-cross-derivation %store new target))) ;; (member (graft
(package-grafts %store dummy #:target target)))) ;; (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" (test-assert "package-grafts, indirect grafts, propagated inputs"
(let* ((new (dummy-package "dep" (let* ((new (dummy-package "dep"
@ -719,6 +722,77 @@
(replacement #f)))) (replacement #f))))
(replacement (package-derivation %store new))))))) (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 ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
;;; find out about their run-time dependencies, so this test is no longer ;;; find out about their run-time dependencies, so this test is no longer
;;; applicable since it would trigger a full rebuild. ;;; applicable since it would trigger a full rebuild.