diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl index bd9555bbb6..a55de2ae0b 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl @@ -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} diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/paths.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/paths.scrbl index 5cc79e3d95..b72d5fb317 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/paths.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/paths.scrbl @@ -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 diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/windows-paths.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/windows-paths.scrbl index 96f6e72851..18d4085d53 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/windows-paths.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/windows-paths.scrbl @@ -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 diff --git a/racket/src/racket/sconfig.h b/racket/src/racket/sconfig.h index dedf10c0da..c759c13d88 100644 --- a/racket/src/racket/sconfig.h +++ b/racket/src/racket/sconfig.h @@ -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. */ diff --git a/racket/src/racket/src/file.c b/racket/src/racket/src/file.c index 25c471e85a..414b9af546 100644 --- a/racket/src/racket/src/file.c +++ b/racket/src/racket/src/file.c @@ -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);