#! /bin/env tclsh
package require {ycl string expand}
namespace import [yclprefix]::string::expand
package require {ycl shelf shelf}
[yclprefix] shelf shelf .spawn [namespace current]
proc after_ {_ args} {
namespace upvar $_ beginning beginning delayed delayed queues queues
switch [lindex $args 0] {
cancel {
$_ cancel $args
}
idle {
if {[llength $args] > 1} {
set script [join $args]
} else {
set script [lindex $args 0]
}
return [$_ push idle default $script]
}
info {
$_ info [lindex $args 0]
}
}
if {[llength $args] == 1} {
set delay [lindex $args 0]
set script {}
return [$_ push_delayed $delay $script]
} elseif {[llength $args] > 1} {
set args [lassign $args[set args {}] delay]
if {[llength $args] > 1} {
set script [lindex $args 0]
} else {
set script [join $args]
}
if {$delay == 0} {
return [$_ push default $script]
} else {
return [$_ push_delayed $delay $script]
}
} else {
error [list {wrong # args}]
}
return $id
}
[namespace current] .method after after_
proc cancel {_ args} {
namespace upvar $_ canceled canceled delayed delayed idlequeues idlequeues queues queues
foreach arg $args {
dict set canceled $arg {}
# Can't just delete an event here because this routine may have been
# called in a script evaluated by [loop] , which has taken a copy of
# the queues . Instead, keep a list of canceled events .
#set found [$_ find {*}$args]
#if {[llength $found] == 4} {
# lassign $found qtype qname queue idx
# dict set $qtype $qname [lreplace $queue[set queue {}] $idx $idx]
#} elseif {[llength $found] == 2} {
# set idx [lindex $found 1]
# set delayed [lreplace $delayed[set delayed {}] $idx $idx]
#} else {
# error [list {internal error}]
#}
}
return
}
[namespace current] .method cancel
proc push {_ args} {
if {[llength $args] == 3} {
lassign $args[set args {}] qtype name script
set qtype [dict get {normal queues idle idlequeues}]
}
if {[llength $args] == 2} {
set qtype queues
lassign $args name script
} elseif {[llength $args] == 1} {
set qtype queues
set name default
lassign $args script
} elseif {[llength $args] > 0} {
error [list {wrong # args} [llength 4args]]
}
namespace upvar $_ count count idlequeues idlequeues queues queues
set id [incr count]
dict update $qtype $name queue {
lappend queue [list $id $script]
}
return $id
}
[namespace current] .method push
proc push_delayed {_ delay script} {
namespace upvar $_ count count delayed delayed
set id [incr count]
set adjusted [expr {[clock milliseconds] + $delay}]
if {$adjusted >= [lindex [lindex delayed end] 0]} {
set idx [llength $delayed]
lappend delayed [list $adjusted $id $script]
} else {
set idx [expr {[lsearch -exact -bisect -index 1 $delayed $adjusted]} + 1]
set delayed [linsert $delayed[set delayed {}] $idx [
list $id $script $adjusted]]
}
return $id
}
[namespace current] .method push_delayed
variable doc::find {
description {
Find event on the queue by id, or, if not found by id, by script.
}
value {
A list of {queue queue_name id indices} for each found event , or if
the queue name is delayed, {queue queue_name id index} .
}
}
if 1 [expand run data {
proc find {_ args} [string map [list @quesearch@ {
foreach qtype [list queues idlequeues] {
dict for {qname queue} [set $qtype] {
set found [lsearch -exact -index 0 $queue $id]
if {$found >= 0} {
return [list $qtype $qname $queue $found]
}
}
}
}] {
namespace upvar $_ delayed delayed idlequeues idlequeues queues queues
set id [lindex $args 0]
set found [lsearch -exact -index 0 $delayed $id]
if {$found >= 0} {
return [list delayed $found]
}
@quesearch@
# Now search for a script
if {[llength $args] > 1} {
set id [join $args]
} else {
set id [lindex $args 0]
}
set found [lsearch -exact -index 1 $delayed $script]
if {$found >= 0} {
return [list delayed $found]
}
@quesearch@
return
}]
[namespace current] .method find
}]
proc info_ {_ args} {
namespace upvar $_ delayed delayed idlequeues idlequeues queues queues
if {![llength $args]} {
return [dict create normal $queues idle $idlequeues delayed $delayed]
}
set id [lindex $args 0]
set found [$_ find $id]
if {[llength $found]} {
} elseif {[llength $found] == 2} {
} else {
return
}
}
[namespace current] .method info info_
proc init {_ args} {
$_ $ active {}
$_ $ beginning [clock milliseconds]
$_ $ delayed_script {}
$_ $ delayed {}
$_ $ callers {}
$_ $ canceled {}
$_ $ count 0
# For better performance, make sure the builtin queues are first
dict set queues default {}
$_ $ queues $queues
$_ $ time [clock milliseconds]
dict set idlequeues default {}
$_ $ idlequeues $idlequeues
coroutine ${_}::loop $_ loop_coro
}
[namespace current] .method init
proc loop_coro _ [expand run data {
namespace upvar $_ active active callers callers canceled canceled \
delayed delayed idlequeues idlequeues queues queues time time
set args {}
#set args [yieldto return -level 0]
while 1 {
set serviced 0
# Scheduled scripts could modify the queue, to pluck off all the ripe
# appointments before evaluating any of them .
set ready {}
while {[llength $delayed]} {
set now [clock milliseconds]
lassign [lindex $delayed 0] id script adjusted
if {$now >= $adjusted} {
set delayed [lreplace $delayed[set delayed {}] 0 0]
lappend ready $id $script
} else {
break
}
}
foreach {id script} $ready {
[$ service {
# even if an event was canceled, it still counts for the
# purposes of determining whether the queues are empty
incr serviced
if {[dict exists $canceled $id]} {
dict unset canceled $id
} else {
namespace eval :: $script
}
} $]
}
# In this iteration , only process appointments already on the queue,
# not anthing queued up by the scripts being evaluated
set ready $queues
set queues {}
while 1 {
set empty 1
#service one event from each queue
dict for {name queue} $ready {
if {[llength $active] && $name ni $active} continue
if {![llength $queue]} continue
dict update ready $name queue {
set queue [lassign $queue[set queue {}] event]
lassign $event id script
}
set empty 0
[$ service $]
}
if {$empty} break
}
if {!$serviced} {
# service one event from each idle queue
# event loop is empty, wait for someone else to restart it
dict for {name queue} $idlequeues {
if {[llength $active] && $name ni $active} continue
if {![llength $queue]} continue
set queue [lassign $queue[set queue {}] event]
dict set idlequeues $name $queue
lassign $event id script
[$ service $]
}
}
lassign [lindex $callers end] callercoro callercmd
if {$callercmd eq {}} {
if {!$serviced} {
if {[llength $delayed]} {
# Assume the event loop is running
after [expr {$adjusted - $now}] [list after idle [
list $_ resume [info coroutine]]]
yield
continue
} else {
set callers [lreplace $callers[
set callers {}] end end]
after 100 [list after idle [list [info coroutine]]]
if {[namespace which $callercoro] eq {}} {
yield
} else {
yieldto $callercoro
}
}
}
} else {
try {
namespace eval :: $callercmd
} on continue {} {
continue
}
set callers [lreplace $callers[
set callers {}] end end]
if {[namespace which $callercoro] eq {}} {
yield
} else {
yieldto $callercoro
}
}
}
}]
[namespace current] .method loop_coro
[namespace current] .method loop
proc quit _ {
rename ${_}::loop {}
coroutine ${_}::loop $_ loop_coro
set quit 1
}
[namespace current] .method quit
proc resume {_ loopid} {
if {[namespace which $loopid] ne {}} {
tailcall $loopid
}
}
[namespace current] .method resume
proc service {_ args} {
namespace upvar $_ callers callers active active
set args [dict merge {queues {} cmd {}} $args[set args {}]]
dict update args cmd cmd queues queues {}
lappend callers [list [info coroutine] $cmd]
yieldto $_ loop
}
[namespace current] .method service
[namespace current] init