From 1b5b8de8ca9da4dfe92841e2910a4bff6f4265a6 Mon Sep 17 00:00:00 2001
From: Aleteoryx <alyx@aleteoryx.me>
Date: Sat, 3 Aug 2024 19:16:19 +0100
Subject: [PATCH] listeners functional, irc.tcl mostly feature-complete

---
 irc.tcl | 168 ++++++++++++++++++++++++++++++++++++++++++++------------
 1 file changed, 134 insertions(+), 34 deletions(-)

diff --git a/irc.tcl b/irc.tcl
index b8772f7..4d4918f 100755
--- a/irc.tcl
+++ b/irc.tcl
@@ -95,7 +95,8 @@ namespace eval ::irc {
     }
   }
 
-  proc ::irc::connect {hostname port {usetls 1}} {
+  # documented
+  proc ::irc::connect {hostname port {usetls 0}} {
     variable chanmeta
     if $usetls {
       if {[info commands ::tls::socket] == ""} { package require tls }
@@ -110,15 +111,19 @@ namespace eval ::irc {
                                    proto    $proto \
                                    hostname $hostname \
                                    port     $port]
+
+    return $chan
   }
 
-  proc ::irc::enroll {chan {meta {}}}
+  # documented
+  proc ::irc::enroll {chan {meta {}}} {
     fconfigure $chan -translation crlf -blocking 0
     dict set meta chan $chan
     dict set meta handlers {}
     set chanmeta($chan) $meta
   }
 
+  # documented
   proc ::irc::listen {subcommand chan} {
     switch -- $subcommand {
       on {
@@ -134,16 +139,21 @@ 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
   }
 
+  # nodoc
   proc ::irc::int-onmsg {chan} {
     set msg [gets $chan]
     if {$msg == ""} { return }
@@ -151,7 +161,10 @@ namespace eval ::irc {
     variable chanmeta
 
     irc::msg parse $msg tags src cmd params
-    set srctype [irc::src parse $src srcparts]
+    set src ""
+    set srcparts ""
+    set srctype ""
+    if {$src != ""} { set srctype [irc::src parse $src srcparts] }
 
     set dispatch [dict create rawmsg $msg \
                               chan $chan \
@@ -161,9 +174,9 @@ namespace eval ::irc {
                               srcparts $srcparts \
                               cmd $cmd \
                               params $params \
-                              meta [dict remove [dict get chanmeta($chan)] handlers]]
+                              meta [dict remove $chanmeta($chan) handlers]]
 
-    foreach handler [dict get chanmeta($chan) handlers] {
+    foreach handler [dict get $chanmeta($chan) handlers] {
       set patlist [lindex $handler 0]
       set type [lindex $handler 1]
       set id [lindex $handler 2]
@@ -208,18 +221,19 @@ namespace eval ::irc {
             irc::int-setaliases $interp
             interp share {} $chan $interp
           }
-          $interp eval dict with $dispatch {}
-          $interp eval after 0 $script
+          $interp eval [list set dispatch $dispatch]
+          $interp eval [list after idle $script]
         }
       }
     }
   }
 
+  # documented
   proc ::irc::listener {subcommand chan args} {
     variable chanmeta
     switch -- $subcommand {
       add {
-        if {[llength args] != 2} { return -code error "wrong # args: should be \"irc::listener add chan patlist script\"" }
+        if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::listener add chan patlist script\"" }
         set patlist [lindex $args 0]
         set script [lindex $args 1]
         set id [format "%016x" [expr {round(rand() * (2**64))}]]
@@ -231,15 +245,15 @@ namespace eval ::irc {
         set pipe [chan pipe]
         set reader [lindex $pipe 0]
         interp transfer {} $reader $interp
-        $interp eval set chan $reader
-        $interp eval after 0 $script
+        $interp eval [list set chan $reader]
+        $interp eval [list after idle $script]
 
         dict lappend chanmeta($chan) handlers [list $patlist chan $id [lindex $pipe 1] $interp]
 
         return $id
       }
       remove {
-        if {[llength args] != 1} { return -code error "wrong # args: should be \"irc::listener remove chan id\"" }
+        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::listener remove chan id\"" }
         set newlist ""
         foreach handler [dict get chanmeta($chan) handlers] {
           if {[lindex $handler 2] != $args} {
@@ -251,33 +265,111 @@ namespace eval ::irc {
         }
         dict set chanmeta($chan) handlers $newlist
       }
-      patlist {
-        if {[llength $args] ni {1 2}} { return -code error "wrong # args: should be \"irc::listener patlist chan id ?patlist?\"" }
-        set id [lindex $args 0]
-
-        if {[llength $args] == 2}
-          set newlist ""
-          set patlist [lindex $args 1]
-          foreach handler [dict get chanmeta($chan) handlers] {
-            if {[lindex $handler 2] != $id} {
-              lset handler 0 $patlist
-            }
+      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
+    }
+  }
+
+  # documented
+  proc ::irc::handler {subcommand chan args} {
+    variable chanmeta
+    switch -- $subcommand {
+      add {
+        if {[llength $args] ni {2 3}} { return -code error "wrong # args: should be \"irc::handlers add chan patlist script ?interp?\"" }
+        set patlist [lindex $args 0]
+        set script [lindex $args 1]
+        set id [format "%016x" [expr {round(rand() * (2**64))}]]
+
+        set interp ""
+        if {[llength $args] == 3} {
+          set interp [lindex $args 2]
+          irc::int-setaliases $interp
+          interp share {} $chan $interp
+          set interp [list $interp]
+        }
+
+        dict lappend chanmeta($chan) handlers [concat [list $patlist script $id $script] $interp]
+
+        return $id
+      }
+      remove {
+        if {[llength args] != 1} { return -code error "wrong # args: should be \"irc::listener remove chan id\"" }
+        set newlist ""
+        foreach handler [dict get chanmeta($chan) handlers] {
+          if {[lindex $handler 2] != $args} {
             lappend newlist $handler
+          } else {
+            interp delete [lindex $handler 4]
           }
-          dict set chanmeta($chan) handlers $newlist
-          return $patlist
-        } else {
-          foreach handler [dict get chanmeta($chan) handlers] {
-            if {[lindex $handler 2] != $id} {
-              return [lindex $handler 0]
-            }
+        }
+        dict set chanmeta($chan) handlers $newlist
+      }
+      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
+    }
+  }
+
+  # nodoc
+  proc ::irc::int-onextern {ichan chan} {
+    set msg [gets $ichan]
+    if [$msg == ""] return
+    puts $chan $msg
+  }
+  # documented
+  proc ::irc::extern {subcommand chan args} {
+    variable chanmeta
+    switch -- $subcommand {
+      add {
+        if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::extern add chan patlist ochan ichan\"" }
+        set patlist [lindex $args 0]
+        set ochan [lindex $args 1]
+        set ichan [lindex $args 2]
+        set id [format "%016x" [expr {round(rand() * (2**64))}]]
+
+        dict lappend chanmeta($chan) handlers [list $patlist extern $id $ochan $ichan]
+
+        fileevent $chan readable [list ::irc::int-onextern $ichan $chan]
+
+        return $id
+      }
+      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] {
+          if {[lindex $handler 2] != $args} {
+            lappend newlist $handler
+          } else {
+            puts [lindex $handler 3] $chan
+            puts [lindex $handler 3] end
+            close [lindex $handler 4]
           }
         }
+        dict set chanmeta($chan) handlers $newlist
       }
-      default { return -code error "unknown subcommand \"$subcommand\": must be add, patlist, or remove" }
+      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
     }
   }
 
+  # documented
+  proc ::irc::patlist {chan id {patlist {}}} {
+    if {$patlist != ""} {
+      set newlist ""
+      foreach handler [dict get chanmeta($chan) handlers] {
+        if {[lindex $handler 2] != $id} {
+          lset handler 0 $patlist
+        }
+        lappend newlist $handler
+      }
+      dict set chanmeta($chan) handlers $newlist
+      return $patlist
+    } else {
+      foreach handler [dict get chanmeta($chan) handlers] {
+        if {[lindex $handler 2] != $id} {
+          return [lindex $handler 0]
+        }
+      }
+    }
+  }
+
+
   proc ::irc::src {subcommand args} {
     switch -- $subcommand {
       parse {
@@ -286,14 +378,14 @@ namespace eval ::irc {
         set partsVar ""
         if {[llength $args] == 1} { set partsVar [lindex $args 1] }
 
-        if [irc::is src::user] {
+        if [irc::is src::user $src] {
           if [string length $partsVar] {
             upvar $partsVar parts
             regexp {^([^!@]+)(?:!([^@]+))?(?:@(.+))?$} $src _ nick username host
             set parts [dict create nick $nick username $username host $host]
           }
           return user
-        } elseif [irc::is src::servername] {
+        } elseif [irc::is src::servername $src] {
           if [string length $partsVar] {
             upvar $partsVar parts
             set parts [dict create servername $src]
@@ -566,5 +658,13 @@ namespace eval ::irc {
   }
 }
 
-irc::msg parse [gets stdin] tags src cmd params
-puts "tags: \"$tags\"\nsrc: \"$src\"\nparams: \"$cmd\"\nparams: \"$params\""
+set chan [irc::connect localhost 8000 0]
+puts $chan
+irc::listen on $chan
+irc::handler add $chan FOO {
+  puts $rawmsg
+  puts $chan "FOO2 BAR2"
+  flush $chan
+}
+
+vwait foo
-- 
2.43.4