From dac1c97d131d297134fa878ac240d9ec0127044b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 28 Apr 2018 17:17:33 +0200 Subject: 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 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 40 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/union.scm b/guix/build/union.scm index 1179f1234b..82d6199d9e 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 -- cgit v1.2.3