suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

win32: support symbolic links

Browse Source 
Windows supports symbolic links in Vista and later.
This commit is contained in:
Matthew Flatt 2014-06-18 00:26:42 -06:00
parent c8c0972fec
commit 3e3cb71680
5 changed files with 332 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl
View File

@ -245,7 +245,7 @@ variations of the special filenames (e.g., @racket["LPT1"],
@defproc[(link-exists? [path path-string?]) boolean?]{
Returns @racket[#t] if a link @racket[path] exists (@|AllUnix|),
Returns @racket[#t] if a link @racket[path] exists,
@racket[#f] otherwise.
The predicates @racket[file-exists?] or @racket[directory-exists?]
@ -255,7 +255,9 @@ work on the final destination of a link or series of links, while
path).
This procedure never raises the @racket[exn:fail:filesystem]
exception.}
exception.
@history[#:changed "6.0.1.12" @elem{Added support for links on Windows.}]}
@defproc[(delete-file [path path-string?]) void?]{
@ -393,12 +395,17 @@ rather than the link itself; if @racket[dest] refers to a link and
@defproc[(make-file-or-directory-link [to path-string?] [path path-string?])
void?]{
Creates a link @racket[path] to @racket[to] on @|AllUnix|. The
Creates a link @racket[path] to @racket[to]. The
creation will fail if @racket[path] already exists. The @racket[to]
need not refer to an existing file or directory, and @racket[to] is
not expanded before writing the link. If the link is not created
successfully,the @exnraise[exn:fail:filesystem]. On Windows, the
@exnraise[exn:fail:unsupported] always.}
successfully,the @exnraise[exn:fail:filesystem].
On Windows XP and earlier, the @exnraise[exn:fail:unsupported]. On
later versions of Windows, the creation of links tends to be disallowed
by security policies.
@history[#:changed "6.0.1.12" @elem{Added support for links on Windows.}]}
@;------------------------------------------------------------------------
@section[#:tag "directories"]{Directories}

22
pkgs/racket-pkgs/racket-doc/scribblings/reference/paths.scrbl
View File

@ -345,11 +345,19 @@ This procedure does not access the filesystem.}
@defproc[(resolve-path [path path-string?]) path?]{
@tech{Cleanse}s @racket[path] and returns a path that references the
same file or directory as @racket[path]. On @|AllUnix|, if
same file or directory as @racket[path]. If
@racket[path] is a soft link to another path, then the referenced path
is returned (this may be a relative path with respect to the directory
owning @racket[path]), otherwise @racket[path] is returned (after
expansion).}
expansion).
On Windows, the path for a link should be simplified syntactically
using the whole link, so that an up-directory indicator removes a
preceding path element independent of whether the preceding element
itself refers to a link. See @secref["windowspaths"] for more
information.
@history[#:changed "6.0.1.12" @elem{Added support for links on Windows.}]}
@defproc[(cleanse-path [path (or/c path-string? path-for-some-system?)])
@ -385,10 +393,12 @@ path. If @racket[path] syntactically refers to a directory, the
result ends with a directory separator.
When @racket[path] is simplified and @racket[use-filesystem?] is true
(the default), a complete path is returned; if @racket[path] is
relative, it is resolved with respect to the current directory, and
up-directory indicators are removed taking into account soft links (so
that the resulting path refers to the same directory as before).
(the default), a complete path is returned. If @racket[path] is
relative, it is resolved with respect to the current directory.
On @|AllUnix|, up-directory indicators are removed taking into account soft links (so
that the resulting path refers to the same directory as before);
on Windows, up-directory indicators are removed by by deleting a
preceding @tech{path element}.
When @racket[use-filesystem?] is @racket[#f], up-directory indicators
are removed by deleting a preceding @tech{path element}, and the result can

7
pkgs/racket-pkgs/racket-doc/scribblings/reference/windows-paths.scrbl
View File

@ -234,6 +234,13 @@ directory. In addition, a path syntactically refers to a directory if
its last element is a same-directory or up-directory indicator (not
quoted by a @litchar{\\?\} form), or if it refers to a root.
Even on variants of Windows that support symbolic links, up-directory
@litchar{..} indicators in a path are resolved syntactically, not
sensitive to links. For example, if a path ends with @litchar{d\..\f}
and @litchar{d} refers to a symbolic link that references a directory
with a different parent than @litchar{d}, the path nevertheless refers
to @litchar{f} in the same directory as @litchar{d}.
Windows paths are @techlink{cleanse}d as follows: In paths that start
@litchar{\\?\}, redundant @litchar{\}s are removed, an extra
@litchar{\} is added in a @litchar{\\?\REL} if an extra one is

44
racket/src/racket/sconfig.h
View File

@ -562,12 +562,10 @@
# if defined(_MSC_VER) || defined(__MINGW32__)
# define NO_READDIR
# define USE_FINDFIRST
# define NO_READLINK
# define MKDIR_NO_MODE_FLAG
# endif
# if defined(__BORLANDC__)
# define DIRENT_NO_NAMLEN
# define NO_READLINK
# define MKDIR_NO_MODE_FLAG
# endif
@ -852,46 +850,6 @@
# endif
/************** DOS with Borland C++ ****************/
/* (Never successfully supported) */
#if defined(__BORLANDC__) && defined(__MSDOS__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "dos\\i386"
# define USE_SENORA_GC
# define DOS_FAR_POINTERS
# define SMALL_HASH_TABLES
# define SYSTEM_TYPE_NAME "dos"
# define DOS_FILE_SYSTEM
# define USE_GETDISK
# define DIRENT_NO_NAMLEN
# define NO_READLINK
# define MKDIR_NO_MODE_FLAG
# define TIME_SYNTAX
# define USE_FTIME
# define GETENV_FUNCTION
# define DIR_FUNCTION
# define DO_STACK_CHECK
# define USE_STACKAVAIL
# define STACK_SAFETY_MARGIN 15000
# define IGNORE_BY_CONTROL_87
# define DIR_INCLUDE
# define IO_INCLUDE
# define NO_SLEEP
# define DONT_IGNORE_PIPE_SIGNAL
# define REGISTER_POOR_MACHINE
# define FLAGS_ALREADY_SET
#endif
/************ QNX *************/
#if defined(__QNX__)
@ -1079,8 +1037,6 @@
/* NO_MKDIR means that there is no mkdir() function. */
/* NO_READLINK means that there is no readlink() function. */
/* BROKEN_READLINK_NUL_TERMINATOR means that readlink() may
report a length that includes trailing NUL terminators,
which should be stripped away. */

371
racket/src/racket/src/file.c
View File

@ -224,7 +224,8 @@ static int has_null(const char *s, intptr_t l);
static void raise_null_error(const char *name, Scheme_Object *path, const char *mod);
static char *do_path_to_complete_path(char *filename, intptr_t ilen, const char *wrt, intptr_t wlen, int kind);
static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle_check, int skip, int use_filesystem, int force_rel_up, int kind);
static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle_check, int skip, int use_filesystem,
int force_rel_up, int kind, int guards);
static char *do_normal_path_seps(char *si, int *_len, int delta, int strip_trail, int kind, int *_did);
static char *remove_redundant_slashes(char *filename, int *l, int delta, int *expanded, int kind);
static Scheme_Object *do_path_to_directory_path(char *s, intptr_t offset, intptr_t len, Scheme_Object *p, int just_check, int kind);
@ -263,6 +264,16 @@ SHARED_OK static gid_t gid;
SHARED_OK static gid_t egid;
#endif
#ifdef DOS_FILE_SYSTEM
typedef BOOLEAN (WINAPI*CreateSymbolicLinkProc_t)(wchar_t *dest, wchar_t *src, DWORD flags);
static CreateSymbolicLinkProc_t CreateSymbolicLinkProc = NULL;
typedef BOOL (WINAPI*DeviceIoControlProc_t)(HANDLE hDevice, DWORD dwIoControlCode, LPVOID lpInBuffer,
DWORD nInBufferSize, LPVOID lpOutBuffer, DWORD nOutBufferSize,
LPDWORD lpBytesReturned, LPOVERLAPPED lpOverlapped);
static DeviceIoControlProc_t DeviceIoControlProc;
#endif
void scheme_init_file(Scheme_Env *env)
{
Scheme_Object *p;
@ -586,6 +597,19 @@ void scheme_init_file(Scheme_Env *env)
"use-collection-link-paths",
MZCONFIG_USE_LINK_PATHS),
env);
#ifdef DOS_FILE_SYSTEM
{
HMODULE hm;
hm = LoadLibrary("kernel32.dll");
CreateSymbolicLinkProc = (CreateSymbolicLinkProc_t)GetProcAddress(hm, "CreateSymbolicLinkW");
DeviceIoControlProc = (DeviceIoControlProc_t)GetProcAddress(hm, "DeviceIoControl");
FreeLibrary(hm);
}
#endif
}
void scheme_init_file_places()
@ -2045,7 +2069,7 @@ static char *do_expand_filename(Scheme_Object *o, char* filename, int ilen, cons
Scheme_Object *p;
p = scheme_make_sized_path(filename, ilen, 0);
p = do_simplify_path(p, scheme_null, 0, 1, 0, SCHEME_WINDOWS_PATH_KIND);
p = do_simplify_path(p, scheme_null, 0, 0, 0, SCHEME_WINDOWS_PATH_KIND, 0);
filename = SCHEME_PATH_VAL(p);
ilen = SCHEME_PATH_LEN(p);
@ -2083,6 +2107,7 @@ char *scheme_expand_string_filename(Scheme_Object *o, const char *errorin, int *
# define FIND_FAILED(h) (h == INVALID_HANDLE_VALUE)
# define FF_A_RDONLY FILE_ATTRIBUTE_READONLY
# define FF_A_DIR FILE_ATTRIBUTE_DIRECTORY
# define FF_A_LINK 0x400
# define GET_FF_ATTRIBS(fd) (fd.dwFileAttributes)
# define GET_FF_MODDATE(fd) convert_date(&fd.ftLastWriteTime)
# define GET_FF_NAME(fd) fd.cFileName
@ -2160,12 +2185,96 @@ static time_t convert_date(const FILETIME *ft)
#endif
#ifdef DOS_FILE_SYSTEM
typedef struct mz_REPARSE_DATA_BUFFER {
ULONG ReparseTag;
USHORT ReparseDataLength;
USHORT Reserved;
union {
struct {
USHORT SubstituteNameOffset;
USHORT SubstituteNameLength;
USHORT PrintNameOffset;
USHORT PrintNameLength;
ULONG Flags;
WCHAR PathBuffer[1];
} SymbolicLinkReparseBuffer;
struct {
USHORT SubstituteNameOffset;
USHORT SubstituteNameLength;
USHORT PrintNameOffset;
USHORT PrintNameLength;
WCHAR PathBuffer[1];
} MountPointReparseBuffer;
struct {
UCHAR DataBuffer[1];
} GenericReparseBuffer;
} u;
} mz_REPARSE_DATA_BUFFER;
#define mzFILE_FLAG_OPEN_REPARSE_POINT 0x200000
static char *UNC_readlink(const char *fn)
{
HANDLE h;
DWORD got;
char *buffer;
int size = 1024;
mz_REPARSE_DATA_BUFFER *rp;
int len, off;
wchar_t *lk;
if (!DeviceIoControlProc) return NULL;
h = CreateFileW(WIDE_PATH(fn), GENERIC_READ,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL,
OPEN_EXISTING, mzFILE_FLAG_OPEN_REPARSE_POINT, NULL);
if (h == INVALID_HANDLE_VALUE) {
errno = -1;
return NULL;
}
while (1) {
buffer = (char *)scheme_malloc_atomic(size);
if (DeviceIoControlProc(h, FSCTL_GET_REPARSE_POINT, NULL, 0, buffer, size,
&got, NULL))
break;
else if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
size *= 2;
buffer = (char *)scheme_malloc_atomic(size);
} else {
errno = -1;
CloseHandle(h);
return NULL;
}
}
CloseHandle(h);
rp = (mz_REPARSE_DATA_BUFFER *)buffer;
if (rp->ReparseTag != IO_REPARSE_TAG_SYMLINK) {
errno = -1;
return NULL;
}
off = rp->u.SymbolicLinkReparseBuffer.PrintNameOffset;
len = rp->u.SymbolicLinkReparseBuffer.PrintNameLength;
lk = (wchar_t *)scheme_malloc_atomic((len + 1) * sizeof(wchar_t));
memcpy(lk, (char *)rp->u.SymbolicLinkReparseBuffer.PathBuffer + off, len);
lk[len>>1] = 0;
return NARROW_PATH(lk);
}
# define MZ_UNC_READ 0x1
# define MZ_UNC_WRITE 0x2
# define MZ_UNC_EXEC 0x4
static int UNC_stat(char *dirname, int len, int *flags, int *isdir, Scheme_Object **date,
mzlonglong *filesize, int set_flags)
static int UNC_stat(char *dirname, int len, int *flags, int *isdir, int *islink,
Scheme_Object **date, mzlonglong *filesize,
char **resolved_path, int set_flags)
/* dirname must be absolute */
{
/* Note: stat() doesn't work with UNC "drive" names or \\?\ paths.
@ -2174,13 +2283,23 @@ static int UNC_stat(char *dirname, int len, int *flags, int *isdir, Scheme_Objec
So, we use GetFileAttributesExW(). */
char *copy;
WIN32_FILE_ATTRIBUTE_DATA fd;
int must_be_dir = 0;
int must_be_dir = 0, orig_len;
Scheme_Object *cycle_check = scheme_null;
if (resolved_path)
*resolved_path = NULL;
retry:
if (islink)
*islink = 0;
if (isdir)
*isdir = 0;
if (date)
*date = scheme_false;
orig_len = len;
copy = scheme_malloc_atomic(len + 14);
if (check_dos_slashslash_qm(dirname, len, NULL, NULL, NULL)) {
memcpy(copy, dirname, len + 1);
@ -2188,6 +2307,7 @@ static int UNC_stat(char *dirname, int len, int *flags, int *isdir, Scheme_Objec
memcpy(copy, dirname, len + 1);
while (IS_A_DOS_SEP(copy[len - 1])) {
--len;
--orig_len;
copy[len] = 0;
must_be_dir = 1;
}
@ -2199,17 +2319,61 @@ static int UNC_stat(char *dirname, int len, int *flags, int *isdir, Scheme_Objec
len -= 4;
copy[len] = 0;
}
/* If we ended up with "\\?\X:", then drop the "\\?\\" */
/* If we ended up with "\\?\\X:", then drop the "\\?\\" */
if ((copy[0] == '\\') && (copy[1] == '\\') && (copy[2] == '?') && (copy[3] == '\\')
&& (copy[4] == '\\') && is_drive_letter(copy[5]) && (copy[6] == ':') && !copy[7]) {
memmove(copy, copy + 5, len - 5);
len -= 5;
copy[len] = 0;
}
if (!GetFileAttributesExW(WIDE_PATH(copy), GetFileExInfoStandard, &fd)) {
errno = -1;
return 0;
} else {
if (GET_FF_ATTRIBS(fd) & FF_A_LINK) {
if (islink) {
*islink = 1;
return 1;
} else {
/* Resolve links ourselves. It's clear how Windows
treats links within a link target path, but it seems
to treat them purely syntactically (i.e., simplifying
"up" before consulting the filesystem). */
Scheme_Object *sp, *cl, *cp;
copy = UNC_readlink(dirname);
while (orig_len && !IS_A_DOS_SEP(dirname[orig_len - 1])) {
--orig_len;
}
while (orig_len && IS_A_DOS_SEP(dirname[orig_len - 1])) {
--orig_len;
}
dirname = do_path_to_complete_path(copy, strlen(copy), dirname, orig_len, SCHEME_WINDOWS_PATH_KIND);
len = strlen(dirname);
sp = scheme_make_sized_path(dirname, len, 0);
sp = do_simplify_path(sp, scheme_null, 0, 0, 0, SCHEME_WINDOWS_PATH_KIND, 0);
if (SCHEME_FALSEP(sp)) {
errno = -1;
return 0;
}
for (cl = cycle_check; !SCHEME_NULLP(cl); cl = SCHEME_CDR(cl)) {
cp = SCHEME_CAR(cl);
if ((SCHEME_PATH_LEN(cp) == SCHEME_PATH_LEN(sp))
&& !strcmp(SCHEME_PATH_VAL(cp), SCHEME_PATH_VAL(sp))) {
/* cycle */
errno = -1;
return 0;
}
}
cycle_check = scheme_make_pair(sp, cycle_check);
dirname = SCHEME_PATH_VAL(sp);
len = SCHEME_PATH_LEN(sp);
if (resolved_path)
*resolved_path = dirname;
goto retry;
}
}
if (set_flags != -1) {
DWORD attrs = GET_FF_ATTRIBS(fd);
@ -2265,7 +2429,7 @@ int scheme_file_exists(char *filename)
{
int isdir;
return (UNC_stat(filename, strlen(filename), NULL, &isdir, NULL, NULL, -1)
return (UNC_stat(filename, strlen(filename), NULL, &isdir, NULL, NULL, NULL, NULL, -1)
&& !isdir);
}
# else
@ -2289,7 +2453,7 @@ int scheme_directory_exists(char *dirname)
# ifdef DOS_FILE_SYSTEM
int isdir;
return (UNC_stat(dirname, strlen(dirname), NULL, &isdir, NULL, NULL, -1)
return (UNC_stat(dirname, strlen(dirname), NULL, &isdir, NULL, NULL, NULL, NULL, -1)
&& isdir);
# else
struct MSC_IZE(stat) buf;
@ -2372,42 +2536,32 @@ static Scheme_Object *directory_exists(int argc, Scheme_Object **argv)
static Scheme_Object *link_exists(int argc, Scheme_Object **argv)
{
char *filename;
#ifndef UNIX_FILE_SYSTEM
Scheme_Object *bs;
#endif
if (!SCHEME_PATH_STRINGP(argv[0]))
scheme_wrong_contract("link-exists?", "path-string?", 0, argc, argv);
#ifndef UNIX_FILE_SYSTEM
/* DOS or MAC: expand isn't called, so check the form now */
bs = TO_PATH(argv[0]);
filename = SCHEME_PATH_VAL(bs);
if (has_null(filename, SCHEME_PATH_LEN(bs))) {
raise_null_error("link-exists?", bs, "");
return NULL;
}
#endif
filename = do_expand_filename(argv[0],
NULL,
0,
"link-exists?",
NULL,
0, 1,
SCHEME_GUARD_FILE_EXISTS,
SCHEME_PLATFORM_PATH_KIND,
0);
#ifdef DOS_FILE_SYSTEM
scheme_security_check_file("link-exists?", filename, SCHEME_GUARD_FILE_EXISTS);
return scheme_false;
#endif
#ifdef UNIX_FILE_SYSTEM
{
int islink;
if (UNC_stat(filename, strlen(filename), NULL, NULL, &islink, NULL, NULL, NULL, -1)
&& islink)
return scheme_true;
else
return scheme_false;
}
#else
{
struct MSC_IZE(stat) buf;
filename = do_expand_filename(argv[0],
NULL,
0,
"link-exists?",
NULL,
0, 1,
SCHEME_GUARD_FILE_EXISTS,
SCHEME_PLATFORM_PATH_KIND,
0);
while (1) {
if (!MSC_W_IZE(lstat)(MSC_WIDE_PATH(filename), &buf))
break;
@ -2465,7 +2619,10 @@ Scheme_Object *scheme_get_fd_identity(Scheme_Object *port, intptr_t fd, char *pa
FILE_SHARE_READ | FILE_SHARE_WRITE,
NULL,
OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS,
FILE_FLAG_BACKUP_SEMANTICS
| ((fd && CreateSymbolicLinkProc)
? mzFILE_FLAG_OPEN_REPARSE_POINT
: 0),
NULL);
if (fdh == INVALID_HANDLE_VALUE) {
errid = GetLastError();
@ -2890,7 +3047,7 @@ static Scheme_Object *do_build_path(int argc, Scheme_Object **argv, int idelta,
simp = do_simplify_path(scheme_make_sized_offset_kind_path(str, 0, pos, 0,
SCHEME_WINDOWS_PATH_KIND),
scheme_null, first_len, 0, 0,
SCHEME_WINDOWS_PATH_KIND);
SCHEME_WINDOWS_PATH_KIND, 0);
if (SCHEME_FALSEP(simp)) {
/* Base path is just relative "here". We can ignore it. */
pos = 0;
@ -2953,7 +3110,7 @@ static Scheme_Object *do_build_path(int argc, Scheme_Object **argv, int idelta,
simp = do_simplify_path(scheme_make_sized_offset_kind_path(str, 0, pos, 0,
SCHEME_WINDOWS_PATH_KIND),
scheme_null, first_len, 0, 1,
SCHEME_WINDOWS_PATH_KIND);
SCHEME_WINDOWS_PATH_KIND, 0);
if (SCHEME_FALSEP(simp)) {
/* Note: if root turns out to be relative, then we couldn't
have had a \\?\RED\ path. */
@ -3245,7 +3402,7 @@ static Scheme_Object *do_build_path(int argc, Scheme_Object **argv, int idelta,
str = do_normal_path_seps(str, &p, first_len, 1, SCHEME_WINDOWS_PATH_KIND, NULL);
str = remove_redundant_slashes(str, &p, first_len, NULL, SCHEME_WINDOWS_PATH_KIND);
simp = do_simplify_path(scheme_make_sized_offset_kind_path(str, 0, p, 0, SCHEME_WINDOWS_PATH_KIND),
scheme_null, first_len, 0, 1, SCHEME_WINDOWS_PATH_KIND);
scheme_null, first_len, 0, 1, SCHEME_WINDOWS_PATH_KIND, 0);
if (SCHEME_FALSEP(simp))
return scheme_make_sized_offset_kind_path(".\\", 0, 1, 0, SCHEME_WINDOWS_PATH_KIND);
else
@ -4198,18 +4355,17 @@ static Scheme_Object *absolute_path_p(int argc, Scheme_Object **argv)
: scheme_false);
}
static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
static Scheme_Object *do_resolve_path(int argc, Scheme_Object *argv[], int guards)
{
#ifndef NO_READLINK
#define SL_NAME_MAX 2048
char buffer[SL_NAME_MAX];
#endif
#ifndef NO_READLINK
intptr_t len;
int copied = 0;
#endif
char *filename;
int expanded;
#ifdef DOS_FILE_SYSTEM
int is_link;
#endif
if (!SCHEME_PATH_STRINGP(argv[0]))
scheme_wrong_contract("resolve-path", "path-string?", 0, argc, argv);
@ -4220,11 +4376,10 @@ static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
"resolve-path",
&expanded,
1, 0,
SCHEME_GUARD_FILE_EXISTS,
guards ? SCHEME_GUARD_FILE_EXISTS : 0,
SCHEME_PLATFORM_PATH_KIND,
0);
#ifndef NO_READLINK
{
char *fullfilename = filename;
@ -4244,6 +4399,22 @@ static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
fullfilename[--len] = 0;
}
#ifdef DOS_FILE_SYSTEM
if (UNC_stat(fullfilename, len, NULL, NULL, &is_link, NULL, NULL, NULL, -1)
&& is_link) {
const char *s;
s = UNC_readlink(fullfilename);
if (s) {
len = strlen(s);
if (len < SL_NAME_MAX)
memcpy(buffer, s, len+1);
else
len = -1;
} else
len = -1;
} else
len = -1;
#else
while (1) {
len = readlink(fullfilename, buffer, SL_NAME_MAX);
if (len == -1) {
@ -4252,6 +4423,7 @@ static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
} else
break;
}
#endif
#ifdef BROKEN_READLINK_NUL_TERMINATOR
while (len > 0 && buffer[len-1] == 0) {
@ -4262,7 +4434,6 @@ static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
if (len > 0)
return scheme_make_sized_path(buffer, len, 1);
}
#endif
if (!expanded)
return argv[0];
@ -4270,6 +4441,11 @@ static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
return scheme_make_sized_path(filename, strlen(filename), 1);
}
static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
{
return do_resolve_path(argc, argv, 1);
}
static Scheme_Object *convert_literal_relative(Scheme_Object *file)
{
int ln;
@ -4453,7 +4629,7 @@ static Scheme_Object *simplify_qm_path(Scheme_Object *path)
static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle_check, int skip,
int use_filesystem,
int force_rel_up,
int kind)
int kind, int guards)
/* When !use_filesystem, the result can be #f for an empty relative
path, and it can contain leading ".."s, or ".."s after an initial
"~" path with "~" paths are absolute.
@ -4632,7 +4808,7 @@ static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle
/* Make it absolute */
s = scheme_expand_string_filename(path,
"simplify-path", NULL,
SCHEME_GUARD_FILE_EXISTS);
guards ? SCHEME_GUARD_FILE_EXISTS : 0);
len = strlen(s);
}
@ -4711,13 +4887,13 @@ static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle
/* Build up path, watching for links just before a ..: */
while (!SCHEME_NULLP(accum)) {
if (SAME_OBJ(SCHEME_CAR(accum), up_symbol)) {
if (use_filesystem) {
if (use_filesystem && (SCHEME_PLATFORM_PATH_KIND != SCHEME_WINDOWS_PATH_KIND)) {
/* Look for symlink in result-so-far. */
Scheme_Object *new_result, *a[1];
while (1) {
a[0] = result;
new_result = resolve_path(1, a);
new_result = do_resolve_path(1, a, guards);
/* Was it a link? */
if (result != new_result) {
@ -4736,11 +4912,28 @@ static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle
aa[1] = new_result;
new_result = do_build_path(2, aa, 0, 0, SCHEME_PLATFORM_PATH_KIND);
}
{
Scheme_Object *cl, *cp;
for (cl = cycle_check; !SCHEME_NULLP(cl); cl = SCHEME_CDR(cl)) {
cp = SCHEME_CAR(cl);
if ((SCHEME_PATH_LEN(cp) == SCHEME_PATH_LEN(new_result))
&& !strcmp(SCHEME_PATH_VAL(cp), SCHEME_PATH_VAL(new_result))) {
/* cycle */
new_result = NULL;
break;
}
}
}
/* Simplify the new result */
result = do_simplify_path(new_result, cycle_check, skip,
use_filesystem, force_rel_up, kind);
cycle_check = scheme_make_pair(new_result, cycle_check);
if (new_result) {
/* Simplify the new result */
result = do_simplify_path(new_result, cycle_check, skip,
use_filesystem, force_rel_up, kind,
guards);
cycle_check = scheme_make_pair(new_result, cycle_check);
} else
break;
} else
break;
}
@ -4843,7 +5036,7 @@ Scheme_Object *scheme_simplify_path(int argc, Scheme_Object *argv[])
NULL);
}
r = do_simplify_path(bs, scheme_null, 0, use_fs, 0, kind);
r = do_simplify_path(bs, scheme_null, 0, use_fs, 0, kind, 1);
if (SCHEME_FALSEP(r)) {
/* Input was just 'same: */
@ -4910,7 +5103,7 @@ static Scheme_Object *expand_user_path(int argc, Scheme_Object *argv[])
"expand-user-path",
&expanded,
1, 0,
SCHEME_GUARD_FILE_EXISTS,
SCHEME_GUARD_FILE_EXISTS,
SCHEME_PLATFORM_PATH_KIND,
1);
@ -4971,7 +5164,7 @@ static Scheme_Object *do_directory_list(int break_ok, int argc, Scheme_Object *a
if (SAME_OBJ(path, argv[0])) {
Scheme_Object *old;
old = scheme_make_path(filename);
path = do_simplify_path(old, scheme_null, 0, 1, 0, SCHEME_WINDOWS_PATH_KIND);
path = do_simplify_path(old, scheme_null, 0, 1, 0, SCHEME_WINDOWS_PATH_KIND, break_ok);
if (SAME_OBJ(path, old))
break;
} else
@ -4988,6 +5181,8 @@ static Scheme_Object *do_directory_list(int break_ok, int argc, Scheme_Object *a
# ifdef USE_FINDFIRST
retry:
if (!filename)
pattern = "*.*";
else {
@ -5029,15 +5224,27 @@ static Scheme_Object *do_directory_list(int break_ok, int argc, Scheme_Object *a
hfile = FIND_FIRST(WIDE_PATH(pattern), &info);
if (FIND_FAILED(hfile)) {
int err_val;
if (!filename)
return scheme_null;
err_val = GetLastError();
if ((err_val == ERROR_DIRECTORY) && CreateSymbolicLinkProc) {
/* check for symbolic link */
char *resolved;
if (UNC_stat(filename, strlen(filename), NULL, NULL, NULL, NULL, NULL, &resolved, -1)) {
if (resolved) {
filename = resolved;
goto retry;
}
}
}
if (break_ok)
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
"directory-list: could not open directory\n"
" path: %q\n"
" system error: %E",
filename,
GetLastError());
err_val);
return NULL;
}
@ -5434,7 +5641,7 @@ static Scheme_Object *make_link(int argc, Scheme_Object *argv[])
{
char *src;
Scheme_Object *dest;
int copied;
int copied, err_val;
if (!SCHEME_PATH_STRINGP(argv[0]))
scheme_wrong_contract("make-file-or-directory-link", "path-string?", 0, argc, argv);
@ -5459,11 +5666,26 @@ static Scheme_Object *make_link(int argc, Scheme_Object *argv[])
SCHEME_PATH_VAL(dest));
#if defined(DOS_FILE_SYSTEM)
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"make-file-or-directory-link: " NOT_SUPPORTED_STR ";\n"
" cannot create link\n"
" path: %Q",
argv[1]);
if (CreateSymbolicLinkProc) {
int flags;
if (do_path_to_directory_path(src, 0, -1, argv[1], 1, SCHEME_WINDOWS_PATH_KIND))
flags = 0x1; /* directory */
else
flags = 0; /* file */
if (CreateSymbolicLinkProc(WIDE_PATH_COPY(src),
WIDE_PATH_COPY(SCHEME_PATH_VAL(dest)),
flags))
return scheme_void;
err_val = GetLastError();
} else {
scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
"make-file-or-directory-link: " NOT_SUPPORTED_STR ";\n"
" cannot create link\n"
" path: %Q",
argv[1]);
}
#else
while (1) {
if (!symlink(SCHEME_PATH_VAL(dest), src))
@ -5471,14 +5693,15 @@ static Scheme_Object *make_link(int argc, Scheme_Object *argv[])
else if (errno != EINTR)
break;
}
err_val = errno;
#endif
scheme_raise_exn((errno == EEXIST) ? MZEXN_FAIL_FILESYSTEM_EXISTS : MZEXN_FAIL_FILESYSTEM,
"make-file-or-directory-link: cannot make link\n"
" path: %q\n"
" system error: %e",
" system error: %E",
filename_for_error(argv[1]),
errno);
#endif
err_val);
return NULL;
}
@ -5526,7 +5749,7 @@ static Scheme_Object *file_modify_seconds(int argc, Scheme_Object **argv)
int len = strlen(file);
Scheme_Object *secs;
if (UNC_stat(file, len, NULL, NULL, &secs, NULL, -1))
if (UNC_stat(file, len, NULL, NULL, NULL, &secs, NULL, NULL, -1))
return secs;
} else
# endif
@ -5794,7 +6017,7 @@ static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[])
} else
new_bits = -1;
if (UNC_stat(filename, len, &flags, NULL, NULL, NULL, new_bits)) {
if (UNC_stat(filename, len, &flags, NULL, NULL, NULL, NULL, NULL, new_bits)) {
if (set_bits)
l = scheme_void;
else if (as_bits)
@ -5819,7 +6042,7 @@ static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[])
scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
"file-or-directory-permissions: %s failed\n"
" path: %q\n"
" system error: %e",
" system error: %E",
set_bits ? "update" : "access",
filename_for_error(argv[0]),
err_val);
@ -5862,7 +6085,7 @@ static Scheme_Object *file_size(int argc, Scheme_Object *argv[])
#ifdef DOS_FILE_SYSTEM
{
if (UNC_stat(filename, strlen(filename), NULL, NULL, NULL, &len, -1)) {
if (UNC_stat(filename, strlen(filename), NULL, NULL, NULL, NULL, &len, NULL, -1)) {
return scheme_make_integer_value_from_long_long(len);
}
}
@ -5911,7 +6134,7 @@ static Scheme_Object *cwd_check(int argc, Scheme_Object **argv)
ed = scheme_make_sized_path(expanded, strlen(expanded), 1);
# ifndef NO_FILE_SYSTEM_UTILS
ed = do_simplify_path(ed, scheme_null, 0, 1, 0, SCHEME_PLATFORM_PATH_KIND);
ed = do_simplify_path(ed, scheme_null, 0, 1, 0, SCHEME_PLATFORM_PATH_KIND, 1);
# endif
ed = scheme_path_to_directory_path(ed);