From 614b00a3997b66b72233608df312afb7c1b0e0b4 Mon Sep 17 00:00:00 2001
From: Aleteoryx <alyx@aleteoryx.me>
Date: Thu, 15 Aug 2024 22:10:54 +0100
Subject: [PATCH] fill out handler types

add multithreading, make removals smarter, change semantics here and there
---
 irc.tcl | 202 ++++++++++++++++++++++++++++++++++++++++----------------
 1 file changed, 144 insertions(+), 58 deletions(-)
 mode change 100755 => 100644 irc.tcl

diff --git a/irc.tcl b/irc.tcl
old mode 100755
new mode 100644
index b7ebbf7..8c680dc
--- a/irc.tcl
+++ b/irc.tcl
@@ -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
-- 
2.45.2