mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

filesystem trickery to scm_i_relativize_path in filesys.c; bugfix.

Browse source 
* libguile/filesys.h:
* libguile/filesys.c (scm_i_relativize_path): New function, moved here
  from fports.c. Internal for now; we can make it external though if
  people like its interface.

* libguile/fports.c (fport_canonicalize_filename): Move all of the
  tricky bits to filesys.c. Also fixes a bug in which a delimiter wasn't
  stripped.
This commit is contained in:
Andy Wingo 2010-04-19 16:39:11 +02:00
parent 0abc210944
commit 22457d5730
3 changed files with 53 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

46
libguile/filesys.c
View file

@ -1654,6 +1654,52 @@ SCM_DEFINE (scm_canonicalize_path, "canonicalize-path", 1, 0, 0,
}
#undef FUNC_NAME
SCM
scm_i_relativize_path (SCM path, SCM in_path)
{
char *str, *canon;
SCM scanon;
str = scm_to_locale_string (path);
canon = canonicalize_file_name (str);
free (str);
if (!canon)
return SCM_BOOL_F;
scanon = scm_take_locale_string (canon);
for (; scm_is_pair (in_path); in_path = scm_cdr (in_path))
if (scm_is_true (scm_string_prefix_p (scm_car (in_path),
scanon,
SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED, SCM_UNDEFINED)))
{
size_t len = scm_c_string_length (scm_car (in_path));
/* The path either has a trailing delimiter or doesn't. scanon will be
delimited by single delimiters. In the case in which the path does
not have a trailing delimiter, add one to the length to strip off the
delimiter within scanon. */
if (!len
#ifdef __MINGW32__
|| (scm_i_string_ref (scm_car (in_path), len - 1) != '/'
&& scm_i_string_ref (scm_car (in_path), len - 1) != '\\')
#else
|| scm_i_string_ref (scm_car (in_path), len - 1) != '/'
#endif
)
len++;
if (scm_c_string_length (scanon) > len)
return scm_substring (scanon, scm_from_size_t (len), SCM_UNDEFINED);
else
return SCM_BOOL_F;
}
return SCM_BOOL_F;
}

3
libguile/filesys.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_FILESYS_H
#define SCM_FILESYS_H
/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010 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
@ -66,6 +66,7 @@ SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile);
SCM_API SCM scm_dirname (SCM filename);
SCM_API SCM scm_basename (SCM filename, SCM suffix);
SCM_API SCM scm_canonicalize_path (SCM path);
SCM_INTERNAL SCM scm_i_relativize_path (SCM path, SCM in_path);
SCM_INTERNAL void scm_init_filesys (void);

27
libguile/fports.c
View file

@ -281,30 +281,13 @@ fport_canonicalize_filename (SCM filename)
}
else if (scm_is_eq (mode, sym_relative))
{
char *str, *canon;
SCM scanon, load_path;
SCM path, rel;
str = scm_to_locale_string (filename);
canon = canonicalize_file_name (str);
free (str);
path = scm_variable_ref (scm_c_module_lookup (scm_the_root_module (),
"%load-path"));
rel = scm_i_relativize_path (filename, path);
if (!canon)
return filename;
scanon = scm_take_locale_string (canon);
for (load_path = scm_variable_ref
(scm_c_module_lookup (scm_the_root_module (), "%load-path"));
scm_is_pair (load_path);
load_path = scm_cdr (load_path))
if (scm_is_true (scm_string_prefix_p (scm_car (load_path),
scanon,
SCM_UNDEFINED, SCM_UNDEFINED,
SCM_UNDEFINED, SCM_UNDEFINED)))
return scm_substring (scanon,
scm_string_length (scm_car (load_path)),
SCM_UNDEFINED);
return filename;
return scm_is_true (rel) ? rel : filename;
}
else if (scm_is_eq (mode, sym_absolute))
{