01/05: union: Add 'relative-file-name'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit dac1c97d131d297134fa878ac240d9ec0127044b
Author: Ludovic Courtès <address@hidden>
Date:   Sat Apr 28 17:17:33 2018 +0200

    union: Add 'relative-file-name'.
    
    * guix/build/union.scm (%not-slash): New variable.
    (relative-file-name): New procedure.
    * tests/union.scm (test-relative-file-name): New macro and tests.
---
 guix/build/union.scm | 41 ++++++++++++++++++++++++++++++++++++++++-
 tests/union.scm      | 18 ++++++++++++++++++
 tests/utils.scm      |  2 +-
 3 files changed, 59 insertions(+), 2 deletions(-)

diff --git a/guix/build/union.scm b/guix/build/union.scm
index 1179f12..82d6199 100644
--- a/guix/build/union.scm
+++ b/guix/build/union.scm
@@ -27,7 +27,9 @@
   #:use-module (rnrs io ports)
   #:export (union-build
 
-            warn-about-collision))
+            warn-about-collision
+
+            relative-file-name))
 
 ;;; Commentary:
 ;;;
@@ -174,4 +176,41 @@ returns #f, skip the faulty file altogether."
 
   (union-of-directories output (delete-duplicates inputs)))
 
+
+;;;
+;;; Relative symlinks.
+;;;
+
+(define %not-slash
+  (char-set-complement (char-set #\/)))
+
+(define (relative-file-name reference file)
+  "Given REFERENCE and FILE, both of which are absolute file names, return the
+file name of FILE relative to REFERENCE.
+
+  (relative-file-name \"/gnu/store/foo\" \"/gnu/store/bin/bar\")
+  => \"../bin/bar\"
+
+Note that this is from a purely lexical standpoint; conversely, \"..\" is
+*not* resolved lexically on POSIX in the presence of symlinks."
+  (if (and (string-prefix? "/" file) (string-prefix? "/" reference))
+      (let loop ((reference (string-tokenize reference %not-slash))
+                 (file      (string-tokenize file %not-slash)))
+        (define (finish)
+          (string-join (append (make-list (length reference) "..") file)
+                       "/"))
+
+        (match reference
+          (()
+           (finish))
+          ((head . tail)
+           (match file
+             (()
+              (finish))
+             ((head* . tail*)
+              (if (string=? head head*)
+                  (loop tail tail*)
+                  (finish)))))))
+      file))
+
 ;;; union.scm ends here
diff --git a/tests/union.scm b/tests/union.scm
index aa95cae..5a6a403 100644
--- a/tests/union.scm
+++ b/tests/union.scm
@@ -184,4 +184,22 @@
                 (file-is-directory? "bin")
                 (eq? 'symlink (stat:type (lstat "bin/guile"))))))))
 
+(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)
diff --git a/tests/utils.scm b/tests/utils.scm
index 035886d..197182a 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès 
<address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès 
<address@hidden>
 ;;; Copyright © 2014 Eric Bavier <address@hidden>
 ;;; Copyright © 2016 Mathieu Lirzin <address@hidden>
 ;;;