union: Add create-all-directories? parameter to 'union-build'.
* guix/build/union.scm (union-build): Add create-all-directories? keyword parameter. * tests/union.scm ("union-build #:create-all-directories? #t"): New test. Co-authored-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
parent
7398d96ee9
commit
addce19e2d
2 changed files with 33 additions and 6 deletions
|
@ -1,6 +1,7 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
|
;;; Copyright © 2012, 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
|
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
|
||||||
|
;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -73,9 +74,12 @@ identical, #f otherwise."
|
||||||
(loop)))))))))))))
|
(loop)))))))))))))
|
||||||
|
|
||||||
(define* (union-build output inputs
|
(define* (union-build output inputs
|
||||||
#:key (log-port (current-error-port)))
|
#:key (log-port (current-error-port))
|
||||||
"Build in the OUTPUT directory a symlink tree that is the union of all
|
(create-all-directories? #f))
|
||||||
the INPUTS."
|
"Build in the OUTPUT directory a symlink tree that is the union of all the
|
||||||
|
INPUTS. As a special case, if CREATE-ALL-DIRECTORIES?, creates the
|
||||||
|
subdirectories in the output directory to make sure the caller can modify them
|
||||||
|
later."
|
||||||
|
|
||||||
(define (symlink* input output)
|
(define (symlink* input output)
|
||||||
(format log-port "`~a' ~~> `~a'~%" input output)
|
(format log-port "`~a' ~~> `~a'~%" input output)
|
||||||
|
@ -104,8 +108,11 @@ the INPUTS."
|
||||||
(define (union output inputs)
|
(define (union output inputs)
|
||||||
(match inputs
|
(match inputs
|
||||||
((input)
|
((input)
|
||||||
;; There's only one input, so just make a link.
|
;; There's only one input, so just make a link unless
|
||||||
(symlink* input output))
|
;; create-all-directories?.
|
||||||
|
(if (and create-all-directories? (file-is-directory? input))
|
||||||
|
(union-of-directories output inputs)
|
||||||
|
(symlink* input output)))
|
||||||
(_
|
(_
|
||||||
(call-with-values (lambda () (partition file-is-directory? inputs))
|
(call-with-values (lambda () (partition file-is-directory? inputs))
|
||||||
(match-lambda*
|
(match-lambda*
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
|
;;; Copyright © 2012, 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -124,4 +124,24 @@
|
||||||
;; new 'bin' sub-directory in the profile.
|
;; new 'bin' sub-directory in the profile.
|
||||||
(eq? 'directory (stat:type (lstat "bin"))))))))
|
(eq? 'directory (stat:type (lstat "bin"))))))))
|
||||||
|
|
||||||
|
(test-assert "union-build #:create-all-directories? #t"
|
||||||
|
(let* ((build `(begin
|
||||||
|
(use-modules (guix build union))
|
||||||
|
(union-build (assoc-ref %outputs "out")
|
||||||
|
(map cdr %build-inputs)
|
||||||
|
#:create-all-directories? #t)))
|
||||||
|
(input (package-derivation %store %bootstrap-guile))
|
||||||
|
(drv (build-expression->derivation %store "union-test-all-dirs"
|
||||||
|
build
|
||||||
|
#:modules '((guix build union))
|
||||||
|
#:inputs `(("g" ,input)))))
|
||||||
|
(and (build-derivations %store (list drv))
|
||||||
|
(with-directory-excursion (derivation->output-path drv)
|
||||||
|
;; Even though there's only one input to the union,
|
||||||
|
;; #:create-all-directories? #t must have created bin/ rather than
|
||||||
|
;; making it a symlink to Guile's bin/.
|
||||||
|
(and (file-exists? "bin/guile")
|
||||||
|
(file-is-directory? "bin")
|
||||||
|
(eq? 'symlink (stat:type (lstat "bin/guile"))))))))
|
||||||
|
|
||||||
(test-end)
|
(test-end)
|
||||||
|
|
Reference in a new issue