Attachment "1479814-extpath.patch" to
ticket [1479814fff]
added by
patthoyts
2007-01-09 05:18:06.
[1479814] Tcl should support Unicode versions of Win32 file APIs
This patch fixes [file normalize] to not mash up the extended path
prefix (\\?\ or //?/) and permits paths up to 32K to be used.
Some tests included.
Supposedly UNC paths are extended using \\?\UNC\HOSTNAME\Share\... but
this doesn't work for me using Windows cmd.exe or explorer.exe
Index: generic/tclFileName.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclFileName.c,v
retrieving revision 1.76
diff -u -r1.76 tclFileName.c
--- generic/tclFileName.c 27 Sep 2006 13:49:06 -0000 1.76
+++ generic/tclFileName.c 3 Jan 2007 00:55:39 -0000
@@ -43,6 +43,33 @@
/*
*----------------------------------------------------------------------
*
+ * SetResultLength --
+ *
+ * Resets the result DString for ExtractWinRoot to accommodate
+ * any NT extended path prefixes.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May modify the Tcl_DString.
+ *----------------------------------------------------------------------
+ */
+
+static void
+SetResultLength(Tcl_DString *resultPtr, int offset, int extended)
+{
+ Tcl_DStringSetLength(resultPtr, offset);
+ if (extended == 2) {
+ Tcl_DStringAppend(resultPtr, "//?/UNC/", 8);
+ } else if (extended == 1) {
+ Tcl_DStringAppend(resultPtr, "//?/", 4);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* ExtractWinRoot --
*
* Matches the root portion of a Windows path and appends it to the
@@ -67,6 +94,21 @@
* stored. */
Tcl_PathType *typePtr) /* Where to store pathType result */
{
+ int extended = 0;
+
+ if ( (path[0] == '/' || path[0] == '\\')
+ && (path[1] == '/' || path[1] == '\\')
+ && (path[2] == '?')
+ && (path[3] == '/' || path[3] == '\\')) {
+ extended = 1;
+ path = path + 4;
+ if (path[0] == 'U' && path[1] == 'N' && path[2] == 'C'
+ && (path[3] == '/' || path[3] == '\\')) {
+ extended = 2;
+ path = path + 4;
+ }
+ }
+
if (path[0] == '/' || path[0] == '\\') {
/*
* Might be a UNC or Vol-Relative path.
@@ -76,7 +118,7 @@
int hlen, slen;
if (path[1] != '/' && path[1] != '\\') {
- Tcl_DStringSetLength(resultPtr, offset);
+ SetResultLength(resultPtr, offset, extended);
*typePtr = TCL_PATH_VOLUME_RELATIVE;
Tcl_DStringAppend(resultPtr, "/", 1);
return &path[1];
@@ -111,7 +153,7 @@
Tcl_DStringAppend(resultPtr, "/", 1);
return &path[2];
}
- Tcl_DStringSetLength(resultPtr, offset);
+ SetResultLength(resultPtr, offset, extended);
share = &host[hlen];
/*
@@ -149,7 +191,7 @@
* Might be a drive separator.
*/
- Tcl_DStringSetLength(resultPtr, offset);
+ SetResultLength(resultPtr, offset, extended);
if (path[2] != '/' && path[2] != '\\') {
*typePtr = TCL_PATH_VOLUME_RELATIVE;
@@ -248,7 +290,7 @@
if (abs != 0) {
*typePtr = TCL_PATH_ABSOLUTE;
- Tcl_DStringSetLength(resultPtr, offset);
+ SetResultLength(resultPtr, offset, extended);
Tcl_DStringAppend(resultPtr, path, abs);
return path + abs;
}
Index: generic/tclPathObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclPathObj.c,v
retrieving revision 1.56
diff -u -r1.56 tclPathObj.c
--- generic/tclPathObj.c 29 Aug 2006 00:36:57 -0000 1.56
+++ generic/tclPathObj.c 3 Jan 2007 00:59:26 -0000
@@ -166,6 +166,21 @@
dirSep = TclGetString(pathPtr);
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ if ( (dirSep[0] == '/' || dirSep[0] == '\\')
+ && (dirSep[1] == '/' || dirSep[1] == '\\')
+ && (dirSep[2] == '?')
+ && (dirSep[3] == '/' || dirSep[3] == '\\')) {
+ /* NT extended path */
+ dirSep += 4;
+
+ if ( (dirSep[0] == 'U' || dirSep[0] == 'u')
+ && (dirSep[1] == 'N' || dirSep[1] == 'n')
+ && (dirSep[2] == 'C' || dirSep[2] == 'c')
+ && (dirSep[3] == '/' || dirSep[3] == '\\')) {
+ /* NT extended UNC path */
+ dirSep += 4;
+ }
+ }
if (dirSep[0] != 0 && dirSep[1] == ':' &&
(dirSep[2] == '/' || dirSep[2] == '\\')) {
/* Do nothing */
Index: tests/winFCmd.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/winFCmd.test,v
retrieving revision 1.41
diff -u -r1.41 winFCmd.test
--- tests/winFCmd.test 3 Nov 2006 00:34:53 -0000 1.41
+++ tests/winFCmd.test 8 Jan 2007 21:37:29 -0000
@@ -1152,6 +1152,86 @@
} -result COM1
+test winFCmd-19.1 {Windows extended path names} -constraints nt -body {
+ file normalize //?/c:/windows/win.ini
+} -result //?/c:/windows/win.ini
+
+test winFCmd-19.2 {Windows extended path names} -constraints nt -body {
+ file normalize //?/c:/windows/../windows/win.ini
+} -result //?/c:/windows/win.ini
+
+test winFCmd-19.3 {Windows extended path names} -constraints nt -setup {
+ set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp]
+ set tmpfile [file normalize $tmpfile]
+} -body {
+ list [catch {
+ set f [open $tmpfile [list WRONLY CREAT]]
+ close $f
+ } res] $res
+} -cleanup {
+ catch {file delete $tmpfile}
+} -result [list 0 {}]
+
+test winFCmd-19.4 {Windows extended path names} -constraints nt -setup {
+ set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp]
+ set tmpfile //?/[file normalize $tmpfile]
+} -body {
+ list [catch {
+ set f [open $tmpfile [list WRONLY CREAT]]
+ close $f
+ } res] $res
+} -cleanup {
+ catch {file delete $tmpfile}
+} -result [list 0 {}]
+
+test winFCmd-19.5 {Windows extended path names} -constraints nt -setup {
+ set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
+ set tmpfile [file normalize $tmpfile]
+} -body {
+ list [catch {
+ set f [open $tmpfile [list WRONLY CREAT]]
+ close $f
+ } res] errormsg ;#$res
+} -cleanup {
+ catch {file delete $tmpfile}
+} -result [list 1 errormsg]
+
+test winFCmd-19.6 {Windows extended path names} -constraints nt -setup {
+ set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp]
+ set tmpfile //?/[file normalize $tmpfile]
+} -body {
+ list [catch {
+ set f [open $tmpfile [list WRONLY CREAT]]
+ close $f
+ } res] $res
+} -cleanup {
+ catch {file delete $tmpfile}
+} -result [list 0 {}]
+
+test winFCmd-19.7 {Windows extended path names} -constraints nt -setup {
+ set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "]
+ set tmpfile [file normalize $tmpfile]
+} -body {
+ list [catch {
+ set f [open $tmpfile [list WRONLY CREAT]]
+ close $f
+ } res] $res [glob -directory $::env(TEMP) -tails tcl[pid].*]
+} -cleanup {
+ catch {file delete $tmpfile}
+} -result [list 0 {} [list tcl[pid].tmp]]
+
+test winFCmd-19.8 {Windows extended path names} -constraints nt -setup {
+ set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "]
+ set tmpfile //?/[file normalize $tmpfile]
+} -body {
+ list [catch {
+ set f [open $tmpfile [list WRONLY CREAT]]
+ close $f
+ } res] $res [glob -directory $::env(TEMP) -tails tcl[pid].*]
+} -cleanup {
+ catch {file delete $tmpfile}
+} -result [list 0 {} [list "tcl[pid].tmp "]]
+
# This block of code used to occur after the "return" call, so I'm
# commenting it out and assuming that this code is still under construction.
#foreach source {tef ted tnf tnd "" nul com1} {
Index: win/tclWinFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinFile.c,v
retrieving revision 1.90
diff -u -r1.90 tclWinFile.c
--- win/tclWinFile.c 13 Oct 2006 12:57:21 -0000 1.90
+++ win/tclWinFile.c 2 Jan 2007 22:40:48 -0000
@@ -3277,6 +3277,13 @@
}
str = Tcl_GetStringFromObj(validPathPtr, &len);
+ if (str[0] == '/' && str[1] == '/' && str[2] == '?' && str[3] == '/')
+ {
+ char *p;
+ for (p = str; p && *p; ++p) {
+ if (*p == '/') *p = '\\';
+ }
+ }
Tcl_WinUtfToTChar(str, len, &ds);
if (tclWinProcs->useWide) {
len = Tcl_DStringLength(&ds) + sizeof(WCHAR);
