Various implementation of a command that is used to periodically invoke a script or command
RS:
proc every {ms body} {
puts $body
try $body
after $ms [list after idle [namespace code [info level 0]]]
}PYK 2012-12-04: Alternatively, use a command instead:
proc every {ms cmd} {
{*}$cmd
after $ms [list after idle [namespace code [info level 0]]]
}
every 1000 {puts hello}Because the name of the command might not be fully qualified, namespace code is used to ensure proper resolution.
... or, with a simple cancel option:
proc every {ms body} {
global every
if {$ms eq {cancel}} {after cancel $every($body); unset every($body); return}
set every($body) [info level 0]
eval $body
after $ms [info level 0]
}
and this is a tidied version of the digital clock that started this page:
pack [label .clock -textvar time]
every 1000 {set ::time [clock format [clock sec] -format %H:%M:%S]}I admit that the minimal every creates runaway timers that will tick on forever - almost: you can reset all timers with
foreach id [after info] {after cancel $id} To limit the number of repetitions, use return:
proc every {ms body} {
eval $body
after $ms [namespace code [info level 0]]
}
set nmax 3
every 1000 {puts hello; if {[incr ::nmax -1]<=0} return}RJM: In the case of a body/script that takes a considerable time fraction of the interval time, the following every is more precise, provided the script under repetitive execution will normally not execute longer than the interval duration:
proc every {ms body} {after $ms [namespace code [info level 0]]; eval $body}The after command is set up prior to the script call. One problem with this approach is that the body can not then "cancel" itself via return
FPX: Note that the latter may not be a good idea if the body (a) may in fact take longer to execute than the interval, and (b) invokes, at some point, the event loop. In that case, you might want to guard against reentrancy.
RJM: Shouldn't be a serious problem. It will only cause more stack access when any script executes longer than the after interval. It works pretty good for situations where the script has a big execution time standard deviation for each invocation.
AMG: Reëntrancy? The event loop runs in the same thread as the rest of the script, so the script can't "run on top of itself". It has return to the event loop before the event loop can start it again. Also, a long script/short timeout won't completely starve out other events, because the event loop will give them all their fair turn. A very long-running script will result in poor user interface response times, but it won't completely freeze the program unless the script loops indefinitely.
Ken: When i ran the code above, it seems it only runs when the event loop is idle. If the event loop is busy with a while procedure, it doesn't run. What is a better alternative?
Lars H: Yes, while one event is being processed, no additional events are fetched. This is as it is supposed to be. As for better alternatives... The hardliners would tell you to not use a while loop, but instead unroll it into the event loop as well. See Keep a GUI alive during a long calculation for more on the subject.
Ken: As currently i am trying to code a simulator of wireless sensor nodes running under the background, so what i have to do is create for example 10 nodes and run them all under the background under the event loop. Thus allowing my main tcl interpreter to be responsive or running to user requests. And how to get one node to run under an event loop is it to create a 'proc' and run a ' after' command on it?
## ********************************************************
##
## Name: bgLoop
##
## Description:
## Start (a)synchronous looping jobs. Jobs are ended by
## setting ::bg::jobs($name,run) to 0.
##
## Usage:
## start: bgLoop $name $code $delay
## stop: set ::bg::jobs($name,run) 0
##
## Comment:
## We started seeing mysterious delays in some very complex
## event code, and I modified the older version of bgLoop
## to provide some timing info... what I learned was that
## beyond a certain level of complexity it is better to know
## what is really going on, so SYNCHRONOUS looping is
## quite useful.
##
## What is very nice is that the event loop is not blocked
## for the entire runtime of the multiple scheduled code
## blocks, and the timing diagnostic lets you design around
## long running tasks by modifying the delays so they are
## of by so-many seconds...
##
## Note that the first iteration "returns" for sanity,
## and that you *should* use a custom bgerror handler
## if you are doing this from Tcl like I am (no Tk).
##
bgLoop { { name NULL } { code "" } { delay 2 } } {
if { ! [ llength [ namespace children :: bg ] ] } {
namespace eval bg {}
set ::bg::starttime [ clock seconds ]
}
set now [ clock seconds ]
set elapsed [ expr { $now - $::bg::starttime } ]
;## register a new job if it has valid args
if { ! [ string equal NULL $name ] && \
[ string length [ join $code ] ] } {
set ::bg::jobs($name,run) 1
set ::bg::jobs($name,code) $code
set ::bg::jobs($name,delay) $delay
puts stderr "Looping process $name started"
}
if { [ info exists ::bg::after ] && \
[ lsearch [ after info ] $::bg::after ] != -1 } {
after cancel $::bg::after
}
if { [ string equal NULL $name ] } {
set dt 0
foreach job [ array names ::bg::jobs *,run ] {
set job [ lindex [ split $job , ] 0 ]
if { [ string equal NULL $job ] } { continue }
if { [ string equal 0 $::bg::jobs($job,run) ] } {
foreach item [ array names ::bg::jobs $job,* ] {
unset ::bg::jobs($item)
}
puts stderr "Looping process $job terminated"
continue
}
if { ! ($elapsed % $::bg::jobs($job,delay)) } {
set ts [ clock clicks -milliseconds ]
eval $::bg::jobs($job,code)
set te [ clock clicks -milliseconds ]
set td [ expr $te - $ts ]
set dt [ expr $dt + $td ]
lappend data [ list $job $td ]
}
}
if { $dt > 1000 } {
puts stderr "bgLoop runtime per iteration: $dt ms ($data)"
}
set ::bg::after [after 1000 [namespace code bgLoop]]
} else {
set retval [ eval $::bg::jobs($name,code) ]
set ::bg::after [ after 1000 bgLoop ]
return $retval
}
}DKF: Here's a version of every that can be cancelled too:
proc every {interval script} {
global everyIds
if {$interval eq "cancel"} {
catch {after cancel $everyIds($script)}
return
}
set everyIds($script) [after $interval [namespace code [info level 0]]]
uplevel #0 $script
}NEM 2006-07-30: : And here's one that can be cancelled from within the script too (using break):
proc every {interval script} {
global everyIds
if {$interval eq {cancel}} {
after cancel $everyIds($script)
return
}
set everyIds($script) [after $interval [namespace code [info level 0]]]
set rc [catch {uplevel #0 $script} result]
if {$rc == [catch break]} {
after cancel $everyIds($script)
set rc 0
} elseif {$rc == [catch continue]} {
# Ignore - just consume the return code
set rc 0
}
# TODO: Need better handling of errorInfo etc...
return -code $rc $result
}Which allows the countdown example to be written as:
set nmax 3
every 1000 {
puts hello
if {[incr nmax -1] <= 0} { break }
}RS 2006-07-31: Hmm yes, but the simple every allows that too, if you just use return:
proc every {ms body} {eval $body; after $ms [namespace code [info level 0]]}
set ::nmax 3
every 1000 {puts hello; if {[incr ::nmax -1]<=0} return}I prefer not to use implicit global scope, for environment tidyness... :)
NEM: Well, implicit global scope is characteristic of other event callbacks, so it seems like the least surprising option. Likewise, having to use return to exit something that isn't a proc seems confusing. I prefer a simple interface to a simple implementation. (Also the simple version has the problem of time drift if you have a long-running script as discussed above).
26-may-2005
Jeffrey Hobbs supplies a comparable, but distinct, version of "every", in a post on comp.lang.tcl , 1999-08-19 .
# every --
# Cheap rescheduler
# every <time> cmd; # cmd is a one arg (cmd as list)
# schedules $cmd to be run every <time> 1000ths of a sec
# IOW, [every 1000 "puts hello"] prints hello every sec
# every cancel cmd
# cancels a cmd if it was specified
# every info ?pattern?
# returns info about commands in pairs of "time cmd time cmd ..."
#
proc every {time {cmd {}}} {
global EVERY
if {[regexp {^[0-9]+$} $time]} {
# A time was given, so schedule a command to run every $time msecs
if {[string compare {} $cmd]} {
set EVERY(TIME,$cmd) $time
set EVERY(CMD,$cmd) [after $time [
namespace code [list every eval $cmd]]]
} else {
return -code error "wrong \# args: should be \"[lindex [info level 0]
0] <number> command"
}
return
}
switch $time {
eval {
if {[info exists EVERY(TIME,$cmd)]} {
uplevel \#0 $cmd
set EVERY(CMD,$cmd) [after $EVERY(TIME,$cmd) [
namespace code [list every eval $cmd]]]
}
}
cancel {
if {[string match all $cmd]} {
foreach i [array names EVERY CMD,*] {
after cancel $EVERY($i)
unset EVERY($i) EVERY(TIME,[string range $i 4 end])
}
} elseif {[info exists EVERY(CMD,$cmd)]} {
after cancel $EVERY(CMD,$cmd)
unset EVERY(CMD,$cmd) EVERY(TIME,$cmd)
}
}
info {
set result {}
foreach i [array names EVERY TIME,$cmd*] {
set cmd [string range $i 5 end]
lappend result $EVERY($i) $cmd
}
return $result
}
default {
return -code error "bad option \"$time\": must be cancel, info or a
number"
}
}
return
}
DKF: Here's a scheduler that lets you schedule regular events and stop them whenever you like, using a similar scheme to [after]/[after cancel].
## ****************************************************************
## Name:
## every
## Description:
## Schedules a script for being regularly executed, returning
## a token that allows the scheduling to be halted at some
## future point.
## Usage:
## every ms script...
## every cancel token
## every cancel script...
## Notes:
## The script is executed at the global level, and any errors
## generated by the script will NOT cause a cessation of future
## schedulings. Thus, any script that always causes an error
## will cause many user-interface problems when used with a
## short delay.
## While differently scheduled scripts do not need to be
## distinct from each other, it is not determined which one
## will be cancelled if you use the cancelling form with the
## script as opposed to the token.
## Example:
## set foo [every 500 {puts [clock format [clock seconds]]}]
## every 10000 puts Howdy!
## # ...
## after cancel $foo
## after cancel puts Howdy!
## ****************************************************************
proc every {option args} {
global everyPriv every:UID
if {[string equal -length [string length $option] $option cancel]} {
set id {}
if {[llength $args] == 1 && [string match every#* [lindex $args 0]]} {
set id [lindex $args 0]
} else {
set script [eval [list concat] $args]
# Yuck, a linear search. A reverse hash would be faster...
foreach {key value} [array get everyPriv] {
if {[string equal $script [lindex $value 1]]} {
set id $key
break
}
}
}
if {[string length $id]} {
after cancel [lindex $everyPriv($id) 2]
unset everyPriv($id)
}
} else {
set id [format "every#%d" [incr every:UID]]
set script [eval [list concat] $args]
set delay $option
set aid [after $delay [namespace code [list every:afterHandler $id]]]
set everyPriv($id) [list $delay $script $aid]
return $id
}
}
## Internal stuff - I could do this with a namespace, I suppose...
array set everyPriv {}
set every:UID 0
proc every:afterHandler {id} {
global everyPriv
foreach {delay script oldaid} $everyPriv($id) {}
set aid [after $delay [namespace code [info level 0]]]
set everyPriv($id) [list $delay $script $aid]
uplevel #0 $script
}(I have this feeling that my definition of production-quality code is not the same as that of other people.)
Josua Dietze <digidietze at t-online.de> contributed this idea on news:comp.lang.tcl :
proc TimerFunction {state {rate {}}} {
global after_id
if { $state eq {start}} {
sendVal send_status
set after_id [after $rate [
namespace code [list TimerFunction start $rate]]
} elseif {$state eq {stop}} {
after cancel $after_id
}
}
TimerFunction start 2000
TimerFunction stopJust make sure you start and stop exactly once ...
kruzalex: An alternative to the stuff mentioned above:
proc every {interval args} {
global everyPriv every:UID
if {[string equal -length [string length $interval] $interval cancel]} {
set id {}
if {[llength $args] == 1 && [string match every#* [lindex $args 0]]} {
set id [lindex $args 0]
}
if {[string length $id]} {
after cancel [lindex $everyPriv($id) 2]
unset everyPriv($id)
return
}
}
set id [format "every#%d" [incr every:UID]]
set script [eval [list concat] $args]
foreach {key value} [array get everyPriv] {
if {[string equal $script [lindex $value 1]]} {
set id $key
set time [lindex $everyPriv($id) 0]
break
}
}
if {![info exists everyPriv($id)]} {
set everyPriv($id) [concat $interval [list $script] [
after $interval [namespace code [info level 0]]]]
} else {
uplevel #0 $script
set everyPriv($id) [concat $time [list $script] [
after $interval [namespace code [info level 0]]]]
}
return $id
}
array set everyPriv {}
set every:UID 0
#Example
set foo [every 1000 {puts foo}]
set foo1 [every 2000 {puts foo1}]
after 3000 [list every cancel $foo]
vwait foreverXO 2008-12-03: See also Recipe 68393: Repeat procedure every X seconds
proc every {ms body} {
set t [string range [time $body] 0 end-27]
after [expr {$ms-$t/1000}] [namespace code [info level 0]]
}rjmcmahon Here's a full blown version of every that covers most cases. Calls to it are:
proc every {args} {
global _everyids _everyid
if {![llength $args]} {
if {[info exists _everyids]} {
parray _everyids
}
return
}
set interval [lindex $args 0]
if {$interval == "info"} {
return [array names _everyids]
}
#
# See if arg1 is a -milliseconds option
#
set arg1 [lindex $args 1]
if {$arg1 == "-milliseconds"} {
set script [lrange $args 2 end]
} else {
#
# In this case a numeric arg1 is given in seconds
# so convert to an integer number of ms.
#
if {$interval != "cancel" && $interval != "idle"} {
set interval [expr {round($interval * 1000)}]
}
set script [lrange $args 1 end]
}
#
# Process any cancel requests.
# Options are
# o every cancel all
# o every cancel <everyid>
#
if {$interval eq "cancel"} {
if {![info exists _everyids]} {
return
}
if {$script eq "all"} {
set idlist [array names _everyids]
foreach id $idlist {
if {$_everyids($id) != "RUNNING"} {
after cancel $_everyids($id)
unset _everyids($id)
} else {
set _everyids($id) "CANCELPENDING"
}
}
} else {
set index $script
if {[info exists _everyids($index)]} {
# Cancel now if the script is not running
# otherwise signal the underlying _every not to reschedule
if {$_everyids($index) != "RUNNING"} {
after cancel $_everyids($index)
unset _everyids($index)
} else {
set _everyids($index) "CANCELPENDING"
}
}
}
return
}
if {[info exists _everyid]} {
incr _everyid
} else {
set _everyid 100
}
#
# Now that user command processing is done, call the
# underlying every routine to start the script on
# its periodic (per interval) and return a unique everyid.
#
_every $interval $script "every#$_everyid"
return "every#$_everyid"
}
proc _every {interval script id} {
global _everyids
#
# Run the script and measure the time taken to run
#
set starttime [clock clicks -milliseconds]
set _everyids($id) "RUNNING"
set rc [catch {uplevel #0 eval $script} result]
set finishtime [clock clicks -milliseconds]
#
# Detect and process any catch codes from the script
#
# Note: The script returning a break catch code is
# used to indicate a silent stop of the rescheduling
#
if {$rc == [catch error]} {
error "$result $script"
return
} elseif {$rc == [catch break]} {
if {[info exists _everyids($id)]} {
unset _everyids($id)
}
return
} elseif {$rc == [catch continue]} {
# Ignore - just consume the return code
set rc 0
}
#
# Adjust the reschedule time per the actual runtime
# Provide a minimum of 30 ms for a yield
#
if {$interval != "idle"} {
set runtime [expr {$finishtime - $starttime}]
set adj_interval [expr {$interval - $runtime}]
if {$adj_interval < 0} {
puts "$script runtime ($runtime ms) exceeded reschedule interval ($interval ms)"
}
#
# Set a minimum of 30 ms to reschedule
#
if {$adj_interval < 30} {
set adj_interval 30
}
} else {
set adj_interval "idle"
}
#
# Reschedule next iteration unless there is a cancel pending.
#
# Note: The rescheduling of the script is done after
# calling it. This can be swapped but is a bit more complex,
# particularly when execution time > interval.
#
if {$_everyids($id) ne {CANCELPENDING}} {
set _everyids($id) [after $adj_interval [namespace code [
list _every $interval $script $id]]]
} else {
unset _everyids($id)
}
}Napier 2015-12-23 How about a version that utilizes coroutines ? I believe this implements all the features of the above options for the most part in a fairly clean and clear manner. It also implements pause and resume capabilities for both scripts and everyid's where they resume as-if they were never paused.
EDIT (2016-10-16): A newer version has been added below.
Or if you prefer you may abbreviate however you'd like, every c $everyID, every p $everyID, every k
If you are wrapping a script, do so the same way you would handle similar scripts like after.
set foo World
every 1000 {puts "Hey There"}
every 1000 [list puts "Hello, $foo"]namespace eval Every {variable Cancel ""; variable Pause ""; variable Active ""}
proc every {option script} {
variable evID
if {[string is entier $option]} {
if {$script eq ""} {return}
#puts "Create Every $option $script"
set name [coroutine every#[incr evID] ::Every::Process $option $script]
dict lappend ::Every::Active $script $name; return $name
} else {
switch -nocase -glob -- $option {
c* {lappend ::Every::Cancel $script }
k* {lappend ::Every::Cancel {*}[dict values $::Every::Active]}
p* {lappend ::Every::Pause $script}
r* {set ::Every::Pause [ lsearch -all -inline -not -exact $::Every::Pause $script ]}
i* -
default {return [concat {*}[dict values $::Every::Active]]}
}
}
}
proc ::Every::Process {delay script} {
variable Cancel
variable Pause
try {
after $delay [info coroutine]
yield [info coroutine]
while {[info coroutine] ni $Cancel && $script ni $Cancel} {
if {[info coroutine] ni $Pause && $script ni $Pause} {
after 0 $script
}
after $delay [info coroutine]
yield [info coroutine]
}
variable Active
dict set Active $script [ lsearch -all -inline -not -exact [dict get $Active $script] [info coroutine] ]
set Cancel [ lsearch -all -inline -not -exact $Cancel [info coroutine] ]
set Pause [ lsearch -all -inline -not -exact $Pause [info coroutine ] ]
if {[dict get $Active $script] eq {}} {
dict unset Active $script
set Cancel [ lsearch -all -inline -not -exact $Cancel $script ]
set Pause [ lsearch -all -inline -not -exact $Pause $script ]
}
} on error {result options} {
puts "Error Occurs in Every: $result"
puts $options
}
}Also, as most similar calls, this will execute in the global namespace. As an extra nice function that has made things a lot easier, see the "callback" option below and example of its use in simplifying callback requirements
proc callback {args} {tailcall namespace code $args}
proc myProc args {puts "Executed in [namespace current]" }
every 1000 myProc
namespace eval foo {
proc myProc args {puts "Executed in [namespace current]" }
every 1000 [callback myProc]
}
vwait foreverPYK 2016-02-25: Changed after 0 {*}$script to after 0 $script. Also removed the note about after idle because after 0 is closely followed by after $delay, which is the point the after idle idiom would be useful: after $delay list after idle [info coroutine. See after for an explanation of the idiom.
Napier 2016-10-16: I have begun using a new version of this script which is a bit more streamlined and efficient. It loses the ability to use the scripts themselves in cancellation (you must use the returned ID) but overall should be much cleaner. Additionally it no longer executes the script in an after as that result can bring upon undesired results when a script uses after often and your overall interval is very short. This version utilizes the coroutine inject feature which allows us to inject commands into a coroutine that execute upon the next waking of the script. In the previous version there were a few memory leak possibilities as well, although small. For example, if you continually attempt to cancel a ID or script which is not looping it would continually build up the variables.
In addition, cancellation is now immediate whereas before it would not cancel until the next waking of the script.
namespace eval Every {variable Paused {}; variable Active {}}
proc every { option {script {}} } {
variable evID
set inject {}
set response 1
if {[string is entier -strict $option]} {
if {$script eq {}} {return}
set name [coroutine every#[incr evID] ::Every::Process $option $script]
return $name
} else {
switch -nocase -glob -- $option {
k* { foreach id $::Every::Active { every cancel $id } }
c* {
set inject {
after cancel $afterID
set Active [ lsearch -all -inline -not -exact $Active $name ]
return
}
}
p* {
set inject {
after cancel $afterID
lappend Paused $name
yield
}
}
r* { set inject { set Paused [ lsearch -all -inline -not -exact $Paused $name ] } }
i* - default {
if { [string equal -nocase -length 3 "pau" $script] } {
return $::Every::Paused
} else {
return $::Every::Active
}
}
}
}
if { $inject ne {} } {
try {
::tcl::unsupported::inject $script try $inject
$script
} on error {result} { set response 0 }
}
return $response
}
proc ::Every::Process {delay script} {
variable Paused; variable Active
set name [info coroutine]
lappend Active $name
after $delay $name
yield $name
while 1 {
try { uplevel #0 $script } on error {result options} {
# Handle Errors in Executing your Every Script Here if needed
}
set afterID [ after $delay $name ]
yield
}
}Napier 2017-03-18: So as our needs have gotten more and more complex in terms of scheduling and execution of commands at intervals or at various times, we needed a more flexible evolution of the every command. For a version of every which supports scheduled task execution, cancellation, management, and introspection you can use the package that is provided and documented at our GitHub Repository
Below are a few examples of the task command in use:
package require task
proc MyProc args {
puts "[clock milliseconds] | MyProc Executes | $args"
}
# Execute the task once, in 5 seconds with no arguments and an auto assigned id
set task_id [ task -in 5000 -command MyProc ]
# Trigger MyProc every 5 seconds. The tasks id is my_task
task -id my_task -every 5000 -command [list MyProc my_task]
# Scheduling a new task with the same id will replace the previous
task -id my_task -every 5000 -command [list MyProc my_task]
# Trigger MyProc every 5 seconds for 5 cycles
task -every 5000 -times 5 -command [list MyProc five_times]
# Trigger MyProc every 5 seconds for 60 seconds
task -every 5000 -for 60000 -command [list MyProc sixty_seconds]
# Trigger MyProc every 5 seconds until the given unix timestamp in ms.
task -every 5000 -until [expr { [clock milliseconds] + 60000 }] -command [list MyProc every_until_unix_ms]
# Trigger MyProc at the given unix timestamp in ms.
task -at [expr { [clock milliseconds] + 5000 }] -command [list MyProc at_unix_ms]
# Now lets add a command that we can use to test if we should continue execution
set i 0
proc RunWhile args {
variable i ; incr i
if { $args ne {} } {
lassign $args task_id
if { $task_id ne {} && $i > 30 } { return 0 }
} elseif { $i > 5 } { return 0 }
return 1
}
# Run the every command every 5 seconds for 5 overall calls of RunWhile
task -every 5000 -while RunWhile -command [list MyProc run_while_true]
# Run the every command every 5 seconds for 30 calls of RunWhile - feed our $task_id to -while and -command.
task -subst 1 -every 5000 -while {RunWhile $task_id} -command {MyProc $task_id}
# Cancel all scheduled tasks by using introspection capabilities
task -cancel [task -info ids]
# Use the subst feature to feed the command information about the current task
task -subst 1 -every 5000 -times 10 -command {MyProc $task_id $task}
The task command also has included modules to mimic the every command we provide above. This allows you to use it without modifying your previous code.
package require tasks::every
set every_id [every 5000 {puts hi}]
# sometime later
every cancel $every_id