Tcl Library Source Code

###
# 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)


::namespace eval ::cron {}

proc ::cron::at args {
  switch [llength $args] {
    2 {
      variable processuid

  set info [list process $process frequency 0 command $command scheduled $scheduled lastevent $now]
  if ![info exists processTable($process)] {
    lappend info lastrun 0 err 0 result {}
  }
  foreach {field value} $info {
    dict set processTable($process) $field $value
  }
  ::cron::wake
  return $process
}

proc ::cron::in args {
  switch [llength $args] {
    2 {
      variable processuid

  set info [list process $process frequency 0 command $command scheduled $scheduled lastevent $now]
  if ![info exists processTable($process)] {
    lappend info lastrun 0 err 0 result {}
  }
  foreach {field value} $info {
    dict set processTable($process) $field $value
  }
  ::cron::wake
  return $process
}


































































































###
# topic: 0776dccd7e84530fa6412e507c02487c
###
proc ::cron::every {process frequency command} {
  variable processTable
  set now [clock seconds]
  set info [list process $process frequency $frequency command $command scheduled [expr {$now + $frequency}] lastevent $now]
  if ![info exists processTable($process)] {
    lappend info lastrun 0 err 0 result {}
  }
  foreach {field value} $info {
    dict set processTable($process) $field $value
  }
  ::cron::wake
}

proc ::cron::cancel {process} {
  variable processTable
  unset -nocomplain processTable($process)
}

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

proc ::cron::doOneEvent task {
  variable lock 1
  variable processTable
  set now [clock seconds]
  dict with processTable($task) {
    set err [catch {uplevel #0 $command} result]
    if $err {
      puts $result
    }
  }
  set lock 0
}

###
# topic: 1f8d4726623321acc311734c1dadcd8e
# description:
#    Run through our process table and
#    kick off overdue tasks
###
proc ::cron::runProcesses {{coro 0}} {
  variable processTable
  set now [clock seconds]
  ###
  # Determine what tasks to run this timestep
  ###
  set tasks {}
  set cancellist {}
  foreach {process} [lsort -dictionary [array names processTable]] {
    dict with processTable($process) {
      if { $scheduled <= $now } {
        lappend tasks $process
        if { $frequency <= 0 } {
          lappend cancellist $process
        } else {
          set scheduled [expr {$frequency + $lastrun}]
          if { $scheduled <= $now } {
            set scheduled [expr {$frequency + $now}]
          }
        }
        set lastrun $now
      }
      set lastevent $now
    }
  }
  foreach task $tasks {
    dict set processTable($task) lastrun $now
    doOneEvent $task
    if {$coro} {
      yield 0
    }
  }
  foreach {task} $cancellist {
    unset -nocomplain processTable($task)
  }
}

###
# topic: 2f5a33d28948c4514764bd2f58b750fc
# description:
#    Called once per second, and timed to ensure
#    we run in roughly realtime
###
proc ::cron::runTasks {} {
  variable lastcall
  after cancel $lastcall
  ###
  # Run the processes before we kick off another task...
  ###
  catch {runProcesses}
  variable processTable
  ###
  # Look at our schedule and book the next timeslot
  # or 15 minutes, whichever is sooner
  ###
  set now [clock seconds]
  set nexttime [expr {$now - ($now % 900) + 900}]
  foreach {process} [array names processTable] {
    dict with processTable($process) {
      if {$scheduled > $now && $scheduled < $nexttime} {
        set nexttime $scheduled
      }
    }
  }
  ###
  # Try to get the event to fire off on the border of the
  # nearest second
  ###
  if { $nexttime > $now } {
    set ctime [clock milliseconds]
    set next [expr {($nexttime-$now)*1000-1000+($ctime % 1000)}]
  } else {
    set next 0
  }
  set lastcall [after $next [namespace current]::runTasks]
}


###
# topic: 21de7bb8db019f3a2fd5a6ae9b38fd55
# description:
#    Called once per second, and timed to ensure
#    we run in roughly realtime
###
proc ::cron::runTasksCoro {} {
  variable lastcall
  after cancel $lastcall
  ###
  # Do this forever
  ###
  variable processTable
  variable processing
  while 1 {
    set lastevent 0









    runProcesses 1



























    # Wake me up in 5 minute intervals, just out of principle
    set now [clock seconds]
    set nextevent [expr {$now-($now % 300) + 300}]
    set nexttask {}
    foreach {process} [lsort -dictionary [array names processTable]] {
      dict with processTable($process) {
        if {$scheduled < $nextevent} {
          set nexttask $process
          set nextevent $scheduled

        set delay [expr {$delay-($delay % 60) + 60}]
      }
      yield $delay      
    }
  }
}



proc ::cron::wake {} {
  variable lock
  ##
  # Only triggered by cron jobs kicking off other cron jobs within
  # the script body
  ##










  if {$lock} return


  ::cron::runTasks

















































}

###
# topic: 4a891d0caabc6e25fbec9514ea8104dd
# description:
#    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.
###
namespace eval ::cron {
  variable lastcall 0
  variable processTable
  variable lock 0






}














::cron::wake
package provide cron 1.2.1

# Tests for the cron module
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2014 by Sean Woods
# (Insert BSDish style "use at your own risk" license text)

source [file join \
    [file dirname [file dirname [file join [pwd] [info script]]]] \
    devtools testutilities.tcl]

package require tcltest
testsNeedTcl     8.5
testsNeedTcltest 1.0

testing {
    useLocal cron.tcl cron
}

set timecounter 0

after 6000 {set pause 0}
vwait pause
test cron-1.8 {cron::in} {
  set ::inevent
} 1













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 1.2.1 [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 oo::meta 0.5.1
package require oo::dialect

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

set ::tool::tool_root [file dirname $cwd]
::tool::pathload $cwd {
  uuid.tcl
  ensemble.tcl
  metaclass.tcl
  event.tcl
} $idxfile
package provide tool 0.5.5

::namespace eval ::tool::signal {}
package require coroutine

proc ::tool::coroutine_register {objname coroutine} {
  variable all_coroutines
  variable object_coroutines
  variable coroutine_object
  # Wake a sleeping main loop
  set ::tool::wake_up 0
  set ::tool::rouser ::tool::coroutine_register
  if {$coroutine in $all_coroutines} {
    return 1
  }

  lappend all_coroutines $coroutine
  lappend object_coroutines($objname) $coroutine
  set coroutine_object($coroutine) $objname
  return 0
}

proc ::tool::coroutine_unregister {coroutine} {
  variable all_coroutines
  variable object_coroutines
  variable coroutine_object
  ldelete all_coroutines $coroutine
  if {[info exists coroutine_object($coroutine)]} {
    set objname $coroutine_object($coroutine)
    ldelete object_coroutines($objname) $coroutine
    unset coroutine_object($coroutine)
  }
}


proc ::tool::do_events {} {
  # Process coroutines
  variable all_coroutines
  variable coroutine_object
  variable coroutine_busy
  variable last_event
  set last_event [clock seconds]
  set count 0
  foreach coro $all_coroutines {
    if {![info exists coroutine_busy($coro)]} {
      set coroutine_busy($coro) 0
    }
    # Prevent a stuck coroutine from logjamming the entire event loop
    if {$coroutine_busy($coro)} continue
    set coroutine_busy($coro) 1
    if {[info command $coro] eq {}} {
      #puts "$coro quit"
      coroutine_unregister $coro
      continue
    }
    set deleted 0
    #puts [list RUN $coro]
    try $coro on return {} {
      # Terminate the coroutine
      coroutine_unregister $coro
    } on break {} {
      # Terminate the coroutine
      coroutine_unregister $coro
    } on error {errtxt errdat} {
      # Coroutine encountered an error
      coroutine_unregister $coro
      puts "ERROR $coro"
      set errorinfo $::errorInfo
      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" } {
        incr count
        coroutine_unregister $coro
        set deleted 1

      }
    } on ok {result opts} {
      if { $result eq "done" } {
        coroutine_unregister $coro
        set deleted 1
      } else {
        incr count
      }
    }
    if {$deleted} {
      unset -nocomplain coroutine_busy($coro)
    } else {
      set coroutine_busy($coro) 0
    }
  }
  return $count
}

proc ::tool::Main_Service {} {
  if {[info command ::CRON] eq {}} {
    coroutine ::CRON ::cron::runTasksCoro
  }
  set now [clock seconds]
  set cron_delay [::CRON]
  set ::tool::busy 1
  set tool_running [::tool::do_events]
  set ::tool::busy 0
  if {$cron_delay==0 || $tool_running>0} {
    set ::tool::wake_up 0
    set ::tool::rouser {Main_Service active}
    incr ::tool::loops(active)
  } else {
    set ::tool::rouser [list Main_Service idle $cron_delay]
    set ::tool::wake_up [expr {$cron_delay+$now}]
    incr ::tool::loops(idle)
  }
}


proc ::tool::main {} {
  set ::tool::rouser STARTUP
  package require cron 1.2
  variable event_loops
  variable last_event
  variable trace
  if {[info exists ::tool::main($event_loops)]} {
    if {$::tool::main($event_loops)} {
      set last_event -1
      set ::tool::wake_up 0
      set ::tool::rouser RESTART_EVENT_LOOP
      update
      if {$last_event>0} {
        return
      }
    }
  }
  ###
  # Have the cron::wake procedure wake up an idle loop instead
  # of it's normal run commands in the background
  ###
  proc ::cron::wake {} {
    set ::tool::wake_up 0
  set ::tool::rouser ::cron::wake

  }
  # Signal for all other MAIN loops to terminate
  for {set x 0} {$x < $event_loops} {incr x} {
    set ::tool::main($x) 0
  }
  set ::tool::wake_up 0
  update
  set this [incr event_loops]
  set ::tool::main($this) 1
  set ::tool::wake_up 0
  set ::tool::busy 0
  while {$::tool::main($this)} {
    # Call an update just to give the rest of the event loop a chance
    update
    incr ::tool::loops(all)
    if {$::tool::busy==0} {
      # Kick off a new round of event processing 
      # only if the current round
      # has completed
      set panic [after 120000 {puts "Warning: Tool event loop has not responded in 2 minutes" ; set ::tool::rouser PANIC ; set ::tool::busy 0}]
      after idle ::tool::Main_Service
      update
    }
    if {$::tool::wake_up > 0} {
      set delay [expr {(${::tool::wake_up}-[clock seconds])*1000}]
      if {$trace} {
        puts [list EVENT LOOP WILL WAKE IN [expr {$delay/1000}]s active: $::tool::loops(active) idle: $::tool::loops(idle) busy: $::tool::busy rouser: $::tool::rouser]
      }
      set next [after $delay {set ::tool::wake_up 0}]
      set ::tool::rouser IDLELOOP
      set ::tool::wake_up 0
      vwait ::tool::wake_up
      after cancel $next
    }
    if {${::tool::busy} == 0} {
      after cancel $panic
    }
  }
}

namespace eval ::tool {
  variable trace 0
  variable event_loops
  if {![info exists event_loops]} {
    set event_loops 0
  }
  if {![info exists ::tool::loops]} {
    array set ::tool::loops {
      active 0
      all 0
      idle 0
    }
  }
  variable all_coroutines
  if {![info exists all_coroutines]} {
    set all_coroutines {}
  }
}

package provide tool::pipeline 0.1

# 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.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}
package ifneeded tool 0.5.5 [list source [file join $dir index.tcl]]