Bug #1479814. Handle extended paths on Windows NT and above.

5 files changed, 159 insertions, 8 deletions

diff --git a/ChangeLog b/ChangeLog
index 470b2f4..b6c8209 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2007-02-20  Pat Thoyts  <patthoyts@users.sourceforge.net>
+
+	* generic/tclFileName.c:  Bug #1479814. Handle extended paths
+	* generic/tclPathObj.c:   on Windows NT and above. These have a
+	* win/tclWinFile.c:       \\?\ prefix.
+	* tests/winFCmd.test:     Tests for extended path handling.
+
 2007-02-19  Jeff Hobbs  <jeffh@ActiveState.com>
 
 	* unix/tcl.m4: use SHLIB_SUFFIX=".so" on HP-UX ia64 arch.
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 590c180..0e2fd20 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.76 2006/09/27 13:49:06 msofer Exp $
+ * RCS: @(#) $Id: tclFileName.c,v 1.77 2007/02/20 15:36:46 patthoyts Exp $
  */
 
 #include "tclInt.h"
@@ -43,6 +43,33 @@ static int		DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr,
 /*
  *----------------------------------------------------------------------
  *
+ * 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 @@ ExtractWinRoot(
 				 * 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 @@ ExtractWinRoot(
 	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 @@ ExtractWinRoot(
 	    Tcl_DStringAppend(resultPtr, "/", 1);
 	    return &path[2];
 	}
-	Tcl_DStringSetLength(resultPtr, offset);
+	SetResultLength(resultPtr, offset, extended);
 	share = &host[hlen];
 
 	/*
@@ -149,7 +191,7 @@ ExtractWinRoot(
 	 * 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 @@ ExtractWinRoot(
 
 	if (abs != 0) {
 	    *typePtr = TCL_PATH_ABSOLUTE;
-	    Tcl_DStringSetLength(resultPtr, offset);
+	    SetResultLength(resultPtr, offset, extended);
 	    Tcl_DStringAppend(resultPtr, path, abs);
 	    return path + abs;
 	}
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index c73eee8..1aa5cb2 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.56 2006/08/29 00:36:57 coldstore Exp $
+ * RCS: @(#) $Id: tclPathObj.c,v 1.57 2007/02/20 15:36:46 patthoyts Exp $
  */
 
 #include "tclInt.h"
@@ -166,6 +166,21 @@ TclFSNormalizeAbsolutePath(
     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 */
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index e2575dd..24fbf8e 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.41 2006/11/03 00:34:53 hobbs Exp $
+# RCS: @(#) $Id: winFCmd.test,v 1.42 2007/02/20 15:36:47 patthoyts Exp $
 #
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -1152,6 +1152,86 @@ test winFCmd-18.8 {Windows reserved path names} -constraints win -body {
 } -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} {
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 2a8a2a5..4139dac 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -11,7 +11,7 @@
  * 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.90 2006/10/13 12:57:21 coldstore Exp $
+ * RCS: @(#) $Id: tclWinFile.c,v 1.91 2007/02/20 15:36:47 patthoyts Exp $
  */
 
 /* #define _WIN32_WINNT	0x0500 */
@@ -3277,6 +3277,13 @@ TclNativeCreateNativeRep(
     }
 
     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);