Version 30 of every

Updated 2010-01-31 22:50:29 by rjmcmahon

Credit RS with canonicalization of

    proc every {ms body} {eval $body; after $ms [info level 0]}

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 (RJM).

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.


Ken: When i ran the code above, it seems it only run when the main event is idle if the main event 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?


 # this every uses a repeats limit and a fixed 1ms inner interval (1 ms is a reliable base rate when small intervals
 #                      are required)
 set _count 0
 set _rep 0
 proc every {ms repeats body} {
    global _count _rep      ;# 'static' variables

    if {$_rep <= 0} {set _rep $repeats}
    if {!$_count} {set _count [expr {$ms ? $ms : 1}]}
    set id [after 1 [info level 0]]   ;# use 1 and count for ms ms
    if {[incr _count -1]} return
    # timed script execute
    if 1 $body
    if {![incr _rep -1]} {after cancel $id}
 }

Perhaps not very elegant compared to the initial version(s). The fixed 1 ms inner time interval shall be more precise in the range until about 20 ms (System, platform dependent - see top of after) - RJM.


RS 2005-05-27: Alternatively, one could put the counter into the script itself, and still use the one-liner every:

 proc every {ms body} {eval $body; after $ms [info level 0]}
 set nmax 3
 every 1000 {puts hello; if {[incr ::nmax -1]<=0} return}

The ability for body to prevent repetition with return is another reason for putting its evaluation in front :^)


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

See also Syncronized timer


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 {interval script} {
    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 [after info]
            foreach id $idlist {
                after cancel $id
            }
            unset _everyids
        } 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)
    }
}