union: Allow callers to choose the collision resolution policy.
* guix/build/union.scm (warn-about-collision): New procedure. (union-build): Add #:resolve-collision. [resolve-collisions]: Call it. * tests/union.scm ("union-build collision first & last"): New test.
This commit is contained in:
parent
1b92d65a40
commit
e40aa54e98
@ -25,7 +25,9 @@
|
|||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:use-module (rnrs io ports)
|
#:use-module (rnrs io ports)
|
||||||
#:export (union-build))
|
#:export (union-build
|
||||||
|
|
||||||
|
warn-about-collision))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
@ -76,14 +78,29 @@ identical, #f otherwise."
|
|||||||
(or (eof-object? n1)
|
(or (eof-object? n1)
|
||||||
(loop))))))))))))))
|
(loop))))))))))))))
|
||||||
|
|
||||||
|
(define (warn-about-collision files)
|
||||||
|
"Handle the collision among FILES by emitting a warning and choosing the
|
||||||
|
first one of THEM."
|
||||||
|
(format (current-error-port)
|
||||||
|
"~%warning: collision encountered:~%~{ ~a~%~}"
|
||||||
|
files)
|
||||||
|
(let ((file (first files)))
|
||||||
|
(format (current-error-port) "warning: choosing ~a~%" file)
|
||||||
|
file))
|
||||||
|
|
||||||
(define* (union-build output inputs
|
(define* (union-build output inputs
|
||||||
#:key (log-port (current-error-port))
|
#:key (log-port (current-error-port))
|
||||||
(create-all-directories? #f)
|
(create-all-directories? #f)
|
||||||
(symlink symlink))
|
(symlink symlink)
|
||||||
|
(resolve-collision warn-about-collision))
|
||||||
"Build in the OUTPUT directory a symlink tree that is the union of all the
|
"Build in the OUTPUT directory a symlink tree that is the union of all the
|
||||||
INPUTS, using SYMLINK to create symlinks. As a special case, if
|
INPUTS, using SYMLINK to create symlinks. As a special case, if
|
||||||
CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to
|
CREATE-ALL-DIRECTORIES?, creates the subdirectories in the output directory to
|
||||||
make sure the caller can modify them later."
|
make sure the caller can modify them later.
|
||||||
|
|
||||||
|
When two or more regular files collide, call RESOLVE-COLLISION with the list
|
||||||
|
of colliding files and use the one that it returns; or, if RESOLVE-COLLISION
|
||||||
|
returns #f, skip the faulty file altogether."
|
||||||
|
|
||||||
(define (symlink* input output)
|
(define (symlink* input output)
|
||||||
(format log-port "`~a' ~~> `~a'~%" input output)
|
(format log-port "`~a' ~~> `~a'~%" input output)
|
||||||
@ -92,15 +109,10 @@ make sure the caller can modify them later."
|
|||||||
(define (resolve-collisions output dirs files)
|
(define (resolve-collisions output dirs files)
|
||||||
(cond ((null? dirs)
|
(cond ((null? dirs)
|
||||||
;; The inputs are all files.
|
;; The inputs are all files.
|
||||||
(format (current-error-port)
|
(match (resolve-collision files)
|
||||||
"~%warning: collision encountered:~%~{ ~a~%~}"
|
(#f #f)
|
||||||
files)
|
((? string? file)
|
||||||
|
(symlink* file output))))
|
||||||
(let ((file (first files)))
|
|
||||||
;; TODO: Implement smarter strategies.
|
|
||||||
(format (current-error-port) "warning: choosing ~a~%" file)
|
|
||||||
|
|
||||||
(symlink* file output)))
|
|
||||||
|
|
||||||
(else
|
(else
|
||||||
;; The inputs are a mixture of files and directories
|
;; The inputs are a mixture of files and directories
|
||||||
|
@ -1,5 +1,5 @@
|
|||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2012, 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
|
;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
@ -124,6 +124,46 @@
|
|||||||
;; 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 collision first & last"
|
||||||
|
(let* ((guile (package-derivation %store %bootstrap-guile))
|
||||||
|
(fake (build-expression->derivation
|
||||||
|
%store "fake-guile"
|
||||||
|
'(begin
|
||||||
|
(use-modules (guix build utils))
|
||||||
|
(let ((out (assoc-ref %outputs "out")))
|
||||||
|
(mkdir-p (string-append out "/bin"))
|
||||||
|
(call-with-output-file (string-append out "/bin/guile")
|
||||||
|
(const #t))))
|
||||||
|
#:modules '((guix build utils))))
|
||||||
|
(builder (lambda (policy)
|
||||||
|
`(begin
|
||||||
|
(use-modules (guix build union)
|
||||||
|
(srfi srfi-1))
|
||||||
|
(union-build (assoc-ref %outputs "out")
|
||||||
|
(map cdr %build-inputs)
|
||||||
|
#:resolve-collision ,policy))))
|
||||||
|
(drv1
|
||||||
|
(build-expression->derivation %store "union-first"
|
||||||
|
(builder 'first)
|
||||||
|
#:inputs `(("guile" ,guile)
|
||||||
|
("fake" ,fake))
|
||||||
|
#:modules '((guix build union))))
|
||||||
|
(drv2
|
||||||
|
(build-expression->derivation %store "union-last"
|
||||||
|
(builder 'last)
|
||||||
|
#:inputs `(("guile" ,guile)
|
||||||
|
("fake" ,fake))
|
||||||
|
#:modules '((guix build union)))))
|
||||||
|
(and (build-derivations %store (list drv1 drv2))
|
||||||
|
(with-directory-excursion (derivation->output-path drv1)
|
||||||
|
(string=? (readlink "bin/guile")
|
||||||
|
(string-append (derivation->output-path guile)
|
||||||
|
"/bin/guile")))
|
||||||
|
(with-directory-excursion (derivation->output-path drv2)
|
||||||
|
(string=? (readlink "bin/guile")
|
||||||
|
(string-append (derivation->output-path fake)
|
||||||
|
"/bin/guile"))))))
|
||||||
|
|
||||||
(test-assert "union-build #:create-all-directories? #t"
|
(test-assert "union-build #:create-all-directories? #t"
|
||||||
(let* ((build `(begin
|
(let* ((build `(begin
|
||||||
(use-modules (guix build union))
|
(use-modules (guix build union))
|
||||||
|
Loading…
Reference in New Issue
Block a user