diff options
| -rw-r--r-- | ChangeLog | 14 | ||||
| -rw-r--r-- | generic/tclFileName.c | 17 | ||||
| -rw-r--r-- | generic/tclFileSystem.h | 8 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 190 | ||||
| -rw-r--r-- | generic/tclPathObj.c | 86 | ||||
| -rw-r--r-- | tests/fileName.test | 14 | ||||
| -rw-r--r-- | tests/winFCmd.test | 49 | ||||
| -rw-r--r-- | unix/tclUnixFile.c | 129 | ||||
| -rw-r--r-- | win/tclWinFile.c | 265 |
9 files changed, 500 insertions, 272 deletions
@@ -1,3 +1,17 @@ +2004-10-07 Vince Darley <vincentdarley@users.sourceforge.net> + + * generic/tclFileName.c: + * generic/tclFileSystem.h: + * generic/tclIOUtil.c: + * generic/tclPathObj.c: + * unix/tclUnixFile.c: + * win/tclWinFile.c: + * tests/fileName.test: + * tests/winFCmd.test: code reorganization for better generic/ + platform code splitting [Bug 925620] removing the need for + several #ifdef's, and tests and fix for an unreported Windows + glob problem ('glob -dir C: -tails *'). + 2004-10-07 Donal K. Fellows <donal.k.fellows@man.ac.uk> * doc/man.macros, *.3: Update .AS macro so it can know how wide to diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 785769a..aba17d7 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileName.c,v 1.59 2004/10/06 23:44:06 dkf Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.60 2004/10/07 14:50:21 vincentdarley Exp $ */ #include "tclInt.h" @@ -1788,8 +1788,19 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) /* If this length has never been set, set it here */ CONST char *pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); - if (prefixLen > 0) { - if (strchr(separators, pre[prefixLen-1]) == NULL) { + if (prefixLen > 0 + && (strchr(separators, pre[prefixLen-1]) == NULL)) { + + /* + * If we're on Windows and the prefix is a volume + * relative one like 'C:', then there won't be + * a path separator in between, so no need to + * skip it here. + */ + + if ((tclPlatform != TCL_PLATFORM_WINDOWS) + || (prefixLen != 2) + || (pre[1] != ':')) { prefixLen++; } } diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h index 2fe4bd6..a9a9245 100644 --- a/generic/tclFileSystem.h +++ b/generic/tclFileSystem.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileSystem.h,v 1.8 2004/09/27 15:00:39 vincentdarley Exp $ + * RCS: @(#) $Id: tclFileSystem.h,v 1.9 2004/10/07 14:50:22 vincentdarley Exp $ */ /* @@ -87,7 +87,7 @@ extern Tcl_ThreadDataKey tclFsDataKey; /* * Private shared functions for use by tclIOUtil.c, tclPathObj.c - * and tclFileName.c + * and tclFileName.c, and any platform-specific filesystem code. */ Tcl_PathType TclFSGetPathType _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Filesystem **filesystemPtrPtr, @@ -99,4 +99,8 @@ Tcl_PathType TclGetPathType _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Filesystem **filesystemPtrPtr, int *driveNameLengthPtr, Tcl_Obj **driveNameRef)); int TclFSEpochOk _ANSI_ARGS_((int filesystemEpoch)); +int TclFSCwdIsNative _ANSI_ARGS_((void)); +Tcl_Obj* TclWinVolumeRelativeNormalize _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *path, Tcl_Obj **useThisCwdPtr)); Tcl_FSPathInFilesystemProc TclNativePathInFilesystem; +Tcl_FSCreateInternalRepProc TclNativeCreateNativeRep; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index fce520e..0f31689 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.110 2004/10/06 23:44:07 dkf Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.111 2004/10/07 14:50:22 vincentdarley Exp $ */ #include "tclInt.h" @@ -296,7 +296,6 @@ TCL_DECLARE_MUTEX(obsoleteFsHookMutex) */ static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; -static Tcl_FSCreateInternalRepProc NativeCreateNativeRep; static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; @@ -344,7 +343,7 @@ Tcl_Filesystem tclNativeFilesystem = { &TclNativeDupInternalRep, &NativeFreeInternalRep, &TclpNativeToNormalized, - &NativeCreateNativeRep, + &TclNativeCreateNativeRep, &TclpObjNormalizePath, &TclpFilesystemPathType, &NativeFilesystemSeparator, @@ -467,6 +466,18 @@ FsThrExitProc(cd) } } +int +TclFSCwdIsNative() +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); + + if (tsdPtr->cwdClientData != NULL) { + return 1; + } else { + return 0; + } +} + /* *---------------------------------------------------------------------- * @@ -4127,179 +4138,6 @@ Tcl_FSGetNativePath(pathPtr) /* *--------------------------------------------------------------------------- * - * NativeCreateNativeRep -- - * - * Create a native representation for the given path. - * - * Results: - * None. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ -static ClientData -NativeCreateNativeRep(pathPtr) - Tcl_Obj* pathPtr; -{ - char *nativePathPtr; - Tcl_DString ds; - Tcl_Obj* validPathPtr; - int len; - char *str; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - - if (tsdPtr->cwdClientData != NULL) { - /* The cwd is native */ - validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); - } else { - /* Make sure the normalized path is set */ - validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - Tcl_IncrRefCount(validPathPtr); - } - - str = Tcl_GetStringFromObj(validPathPtr, &len); -#ifdef __WIN32__ - Tcl_WinUtfToTChar(str, len, &ds); - if (tclWinProcs->useWide) { - len = Tcl_DStringLength(&ds) + sizeof(WCHAR); - } else { - len = Tcl_DStringLength(&ds) + sizeof(char); - } -#else - Tcl_UtfToExternalDString(NULL, str, len, &ds); - len = Tcl_DStringLength(&ds) + sizeof(char); -#endif - Tcl_DecrRefCount(validPathPtr); - nativePathPtr = ckalloc((unsigned) len); - memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len); - - Tcl_DStringFree(&ds); - return (ClientData)nativePathPtr; -} - -/* - *--------------------------------------------------------------------------- - * - * TclpNativeToNormalized -- - * - * Convert native format to a normalized path object, with refCount - * of zero. - * - * Currently assumes all native paths are actually normalized - * already, so if the path given is not normalized this will - * actually just convert to a valid string path, but not - * necessarily a normalized one. - * - * Results: - * A valid normalized path. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ -Tcl_Obj* -TclpNativeToNormalized(clientData) - ClientData clientData; -{ - Tcl_DString ds; - Tcl_Obj *objPtr; - int len; - -#ifdef __WIN32__ - char *copy; - char *p; - Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds); -#else - CONST char *copy; - Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds); -#endif - - copy = Tcl_DStringValue(&ds); - len = Tcl_DStringLength(&ds); - -#ifdef __WIN32__ - /* - * Certain native path representations on Windows have this special - * prefix to indicate that they are to be treated specially. For - * example extremely long paths, or symlinks - */ - if (*copy == '\\') { - if (0 == strncmp(copy,"\\??\\",4)) { - copy += 4; - len -= 4; - } else if (0 == strncmp(copy,"\\\\?\\",4)) { - copy += 4; - len -= 4; - } - } - /* - * Ensure we are using forward slashes only. - */ - for (p = copy; *p != '\0'; p++) { - if (*p == '\\') { - *p = '/'; - } - } -#endif - - objPtr = Tcl_NewStringObj(copy,len); - Tcl_DStringFree(&ds); - - return objPtr; -} - - -/* - *--------------------------------------------------------------------------- - * - * TclNativeDupInternalRep -- - * - * Duplicate the native representation. - * - * Results: - * The copied native representation, or NULL if it is not possible - * to copy the representation. - * - * Side effects: - * None. - * - *--------------------------------------------------------------------------- - */ -ClientData -TclNativeDupInternalRep(clientData) - ClientData clientData; -{ - char *copy; - size_t len; - - if (clientData == NULL) { - return NULL; - } - -#ifdef __WIN32__ - if (tclWinProcs->useWide) { - /* unicode representation when running on NT/2K/XP */ - len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR)); - } else { - /* ansi representation when running on 95/98/ME */ - len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); - } -#else - /* ansi representation when running on Unix */ - len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); -#endif - - copy = (char *) ckalloc(len); - memcpy((VOID*)copy, (VOID*)clientData, len); - return (ClientData)copy; -} - -/* - *--------------------------------------------------------------------------- - * * NativeFreeInternalRep -- * * Free a native internal representation, which will be non-NULL. diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 57dc048..26d5e70 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPathObj.c,v 1.36 2004/10/06 12:09:14 dkf Exp $ + * RCS: @(#) $Id: tclPathObj.c,v 1.37 2004/10/07 14:50:23 vincentdarley Exp $ */ #include "tclInt.h" @@ -1238,7 +1238,7 @@ TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len) Tcl_Obj* TclFSMakePathRelative(interp, pathPtr, cwdPtr) Tcl_Interp *interp; /* Used for error reporting if not NULL. */ - Tcl_Obj *pathPtr; /* The object we have. */ + Tcl_Obj *pathPtr; /* The path we have. */ Tcl_Obj *cwdPtr; /* Make it relative to this. */ { int cwdLen, len; @@ -1789,86 +1789,12 @@ Tcl_FSGetNormalizedPath(interp, pathPtr) /* We have a refCount on the cwd */ #ifdef __WIN32__ } else if (type == TCL_PATH_VOLUME_RELATIVE) { - /* - * Only Windows has volume-relative paths. These - * paths are rather rare, but it is nice if Tcl can - * handle them. It is much better if we can - * handle them here, rather than in the native fs code, - * because we really need to have a real absolute path - * just below. - * - * We do not let this block compile on non-Windows - * platforms because the test suite's manual forcing - * of tclPlatform can otherwise cause this code path - * to be executed, causing various errors because - * volume-relative paths really do not exist. - */ - - useThisCwd = Tcl_FSGetCwd(interp); - if (useThisCwd == NULL) { + /* Only Windows has volume-relative paths */ + absolutePath = TclWinVolumeRelativeNormalize(interp, path, + &useThisCwd); + if (absolutePath == NULL) { return NULL; } - - if (path[0] == '/') { - /* - * Path of form /foo/bar which is a path in the - * root directory of the current volume. - */ - - CONST char *drive = TclGetString(useThisCwd); - - absolutePath = Tcl_NewStringObj(drive, 2); - Tcl_AppendToObj(absolutePath, path, -1); - Tcl_IncrRefCount(absolutePath); - /* We have a refCount on the cwd */ - } else { - /* - * Path of form C:foo/bar, but this only makes - * sense if the cwd is also on drive C. - */ - - int cwdLen; - CONST char *drive = - Tcl_GetStringFromObj(useThisCwd, &cwdLen); - char drive_cur = path[0]; - - if (drive_cur >= 'a') { - drive_cur -= ('a' - 'A'); - } - if (drive[0] == drive_cur) { - absolutePath = Tcl_DuplicateObj(useThisCwd); - /* - * We have a refCount on the cwd, which we - * will release later. - */ - - if (drive[cwdLen-1] != '/' && (path[2] != '\0')) { - /* - * Only add a trailing '/' if needed, which - * is if there isn't one already, and if we - * are going to be adding some more - * characters. - */ - Tcl_AppendToObj(absolutePath, "/", 1); - } - } else { - TclDecrRefCount(useThisCwd); - useThisCwd = NULL; - - /* - * The path is not in the current drive, but - * is volume-relative. The way Tcl 8.3 handles - * this is that it treats such a path as - * relative to the root of the drive. We - * therefore behave the same here. - */ - - absolutePath = Tcl_NewStringObj(path, 2); - Tcl_AppendToObj(absolutePath, "/", 1); - } - Tcl_IncrRefCount(absolutePath); - Tcl_AppendToObj(absolutePath, path+2, -1); - } #endif /* __WIN32__ */ } } diff --git a/tests/fileName.test b/tests/fileName.test index 9c6cbb1..0cf0c1c 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fileName.test,v 1.43 2004/06/23 15:36:56 dkf Exp $ +# RCS: @(#) $Id: fileName.test,v 1.44 2004/10/07 14:50:23 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1484,6 +1484,18 @@ test filename-16.15 {windows specific globbing} {win} { test filename-16.16 {windows specific globbing} {win} { file tail [lindex [glob -nocomplain "[lindex [glob -types d -dir C:/ *] 0]/.."] 0] } {..} +test filename-16.17 {windows specific globbing} {win} { + cd C:/ + # Ensure correct trimming of tails with absolute and + # volume relative globbing. + set res1 [glob -nocomplain -tails -dir C:/ *] + set res2 [glob -nocomplain -tails -dir C: *] + if {$res1 eq $res2} { + concat ok + } else { + concat $res1 ne $res2 + } +} {ok} test filename-17.1 {windows specific special files} {testsetplatform} { testsetplatform win diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 891925e..9992db4 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winFCmd.test,v 1.34 2004/09/27 15:00:42 vincentdarley Exp $ +# RCS: @(#) $Id: winFCmd.test,v 1.35 2004/10/07 14:50:23 vincentdarley Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -1023,17 +1023,34 @@ test winFCmd-16.11 {Windows file normalization} -constraints {win cdrom} \ # Must not crash set result "no crash" } -cleanup { - cd ${d}: + cd $pwd } -result {no crash} -test winFCmd-16.12 {Windows file normalization} -constraints win -setup { - set oldwd [pwd] + +test winFCmd-16.12 {Windows file normalization - no crash} \ + -constraints win -setup { set oldhome "" catch {set oldhome $::env(HOME)} } -body { set expectedResult [file normalize ${d}:] set ::env(HOME) ${d}: cd + # At one point this led to an infinite recursion in Tcl set result [pwd]; # <- Must not crash + set result "no crash" +} -cleanup { + set ::env(HOME) $oldhome + cd $pwd +} -result {no crash} + +test winFCmd-16.13 {Windows file normalization} -constraints win -setup { + set oldhome "" + catch {set oldhome $::env(HOME)} +} -body { + # Test 'cd' normalization when HOME is absolute + set expectedResult [file normalize ${d}:/] + set ::env(HOME) ${d}:/ + cd + set result [pwd] if { [string equal $result $expectedResult] } { concat ok } else { @@ -1041,12 +1058,28 @@ test winFCmd-16.12 {Windows file normalization} -constraints win -setup { } } -cleanup { set ::env(HOME) $oldhome - cd $oldwd + cd $pwd } -result ok -test winFCmd-16.13 {Windows bad permissions cd} -constraints win -setup { - set oldwd [pwd] +test winFCmd-16.14 {Windows file normalization} -constraints win -setup { + set oldhome "" + catch {set oldhome $::env(HOME)} } -body { + # Test 'cd' normalization when HOME is relative + set ::env(HOME) ${d}: + cd + set result [pwd] + if { [string equal $result $pwd] } { + concat ok + } else { + list $result != $pwd + } +} -cleanup { + set ::env(HOME) $oldhome + cd $pwd +} -result ok + +test winFCmd-17.1 {Windows bad permissions cd} -constraints win -body { set d {} foreach dd {c:/ d:/ e:/} { eval lappend d [glob -nocomplain \ @@ -1061,7 +1094,7 @@ test winFCmd-16.13 {Windows bad permissions cd} -constraints win -setup { set err "permission denied" } } -cleanup { - cd $oldwd + cd $pwd } -result "permission denied" cd $pwd diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 07e43fc..842d1b6 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -9,10 +9,11 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFile.c,v 1.41 2004/07/20 10:12:29 das Exp $ + * RCS: @(#) $Id: tclUnixFile.c,v 1.42 2004/10/07 14:50:23 vincentdarley Exp $ */ #include "tclInt.h" +#include "tclFileSystem.h" static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types); @@ -903,6 +904,132 @@ TclpFilesystemPathType(pathPtr) /* *--------------------------------------------------------------------------- * + * TclpNativeToNormalized -- + * + * Convert native format to a normalized path object, with refCount + * of zero. + * + * Currently assumes all native paths are actually normalized + * already, so if the path given is not normalized this will + * actually just convert to a valid string path, but not + * necessarily a normalized one. + * + * Results: + * A valid normalized path. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +TclpNativeToNormalized(clientData) + ClientData clientData; +{ + Tcl_DString ds; + Tcl_Obj *objPtr; + int len; + + CONST char *copy; + Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds); + + copy = Tcl_DStringValue(&ds); + len = Tcl_DStringLength(&ds); + + objPtr = Tcl_NewStringObj(copy,len); + Tcl_DStringFree(&ds); + + return objPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TclNativeCreateNativeRep -- + * + * Create a native representation for the given path. + * + * Results: + * The nativePath representation. + * + * Side effects: + * Memory will be allocated. The path may need to be normalized. + * + *--------------------------------------------------------------------------- + */ +ClientData +TclNativeCreateNativeRep(pathPtr) + Tcl_Obj* pathPtr; +{ + char *nativePathPtr; + Tcl_DString ds; + Tcl_Obj* validPathPtr; + int len; + char *str; + + if (TclFSCwdIsNative()) { + /* + * The cwd is native, which means we can use the translated + * path without worrying about normalization (this will also + * usually be shorter so the utf-to-external conversion will + * be somewhat faster). + */ + validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + } else { + /* Make sure the normalized path is set */ + validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + Tcl_IncrRefCount(validPathPtr); + } + + str = Tcl_GetStringFromObj(validPathPtr, &len); + Tcl_UtfToExternalDString(NULL, str, len, &ds); + len = Tcl_DStringLength(&ds) + sizeof(char); + Tcl_DecrRefCount(validPathPtr); + nativePathPtr = ckalloc((unsigned) len); + memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len); + + Tcl_DStringFree(&ds); + return (ClientData)nativePathPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TclNativeDupInternalRep -- + * + * Duplicate the native representation. + * + * Results: + * The copied native representation, or NULL if it is not possible + * to copy the representation. + * + * Side effects: + * Memory will be allocated for the copy. + * + *--------------------------------------------------------------------------- + */ +ClientData +TclNativeDupInternalRep(clientData) + ClientData clientData; +{ + char *copy; + size_t len; + + if (clientData == NULL) { + return NULL; + } + + /* ascii representation when running on Unix */ + len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); + + copy = (char *) ckalloc(len); + memcpy((VOID*)copy, (VOID*)clientData, len); + return (ClientData)copy; +} + +/* + *--------------------------------------------------------------------------- + * * TclpUtime -- * * Set the modification date for a file. diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 6113b4e..8406a3e 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -11,12 +11,13 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinFile.c,v 1.66 2004/06/30 14:46:11 vincentdarley Exp $ + * RCS: @(#) $Id: tclWinFile.c,v 1.67 2004/10/07 14:50:24 vincentdarley Exp $ */ //#define _WIN32_WINNT 0x0500 #include "tclWinInt.h" +#include "tclFileSystem.h" #include <winioctl.h> #include <sys/stat.h> #include <shlobj.h> @@ -2642,6 +2643,268 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint) /* *--------------------------------------------------------------------------- * + * TclWinVolumeRelativeNormalize -- + * + * Only Windows has volume-relative paths. These paths are rather + * rare, but it is nice if Tcl can handle them. It is much better + * if we can handle them here, rather than in the native fs code, + * because we really need to have a real absolute path just below. + * + * We do not let this block compile on non-Windows platforms + * because the test suite's manual forcing of tclPlatform can + * otherwise cause this code path to be executed, causing various + * errors because volume-relative paths really do not exist. + * + * Results: + * A valid normalized path. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +TclWinVolumeRelativeNormalize(interp, path, useThisCwdPtr) + Tcl_Interp *interp; + CONST char *path; + Tcl_Obj **useThisCwdPtr; +{ + Tcl_Obj *absolutePath, *useThisCwd; + + useThisCwd = Tcl_FSGetCwd(interp); + if (useThisCwd == NULL) { + return NULL; + } + + if (path[0] == '/') { + /* + * Path of form /foo/bar which is a path in the + * root directory of the current volume. + */ + CONST char *drive = Tcl_GetString(useThisCwd); + + absolutePath = Tcl_NewStringObj(drive,2); + Tcl_AppendToObj(absolutePath, path, -1); + Tcl_IncrRefCount(absolutePath); + /* We have a refCount on the cwd */ + } else { + /* + * Path of form C:foo/bar, but this only makes + * sense if the cwd is also on drive C. + */ + + int cwdLen; + CONST char *drive = + Tcl_GetStringFromObj(useThisCwd, &cwdLen); + char drive_cur = path[0]; + + if (drive_cur >= 'a') { + drive_cur -= ('a' - 'A'); + } + if (drive[0] == drive_cur) { + absolutePath = Tcl_DuplicateObj(useThisCwd); + /* + * We have a refCount on the cwd, which we + * will release later. + */ + + if (drive[cwdLen-1] != '/' && (path[2] != '\0')) { + /* + * Only add a trailing '/' if needed, which + * is if there isn't one already, and if we + * are going to be adding some more + * characters. + */ + Tcl_AppendToObj(absolutePath, "/", 1); + } + } else { + Tcl_DecrRefCount(useThisCwd); + useThisCwd = NULL; + /* + * The path is not in the current drive, but + * is volume-relative. The way Tcl 8.3 handles + * this is that it treats such a path as + * relative to the root of the drive. We + * therefore behave the same here. This + * behaviour is, however, different to that + * of the windows command-line. If we want + * to fix this at some point in the future + * (at the expense of a behaviour change to + * Tcl), we could use the '_dgetdcwd' Win32 + * API to get the drive's cwd. + */ + absolutePath = Tcl_NewStringObj(path, 2); + Tcl_AppendToObj(absolutePath, "/", 1); + } + Tcl_IncrRefCount(absolutePath); + Tcl_AppendToObj(absolutePath, path+2, -1); + } + *useThisCwdPtr = useThisCwd; + return absolutePath; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpNativeToNormalized -- + * + * Convert native format to a normalized path object, with refCount + * of zero. + * + * Currently assumes all native paths are actually normalized + * already, so if the path given is not normalized this will + * actually just convert to a valid string path, but not + * necessarily a normalized one. + * + * Results: + * A valid normalized path. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +Tcl_Obj* +TclpNativeToNormalized(clientData) + ClientData clientData; +{ + Tcl_DString ds; + Tcl_Obj *objPtr; + int len; + + char *copy; + char *p; + Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds); + + copy = Tcl_DStringValue(&ds); + len = Tcl_DStringLength(&ds); + + /* + * Certain native path representations on Windows have this special + * prefix to indicate that they are to be treated specially. For + * example extremely long paths, or symlinks + */ + if (*copy == '\\') { + if (0 == strncmp(copy,"\\??\\",4)) { + copy += 4; + len -= 4; + } else if (0 == strncmp(copy,"\\\\?\\",4)) { + copy += 4; + len -= 4; + } + } + /* + * Ensure we are using forward slashes only. + */ + for (p = copy; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } + + objPtr = Tcl_NewStringObj(copy,len); + Tcl_DStringFree(&ds); + + return objPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TclNativeCreateNativeRep -- + * + * Create a native representation for the given path. + * + * Results: + * The nativePath representation. + * + * Side effects: + * Memory will be allocated. The path may need to be normalized. + * + *--------------------------------------------------------------------------- + */ +ClientData +TclNativeCreateNativeRep(pathPtr) + Tcl_Obj* pathPtr; +{ + char *nativePathPtr; + Tcl_DString ds; + Tcl_Obj* validPathPtr; + int len; + char *str; + + if (TclFSCwdIsNative()) { + /* + * The cwd is native, which means we can use the translated + * path without worrying about normalization (this will also + * usually be shorter so the utf-to-external conversion will + * be somewhat faster). + */ + validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + } else { + /* Make sure the normalized path is set */ + validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + Tcl_IncrRefCount(validPathPtr); + } + + str = Tcl_GetStringFromObj(validPathPtr, &len); + Tcl_WinUtfToTChar(str, len, &ds); + if (tclWinProcs->useWide) { + len = Tcl_DStringLength(&ds) + sizeof(WCHAR); + } else { + len = Tcl_DStringLength(&ds) + sizeof(char); + } + Tcl_DecrRefCount(validPathPtr); + nativePathPtr = ckalloc((unsigned) len); + memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len); + + Tcl_DStringFree(&ds); + return (ClientData)nativePathPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TclNativeDupInternalRep -- + * + * Duplicate the native representation. + * + * Results: + * The copied native representation, or NULL if it is not possible + * to copy the representation. + * + * Side effects: + * Memory allocation for the copy. + * + *--------------------------------------------------------------------------- + */ +ClientData +TclNativeDupInternalRep(clientData) + ClientData clientData; +{ + char *copy; + size_t len; + + if (clientData == NULL) { + return NULL; + } + + if (tclWinProcs->useWide) { + /* unicode representation when running on NT/2K/XP */ + len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR)); + } else { + /* ansi representation when running on 95/98/ME */ + len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); + } + + copy = (char *) ckalloc(len); + memcpy((VOID*)copy, (VOID*)clientData, len); + return (ClientData)copy; +} + +/* + *--------------------------------------------------------------------------- + * * TclpUtime -- * * Set the modification date for a file. |