Updated 2016-10-16 22:06:07 by Napier

Description  edit

Various implementation of a command that is used to periodically invoke a script or command

Barebones  edit

RS:
proc every {ms body} {
    if 1 $body
    after $ms [list after idle [info level 0]]
}

PYK 2012-12-04: Alternatively, use a command instead:
proc every {ms cmd} {
    {*}$cmd
    after $ms [list after idle [info level 0]]
}

... or, with a simple cancel option:
proc every {ms body} {
    global every
    if {$ms == "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 [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 [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?

See Also  edit

bgLoop  edit

## ******************************************************** 
##
## 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 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 [info level 0]]
    uplevel #0 $script
}

NEM 30 July 2006: 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 [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 [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 [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) \
                        [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 [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 [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 == "start" } {
        sendVal "send_status"
        set after_id [after $rate TimerFunction start $rate]
    } elseif { $state == "stop" } {
        after cancel $after_id
    }
 }

 TimerFunction start 2000
 TimerFunction stop

Just 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 [info level 0]]]
    } else {
        uplevel #0 $script
        set everyPriv($id) [concat $time [list $script] [after $interval [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 forever

XO 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}] [info level 0]  
}

rjmcmahon Here's a full blown version of every that covers most cases. Calls to it are:
every seconds ?script script ...?

    • returns an everyid
every integer -milliseconds ?script script ...?

    • returns an everyid
every cancel everyid
every cancel all
every info

    • returns all everyids
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) != "CANCELPENDING"} {
        set _everyids($id) [after $adj_interval [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.
every milliseconds ?script...?

  • returns an everyid
every pause everyid

  • pauses execution of everyid until resumed or cancelled/killed
every pause ?script...?

  • pauses the executions of ?script...? until resumed or cancelled/killed
every resume everyid

  • resumes execution of everyid
every resume ?script...?

  • resumes execution of ?script...?
every cancel everyid

  • cancels future execution of everyid
every cancel ?script...?

  • cancels all executions of ?script...?
every kill

  • cancels all executions immediately
every info

  • provides a list of all active everyid values

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 forever

PYK 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
  }
}