Tcl Library Source Code

[comment {-*- tcl -*- doctools manpage}]
[vset PACKAGE_VERSION 2.0]
[manpage_begin cron n [vset PACKAGE_VERSION]]
[keywords {cron}]
[keywords {odie}]
[copyright {2016 Sean Woods <[email protected]>}]
[moddesc   {cron}]
[titledesc {Tool for automating the period callback of commands}]
[category  System]
[require Tcl 8.6]
[require cron [opt [vset PACKAGE_VERSION]]]
[description]
[para]

The [package cron] package provides a Pure-tcl set of tools to allow
programs to schedule tasks to occur at regular intervals. Rather than
force each task to issue it's own call to the event loop, the cron
system mimics the cron utility in Unix: on task periodically checks to
see if something is to be done, and issues all commands for a given
time step at once.
[para]
Changes in version 2.0
[para]
While cron was originally designed to handle time scales > 1 second, the
latest version's internal understand time granularity down to the millisecond,
making it easier to integrate with other timed events.

Version 2.0 also understands how to properly integrate coroutines and objects.
It also adds a facility for an external (or script driven) clock. Note that vwait style events
won't work very well with an external clock.

[section Commands]
[list_begin definitions]

[call [cmd ::cron::at] [arg ?processname?] [arg timecode] [arg command]]

This command registers a [arg command] to be called at the time specified by [arg timecode].

This command registers a [arg command] to be called after a delay of time specified by [arg timecode].
[arg timecode] is expressed as an seconds.
This task can be modified by subsequent calls to
this package's commands by referencing [arg processname]. If [arg processname] exists,
it will be replaced.

If [arg processname] is not given, one is generated and returned by the command.

[call [cmd ::cron::object_coroutine] [arg object] [arg coroutine] [arg ?info?]]

This command registers a [arg coroutine], associated with [arg object] to be called
given the parameters of [arg info]. If now parameters are given, the coroutine is assumed
to be an idle task which will self-terminate. [arg info] can be given in any form compadible with
[cmd {::cron::task set}]

[call [cmd ::cron::sleep] [arg milliseconds]]

When run within a coroutine, this command will register the coroutine for a callback
at the appointed time, and immediately yield.
[para]
If the ::cron::time variable is > 0 this command will advance the internal time,
100ms at a time.
[para]
In all other cases this command will generate a fictious variable, generate an
after call, and vwait the variable:
[example {
set eventid [incr ::cron::eventcount]
set var ::cron::event_#$eventid
set $var 0
::after $ms "set $var 1"
::vwait $var
::unset $var
}]
[para]
Usage:
[example_begin]
::cron::sleep 250
[example_end]

[call [cmd {::cron::task delete}] [arg process]]
Delete the process specified the [arg process]

[call [cmd {::cron::task exists}] [arg process]]
Returns true if [arg process] is registered with cron.

[call [cmd {::cron::task info}] [arg process]]
Returns a dict describing [arg process]. See [cmd {::cron::task set}] for a description of the options.

[call [cmd {::cron::task set}] [arg process] [arg field] [arg value] [arg ?field...?] [arg ?value...?]]
[para]
If [arg process] does not exist, it is created. Options Include:
[list_begin definitions]
[cmd command]
If [cmd coroutine] is black, a global command which implements this process. If [cmd coroutine] is not
black, the command to invoke to create or recreate the coroutine.
[cmd coroutine]
The name of the coroutine (if any) which implements this process.
[cmd frequency]
If -1, this process is terminated after the next event. If 0 this process should be called during every
idle event. If positive, this process should generate events periodically. The frequency is an interger number
of milleseconds between events.

[cmd object]
The object associated with this process or coroutine.
[cmd scheduled]
If non-zero, the absolute time from the epoch (in milleseconds) that this process will trigger an event.
If zero, and the [cmd frequency] is also zero, this process is called every idle loop.
[cmd running]
A boolean flag. If true it indicates the process never returned or yielded during the event loop,
and will not be called again until it does so.
[list_end]
[call [cmd ::cron::wake] [arg ?who?]]

Wake up cron, and arrange for its event loop to be run during the next Idle cycle.

[example_begin]
::cron::wake {I just did something important}
[example_end]
[list_end]
[para]
Several utility commands are provided that are used internally within cron and for
testing cron, but may or may not be useful in the general cases.
[list_begin definitions]

[call [cmd ::cron::clock_step] [arg milleseconds]]
[para]
Return a clock time absolute to the epoch which falls on the next
border between one second and the next for the value of [arg milleseconds]

[call [cmd ::cron::clock_delay] [arg milleseconds]]
[para]
Return a clock time absolute to the epoch which falls on the next
border between one second and the next [arg milleseconds] in the future.

[call [cmd ::cron::clock_sleep] [arg seconds] [arg ?offset?]]
[para]
Return a clock time absolute to the epoch which falls exactly [arg seconds] in
the future. If offset is given it may be positive or negative, and will shift
the final time to before or after the second would flip.

[call [cmd ::cron::clock_set] [arg newtime]]
[para]
Sets the internal clock for cron. This command will advance the time in 100ms
increment, triggering events, until the internal time catches up with [arg newtime].
[para]
[arg newtime] is expressed in absolute milleseconds since the beginning of the epoch.


[list_end]
[para]
[vset CATEGORY odie]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

###
# This file implements a process table
# Instead of having individual components try to maintain their own timers
# we centrally manage how often tasks should be kicked off here.
###
#
# Author: Sean Woods (for T&E Solutions)
package require coroutine
package require dicttool
::namespace eval ::cron {}

proc ::cron::task {command args} {
  if {$::cron::trace > 1} {
    puts [list ::cron::task $command $args]
  }
  variable processTable
  switch $command {
    TEMPLATE {
      return [list object {} lastevent 0 lastrun 0 err 0 result {} \
        running 0 coroutine {} scheduled 0 frequency 0 command {}]
    }
    delete {
      unset -nocomplain ::cron::processTable([lindex $args 0])
    }
    exists {
      return [::info exists ::cron::processTable([lindex $args 0])]
    }
    info {
      set process [lindex $args 0]
      if {![::info exists ::cron::processTable($process)]} {
        error "Process $process does not exist"
      }
      return $::cron::processTable($process)
    }
    create -
    set {
      set process [lindex $args 0]
      if {![::info exists ::cron::processTable($process)]} {
        set ::cron::processTable($process) [task TEMPLATE]
      }
      if {[llength $args]==2} {
        foreach {field value} [lindex $args 1] {
          dict set ::cron::processTable($process) $field $value
        }
      } else {
        foreach {field value} [lrange $args 1 end] {
          dict set ::cron::processTable($process) $field $value
        }
      }
    }
  }
}

proc ::cron::at args {
  if {$::cron::trace > 1} {
    puts [list ::cron::at $args]
  }
  switch [llength $args] {
    2 {
      variable processuid
      set process event#[incr processuid]
      lassign $args timecode command
    }
    3 {
      lassign $args process timecode command
    }
    default {
      error "Usage: ?process? timecode command"
    }
  }
  variable processTable
  if {[string is integer -strict $timecode]} {
    set scheduled [expr {$timecode*1000}]
  } else {
    set scheduled [expr {[clock scan $timecode]*1000}]
  }
  ::cron::task set $process \
    frequency -1 \
    command $command \
    scheduled $scheduled \
    coroutine {}
  
  if {$::cron::trace > 1} {
    puts [list ::cron::task info $process - > [::cron::task info $process]]
  }
  ::cron::wake NEW
  return $process
}

proc ::cron::idle args {
  if {$::cron::trace > 1} {
    puts [list ::cron::idle $args]
  }
  switch [llength $args] {
    2 {
      variable processuid
      set process event#[incr processuid]
      lassign $args command
    }
    3 {
      lassign $args process command
    }
    default {
      error "Usage: ?process? timecode command"
    }
  }
  ::cron::task set $process \
    scheduled 0 \
    frequency 0 \
    command $command
  ::cron::wake NEW
  return $process
}

proc ::cron::in args {
  if {$::cron::trace > 1} {
    puts [list ::cron::in $args]
  }
  switch [llength $args] {
    2 {
      variable processuid
      set process event#[incr processuid]
      lassign $args timecode command
    }
    3 {
      lassign $args process timecode command
    }
    default {
      error "Usage: ?process? timecode command"
    }
  }

  set now [clock_step [current_time]]
  set scheduled [expr {$timecode*1000+$now}]

  ::cron::task set $process \


    frequency -1 \
    command $command \

    scheduled $scheduled
  ::cron::wake NEW
  return $process
}

proc ::cron::cancel {process} {












































































  if {$::cron::trace > 1} {













    puts [list ::cron::cancel $process]














  }








  ::cron::task delete $process
















}

###
# topic: 0776dccd7e84530fa6412e507c02487c
###
proc ::cron::every {process frequency command} {
  if {$::cron::trace > 1} {
    puts [list ::cron::every $process $frequency $command]
  }
  variable processTable
  set mnow [clock_step [current_time]]
  set frequency [expr {$frequency*1000}]
  ::cron::task set $process \
    frequency $frequency \
    command $command \
    scheduled [expr {$mnow + $frequency}]
  ::cron::wake NEW
}


proc ::cron::object_coroutine {objname coroutine {info {}}} {
  if {$::cron::trace > 1} {
    puts [list ::cron::object_coroutine $objname $coroutine $info]
  }
  task set $coroutine \
    {*}$info \
    object $objname \
    coroutine $coroutine \

  ::cron::wake NEW
  return $coroutine
}

# Notification that an object has been destroyed, and that
# it should give up any toys associated with events
proc ::cron::object_destroy {objname} {
  if {$::cron::trace > 1} {
    puts [list ::cron::object_destroy $objname]
  }
  variable processTable
  set dat [array get processTable]
  foreach {process info} $dat {
    if {[dict exists $info object] && [dict get $info object] eq $objname} {
      unset -nocomplain processTable($process)
    }
  }
}

###
# topic: 97015814408714af539f35856f85bce6
###
proc ::cron::run process {
  variable processTable
  dict set processTable($process) lastrun 0
  ::cron::wake PROCESS
}

proc ::cron::clock_step timecode {
  return [expr {$timecode-($timecode%1000)}]
}

proc ::cron::clock_delay {delay} {
  set now [current_time]
  set then [clock_step [expr {$delay+$now}]]
  return [expr {$then-$now}]
}

# Sleep for X seconds, wake up at the top
proc ::cron::clock_sleep {{sec 1} {offset 0}} {
  set now [current_time]
  set delay [expr {[clock_delay [expr {$sec*1000}]]+$offset}]
  sleep $delay
}

proc ::cron::current_time {} {
  if {$::cron::time < 0} {
    return [clock milliseconds]
  }
  return $::cron::time
}

proc ::cron::clock_set newtime {
  variable time
  for {} {$time < $newtime} {incr time 100} {
    uplevel #0 {::cron::do_one_event CLOCK_ADVANCE}
  }
  set time $newtime
  uplevel #0 {::cron::do_one_event CLOCK_ADVANCE}
}

proc ::cron::sleep ms {
  if {$::cron::trace > 1} {
    puts [list ::cron::sleep $ms [info coroutine]]
  }
  
  set coro [info coroutine]
  variable time
  if {$time >= 0 && $coro eq {}} {
    ::cron::clock_set [expr {$time+$ms}]
    return
  }
  if {$coro ne {}} {
    set mnow [current_time]
    set start $mnow
    set end [expr {$start+$ms}]
    set eventid $coro
    if {$::cron::trace} {
      puts "::cron::sleep $ms $coro"
    }
    task set $eventid scheduled $end coroutine $coro
    ::cron::wake WAKE_IN_CORO
    yield
    while {$end >= $mnow} {
      if {$::cron::trace} {
        puts "::cron::sleep $ms $coro (loop)"
      }
      set mnow [current_time]
      yield
    }
    if {$::cron::trace} {
      puts "/::cron::sleep $ms $coro"
    }
  } else {  
    set eventid [incr ::cron::eventcount]
    set var ::cron::event_#$eventid
    set $var 0
    if {$::cron::trace} {
      puts "::cron::sleep $ms $eventid waiting for $var"
      ::after $ms "set $var 1 ; puts \"::cron::sleep - $eventid - FIRED\""
    } else {
      ::after $ms "set $var 1"
    }
    ::vwait $var
    if {$::cron::trace} {
      puts "/::cron::sleep $ms $eventid"
    }
    unset $var
  }
}

###
# topic: 21de7bb8db019f3a2fd5a6ae9b38fd55
# description:
#    Called once per second, and timed to ensure
#    we run in roughly realtime
###
proc ::cron::runTasksCoro {} {
  ###
  # Do this forever
  ###
  variable processTable
  variable processing
  variable all_coroutines
  variable coroutine_object
  variable coroutine_busy
  variable nextevent
  
  while 1 {
    set lastevent 0
    set now [current_time]
    # Wake me up in 5 minute intervals, just out of principle
    set nextevent [expr {$now-($now % 300000) + 300000}]
    set next_idle_event [expr {$now+250}]
    if {$::cron::trace > 1} {
      puts [list CRON TASK RUNNER nextevent $nextevent]
    }
    ###
    # Determine what tasks to run this timestep
    ###
    set tasks {}
    set cancellist {}
    set nexttask {}

    foreach {process} [lsort -dictionary [array names processTable]] {
      dict with processTable($process) {
        if {$::cron::trace > 1} {
          puts [list CRON TASK RUNNER process $process frequency: $frequency scheduled: $scheduled]
        }
        if {$scheduled==0 && $frequency==0} {
          set lastrun $now
          set lastevent $now
          lappend tasks $process
        } else {
          if { $scheduled <= $now } {
            lappend tasks $process
            if { $frequency < 0 } {
              lappend cancellist $process
            } elseif {$frequency==0} {
              set scheduled 0
              if {$::cron::trace > 1} {
                puts [list CRON TASK RUNNER process $process demoted to idle]
              }
            } else {
              set scheduled [clock_step [expr {$frequency+$lastrun}]]
              if { $scheduled <= $now } {
                set scheduled [clock_step [expr {$frequency+$now}]]
              }
              if {$::cron::trace > 1} {
                puts [list CRON TASK RUNNER process $process rescheduled to $scheduled]
              }
            }
            set lastrun $now
          }
          set lastevent $now
        }
      }
    }
    foreach task $tasks {
      dict set processTable($task) lastrun $now
      if {[dict exists processTable($task) running] && [dict set processTable($task) running]} {
        if {$::cron::trace} {
          puts "Process: $task is stuck"
        }
        continue
      }
      if {$::cron::trace > 2} {
        puts [list RUNNING $task [task info $task]]
      }
      dict set processTable($task) running 1
      set coro [dict get $processTable($task) coroutine]
      if {$coro ne {}} {
        if {[info command $coro] eq {}} {
          set command [dict get $processTable($task) command]
          set object [dict get $processTable($task) object]
          # Trigger coroutine again if a command was given
          # If this coroutine is associated with an object, ensure
          # the object still exists before invoking its method
          if {$command eq {} || ($object ne {} && [info command $object] eq {})} {
            lappend cancellist $task
            dict set processTable($task) running 0
            continue            
          }
          if {$::cron::trace} {
            puts [list RESTARTING $task - coroutine $coro - with $command]
          }
          ::coroutine $coro {*}$command
        }
        try $coro on return {} {
          # Terminate the coroutine
          lappend cancellist $task
        } on break {} {
          # Terminate the coroutine
          lappend cancellist $task
        } on error {errtxt errdat} {
          # Coroutine encountered an error
          lappend cancellist $task
          puts "ERROR $coro"
          set errorinfo [dict get $errdat -errorinfo]
          if {[info exists coroutine_object($coro)] && $coroutine_object($coro) ne {}} {
            catch {
            puts "OBJECT: $coroutine_object($coro)"
            puts "CLASS: [info object class $coroutine_object($coro)]"
            }
          }
          puts "$errtxt"
          puts ***
          puts $errorinfo
        } on continue {result opts} {
          # Ignore continue
          if { $result eq "done" } {
            lappend cancellist $task
          }
        } on ok {result opts} {
          if { $result eq "done" } {
            lappend cancellist $task
          }
        }
      } else {
        dict with processTable($task) {
          set err [catch {uplevel #0 $command} result errdat]
          if $err {
            puts "CRON TASK FAILURE:"
            puts "PROCESS: $task"
            puts $result
            puts ***
            puts [dict get $errdat -errorinfo]
          }
        }
        yield 0
      }
      dict set processTable($task) running 0
    }
    foreach {task} $cancellist {
      unset -nocomplain processTable($task)
    }




    foreach {process} [lsort -dictionary [array names processTable]] {
      dict with processTable($process) {
        if {$scheduled==0 && $frequency==0} {
          if {$next_idle_event < $nextevent} {
            set nexttask $task
            set nextevent $next_idle_event
          }
        } elseif {$scheduled < $nextevent} {
          set nexttask $process
          set nextevent $scheduled
        }
        set lastevent $now
      }
    }

    foreach {eventid msec} [array get ::cron::coro_sleep] {
      if {$msec < 0} continue




      if {$msec<$nextevent} {
        set nexttask "CORO $eventid"
        set nextevent $scheduled
      }
    }
    set delay [expr {$nextevent-$now}]
    if {$delay <= 0} {
      yield 0
    } else {
      if {$::cron::trace > 1} {
        puts "NEXT EVENT $delay - NEXT TASK $nexttask"
      }
      yield $delay      
    }
  }
}

proc ::cron::wake {{who ???}} {
  ##
  # Only triggered by cron jobs kicking off other cron jobs within
  # the script body
  ##
  if {$::cron::trace} {

    puts "::cron::wake $who"

  }
  if {$who eq "PANIC"} {
    # Cron is overdue and may be stuck
    set ::cron::busy 0
    set ::cron::panic_event {}
  }
  if {$::cron::busy && $::cron::panic_event eq {}} {
    if {$::cron::trace} {
      puts "CRON BUSY... RESCHEDULING PANIC"
    }
    after cancel $::cron::panic_event
    set ::cron::panic_event [after 120000 {::cron::wake PANIC}]
    return
  }
  after cancel $::cron::next_event
  set ::cron::next_event [after idle [list ::cron::do_one_event $who]]
}
  
proc ::cron::do_one_event {{who ???}} {
  if {$::cron::trace} {
    puts "::cron::do_one_event $who"
  }
  after cancel $::cron::next_event
  set now [current_time]
  set ::cron::busy 1

  after cancel $::cron::panic_event
  set ::cron::panic_event [after 120000 {::cron::wake PANIC}]
  while {$::cron::busy} {
    if {[info command ::cron::COROUTINE] eq {}} {
      ::coroutine ::cron::COROUTINE ::cron::runTasksCoro
    }
    set cron_delay [::cron::COROUTINE]

    if {$cron_delay==0} {
      if {[incr loops]>10} {
        if {$::cron::trace} {
          puts "Breaking out of 10 recursive loops"
        }
        set ::cron::wake_time 1000
        break
      }
      set ::cron::wake_time 0
      incr ::cron::loops(active)
    } else {
      set ::cron::busy 0
      incr ::cron::loops(idle)
    }
  }
  ###
  # Try to get the event to fire off on the border of the
  # nearest second
  ###
  if {$cron_delay < 10} {
    set cron_delay 250
  }
  set ctime [current_time]
  set next [expr {$ctime+$cron_delay}]
  set ::cron::wake_time [expr {$next/1000}]
  if {$::cron::trace} {
    puts [list EVENT LOOP WILL WAKE IN $cron_delay ms next: [clock format $::cron::wake_time -format "%H:%M:%S"] active: $::cron::loops(active) idle: $::cron::loops(idle) woken_by: $who]
  }
  set ::cron::next_event [after $cron_delay {::cron::do_one_event TIMER}]
}


proc ::cron::main {} {
  # Never launch from a coroutine
  if {[info coroutine] ne {}} {
    return
  }
  set ::cron::forever 1
  while {$::cron::forever} {
    ::after 120000 {set ::cron::forever 1}
    # Call an update just to give the rest of the event loop a chance
    incr ::cron::loops(main)
    ::after cancel $::cron::next_event
    set ::cron::next_event [::after idle {::cron::wake MAIN}]
    set ::cron::forever 1
    set ::cron::busy 0
    ::vwait ::cron::forever

namespace eval ::cron {
  variable lastcall 0
  variable processTable
  variable busy 0
  variable next_event {}
  variable trace 0
  variable event_loops
  variable time -1
  variable panic_event {}
  if {![info exists event_loops]} {
    set event_loops 0
  }
  if {![info exists ::cron::loops]} {
    array set ::cron::loops {
      active 0
      main 0
      idle 0
      wake 0
    }
  }




}

::cron::wake STARTUP
package provide cron 2.0

support {
    use dicttool/dicttool.tcl   dicttool
}
testing {
    useLocal cron.tcl cron
}

###
# For the first part of our testing, control the clock
# via the test harness
###
set ::cron::trace 0
set ::cron::time [expr {[clock scan {2016-01-01}]*1000}]

foreach {val testval} {
  1000 1000
  11235 11000
  1241241 1241000
} {
  test cron-step-$val [list test clock_step function for $val] {
    ::cron::clock_step $val
  } $testval 
}

proc test_elapsed_time {start target} {
  set now [::cron::current_time]
  set value [expr {$now-$start}]
  if {$value < ($target-5)} {
    puts "ELAPSED TIME WAS SHORT: $value / $target"
    return 1
  }
  if {$value > ($target+250)} {
    puts "ELAPSED TIME WAS LONG: $value / $target"
    return 1
  }
  return 0
}


set start [::cron::current_time]
::cron::sleep 250
test cron-sleep-1 {Ensure sleep is in a plausible range} {
  test_elapsed_time $start 250
} 0

# Sleep until the top of the second
::cron::clock_sleep 1
set start [::cron::current_time]
::cron::clock_sleep 0 750
test cron-sleep-2 {Ensure sleep is in a plausible range} {
  test_elapsed_time $start 750
} 0
::cron::clock_sleep 1 0
test cron-sleep-3 {Ensure sleep is in a plausible range} {
  test_elapsed_time $start 1000
} 0
::cron::clock_sleep 1 0

###
# Object interaction tests
###
oo::class create CronTest {

  method coro_name {} {
    return [info object namespace [self]]::idle
  }
  method idle {} {
    set coro [my coro_name]
    ::cron::object_coroutine [self] $coro
    ::coroutine $coro {*}[namespace code {my IdleTask}]
  }

}

###
# This test is a mockup of typical Tk widget
# which has some portion of its startup that has to
# process after an idle loop has completed
###
oo::class create CronTest_3Pings {
  superclass CronTest
  constructor {} {
    set ::TESTOBJ([self]) 0
    my idle
  }
  method IdleTask {} {
    incr ::TESTOBJ([self])
    yield
    incr ::TESTOBJ([self])
    yield
    incr ::TESTOBJ([self])
  }
}
CronTest_3Pings create FOO
set coro [FOO coro_name]
###
# The coroutine for the object exist on startup
test cron-objects-1-1 {cron::every} {
  info commands $coro
} $coro
# And CRON knows about it
test cron-objects-1-2 {cron::every} {
  ::cron::task exists $coro
} 1
# The counter should be initialized to the value
# before the first yield
test cron-objects-1-3 {cron::every} {
  set ::TESTOBJ(::FOO)
} 1
::cron::clock_sleep 1

###
# The couroutine should have completed, and now ceases to exist
###
test cron-objects-1-4 {cron::every} {
  ::cron::task exists $coro
} 0
# The counter should be 3
test cron-objects-1-5 {cron::every} {
  set ::TESTOBJ(::FOO)
} 3

###
# Test that cron cleans up after a destroyed object
###
CronTest_3Pings create FOOBAR
set coro [FOOBAR coro_name]
###
# The coroutine for the object exist on startup
test cron-objects-2-1 {cron::every} {
  info commands $coro
} $coro
# However CRON knows about it
test cron-objects-2-2 {cron::every} {
  ::cron::task exists $coro
} 1
FOOBAR destroy

# The idle routine did parse up to the first yield
test cron-objects-2-3 {cron::every} {
  set ::TESTOBJ(::FOOBAR)
} 1

###
# The coroutine for the object exist on startup
test cron-objects-2-4 {cron::every} {
  info commands $coro
} {}
# However CRON knows about it
test cron-objects-2-5 {cron::every} {
  ::cron::task exists $coro
} 1

# Trigger the idle loop
::cron::do_one_event TEST
# The idle routine did parse up to the first yield
test cron-objects-2-6 {cron::every} {
  set ::TESTOBJ(::FOOBAR)
} 1
# The coroutine is still gone
test cron-objects-2-7 {cron::every} {
  info commands $coro
} {}
# And now cron has forgotten about the object
test cron-objects-2-8 {cron::every} {
  ::cron::task exists $coro
} 0

::cron::do_one_event TEST
test cron-objects-2-9 {cron::every} {
  info commands $coro
} {}
# However cron has forgotten about the object
test cron-objects-2-10 {cron::every} {
  ::cron::task exists $coro
} 0


oo::class create CronTest_Persistant_Coro {
  superclass CronTest
  constructor {} {
    set nspace [info object namespace [self]]
    set coro_do [my coro_name DoLoop]
    set ::TESTOBJ([self]) -1
    set now [::cron::current_time]
    set frequency 1000
    set scheduled [::cron::clock_step [expr {$now+$frequency}]]
    ::cron::object_coroutine [self] $coro_do [list frequency $frequency scheduled $scheduled command [namespace code {my DoLoop}]]
  }
  method coro_name {which} {
    return [info object namespace [self]]::${which}
  }
  method exit_loop {} {
    my variable doloop
    set doloop 0
    if {$::cron::trace} {
      puts [list [self] SIGNAL TO EXIT]
    }
  }
  
  method DoLoop {} {
    if {$::cron::trace} {
      puts "[self] CORO START"
    }
    my variable doloop
    set doloop 1
    set ::TESTOBJ([self]) 0
    yield
    while {$doloop} {
      if {$::cron::trace} {
        puts [list [self] LOOP $doloop]
      }
      incr ::TESTOBJ([self])
      yield
    }
    if {$::cron::trace} {
      puts "[self] CORO EXIT"
    }
  }
}

###
# This series of tests is built around a more complex case:
# an object wants a method invoked periodically. CRON
# will create a coroutine (based on the name given by the object)
# and invoke that coroutine at the frequency requested
#
# If the coroutine exits (or throws an error) It will be restarted
###
set ::cron::trace 0
::cron::clock_sleep 1

CronTest_Persistant_Coro create IRONBAR
set coro [IRONBAR coro_name DoLoop]
test cron-objects-3-1 {
The actual coroutine should not exist yet
} {
  info commands $coro
} {}
# And CRON knows about it
test cron-objects-3-2 {
CRON should be aware of the task
} {
  ::cron::task exists $coro
} 1

test cron-objects-3-3 {
The counter should be initialized to the value
before the first yield
} {
  set ::TESTOBJ(::IRONBAR)
} -1

set start [::cron::current_time]
::cron::clock_sleep 1

test cron-objects-3-4 {The coroutine for the object exists} {
  info commands $coro
} $coro
test cron-objects-3-5 {Cron should know about the task} {
  ::cron::task exists $coro
} 1
test cron-objects-3-6 {The counter should have incremented} {
  set ::TESTOBJ(::IRONBAR)
} 1

::cron::clock_sleep 0 500
test cron-objects-3-7 {The counter should have incremented} {
  set ::TESTOBJ(::IRONBAR)
} 1
::cron::clock_sleep 1

# Test a graceful exit of the coroutine
::IRONBAR exit_loop
::cron::clock_sleep 1
set coro [IRONBAR coro_name DoLoop]
test cron-objects-3-8 {
The actual coroutine should now exit
} {
  info commands $coro
} {}
test cron-objects-3-9 {
CRON should still be aware of the tast
} {
  ::cron::task exists $coro
} 1
test cron-objects-3-10 {The counter hasn't reset} {
  set ::TESTOBJ(::IRONBAR)
} 2
::cron::clock_sleep 1
test cron-objects-3-11 {The should have reset when the coroutine restarted} {
  set ::TESTOBJ(::IRONBAR)
} 1
#::cron::object_destroy ::IRONBAR
::IRONBAR destroy

set ::cron::trace 0
proc my_coro {} {
  if {$::cron::trace} {
    puts "START MY CORO"
  }
  set ::my_coro_progress 0
  set ::my_coro_start [::cron::current_time]
  if {$::cron::trace} {
    puts "SLEEP MY CORO"
  }
  ::cron::sleep 1250
  if {$::cron::trace} {
    puts "/SLEEP MY CORO"
  }
  set ::my_coro_end [::cron::current_time]
  set ::my_coro_progress 1
  if {$::cron::trace} {
    puts "END MY CORO"
  }
}

###
# Test that an otherwise inprepared coroutine
# which invokes "::cron::sleep" partipates in
# the ::cron event system
###
if {$::cron::trace} {
  puts "PRE-MY CORO"
}
coroutine ::TESTCORO my_coro
if {$::cron::trace} {
  puts "POST-MY CORO"
}
test cron-naive-corotine-1 {cron::coroutine sleep} {
  set ::my_coro_progress
} 0
::cron::clock_sleep 3
set ::cron::trace 0

test cron-naive-corotine-2 {cron::coroutine sleep} {
  set ::my_coro_progress
} 1

test cron-naive-corotine-3 {cron::coroutine sleep} {
  set delay [expr {($::my_coro_end - $::my_coro_start)}]
  if {$delay < 1000 || $delay > 2000} {
    puts "TIME DELAY OUT OF RANGE: $delay"
    return 1
  } else {
    return 0
  }
  
} 0

###
# Tests after this point test interactions with the Tcl event loop
# We need to be slaved to the real time clock to work properly
###
set ::cron::trace 0
set ::cron::time -1

###
# Test the clock sleep offset feature
###
# Reset to the top of a clock step
::cron::clock_sleep 1

set ::cron::trace 0
set start [::cron::current_time]
set ::FLAG -1
set time_0 [::cron::clock_delay 1000]
set time_1 [::cron::clock_delay 2000]

after $time_0 {set ::FLAG 0}
after $time_1 {set ::FLAG 1}
test cron-delay-1 {Prior to the first event the value should not have changed} {
  set ::FLAG
} -1

vwait ::FLAG
test cron-delay-3 {At the top of the second, we should have a new value for flag} {
  set ::FLAG
} 0
vwait ::FLAG
test cron-delay-5 {At the top of the second second, we should have a new value for flag} {
  set ::FLAG
} 1
set ::cron::trace 0

proc elapsed_time_coro {} {
  set ::start [::cron::current_time]
  while 1 {
    set now [::cron::current_time]
    set ::elapsed_time [expr {($now-$::start)/1000}]
    yield
  }
}

::cron::task set ::ELAPSED_TIME \
  coroutine ::ELAPSED_TIME \
  command elapsed_time_coro \
  frequency 1000

set timecounter 0
::cron::every timecounter 1 {incr timecounter}
set now [clock seconds]

# Test at
set timerevent 0

  set ::timerevent
} 0
vwait eventpause
test cron-1.3 {cron::at1} {
  set ::timerevent
} 1


###
# At this point 6 seconds should have passed
###
#test cron-1.elapsed-1 {Elapsed time} {
#  set ::elapsed_time
#} 5
# - Test removed - Was too unstable on a busy computer

vwait pause
###
# At this point 11 seconds should have passed
###
#test cron-1.elapsed-2 {Elapsed time} {
#  set ::elapsed_time
#} 10
# - Test removed - Was too unstable on a busy computer

# Test that in X seconds our timer
# was incremented X times

#test cron-1.4 {cron::every} {
#  set ::timecounter

#} $::elapsed_time
#
# - Test removed - Was too unstable on a busy computer

test cron-1.5 {cron::at2} {
  set ::timerevent
} 2

###
# Confirm cancel works
::cron::cancel timecounter
set timecounterfinal $::timecounter

::cron::clock_sleep 2
test cron-1.6 {cron::cancel} {
  set ::timecounter
} $::timecounterfinal

###
# Test the new IN command
###
set ::inevent 0
cron::in 5 {set ::inevent 1}

test cron-1.7 {cron::in} {
  set ::inevent
} 0

::cron::clock_sleep 6

test cron-1.8 {cron::in} {
  set ::inevent
} 1













set FAILED 0

after 10000 {set ::cron::forever 0 ; set FAILED 1}









::cron::in 5 {
  set ::cron::forever 0
test cron-1.12 {cron::main} {
  set ::cron::forever
} 0
}
::cron::wake TEST

###
# At this point 22 seconds should have passed
###
#test cron-1.elapsed-3 {Elapsed time} {
#  set ::elapsed_time
#} 21
#
# Test removed - it was too unstable on a real working computer

::cron::main

# If we get to this test, mission successful
test cron-1.13 {cron::main} {
  return 1
} 1

test cron-1.14 {cron::main} {
  set FAILED
} 0

testsuiteCleanup
return

# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script.  It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

package ifneeded cron 2.0 [list source [file join $dir cron.tcl]]

package require Tcl 8.6 ;# try in pipeline.tcl. Possibly other things.
package require dicttool
package require TclOO
package require sha1
package require cron 2.0
package require oo::meta 0.5.1
package require oo::dialect

::oo::dialect::create ::tool
::namespace eval ::tool {}
set ::tool::trace 0
###

}

proc ::tool::object_create objname {
  foreach varname {
    object_info
    object_signal
    object_subscribe

  } {
    variable $varname
    set ${varname}($objname) {}
  }
  set object_info($objname) [list class [info object class $objname]]
}


proc ::tool::object_rename {object newname} {
  foreach varname {
    object_info
    object_signal
    object_subscribe

  } {
    variable $varname
    if {[info exists ${varname}($object)]} {
      set ${varname}($newname) [set ${varname}($object)]
      unset ${varname}($object)
    }
  }
  variable coroutine_object
  foreach {coro coro_objname} [array get coroutine_object] {
    if { $object eq $coro_objname } {
      set coroutine_object($coro) $newname
    }
  }
  rename $object ::[string trimleft $newname]
  ::tool::event::generate $object object_rename [list newname $newname]
}

proc ::tool::object_destroy objname {
  ::tool::event::generate $objname object_destroy [list objname $objname]
  ::tool::event::cancel $objname *
  ::cron::object_destroy $objname
  variable coroutine_object





  foreach varname {
    object_info
    object_signal
    object_subscribe

  } {
    variable $varname
    unset -nocomplain ${varname}($objname)
  }
}

#-------------------------------------------------------------------------