diff options
-rw-r--r-- | libguile/filesys.c | 8 | ||||
-rw-r--r-- | test-suite/tests/ports.test | 28 |
2 files changed, 34 insertions, 2 deletions
diff --git a/libguile/filesys.c b/libguile/filesys.c index f18560162..af283dd5e 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 007f56605..3c8ae3050 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) |