X-Git-Url: http://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/233e76769ae3a438bff7117c68f2c88739a28db0..6611cabd1c3791c79ce2ff701eaf758ceacd9119:/tests/union.scm diff --git a/tests/union.scm b/tests/union.scm index 317d49dc35..a8387edf42 100644 --- a/tests/union.scm +++ b/tests/union.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. ;;; @@ -16,8 +17,8 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . - (define-module (test-union) + #:use-module (guix tests) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix derivations) @@ -25,48 +26,66 @@ #:use-module (guix build union) #:use-module ((guix build utils) #:select (with-directory-excursion directory-exists?)) - #:use-module (distro packages bootstrap) + #:use-module (gnu packages bootstrap) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) + #:use-module (rnrs io ports) #:use-module (ice-9 match)) ;; Exercise the (guix build union) module. (define %store - (false-if-exception (open-connection))) - -(when %store - ;; By default, use %BOOTSTRAP-GUILE for the current system. - (let ((drv (package-derivation %store %bootstrap-guile))) - (%guile-for-build drv))) + (open-connection-for-tests)) (test-begin "union") -(test-equal "tree-union, empty" - '() - (tree-union '())) - -(test-equal "tree-union, leaves only" - '(a b c d) - (tree-union '(a b c d))) - -(test-equal "tree-union, simple" - '((bin ls touch make awk gawk)) - (tree-union '((bin ls touch) - (bin make) - (bin awk gawk)))) +(test-assert "union-build with symlink to directory" + ;; http://bugs.gnu.org/17083 + ;; Here both ONE and TWO provide an element called 'foo', but in ONE it's a + ;; directory whereas in TWO it's a symlink to a directory. + (let* ((one (build-expression->derivation + %store "one" + '(begin + (use-modules (guix build utils) (srfi srfi-26)) + (let ((foo (string-append %output "/foo"))) + (mkdir-p foo) + (call-with-output-file (string-append foo "/one") + (cut display "one" <>)))) + #:modules '((guix build utils)))) + (two (build-expression->derivation + %store "two" + '(begin + (use-modules (guix build utils) (srfi srfi-26)) + (let ((foo (string-append %output "/foo")) + (bar (string-append %output "/bar"))) + (mkdir-p bar) + (call-with-output-file (string-append bar "/two") + (cut display "two" <>)) + (symlink "bar" foo))) + #:modules '((guix build utils)))) + (builder '(begin + (use-modules (guix build union)) -(test-equal "tree-union, several levels" - '((share (doc (make README) (coreutils README))) - (bin ls touch make)) - (tree-union '((bin ls touch) - (share (doc (coreutils README))) - (bin make) - (share (doc (make README)))))) + (union-build (assoc-ref %outputs "out") + (list (assoc-ref %build-inputs "one") + (assoc-ref %build-inputs "two"))))) + (drv + (build-expression->derivation %store "union-collision-symlink" + builder + #:inputs `(("one" ,one) ("two" ,two)) + #:modules '((guix build union))))) + (and (build-derivations %store (list drv)) + (with-directory-excursion (pk (derivation->output-path drv)) + (and (string=? "one" + (call-with-input-file "foo/one" get-string-all)) + (string=? "two" + (call-with-input-file "foo/two" get-string-all)) + (string=? "two" + (call-with-input-file "bar/two" get-string-all)) + (not (file-exists? "bar/one"))))))) -(test-skip (if (and %store - (false-if-exception - (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))) +(test-skip (if (and %store (network-reachable?)) 0 1)) @@ -74,32 +93,115 @@ (let* ((inputs (map (match-lambda ((name package) `(,name ,(package-derivation %store package)))) - %bootstrap-inputs)) + + ;; Purposefully leave duplicate entries. + (filter (compose package? cadr) + (append %bootstrap-inputs-for-tests + (take %bootstrap-inputs-for-tests 3))))) (builder `(begin (use-modules (guix build union)) (union-build (assoc-ref %outputs "out") (map cdr %build-inputs)))) (drv (build-expression->derivation %store "union-test" - (%current-system) - builder inputs + builder + #:inputs inputs #:modules '((guix build union))))) (and (build-derivations %store (list (pk 'drv drv))) - (with-directory-excursion (derivation-path->output-path drv) + (with-directory-excursion (derivation->output-path drv) (and (file-exists? "bin/touch") (file-exists? "bin/gcc") (file-exists? "bin/ld") (file-exists? "lib/libc.so") (directory-exists? "lib/gcc") - (file-exists? "include/unistd.h")))))) + (file-exists? "include/unistd.h") -(test-end) + ;; The 'include/c++' sub-directory is only found in + ;; gcc-bootstrap, so it should be unified in a + ;; straightforward way, without traversing it. + (eq? 'symlink (stat:type (lstat "include/c++"))) - -(exit (= (test-runner-fail-count (test-runner-current)) 0)) + ;; Conversely, several inputs have a 'bin' sub-directory, so + ;; unifying it requires traversing them all, and creating a + ;; new 'bin' sub-directory in the profile. + (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" + (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")))))))) -;;; Local Variables: -;;; eval: (put 'test-assert 'scheme-indent-function 1) -;;; eval: (put 'test-equal 'scheme-indent-function 1) -;;; eval: (put 'call-with-input-string 'scheme-indent-function 1) -;;; End: +(letrec-syntax ((test-relative-file-name + (syntax-rules (=>) + ((_ (reference file => expected) rest ...) + (begin + (test-equal (string-append "relative-file-name " + reference " " file) + expected + (relative-file-name reference file)) + (test-relative-file-name rest ...))) + ((_) + #t)))) + (test-relative-file-name + ("/a/b" "/a/c/d" => "../c/d") + ("/a/b" "/a/b" => "") + ("/a/b" "/a" => "..") + ("/a/b" "/a/b/c/d" => "c/d") + ("/a/b/c" "/a/d/e/f" => "../../d/e/f"))) + +(test-end)