diff options
| -rw-r--r-- | .dir-locals.el | 1 | ||||
| -rw-r--r-- | guix/build/union.scm | 43 | ||||
| -rw-r--r-- | tests/profiles.scm | 29 |
3 files changed, 53 insertions, 20 deletions
diff --git a/.dir-locals.el b/.dir-locals.el index 4aaeae95c9..04b58d2ce0 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -17,6 +17,7 @@ (eval . (put 'call-with-prompt 'scheme-indent-function 1)) (eval . (put 'test-assert 'scheme-indent-function 1)) (eval . (put 'test-assertm 'scheme-indent-function 1)) + (eval . (put 'test-equalm 'scheme-indent-function 1)) (eval . (put 'test-equal 'scheme-indent-function 1)) (eval . (put 'test-eq 'scheme-indent-function 1)) (eval . (put 'call-with-input-string 'scheme-indent-function 1)) diff --git a/guix/build/union.scm b/guix/build/union.scm index a2ea72e1f5..18167fa3e3 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -47,31 +47,34 @@ (loop (cons file files))))))) (define (file-is-directory? file) - (eq? 'directory (stat:type (stat file)))) + (match (stat file #f) + (#f #f) ;maybe a dangling symlink + (st (eq? 'directory (stat:type st))))) (define (file=? file1 file2) "Return #t if FILE1 and FILE2 are regular files and their contents are identical, #f otherwise." - (let ((st1 (stat file1)) - (st2 (stat file2))) + (let ((st1 (stat file1 #f)) + (st2 (stat file2 #f))) ;; When deduplication is enabled, identical files share the same inode. - (or (= (stat:ino st1) (stat:ino st2)) - (and (eq? (stat:type st1) 'regular) - (eq? (stat:type st2) 'regular) - (= (stat:size st1) (stat:size st2)) - (call-with-input-file file1 - (lambda (port1) - (call-with-input-file file2 - (lambda (port2) - (define len 8192) - (define buf1 (make-bytevector len)) - (define buf2 (make-bytevector len)) - (let loop () - (let ((n1 (get-bytevector-n! port1 buf1 0 len)) - (n2 (get-bytevector-n! port2 buf2 0 len))) - (and (equal? n1 n2) - (or (eof-object? n1) - (loop))))))))))))) + (and st1 st2 + (or (= (stat:ino st1) (stat:ino st2)) + (and (eq? (stat:type st1) 'regular) + (eq? (stat:type st2) 'regular) + (= (stat:size st1) (stat:size st2)) + (call-with-input-file file1 + (lambda (port1) + (call-with-input-file file2 + (lambda (port2) + (define len 8192) + (define buf1 (make-bytevector len)) + (define buf2 (make-bytevector len)) + (let loop () + (let ((n1 (get-bytevector-n! port1 buf1 0 len)) + (n2 (get-bytevector-n! port2 buf2 0 len))) + (and (equal? n1 n2) + (or (eof-object? n1) + (loop)))))))))))))) (define* (union-build output inputs #:key (log-port (current-error-port)) diff --git a/tests/profiles.scm b/tests/profiles.scm index d0b1e14a86..093422792f 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -50,6 +50,12 @@ (run-with-store %store exp #:guile-for-build (%guile-for-build)))) +(define-syntax-rule (test-equalm name value exp) + (test-equal name + value + (run-with-store %store exp + #:guile-for-build (%guile-for-build)))) + ;; Example manifest entries. (define guile-1.8.8 @@ -366,6 +372,29 @@ get-string-all) "foo!")))))) +(test-equalm "union vs. dangling symlink" ;<https://bugs.gnu.org/26949> + "does-not-exist" + (mlet* %store-monad + ((thing1 -> (dummy-package "dummy" + (build-system trivial-build-system) + (arguments + `(#:guile ,%bootstrap-guile + #:builder + (let ((out (assoc-ref %outputs "out"))) + (mkdir out) + (symlink "does-not-exist" + (string-append out "/dangling")) + #t))))) + (thing2 -> (package (inherit thing1) (name "dummy2"))) + (drv (profile-derivation (packages->manifest + (list thing1 thing2)) + #:hooks '() + #:locales? #f)) + (profile -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (readlink (readlink (string-append profile "/dangling"))))))) + (test-end "profiles") ;;; Local Variables: |