From: "Ludovic Courtès" <ludo@gnu.org>
To: 31360@debbugs.gnu.org
Subject: [bug#31360] [PATCH 1/5] union: Add 'relative-file-name'.
Date: Thu, 3 May 2018 22:22:23 +0200 [thread overview]
Message-ID: <20180503202227.22485-1-ludo@gnu.org> (raw)
In-Reply-To: <20180503201531.22213-1-ludo@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)))
+\f
+;;;
+;;; 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 <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;;
--
2.17.0
next prev parent reply other threads:[~2018-05-03 20:23 UTC|newest]
Thread overview: 11+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-05-03 20:15 [bug#31360] [PATCH 0/5] 'guix pack --relocatable' Ludovic Courtès
2018-05-03 20:22 ` Ludovic Courtès [this message]
2018-05-03 20:22 ` [bug#31360] [PATCH 2/5] profiles: Optionally use relative file names for symlink targets Ludovic Courtès
2018-05-03 20:22 ` [bug#31360] [PATCH 3/5] profiles: Allow lowerable objects other than packages in <manifest-entry> Ludovic Courtès
2018-05-03 20:22 ` [bug#31360] [PATCH 4/5] search-paths: Add 'set-search-paths' Ludovic Courtès
2018-05-03 20:22 ` [bug#31360] [PATCH 5/5] pack: Add '--relocatable' Ludovic Courtès
2018-05-04 2:45 ` [bug#31360] [PATCH 0/5] 'guix pack --relocatable' Thompson, David
2018-05-04 9:27 ` Ludovic Courtès
2018-05-04 13:01 ` Thompson, David
2018-05-10 12:55 ` bug#31360: " Ludovic Courtès
2018-05-11 16:42 ` ‘guix pack --relocatable’ and the binary installation tarball Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20180503202227.22485-1-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=31360@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.