From cdbca518ca797cae61c7829e51649b55c47f6a2f Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 31 Oct 2013 23:31:00 +0100
Subject: union: Do not warn when identical files collide.

* guix/build/union.scm (file=?): New procedure.
  (union-build)[resolve-collision]: Do not warn when identical files
  collide.
---
 guix/build/union.scm | 36 ++++++++++++++++++++++++++++--------
 1 file changed, 28 insertions(+), 8 deletions(-)

(limited to 'guix')

diff --git a/guix/build/union.scm b/guix/build/union.scm
index 0f8c87e171..1b09da45c7 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -22,6 +22,8 @@
   #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
   #:export (tree-union
             delete-duplicate-leaves
             union-build))
@@ -100,6 +102,23 @@ single leaf."
            ,@(map loop dirs))))
       (leaf leaf))))
 
+(define (file=? file1 file2)
+  "Return #t if the contents of FILE1 and FILE2 are identical, #f otherwise."
+  (and (= (stat:size (stat file1)) (stat:size (stat file2)))
+       (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 directories
                       #:key (log-port (current-error-port)))
   "Build in the OUTPUT directory a symlink tree that is the union of all
@@ -163,14 +182,15 @@ the DIRECTORIES."
        ;; LEAVES all actually point to the same file, so nothing to worry
        ;; about.
        one-and-the-same)
-      ((and lst (head _ ...))
-       ;; A real collision.
-       (format (current-error-port) "warning: collision encountered: ~{~a ~}~%"
-               lst)
-
-       ;; TODO: Implement smarter strategies.
-       (format (current-error-port) "warning: arbitrarily choosing ~a~%"
-               head)
+      ((and lst (head rest ...))
+       ;; A real collision, unless those files are all identical.
+       (unless (every (cut file=? head <>) rest)
+         (format (current-error-port) "warning: collision encountered: ~{~a ~}~%"
+                 lst)
+
+         ;; TODO: Implement smarter strategies.
+         (format (current-error-port) "warning: arbitrarily choosing ~a~%"
+                 head))
        head)))
 
   (setvbuf (current-output-port) _IOLBF)
-- 
cgit v1.2.3