@@ 1,18 1,23 @@
#!/bin/tclsh
# handler types:
-# chan <chanid> <interp> // irc::listener
-# passes to a pipe to a sub-interpreter
+# chan <dispatch> <interp> // irc::listener
+# tchan <dispatch> <thread> // irc::listener -thread
+# passes to a pipe to a sub-interpreter/thread
# extern <ochanid> <ichanid> // irc::extern
# dispatches chan+raw IRC to generic IPC ochanid
# for non-tcl plugins
# ichanid is listened on for IRC commands to send over the socket
# script <script> // irc::handler
-# script is to be executed in a sub-interpreter with dispatch as locals
+# script is to be executed in global scope with dispatch set
# script <script> <interp> // irc::handler
-# script is to be executed inside interp with dispatch as locals
+# script is to be executed inside interp with dispatch set
+# tscript <script> <thread> // irc::handler -thread
+# script is to be executed inside thread with dispatch as locals
# handler: <patlist> <type> <id> <type args...>
+package require Thread
+
namespace eval ::irc {
variable chan.meta
variable chan.handlers
@@ 184,17 189,17 @@ namespace eval ::irc {
# nodoc
proc ::irc::int-setaliases {interp} {
- $interp alias irc::is
- $interp alias irc::msg
- $interp alias irc::listener
- $interp alias irc::extern
- $interp alias irc::handler
- $interp alias irc::esc
- $interp alias irc::unesc
- $interp alias irc::src
- $interp alias irc::tags
- $interp alias irc::patlist
- $interp alias irc::meta
+ $interp alias irc::is irc::is
+ $interp alias irc::msg irc::msg
+ $interp alias irc::listener irc::listener
+ $interp alias irc::extern irc::extern
+ $interp alias irc::handler irc::handler
+ $interp alias irc::esc irc::esc
+ $interp alias irc::unesc irc::unesc
+ $interp alias irc::src irc::src
+ $interp alias irc::tags irc::tags
+ $interp alias irc::patlist irc::patlist
+ $interp alias irc::meta irc::meta
}
# nodoc
@@ 249,6 254,11 @@ namespace eval ::irc {
puts $writer $dispatch
flush $writer
}
+ tchan {
+ lassign $rest writer thread
+ puts $writer $dispatch
+ flush $writer
+ }
extern {
lassign $rest ochan ichan
puts $ochan $chan
@@ 259,13 269,17 @@ namespace eval ::irc {
set interp [lassign $rest script]
if [llength $interp] {
set interp [lindex $interp 0]
+ {*}$interp eval [list set dispatch $dispatch]
+ {*}$interp eval $script
} else {
- set interp [interp create]
- irc::int-setaliases $interp
- interp share {} $chan $interp
+ uplevel #0 [list set dispatch $dispatch]
+ uplevel #0 $script
}
- {*}$interp eval [list set dispatch $dispatch]
- {*}$interp eval [list after idle $script]
+ }
+ tscript {
+ lassign $rest script thread
+ thread::send -async $thread [list set dispatch $dispatch]
+ thread::send -async $thread $script
}
}
}
@@ 274,25 288,48 @@ namespace eval ::irc {
}
}
+ # nodoc
+ proc ::irc::int-rminterp {interp} {
+ interp delete $interp
+ }
# documented
proc ::irc::listener {subcommand chan args} {
variable chan.handlers
switch -- $subcommand {
add {
- if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::listener add chan patlist script\"" }
+ set thread false
+ if {[lindex $args 0] == "-thread"} {
+ set thread true
+ set args [lrange $args 1 end]
+ }
+
+ if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::listener add chan ?-thread? patlist script\"" }
lassign $args patlist script
set id [format "%016x" [expr {round(rand() * (2**64))}]]
- set interp [interp create]
- irc::int-setaliases $interp
- interp share {} $chan $interp
+ if !$thread {
+ set interp [interp create]
+ irc::int-setaliases $interp
+ interp share {} $chan $interp
- lassign [chan pipe] reader writer
- interp transfer {} $reader $interp
- $interp eval [list set chan $reader]
- $interp eval [list after idle $script]
+ lassign [chan pipe] reader writer
+ interp transfer {} $reader $interp
+ $interp alias selfdestruct ::irc::int-rminterp $interp
+ $interp eval [list set dispatch $reader]
+ $interp eval [list after idle $script]
- lappend chan.handlers($chan) [list $patlist chan $id $writer $interp]
+ lappend chan.handlers($chan) [list $patlist chan $id $writer $interp]
+ } else {
+ set thread [thread::create -preserved]
+ lassign [chan pipe] reader writer
+
+ thread::transfer $thread $reader
+ thread::send -async $thread [list set dispatch $reader]
+ thread::send -async $thread [list set parent [thread::id]]
+ thread::send -async $thread $script
+
+ lappend chan.handlers($chan) [list $patlist tchan $id $writer $thread]
+ }
return $id
}
@@ 300,13 337,17 @@ namespace eval ::irc {
if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::listener remove chan id\"" }
lassign $args rmid
set newlist ""
- foreach handler [set chan.handlers($chan)]] {
- lassign $handler _ _ handlerid writer
- if {$handlerid != $rmid} {
+ foreach handler [set chan.handlers($chan)] {
+ lassign $handler _ type handlerid writer iot
+ if {$handlerid != $rmid || $type ni {chan tchan}} {
lappend newlist $handler
- } else {
+ } elseif {$type == "chan"} {
puts $writer end
flush $writer
+ } elseif {$type == "tchan"} {
+ puts $writer end
+ flush $writer
+ thread::release $iot
}
}
set chan.handlers($chan) $newlist
@@ 320,16 361,34 @@ namespace eval ::irc {
variable chan.handlers
switch -- $subcommand {
add {
- if {[llength $args] ni {2 3}} { return -code error "wrong # args: should be \"irc::handlers add chan patlist script ?interp?\"" }
- set interp [lassign $args patlist script]
+ set thread false
+ if {[lindex $args 0] == "-thread"} {
+ set thread true
+ set args [lrange $args 1 end]
+ }
+
+ if {[llength $args] ni {2 3}} { return -code error "wrong # args: should be \"irc::handlers add chan ?-thread? patlist script ?interp-or-thread?\"" }
+ set iot [lassign $args patlist script]
set id [format "%016x" [expr {round(rand() * (2**64))}]]
- if [llength $interp] {
- irc::int-setaliases {*}$interp
- interp share {} $chan {*}$interp
- }
+ if !$thread {
+ if [llength $iot] {
+ irc::int-setaliases {*}$iot
+ interp share {} $chan {*}$iot
+ }
+
+ lappend chan.handlers($chan) [list $patlist script $id $script {*}$iot]
+ } else {
+ if ![llength $iot] {
+ set iot [list [thread::create -preserved]]
+ } else {
+ thread::preserve {*}$iot
+ }
- lappend chan.handlers($chan) [list $patlist script $id $script {*}$interp]
+ thread::send -async $iot [list set parent [thread::id]]
+
+ lappend chan.handlers($chan) [list $patlist tscript $id $script {*}$iot]
+ }
return $id
}
@@ 338,11 397,13 @@ namespace eval ::irc {
lassign $args rmid
set newlist ""
foreach handler [set chan.handlers($chan)] {
- set interp [lassign $handler _ _ handlerid _]
- if {$handlerid != $rmid} {
+ set iot [lassign $handler _ type handlerid _]
+ if {$handlerid != $rmid || $type ni {script tscript}} {
lappend newlist $handler
- } elseif [llength $interp] {
- interp delete {*}$interp
+ } elseif {$type == "script" && [llength $iot]} {
+ interp delete {*}$iot
+ } elseif {$type == "tscript"} {
+ thread::release {*}$iot
}
}
set chan.handlers($chan) $newlist
@@ 376,9 437,9 @@ namespace eval ::irc {
remove {
if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::extern remove chan id\"" }
set newlist ""
- foreach handler [dict get chanmeta($chan) handlers] {
- lassign $handler _ _ handlerid ochan ichan
- if {$handlerid != $rmid} {
+ foreach handler [set chan.handlers($chan)] {
+ lassign $handler _ type handlerid ochan ichan
+ if {$handlerid != $rmid || $type != "extern"} {
lappend newlist $handler
} else {
puts $ochan $chan
@@ 697,17 758,42 @@ namespace eval ::irc {
}
}
-#set chan [irc::connect irc.libera.chat 6697 1]
-#puts $chan
-#irc::listen on $chan
-#lassign [chan pipe] ichan ochan
-#irc::extern add $chan * stdout stdin
+set chan [irc::connect localhost 9999 0]
+puts $chan
+irc::listen on $chan
+
+set ghandler [irc::handler add $chan {FOO GHAND} {puts "global handler called with dispatch [list $dispatch]"}]
+set ihandler [irc::handler add $chan {FOO IHAND} {puts "interp handler called with dispatch [list $dispatch]"} [interp create]]
+set thandler [irc::handler add $chan -thread {FOO THAND} {puts "threaded handler called with dispatch [list $dispatch]"}]
+puts "handlers created:"
+puts " global = $ghandler"
+puts " interp = $ihandler"
+puts " threaded = $thandler"
+
+set ilistener [irc::listener add $chan {FOO ILIST} {
+ puts "hello from interp listener with dispatch $dispatch"
+ fileevent $dispatch readable {
+ set line [gets $dispatch]
+ if {$line == "end"} {
+ puts "interp listener exiting!"
+ fileevent $dispatch readable {}
+ selfdestruct
+ }
+ puts "interp listener dispatch read [list $line]" }
+}]
+set tlistener [irc::listener add $chan -thread {FOO TLIST} {
+ puts "hello from threaded listener with dispatch $dispatch and parent $parent"
+ while {[set line [gets $dispatch]] != "end"} {
+ puts "thread listener dispatch read [list $line]"
+ }
+ puts "thread listener exiting!"
+ thread::release
+}]
-#fileevent stdin readable { set input [gets stdin] }
+puts "listeners created:"
+puts " interp = $ilistener"
+puts " threaded = $tlistener"
-#set input ""
+irc::handler add $chan EVAL { eval {*}[dict get $dispatch params] }
-#while 1 {
-# vwait input
-# eval $input
-#}
+vwait nil