[Guile-commits] 01/01: Correctly relativize file names in the presence of common prefixes.

[Ludovic Courtès]

civodul pushed a commit to branch stable-2.2
in repository guile.

commit 155ddcdc3bfc0d5e87397f18cd4cfb2f062fbb75
Author: Ludovic Courtès <address@hidden>
Date:   Thu Jun 15 17:44:57 2017 +0200

    Correctly relativize file names in the presence of common prefixes.
    
    * libguile/filesys.c (scm_i_relativize_path): When DIR is a prefix of
    SCANON, make sure DIR ends with a separator or SCANON starts with a
    separator.
    * test-suite/tests/ports.test (%temporary-directory): New variable.
    ("%file-port-name-canonicalization")["relative canonicalization with
    common prefixes"]: New test.
---
 libguile/filesys.c          |  8 ++++++--
 test-suite/tests/ports.test | 28 ++++++++++++++++++++++++++++
 2 files changed, 34 insertions(+), 2 deletions(-)

diff --git a/libguile/filesys.c b/libguile/filesys.c
index f185601..af283dd 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004, 2006,
- *   2009, 2010, 2011, 2012, 2013, 2014, 2016 Free Software Foundation, Inc.
+ *   2009, 2010, 2011, 2012, 2013, 2014, 2016, 2017 Free Software Foundation, 
Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -1679,7 +1679,11 @@ scm_i_relativize_path (SCM path, SCM in_path)
       if (len > 0
          && scm_is_true (scm_string_prefix_p (dir, scanon,
                                               SCM_UNDEFINED, SCM_UNDEFINED,
-                                              SCM_UNDEFINED, SCM_UNDEFINED)))
+                                              SCM_UNDEFINED, SCM_UNDEFINED))
+
+         /* Make sure SCANON starts with DIR followed by a separator.  */
+         && (is_file_name_separator (scm_c_string_ref (dir, len - 1))
+             || is_file_name_separator (scm_c_string_ref (scanon, len))))
        {
          /* DIR either has a trailing delimiter or doesn't.  SCANON
             will be delimited by single delimiters.  When DIR does not
diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test
index 007f566..3c8ae30 100644
--- a/test-suite/tests/ports.test
+++ b/test-suite/tests/ports.test
@@ -1890,6 +1890,10 @@
       (lambda ()
         (set! %load-path old)))))
 
+(define %temporary-directory
+  (string-append (or (getenv "TMPDIR") "/tmp") "/guile-ports-test."
+                 (number->string (getpid))))
+
 (with-test-prefix "%file-port-name-canonicalization"
 
   (pass-if-equal "absolute file name & empty %load-path entry" "/dev/null"
@@ -1916,6 +1920,30 @@
       (port-filename
        (open-input-file (%search-load-path "ice-9/q.scm")))))
 
+  (pass-if-equal "relative canonicalization with common prefixes"
+      "x.scm"
+
+    ;; In Guile up to 2.2.2, this would return "wrong/x.scm'.
+    (let* ((dir1 (string-append %temporary-directory "/something"))
+           (dir2 (string-append dir1 "-wrong")))
+      (with-load-path (append (list dir1 dir2) %load-path)
+        (dynamic-wind
+          (lambda ()
+            (mkdir %temporary-directory)
+            (mkdir dir1)
+            (mkdir dir2)
+            (call-with-output-file (string-append dir2 "/x.scm")
+              (const #t)))
+          (lambda ()
+            (with-fluids ((%file-port-name-canonicalization 'relative))
+              (port-filename
+               (open-input-file (string-append dir2 "/x.scm")))))
+          (lambda ()
+            (delete-file (string-append dir2 "/x.scm"))
+            (rmdir dir2)
+            (rmdir dir1)
+            (rmdir %temporary-directory))))))
+
   (pass-if-equal "absolute canonicalization from ice-9"
       (canonicalize-path
        (string-append (assoc-ref %guile-build-info 'top_srcdir)