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

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:
Ludovic Courtès 2018-11-26 22:27:39 +01:00
parent 8856f409d1
commit 64fd1c01bc
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 14 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
guix/grafts.scm
View File

@ -123,6 +123,10 @@ are not recursively applied to dependencies of DRV."
(define add-label (define add-label
(cut cons "x" <>)) (cut cons "x" <>))
(define properties
`((type . graft)
(graft (count . ,(length grafts)))))
(match grafts (match grafts
((($ <graft> sources source-outputs targets target-outputs) ...) ((($ <graft> sources source-outputs targets target-outputs) ...)
(let ((sources (zip sources source-outputs)) (let ((sources (zip sources source-outputs))
@ -140,7 +144,8 @@ are not recursively applied to dependencies of DRV."
,@(append (map add-label sources) ,@(append (map add-label sources)
(map add-label targets))) (map add-label targets)))
#:outputs outputs #:outputs outputs
#:local-build? #t))))) #:local-build? #t
#:properties properties)))))
(define (item->deriver store item) (define (item->deriver store item)
"Return two values: the derivation that led to ITEM (a store item), and the "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 name of the output of that derivation ITEM corresponds to (for example

11
tests/grafts.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -51,7 +51,8 @@
(test-begin "grafts") (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 (let* ((build `(begin
(mkdir %output) (mkdir %output)
(chdir %output) (chdir %output)
@ -76,14 +77,16 @@
(origin %mkdir) (origin %mkdir)
(replacement two)))))) (replacement two))))))
(and (build-derivations %store (list grafted)) (and (build-derivations %store (list grafted))
(let ((two (derivation->output-path two)) (let ((properties (derivation-properties grafted))
(two (derivation->output-path two))
(grafted (derivation->output-path grafted))) (grafted (derivation->output-path grafted)))
(and (string=? (format #f "foo/~a/bar" two) (and (string=? (format #f "foo/~a/bar" two)
(call-with-input-file (string-append grafted "/text") (call-with-input-file (string-append grafted "/text")
get-string-all)) get-string-all))
(string=? (readlink (string-append grafted "/sh")) one) (string=? (readlink (string-append grafted "/sh")) one)
(string=? (readlink (string-append grafted "/self")) (string=? (readlink (string-append grafted "/self"))
grafted)))))) grafted)
properties)))))
(test-assert "graft-derivation, grafted item uses a different name" (test-assert "graft-derivation, grafted item uses a different name"
(let* ((build `(begin (let* ((build `(begin