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)
package require coroutine
package require dicttool
::namespace eval ::cron {}

proc ::cron::at args {
  switch [llength $args] {
    2 {
      variable processuid
      set process event#[incr processuid]

  }

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

proc ::cron::sleep_handle {ms} {
  set eventid [incr ::cron::eventcount]
  set var ::cron::event($eventid)
  set ${var} [expr {[clock milliseconds]+$ms}]
  return $var
}


proc ::cron::sleep ms {
  set coro [info coroutine]
  if {$coro eq {}} {
    set handle [sleep_handle $ms]
    ::cron::wake CRON_SLEEP
    while {[set $handle]>0} {
      vwait $handle
    }
    unset $handle
    return
  }
  variable all_coroutines
  variable coroutine_sleep
  if {$coro ni $all_coroutines} {
    coroutine_register {} $coro
  }
  if {![info exists coroutine_sleep($coro)]} {
    set coroutine_sleep($coro) [expr {[clock milliseconds]+$ms}]
    ::cron::wake COROUTINE_SLEEP
  }
  yield
  while {$coroutine_sleep($coro)>[clock milliseconds]} {
    yield
  }
  unset coroutine_sleep($coro)
}

proc ::cron::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 ::cron::do_events {} {
  # Process coroutines
  variable all_coroutines
  variable coroutine_object
  variable coroutine_busy
  variable coroutine_sleep
  variable last_event
  set last_event [clock seconds]
  set count 0
  set mnow [clock milliseconds]
  foreach coro $all_coroutines {
    if {[info exists coroutine_sleep($coro)]} {
      if {$coroutine_sleep($coro) > $mnow} continue
    }
    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 {}} {

        if {$scheduled < $nextevent} {
          set nexttask $process
          set nextevent $scheduled
        }
        set lastevent $now
      }
    }
    set mnow [clock milliseconds]
    foreach {coro msec} [array get ::cron::coroutine_sleep] {
      set scheduled [expr $msec/1000]
      if {$scheduled<$nextevent} {
        set nexttask $coro
        set nextevent $scheduled
      }
    }
    foreach {eventid msec} [array get ::cron::event] {
      if {$msec < 0} continue
      if {$msec < $mnow} {
        set ::cron::event($eventid) -1
      }
      set scheduled [expr $msec/1000]
      if {$scheduled<$nextevent} {
        set nexttask "SLEEP $eventid"
        set nextevent $scheduled
      }
    }  
    set delay [expr {$nextevent-$now}]
    if {$delay < 0} {
      yield 0
    } else {
      if {$delay > 120} {
        set delay [expr {$delay-($delay % 60) + 60}]
      }
      yield $delay      
    }
  }
}

proc ::cron::wake {{who ???}} {
  ##
  # Only triggered by cron jobs kicking off other cron jobs within
  # the script body
  ##
  after cancel $::cron::next_event
  if {[info coroutine] ne {}} {
    set ::cron::next_event [after idle {::cron::wake IDLE}]
    return
  }
  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 {}} {
    puts "BUSY..."

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

package require tcltest
testsNeedTcl     8.6
testsNeedTcltest 1.0

support {
    use dicttool/dicttool.tcl   dicttool
}
testing {
    useLocal cron.tcl cron
}
set ::cron::trace 0
# Sleep until the top of the second
::cron::sleep [expr {1000-[clock milliseconds]%1000}]

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

# Test at
set timerevent 0

} 2

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

::cron::sleep 2000

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::sleep 6000

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

proc my_coro {} {
  set ::my_coro_progress 0
  set ::my_coro_start [clock milliseconds]
  ::cron::sleep 1250
  set ::my_coro_end [clock milliseconds]
  set ::my_coro_progress 1
}
coroutine TESTCORO my_coro
::cron::coroutine_register {} TESTCORO
test cron-1.9 {cron::coroutine_register} {
  set ::my_coro_progress
} 0

::cron::sleep 2000

test cron-1.10 {cron::coroutine_register} {
  set ::my_coro_progress
} 1

puts "DELAY [expr {$::my_coro_end - $::my_coro_start}]"
test cron-1.11 {cron::coroutine_register} {
  expr {($::my_coro_end - $::my_coro_start) >= 1250}
} 1

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

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

if {![package vsatisfies [package provide Tcl] 8.5]} {return}
# Backward compadible alias
package ifneeded nameserv::cluster 0.2.5   {package require udpcluster ; package provide nameserv::cluster 0.2.5}
package ifneeded udpcluster 0.3.2  [list source [file join $dir udpcluster.tcl]]

      chan flush $s
      chan close $s
    }
  } error]} {
    set ::cluster::broadcast_sock {}
    if {$::cluster::config(debug)} {
      puts "Broadcast ERR: $error - Reopening Socket"
      ::cron::sleep 2000
    } else {
      # Double the delay
      ::cron::sleep 250
    }
  }
}

###
# topic: 963e24601d0dc61580c9727a74cdba67
###

    } else {
      set directory_sock {}
      set directory_pid {}
    }
  }
  return $broadcast_sock
}

proc ::cluster::sleep args {
  ::cron::sleep {*}$args
}

proc ::cluster::TCPAccept {sock host port} {
  chan configure $sock -translation {crlf crlf} -buffering line -blocking 1
  set packet [chan gets $sock]
  if {![string is ascii $packet]} return
  if {![::info complete $packet]} return
  if {[catch {Directory {*}$packet} reply errdat]} {

  }
  while 1 {
    if {$::cluster::ping_recv($rcpt)} break
    if {([clock seconds] - $starttime) > $timeout} {
      error "Could not locate $rcpt on the network"
    }
    broadcast PING $rcpt
    ::cron::sleep $::cluster::config(ping_sleep)
  }
  if {[::info exists ptpdata($rcpt)]} {
    return [dict getnull $ptpdata($rcpt) ipaddr]
  }
}

proc ::cluster::publish {url infodict} {

    return
  }
  if [catch {::comm::comm send -async $commid $command {*}$args} reply] {
    puts $stderr "ERR: SEND $service $reply"
  }
}















###
# topic: c8475e832c912e962f238c61580b669e
###
proc ::cluster::search pattern {
  _Winnow
  set result {}  
  variable ptpdata

  # See: RFC3692 and http://www.iana.org
  variable discovery_group 224.0.0.200
  variable local_port {}
  variable local_macid [lindex [::nettool::mac_list] 0]
  variable local_pid   [::uuid::uuid generate]
}

package provide udpcluster 0.3.2