grafts: Record metadata as derivation properties.
* guix/grafts.scm (graft-derivation/shallow): Pass #:properties to 'build-expression->derivation'. * tests/grafts.scm ("graft-derivation, grafted item is a direct dependency"): Check the value returned by 'derivation-properties'.
This commit is contained in:
parent
8856f409d1
commit
64fd1c01bc
|
@ -123,6 +123,10 @@ are not recursively applied to dependencies of DRV."
|
|||
(define add-label
|
||||
(cut cons "x" <>))
|
||||
|
||||
(define properties
|
||||
`((type . graft)
|
||||
(graft (count . ,(length grafts)))))
|
||||
|
||||
(match grafts
|
||||
((($ <graft> sources source-outputs targets target-outputs) ...)
|
||||
(let ((sources (zip sources source-outputs))
|
||||
|
@ -140,7 +144,8 @@ are not recursively applied to dependencies of DRV."
|
|||
,@(append (map add-label sources)
|
||||
(map add-label targets)))
|
||||
#:outputs outputs
|
||||
#:local-build? #t)))))
|
||||
#:local-build? #t
|
||||
#:properties properties)))))
|
||||
(define (item->deriver store item)
|
||||
"Return two values: the derivation that led to ITEM (a store item), and the
|
||||
name of the output of that derivation ITEM corresponds to (for example
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
@ -51,7 +51,8 @@
|
|||
|
||||
(test-begin "grafts")
|
||||
|
||||
(test-assert "graft-derivation, grafted item is a direct dependency"
|
||||
(test-equal "graft-derivation, grafted item is a direct dependency"
|
||||
'((type . graft) (graft (count . 2)))
|
||||
(let* ((build `(begin
|
||||
(mkdir %output)
|
||||
(chdir %output)
|
||||
|
@ -76,14 +77,16 @@
|
|||
(origin %mkdir)
|
||||
(replacement two))))))
|
||||
(and (build-derivations %store (list grafted))
|
||||
(let ((two (derivation->output-path two))
|
||||
(grafted (derivation->output-path grafted)))
|
||||
(let ((properties (derivation-properties grafted))
|
||||
(two (derivation->output-path two))
|
||||
(grafted (derivation->output-path grafted)))
|
||||
(and (string=? (format #f "foo/~a/bar" two)
|
||||
(call-with-input-file (string-append grafted "/text")
|
||||
get-string-all))
|
||||
(string=? (readlink (string-append grafted "/sh")) one)
|
||||
(string=? (readlink (string-append grafted "/self"))
|
||||
grafted))))))
|
||||
grafted)
|
||||
properties)))))
|
||||
|
||||
(test-assert "graft-derivation, grafted item uses a different name"
|
||||
(let* ((build `(begin
|
||||
|
|
Loading…
Reference in New Issue