mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Correctly relativize file names in the presence of common prefixes.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2017-06-15 17:44:57 +02:00
parent d3fcefc3d5
commit 155ddcdc3b
2 changed files with 34 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

8
libguile/filesys.c
View file

@ -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

28
test-suite/tests/ports.test
View file

@ -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)