merge fix-1613456fff, closes [1613456fffffffff] and [27b682284974d0cd]

6 files changed, 101 insertions, 55 deletions

diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index c52cd1e..1363829 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -373,14 +373,7 @@ TclFileDeleteCmd(
 	 */
 
 	if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
-	    /*
-	     * Trying to delete a file that does not exist is not considered
-	     * an error, just a no-op
-	     */
-
-	    if (errno != ENOENT) {
-		result = TCL_ERROR;
-	    }
+	    result = TCL_ERROR;
 	} else if (S_ISDIR(statBuf.st_mode)) {
 	    /*
 	     * We own a reference count on errorBuffer, if it was set as a
@@ -416,13 +409,20 @@ TclFileDeleteCmd(
 	}
 
 	if (result != TCL_OK) {
-	    result = TCL_ERROR;
 
 	    /*
+	     * Avoid possible race condition (file/directory deleted after call
+	     * of lstat), so bypass ENOENT because not an error, just a no-op
+	     */
+	    if (errno == ENOENT) {
+		result = TCL_OK;
+		continue;
+	    }
+	    /*
 	     * It is important that we break on error, otherwise we might end
 	     * up owning reference counts on numerous errorBuffers.
 	     */
-
+	    result = TCL_ERROR;
 	    break;
 	}
     }
diff --git a/tests/fileName.test b/tests/fileName.test
index d224011..0851e94 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -770,6 +770,7 @@ test filename-11.16 {Tcl_GlobCmd} {
 
 set globname "globTest"
 set horribleglobname "glob\[\{Test"
+set tildeglobname "./~test.txt"
 
 test filename-11.17 {Tcl_GlobCmd} {unix} {
     list [catch {lsort [glob -directory $globname *]} msg] $msg
@@ -940,11 +941,11 @@ test filename-11.21.1 {Tcl_GlobCmd} {
 
 # Get rid of file/dir if it exists, since it will have
 # been left behind by a previous failed run.
-if {[file exists $horribleglobname]} {
-    file delete -force $horribleglobname
-}
+file delete -force $horribleglobname
 file rename globTest $horribleglobname
 set globname $horribleglobname
+file delete -force $tildeglobname
+close [open $tildeglobname w]
 
 test filename-11.22 {Tcl_GlobCmd} {unix} {
     list [catch {lsort [glob -dir $globname *]} msg] $msg
@@ -1067,7 +1068,9 @@ test filename-11.41 {Tcl_GlobCmd} {
 test filename-11.42 {Tcl_GlobCmd} {
     set res [list]
     foreach f [glob -dir [pwd] *] {
-	lappend res [file tail $f]
+	set f [file tail $f]
+	regsub {^./} $f {} f; # until glob bug [2511011fff] don't fixed (tilde expansion prevention).
+	lappend res $f
     }
     expr {$res == [glob *]}
 } {1}
@@ -1109,8 +1112,9 @@ test filename-11.49 {Tcl_GlobCmd} {
 } {1 {bad argument to "-types": abcde}}
 
 file rename $horribleglobname globTest
+file delete -force $tildeglobname
 set globname globTest
-unset horribleglobname
+unset horribleglobname tildeglobname
 
 test filename-12.1 {simple globbing} {unixOrPc} {
     list [catch {glob {}} msg] $msg
diff --git a/tests/tcltest.test b/tests/tcltest.test
index ce8d617..d513856 100644
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -549,8 +549,9 @@ switch -- $::tcl_platform(platform) {
 	file attributes $notWriteableDir -permissions 00555
     }
     default {
+	# note in FAT/NTFS we won't be able to protect directory with read-only attribute...
 	catch {file attributes $notWriteableDir -readonly 1}
-	catch {testchmod 000 $notWriteableDir}
+	catch {testchmod 0 $notWriteableDir}
     }
 }
 test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
@@ -565,9 +566,10 @@ test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
 # This constraint doesn't go at the top of the file so that it doesn't
 # interfere with tcltest-5.5
 testConstraint notFAT [expr {
-    ![string match "FAT*" [lindex [file system $notWriteableDir] 1]]
+       ![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]]
+    || $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]]
 }]
-# FAT permissions are fairly hopeless; ignore this test if that FS is used
+# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used
 test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
     -constraints {unixOrPc notRoot notFAT}
     -body {
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index f0cb406..b3fd921 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -17,6 +17,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 
 # Initialise the test constraints
 
+testConstraint winVista 0
+testConstraint winXP 0
 testConstraint testvolumetype [llength [info commands testvolumetype]]
 testConstraint testfile       [llength [info commands testfile]]
 testConstraint testchmod      [llength [info commands testchmod]]
@@ -50,20 +52,25 @@ proc cleanup {args} {
     }
 }
 
+if {[testConstraint win]} {
+    set major [string index $tcl_platform(osVersion) 0]
+    if {$major > 5} {
+	testConstraint winVista 1
+    } elseif {$major == 5} {
+	testConstraint winXP 1
+    }
+}
+
 # find a CD-ROM so we can test read-only filesystems.
 
 proc findfile {dir} {
-    foreach p [glob -directory $dir *] {
-        if {[file type $p] == "file"} {
-	    return $p
-	}
+    foreach p [glob -nocomplain -type f -directory $dir *] {
+	return $p
     }
-    foreach p [glob -directory $dir *] {
-        if {[file type $p] == "directory"} {
-	    set f [findfile $p]
-	    if {$f != ""} {
-	        return $f
-	    }
+    foreach p [glob -nocomplain -type d -directory $dir *] {
+	set f [findfile $p]
+	if {$f ne ""} {
+	    return $f
 	}
     }
     return ""
@@ -71,7 +78,7 @@ proc findfile {dir} {
 
 if {[testConstraint testvolumetype]} {
     foreach p {d e f g h i j k l m n o p q r s t u v w x y z} {
-        if {![catch {testvolumetype ${p}:} result] && $result eq "CDFS"} {
+        if {![catch {testvolumetype ${p}:} result] && $result in {CDFS UDF}} {
             set cdrom ${p}:
 	    set cdfile [findfile $cdrom]
 	    testConstraint cdrom 1
@@ -893,11 +900,22 @@ test winFCmd-12.4 {ConvertFileNameFormat} {win} {
 test winFCmd-12.5 {ConvertFileNameFormat: absolute path} {win} {
     list [file attributes / -longname] [file attributes \\ -longname]
 } {/ /}
-test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} {win} {
+test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup {
     catch {file delete -force -- c:/td1}
-    close [open c:/td1 w]
-    list [catch {string tolower [file attributes c:/td1 -longname]} msg] $msg [file delete -force -- c:/td1]
-} {0 c:/td1 {}}
+} -constraints {win winXP} -body {
+    createfile c:/td1 {}
+    string tolower [file attributes c:/td1 -longname]
+} -cleanup {
+    file delete -force -- c:/td1
+} -result {c:/td1}
+test winFCmd-12.6.2 {ConvertFileNameFormat: absolute path with drive (in temp folder)} -setup {
+    catch {file delete -force -- $::env(TEMP)/td1}
+} -constraints {win} -body {
+    createfile $::env(TEMP)/td1 {}
+    string tolower [file attributes $::env(TEMP)/td1 -longname]
+} -cleanup {
+    file delete -force -- $::env(TEMP)/td1
+} -result [string tolower [file normalize $::env(TEMP)]/td1]
 test winFCmd-12.7 {ConvertFileNameFormat} {nonPortable win} {
     string tolower [file attributes //bisque/tcl/ws -longname]
 } {//bisque/tcl/ws}
diff --git a/tests/winPipe.test b/tests/winPipe.test
index 3f983e1..f993e0c 100644
--- a/tests/winPipe.test
+++ b/tests/winPipe.test
@@ -21,6 +21,7 @@ set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
 set cat32 [file join $bindir cat32.exe]
 
 testConstraint exec         [llength [info commands exec]]
+testConstraint testexcept   [llength [info commands testexcept]]
 testConstraint cat32        [file exists $cat32]
 testConstraint AllocConsole [catch {puts console1 ""}]
 testConstraint RealConsole  [expr {![testConstraint AllocConsole]}]
@@ -193,28 +194,28 @@ test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} {
     vwait x
     list $result $x [contents $path(stderr)]
 } "{$big} 1 stderr32"
-test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec} {
+test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} {
     set f [open "|[list [interpreter]]" w+]
     set pid [pid $f]
     puts $f "testexcept float_underflow"
     set status [catch {close $f}]
     list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
 } {1 1 SIGFPE}
-test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec} {
+test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept} {
     set f [open "|[list [interpreter]]" w+]
     set pid [pid $f]
     puts $f "testexcept access_violation"
     set status [catch {close $f}]
     list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
 } {1 1 SIGSEGV}
-test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec} {
+test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept} {
     set f [open "|[list [interpreter]]" w+]
     set pid [pid $f]
     puts $f "testexcept illegal_instruction"
     set status [catch {close $f}]
     list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
 } {1 1 SIGILL}
-test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec} {
+test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept} {
     set f [open "|[list [interpreter]]" w+]
     set pid [pid $f]
     puts $f "testexcept ctrl+c"
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index e671058..8fc0b8e 100755
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -1576,11 +1576,12 @@ NativeAccess(
 	return 0;
     }
 
-    if ((mode & W_OK)
-	&& (attr & FILE_ATTRIBUTE_READONLY)
-	&& !(attr & FILE_ATTRIBUTE_DIRECTORY)) {
+    /* 
+     * If it's not a directory (assume file), do several fast checks:
+     */
+    if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
 	/*
-	 * The attributes say the file is not writable.	 If the file is a
+	 * If the attributes say this is not writable at all.  The file is a
 	 * regular file (i.e., not a directory), then the file is not
 	 * writable, full stop.	 For directories, the read-only bit is
 	 * (mostly) ignored by Windows, so we can't ascertain anything about
@@ -1588,21 +1589,38 @@ NativeAccess(
 	 * advanced 'getFileSecurityProc', then more robust ACL checks
 	 * will be done below.
 	 */
+	if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
+	    Tcl_SetErrno(EACCES);
+	    return -1;
+	}
 
-	Tcl_SetErrno(EACCES);
-	return -1;
-    }
-
-    if (mode & X_OK) {
-	if (!(attr & FILE_ATTRIBUTE_DIRECTORY) && !NativeIsExec(nativePath)) {
-	    /*
-	     * It's not a directory and doesn't have the correct extension.
-	     * Therefore it can't be executable
-	     */
-
+	/* If doesn't have the correct extension, it can't be executable */
+	if ((mode & X_OK) && !NativeIsExec(nativePath)) {
 	    Tcl_SetErrno(EACCES);
 	    return -1;
 	}
+	/* Special case for read/write/executable check on file */
+	if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) {
+	    DWORD mask = 0;
+	    HANDLE hFile;
+	    if (mode & R_OK) { mask |= GENERIC_READ;  }
+	    if (mode & W_OK) { mask |= GENERIC_WRITE; }
+	    if (mode & X_OK) { mask |= GENERIC_EXECUTE; }
+
+	    hFile = (tclWinProcs->createFileProc)(nativePath, mask,
+		FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL,
+		OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
+	    if (hFile != INVALID_HANDLE_VALUE) {
+		CloseHandle(hFile);
+		return 0;
+	    }
+	    /* fast exit if access was denied */
+	    if (GetLastError() == ERROR_ACCESS_DENIED) {
+		Tcl_SetErrno(EACCES);
+		return -1;
+	    }
+	}
+	/* We cannnot verify the access fast, check it below using security info. */
     }
 
     /*
@@ -1811,9 +1829,12 @@ NativeIsExec(
 	 * Use wide-char case-insensitive comparison
 	 */
 
-	if ((_wcsicmp(path+len-3, L"exe") == 0)
-		|| (_wcsicmp(path+len-3, L"com") == 0)
-		|| (_wcsicmp(path+len-3, L"bat") == 0)) {
+	path += len-3;
+	if ((_wcsicmp(path, L"exe") == 0)
+		|| (_wcsicmp(path, L"com") == 0)
+		|| (_wcsicmp(path, L"cmd") == 0)
+		|| (_wcsicmp(path, L"ps1") == 0)
+		|| (_wcsicmp(path, L"bat") == 0)) {
 	    return 1;
 	}
     } else {