Tcl Source Code

Artifact 7628ccafb73a713a0ec43e0d2c61872e82dd3717:

#repeatedly create & destroy threads to see if/when things die.
#
#Uses Cheap rescheduler code by Jeffery Hobbs  (every::)
#
#
package require Thread

namespace eval ::every {}

proc main args {
    global i
    set i 0

    #min timer granularity on windows is about 10ms anyway?
    every::schedule 10 "spawnthread"
    vwait forever
}
proc spawnthread {} {
    global i
    incr i

    #crashes at approx iteration 340 when scheduled at 10ms
    #other timers give varied and inconsistent results from run to run
    #e.g got up to around 3500 when scheduled at 1000ms
    thread::create "puts $i"
}
proc ::every::schedule {time cmd} {
    if {![string is integer -strict $time]} {
    return -code error "usage: [lindex [::info level 0] 0] time command"
    }
    # A time was given, so schedule a command to run every $time msecs
    variable ID
    if {[string compare {} $cmd]} {
    set ID($cmd) [list $time [after $time [list ::every::_do $cmd]]]
    }
}
proc ::every::_do {cmd} {
    variable ID
    if {[::info exists ID($cmd)]} {
    uplevel \#0 $cmd
    set time [lindex $ID($cmd) 0]
    set ID($cmd) [list $time [after $time [list ::every::_do $cmd]]]
    }
}
proc ::every::cancel {pattern} {
    variable ID
    foreach i [array names ID $pattern] {
    after cancel [lindex $ID($i) 1]
    unset ID($i)
    }
}
proc ::every::info {{pattern *}} {
    variable ID
    set result {}
    foreach i [array names ID $pattern] {
    lappend result [lindex $ID($i) 0] [lindex $ID($i) 1]
    }
    return $result
}
main