Tcl Source Code

Command `file delete $target` fails with "permission denied" under Windows, if another worker checks the same target with file stat (Tcl_FSStat, resp. TclpObjStat) internally, for example by usage of `file mkdir $target`, etc.

I saw this annoying sporadic bug already several times, but thought it going to rude antivirus. Nope!

This is another continuation of latest "race conditions" (this time on the other end and windows only), going to missing flag FILE_SHARE_DELETE in NativeStat of tclWinFile.c in opposite to NativeAccess.

I've fixed it already (waiting for test-cases pass) and will merge it hereafter in all branches since 8.5.

As PoC, following script (requires RFE [4f322b9d21]) fill sporadically throw "permission denied" by `file delete` on windows. This script (was initially a race condition test-case) tries to create exactly 5 unique temp-folders (.../temp/tcl-test-tmp/0..4) with 5 workers and deletes it after short time. After my fix (adding FILE_SHARE_DELETE flag) it does not occur anymore.

set prms(path) [file join $::env(TEMP) tcl-test-tmp]
set prms(thcount) 5
set prms(repcount) 1000
set prms(main) [thread::id]

proc ::out {th s} {
  puts "$th $s"
}
## create workers and test-routines:
set i 0
time {
  set th($i) [thread::create [string map [list \$\$PRMS [list [array get prms]]] {
    proc out {s} {
      upvar prms prms
      thread::send -async $prms(main) [list out [thread::id] $s]
    }
    proc create-tmp {} {
      upvar prms prms
      set i 0
      while 1 {
        set path [file join $prms(path) $i]
        if {[file mkdir $path]} {
          return $path
        }
        if {[incr cntr] > 10000} { error "endless cycle" }
        if {[incr i] >= $prms(thcount)} {set i 0}
      }
    }
    proc do-test {} {
      array set prms $$PRMS
      if {[catch {
        ## repeat worker task:
        time {
          set path [create-tmp]
          out "++ [file tail $path]"
          file delete -force $path
          out "-- [file tail $path]"
        } $prms(repcount)
        ## done.
      } msg opt]} {
        out "failed with [dict get $opt -errorcode]: $msg"
      }
      thread::send -async $prms(main) {incr ::test_end}
      thread::release
    }
    thread::wait
  }]]
  incr i
} $prms(thcount)

## start in all workers:
set ::test_end 0
file delete -force $prms(path)
set i 0
time {
  thread::send -async $th($i) do-test
  incr i
} $prms(thcount)

## wait until all workers get ready and cleanup:
set ev [after 60000 [list set ::test_end $prms(thcount)]]
while {$::test_end < $prms(thcount)} {vwait ::test_end}
after cancel $ev
file delete -force $prms(path)

fixed in all branches now (since [4af9ff473e] for 8.5th), thus close.