mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 17:00:23 +02:00
Code Activity

'basename' correctly handles "/" and "//".

Browse source 
* libguile/filesys.c (scm_basename): Special-case "/" and "//".
* test-suite/tests/filesys.test ("basename"): New test prefix.
This commit is contained in:
Ludovic Courtès 2019-06-04 21:20:15 +02:00
parent 65d98d8fd2
commit 36ad1d24b3
2 changed files with 20 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

9
libguile/filesys.c
View file

@ -1602,11 +1602,20 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
c_filename = scm_to_utf8_string (filename); c_filename = scm_to_utf8_string (filename);
scm_dynwind_free (c_filename); scm_dynwind_free (c_filename);
if (strcmp (c_filename, "/") == 0
|| strcmp (c_filename, "//") == 0)
/* As per
<http://pubs.opengroup.org/onlinepubs/9699919799/functions/basename.html>,
"/" and "//" are treated specially. */
res = scm_from_utf8_string ("/");
else
{
c_last_component = last_component (c_filename); c_last_component = last_component (c_filename);
if (!c_last_component) if (!c_last_component)
res = filename; res = filename;
else else
res = scm_from_utf8_string (c_last_component); res = scm_from_utf8_string (c_last_component);
}
scm_dynwind_end (); scm_dynwind_end ();
if (!SCM_UNBNDP (suffix) && if (!SCM_UNBNDP (suffix) &&

8
test-suite/tests/filesys.test
View file

@ -1,6 +1,6 @@
;;;; filesys.test --- test file system functions -*- scheme -*- ;;;; filesys.test --- test file system functions -*- scheme -*-
;;;; ;;;;
;;;; Copyright (C) 2004, 2006, 2013 Free Software Foundation, Inc. ;;;; Copyright (C) 2004, 2006, 2013, 2019 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -222,6 +222,12 @@
(cons (join-thread child) out))) (cons (join-thread child) out)))
(throw 'unresolved))))) (throw 'unresolved)))))
(with-test-prefix "basename"
(pass-if-equal "/" "/" (basename "/"))
(pass-if-equal "//" "/" (basename "//"))
(pass-if-equal "a/b/c" "c" (basename "a/b/c")))
(delete-file (test-file)) (delete-file (test-file))
(when (file-exists? (test-symlink)) (when (file-exists? (test-symlink))
(delete-file (test-symlink))) (delete-file (test-symlink)))