From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:51603) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1fEKkp-0005N2-Bs for guix-patches@gnu.org; Thu, 03 May 2018 16:23:04 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1fEKko-0005rH-6a for guix-patches@gnu.org; Thu, 03 May 2018 16:23:03 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:40733) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1fEKko-0005r4-3F for guix-patches@gnu.org; Thu, 03 May 2018 16:23:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1fEKkn-0003vi-RS for guix-patches@gnu.org; Thu, 03 May 2018 16:23:01 -0400 Subject: [bug#31360] [PATCH 1/5] union: Add 'relative-file-name'. References: <20180503201531.22213-1-ludo@gnu.org> In-Reply-To: <20180503201531.22213-1-ludo@gnu.org> Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Thu, 3 May 2018 22:22:23 +0200 Message-Id: <20180503202227.22485-1-ludo@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 31360@debbugs.gnu.org * 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 1179f1234..82d6199d9 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 aa95cae00..5a6a4033f 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 035886dd1..197182acf 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 +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2016 Mathieu Lirzin ;;; -- 2.17.0