From d9866626fadb0a1c94f0317d07cb7dcb5dfd7c86 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 6 May 2014 11:17:28 +0000
Subject: Start working on [3389978]. Appears to work, but some clean-up
 needed.

---
 tests/winFCmd.test |  4 ++--
 win/tclWinFile.c   | 32 ++++++++++++++++++++++++++++++--
 2 files changed, 32 insertions(+), 4 deletions(-)

diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index bd50328..28257c6 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -1385,10 +1385,10 @@ test winFCmd-19.5 {Windows extended path names} -constraints nt -setup {
     list [catch {
         set f [open $tmpfile [list WRONLY CREAT]]
         close $f
-    } res] errormsg ;#$res
+    } res] $res
 } -cleanup {
     catch {file delete $tmpfile}
-} -result [list 1 errormsg]
+} -result [list 0 {}]
 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]
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index fc0ac9e..e32cd94 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -2930,8 +2930,36 @@ TclNativeCreateNativeRep(
     Tcl_WinUtfToTChar(str, len, &ds);
     len = Tcl_DStringLength(&ds) + sizeof(WCHAR);
     wp = (WCHAR *) Tcl_DStringValue(&ds);
-    for (i=sizeof(WCHAR); i<len; ++wp,i+=sizeof(WCHAR)) {
-	if ( (*wp < ' ') || wcschr(L"\"*<>|", *wp) ){
+    i=sizeof(WCHAR);
+    if ((wp[0]=='/'||wp[0]=='\\') && (wp[1]=='/'||wp[1]=='\\')) {
+	if (wp[2]=='?'){
+	    /* Extended path prefix: convert slashes but not the '?' */
+	    wp[0] = wp[1] = wp[3] = '\\';
+	    i += 8; wp+=4;
+	    if (((wp[0]>='A'&&wp[0]<='Z') || (wp[0]>='a'&&wp[0]<='z'))
+		    && (wp[1]==':') && (wp[2]=='/' || wp[2]=='\\')) {
+		/* With drive, don't convert the ':' */
+		i += 4; wp+=2;
+	    }
+	}
+    } else {
+	if (((wp[0]>='A'&&wp[0]<='Z') || (wp[0]>='a'&&wp[0]<='z'))
+		&& (wp[1]==':') && (wp[2]=='/' || wp[2]=='\\')) {
+	    /* With drive, don't convert the ':' */
+	    i += 4; wp+=2;
+	    if (len > (MAX_PATH * sizeof(WCHAR))){
+		/* Path is too long, needs an extended path prefix. */
+		Tcl_DStringSetLength(&ds, len+=8);
+		Tcl_DStringSetLength(&ds, len+1); /* Must end with two NUL bytes */
+		wp = (WCHAR *) Tcl_DStringValue(&ds); /* wp might be re-allocated */
+		memmove(wp+4, wp, len-8);
+		memcpy(wp, L"\\\\?\\", 8);
+		i+=12; wp += 6;
+	    }
+	}
+    }
+    for (; i<len; ++wp,i+=sizeof(WCHAR)) {
+	if ( (*wp < ' ') || wcschr(L"\"*:<>?|", *wp) ){
 	    if (!*wp){
 		/* See bug [3118489]: NUL in filenames */
 		Tcl_DecrRefCount(validPathPtr);
-- 
cgit v0.12