#
# stimer.tcl for All-Tools TCL
# created by CyBex at 02.05.2012 (05/02/2012)
# last modified for 1.0.0 by CyBex at 06.05.2012 (05/06/2012)
#
# based on: utimers killutimer utimer utimerexists
#
# CyBex     02May1999: created and basic skeleton
#
# Why do i/you need this script?
# This timer are more accurate if you have many blocking operation, like http access with timeouted or slow servers, very bad scripted procs and more.
#

# Configure:
set ::replaceutimer 0

# Commands: stimer stimers killstimer stimerexists
# Or if replace is on, the old utimer function are renamed to origutimer

#
# stimer <seconds> <tcl-command>
#
#Description: executes the given Tcl command after a certain number of seconds have passed
#Returns: a timerID
#
# Script: stimer.tcl
#
proc stimer {seconds command} {return [stimer::add $seconds $command]}

#
# stimers
#
#Returns: a list of active secondly timers. Each entry in the list contains the timestamp of time left till activation, the command that will be executed, and the timerID.
#
proc stimers {} {return ${stimer::stimers}}

#
# killstimer <timerID>
#
#Description: removes a secondly timer from the list
#Returns: nothing
#
proc killstimer {timerID} {stimer::del $timerID}

#
# stimerexists <tcl-command>
#
#Description: search for tcl-command in the stimers-list
#Returns: a timerID
#
# Script: based on Alltools.tcl
#
proc stimerexists {command} {
	foreach i [stimers] {
		if {![string compare $command [lindex $i 1]]} then {
			return [lindex $i 2]
		}
	}
	return
}

# init script, for saved variabled
namespace eval stimer {
	variable stimers
	if {![info exists stimers]} then {set stimers {}}
	variable timer
	if {![info exists timer]} then {set timer 0}
	proc loop {} {
		variable stimers
		if {[llength $stimers]>0} {
			foreach item $stimers {
				if {[clock seconds]>=[lindex $item 0]} {
					if {[lindex $item 1]=="[namespace current]::loop"} {
						#putcmdlog "myself stimer:'';"
						del [lindex $item 2]
					} else {

						#set ::stimerexec [lindex $item 1]
						#putcmdlog "exec:'[lindex $item 1]'"
						#utimer 1 $::stimerexec
						if {[info command origutimer]!="origutimer"} then {
							utimer 0 [lindex $item 1]
						} {
							origutimer 0 [lindex $item 1]
						}
						del [lindex $item 2]
						#putcmdlog "del $item"
						#if {[uplevel #0 {catch {eval $::stimerexec} ::stimermsg}]} {
						#  #putcmdlog "error stimer:'$::stimermsg';"
						#  error $::stimermsg $::errorInfo $::errorCode
						#} {
						#  #putcmdlog "executed stimer:'$::stimerexec' ($::stimermsg)"
						#  del [lindex $item 2]
						#  unset -nocomplain -- ::stimerexec
						#  unset -nocomplain -- ::stimermsg
						#}
					}
				} {
					#putcmdlog "ignore $item;"
				}
			}
			#putcmdlog "loop stimer:[llength $stimers]"
			if {[llength $stimers]>0} {
				set found 0
				foreach id [after info] {
					if {[lindex [after info $id] 0]=="[namespace current]::loop"} {
						set found 1; break
					}
				}
				if {!$found} {
					after 250 [namespace current]::loop
				}
			}
		} elseif {[llength $stimers]>0} {
			set stimers {}
		}
	}
	proc add {seconds command} {
		variable stimers
		variable timer
		incr timer
		#putcmdlog "add stimer:$command"
		set tid timer$timer
		set time [expr {[clock seconds]+$seconds}]
		set stimer [list $time $command $tid]
		set chktimer [list $time $command *]
		if {[lsearch -glob $stimers $chktimer]==-1} {
			#putcmdlog "append s:$stimer; [lsearch -glob $stimers $chktimer]==lsearch -glob '$stimers' '$chktimer'"
			lappend stimers $stimer
		} {
			putcmdlog "ignore s:$stimer"
		}
		if {[stimerexists [namespace current]::loop]==""} {
			#putcmdlog "create stimer loop ($stimers); r:$tid;"
			[namespace current]::loop
			#putcmdlog "done $stimers;"
		} {
			#putcmdlog "allready stimer loop exists ($stimers); r:$tid;"
		}
		return $tid
	}
	proc del {timerID} {
		variable stimers
		#putcmdlog "lsearch -glob $stimers '* $timerID'==[lsearch -glob $stimers "* $timerID"]"
		if {[set pos [lsearch -glob $stimers "* $timerID"]]>=0} {
			#putcmdlog "remove stimer:$pos:'[lindex $stimers $pos 1]':'[lindex $stimers $pos 2]';"
			set stimers [lreplace $stimers $pos $pos]
		}
	}
	if {[set [namespace parent]::replaceutimer]==1} then {
		if {[info command origutimer]!="origutimer"} then {
			#rename stimer stimers killstimer stimerexists
			namespace eval :: {
				#putcmdlog "rename orignal to save"
				rename utimer origutimer
				rename utimers origutimers
				rename killutimer killorigutimer
				if {[info command utimerexists]=="utimerexists"} then { ; # not everone has alltools.tcl loaded
					#putcmdlog "rename alltools to save"
					rename utimerexists origutimerexists
				}
				#putcmdlog "create interp from stimer procs"
				interp alias {} utimer {} stimer
				interp alias {} utimers {} stimers
				interp alias {} killutimer {} sillutimer
				interp alias {} utimerexists {} stimerexists
			}
		}
	} else {
		if {[info command origutimer]=="origutimer"} then {
			#rename origutimer origutimers killorigutimer origutimerexists
			namespace eval :: {
				#putcmdlog "delete stimer interps"
				interp alias {} utimer {}
				interp alias {} utimers {}
				interp alias {} killutimer {}
				interp alias {} utimerexists {}
				if {[info command origutimerexists]=="origutimerexists"} then { ; # not everone has alltools.tcl loaded
					#putcmdlog "rename alltools to orignal"
					rename origutimerexists utimerexists
				}
				#putcmdlog "rename save to orignal"
				rename origutimer utimer
				rename origutimers utimers
				rename killorigutimer killutimer
			}
		}
	}

}