From 7fdaa9361e04b0445c322ca41537ede6fc8bda72 Mon Sep 17 00:00:00 2001
From: Aleteoryx <alyx@aleteoryx.me>
Date: Wed, 1 Jan 2025 18:00:06 -0500
Subject: [PATCH] subcommand system

---
 src/conn.tcl        |   3 +
 src/db/networks.tcl |  18 +++
 src/deps.tcl        |   1 +
 src/irc.tcl         | 358 +++++++++++++++++++++-----------------------
 src/ui.tcl          |  31 +++-
 src/util.tcl        |  74 +++++++++
 6 files changed, 292 insertions(+), 193 deletions(-)
 create mode 100644 src/conn.tcl

diff --git a/src/conn.tcl b/src/conn.tcl
new file mode 100644
index 0000000..cc01872
--- /dev/null
+++ b/src/conn.tcl
@@ -0,0 +1,3 @@
+source src/deps.tcl
+source src/util.tcl
+source src/irc.tcl
diff --git a/src/db/networks.tcl b/src/db/networks.tcl
index 7e59856..ede8eb7 100644
--- a/src/db/networks.tcl
+++ b/src/db/networks.tcl
@@ -15,3 +15,21 @@ proc db::networks::ls {db} {
 proc db::networks::add {db name servers} {
   $db eval {INSERT INTO networks VALUES ($name $servers);}
 }
+
+proc db::networks::exists {db name} {
+  $db exists {SELECT * FROM networks WHERE name = :name}
+}
+
+sproc db::networks::creds {
+  add {db network name type args} {
+    if ![exists $db $network] { return -code error "Unknown network \"$network\" in \"$db\"." }
+  }
+  ls {db network} {
+    if ![exists $db $network] { return -code error "Unknown network \"$network\" in \"$db\"." }
+    
+  }
+  remove {db network name} {
+    if ![exists $db $network] { return -code error "Unknown network \"$network\" in \"$db\"." }
+    
+  }
+}
diff --git a/src/deps.tcl b/src/deps.tcl
index f36c0ff..1d0bd93 100644
--- a/src/deps.tcl
+++ b/src/deps.tcl
@@ -1,6 +1,7 @@
 set deps {
   Tcl 8.6
   Tk 8.6
+  Thread 2.8
   sqlite3 3.37
   tls 1.7
   logger 0.9
diff --git a/src/irc.tcl b/src/irc.tcl
index e73f7ed..0c7690d 100644
--- a/src/irc.tcl
+++ b/src/irc.tcl
@@ -46,7 +46,7 @@ namespace eval ::irc {
   # [para]
   # [sectref {Channel metadata}] is initialized with [arg proto], [arg hostname], [arg port], and [arg uri] set.
   proc connect {hostname port {usetls 0}} {
-    if $usetls {
+    if {$usetls} {
       if {[info commands ::tls::socket] == ""} { package require tls }
       set chan [::tls::socket $hostname $port]
       set proto ircs
@@ -76,7 +76,7 @@ namespace eval ::irc {
     variable chan.meta
     variable chan.handlers
     variable chan.interceptors
-    fconfigure $chan -translation crlf -blocking 0a
+    fconfigure $chan -translation crlf -blocking 0
     set chan.meta($chan) $meta
     set chan.handlers($chan) {}
     set chan.interceptors($chan) {}
@@ -93,26 +93,24 @@ namespace eval ::irc {
   # Enable or disable the [cmd fileevent] script for the dispatch system.
   #
   # [list_begin definitions]
-  proc listen {subcommand chan} {
-    switch -- $subcommand {
-      on {
-        #***
-        # [call [cmd irc::listen] [const on] [arg chan]]
-        # Apply the [cmd fileevent] wrapper to [arg chan].
-        # Returns the previous [cmd fileevent] wrapper.
-        fileevent $chan readable [list ::irc::int-onmsg $chan]
-      }
-      off {
-        #***
-        # [call [cmd irc::listen] [const off] [arg chan]]
-        # Remove the [cmd fileevent] wrapper from [arg chan].
-        # Errors if the channel does not currently have the irc handler set.
-        set oldfe [fileevent $chan readable]
-        if {[fileevent $chan readable] != [list ::irc::int-onmsg $chan]} {
-          return -code error "channel \"$chan\" not listening for irc"
-        } else { fileevent $chan readable "" }
-      }
-      default { return -code error "unknown subcommand \"$subcommand\": must be off or on" }
+  sproc listen {
+    _prefix {chan} {}
+    on {} {
+      #***
+      # [call [cmd irc::listen] [const on] [arg chan]]
+      # Apply the [cmd fileevent] wrapper to [arg chan].
+      # Returns the previous [cmd fileevent] wrapper.
+      fileevent $chan readable [list ::irc::int-onmsg $chan]
+    }
+    off {} {
+      #***
+      # [call [cmd irc::listen] [const off] [arg chan]]
+      # Remove the [cmd fileevent] wrapper from [arg chan].
+      # Errors if the channel does not currently have the irc handler set.
+      set oldfe [fileevent $chan readable]
+      if {[fileevent $chan readable] != [list ::irc::int-onmsg $chan]} {
+        return -code error "channel \"$chan\" not listening for irc"
+      } else { fileevent $chan readable "" }
     }
   }
   #***
@@ -135,77 +133,74 @@ namespace eval ::irc {
   # Threads may simply [cmd thread::release] themselves, while interps may call the provided [cmd selfdestruct].
   #
   # [list_begin definitions]
-  proc listener {subcommand chan args} {
-    variable chan.handlers
-    switch -- $subcommand {
-      add {
-        #***
-        # [call [cmd irc::listener] [const add] [arg chan] [opt [option -thread]] [arg patlist] [arg script]]
-        # Registers [arg script] as a [cmd listener]-type handler on [arg chan], using [arg patlist] as the [sectref {Message Pattern List}].
-        # Returns an id that can be passed to [cmd irc::listener] [const remove] or [cmd irc::patlist].
-        # [para]
-        # If [option -thread] is passed, it will be created as a threaded listener, otherwise it will be created in a sub-interpreter.
-        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))}]]
-
-        if !$thread {
-          set interp [interp create]
-          irc::int-setaliases $interp
-          interp share {} $chan $interp
-
-          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]
-        } 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
-      }
-      remove {
-        #***
-        # [call [cmd irc::listener] [const remove] [arg chan] [arg id]]
-        # Unregisters the listener identified by [arg id] from [arg chan].
-        # [para]
-        # Ignores requests for nonexistent handlers or handlers of the wrong type.
-        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 _ type handlerid writer iot
-          if {$handlerid != $rmid || $type ni {chan tchan}} {
-            lappend newlist $handler
-          } elseif {$type == "chan"} {
-            puts $writer end
-            flush $writer
-          } elseif {$type == "tchan"} {
-            puts $writer end
-            flush $writer
-            thread::release $iot
-          }
-        }
-        set chan.handlers($chan) $newlist
-      }
-      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
+  sproc listener {
+    _prefix {chan} {
+      variable chan.handlers
+    }
+    add {args} {
+      #***
+      # [call [cmd irc::listener] [const add] [arg chan] [opt [option -thread]] [arg patlist] [arg script]]
+      # Registers [arg script] as a [cmd listener]-type handler on [arg chan], using [arg patlist] as the [sectref {Message Pattern List}].
+      # Returns an id that can be passed to [cmd irc::listener] [const remove] or [cmd irc::patlist].
+      # [para]
+      # If [option -thread] is passed, it will be created as a threaded listener, otherwise it will be created in a sub-interpreter.
+      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))}]]
+
+      if !$thread {
+        set interp [interp create]
+        irc::int-setaliases $interp
+        interp share {} $chan $interp
+
+        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]
+      } 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
+    }
+    remove {rmid} {
+      #***
+      # [call [cmd irc::listener] [const remove] [arg chan] [arg id]]
+      # Unregisters the listener identified by [arg id] from [arg chan].
+      # [para]
+      # Ignores requests for nonexistent handlers or handlers of the wrong type.
+      set newlist ""
+      foreach handler [set chan.handlers($chan)] {
+        lassign $handler _ type handlerid writer iot
+        if {$handlerid != $rmid || $type ni {chan tchan}} {
+          lappend newlist $handler
+        } elseif {$type == "chan"} {
+          puts $writer end
+          flush $writer
+        } elseif {$type == "tchan"} {
+          puts $writer end
+          flush $writer
+          thread::release $iot
+        }
+      }
+      set chan.handlers($chan) $newlist
     }
   }
   #***
@@ -213,59 +208,56 @@ namespace eval ::irc {
 
   #***
   # [subsection [concat [cmd irc::handler] [arg subcommand] [arg chan] [opt [arg arg]...]]]
-  # 
-  proc handler {subcommand chan args} {
-    variable chan.handlers
-    switch -- $subcommand {
-      add {
-        set thread false
-        if {[lindex $args 0] == "-thread"} {
-          set thread true
-          set args [lrange $args 1 end]
-        }
+  #
+  sproc handler {
+    _prefix {chan} {
+      variable chan.handlers
+    }
+    add {args} {
+      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 $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 !$thread {
-          if [llength $iot] {
-            irc::int-setaliases {*}$iot
-            interp share {} $chan {*}$iot
-          }
+      if !$thread {
+        if [llength $iot] {
+          irc::int-setaliases {*}$iot
+          interp share {} $chan {*}$iot
+        }
 
-          lappend chan.handlers($chan) [list $patlist script $id $script {*}$iot]
+        lappend chan.handlers($chan) [list $patlist script $id $script {*}$iot]
+      } else {
+        if ![llength $iot] {
+          set iot [list [thread::create -preserved]]
         } else {
-          if ![llength $iot] {
-            set iot [list [thread::create -preserved]]
-          } else {
-            thread::preserve {*}$iot
-          }
-
-          thread::send -async $iot [list set parent [thread::id]]
-
-          lappend chan.handlers($chan) [list $patlist tscript $id $script {*}$iot]
+          thread::preserve {*}$iot
         }
 
-        return $id
+        thread::send -async $iot [list set parent [thread::id]]
+
+        lappend chan.handlers($chan) [list $patlist tscript $id $script {*}$iot]
       }
-      remove {
-        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)] {
-          set iot [lassign $handler _ type handlerid _]
-          if {$handlerid != $rmid || $type ni {script tscript}} {
-            lappend newlist $handler
-          } elseif {$type == "script" && [llength $iot]} {
-            interp delete {*}$iot
-          } elseif {$type == "tscript"} {
-            thread::release {*}$iot
-          }
+
+      return $id
+    }
+    remove {rmid} {
+      set newlist ""
+      foreach handler [set chan.handlers($chan)] {
+        set iot [lassign $handler _ type handlerid _]
+        if {$handlerid != $rmid || $type ni {script tscript}} {
+          lappend newlist $handler
+        } elseif {$type == "script" && [llength $iot]} {
+          interp delete {*}$iot
+        } elseif {$type == "tscript"} {
+          thread::release {*}$iot
         }
-        set chan.handlers($chan) $newlist
       }
-      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
+      set chan.handlers($chan) $newlist
     }
   }
 
@@ -275,7 +267,7 @@ namespace eval ::irc {
   # Validation helper.
   #
   # [para]
-  # 
+  #
   proc is {type value} {
     # validation helper.
     # cap is a list of negotiated capabilities.
@@ -531,66 +523,60 @@ namespace eval ::irc {
     flush $chan
   }
   # documented
-  proc extern {subcommand chan args} {
-    variable chan.handlers
-    switch -- $subcommand {
-      add {
-        if {[llength $args] != 3} { return -code error "wrong # args: should be \"irc::extern add chan patlist ochan ichan\"" }
-        lassign $args patlist ochan ichan
-        set id [format "%016x" [expr {round(rand() * (2**64))}]]
+  sproc extern {
+    _prefix {chan} {
+      variable chan.handlers
+    }
+    add {patlist ochan ichan} {
+      set id [format "%016x" [expr {round(rand() * (2**64))}]]
 
-        lappend chan.handlers($chan) [list $patlist extern $id $ochan $ichan]
+      lappend chan.handlers($chan) [list $patlist extern $id $ochan $ichan]
 
-        fileevent $ichan readable [list ::irc::int-onextern $ichan $chan]
+      fileevent $ichan 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\"" }
-        lassign $args rmid
-        set newlist ""
-        foreach handler [set chan.handlers($chan)] {
-          lassign $handler _ type handlerid ochan ichan
-          if {$handlerid != $rmid || $type != "extern"} {
-            lappend newlist $handler
-          } else {
-            puts $ochan $chan
-            puts $ochan end
-            close $ichan
-          }
+      return $id
+    }
+    remove {rmid} {
+      set newlist ""
+      foreach handler [set chan.handlers($chan)] {
+        lassign $handler _ type handlerid ochan ichan
+        if {$handlerid != $rmid || $type != "extern"} {
+          lappend newlist $handler
+        } else {
+          puts $ochan $chan
+          puts $ochan end
+          close $ichan
         }
-        set chan.handler($chan) $newlist
       }
-      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
+      set chan.handlers($chan) $newlist
     }
   }
 
   # documented
-  proc interceptor {subcommand chan args} {
-    variable chan.interceptors
-    switch -- $subcommand {
-      add {
-        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::interceptor add chan procname\"" }
-        lassign $args procname
-        set id [format "%016x" [expr {round(rand() * (2**64))}]]
+  sproc interceptor {
+    _prefix {chan} {
+      variable chan.interceptors
+    }
+    add {procname} {
+      variable chan.interceptors
 
-        lappend chan.interceptors($chan) [list $id $procname]
+      set id [format "%016x" [expr {round(rand() * (2**64))}]]
 
-        return $id
-      }
-      remove {
-        if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::interceptor remove chan id\"" }
-        lassign $args rmid
-        set newlist ""
-        foreach interceptor [set chan.interceptor($chan)] {
-          lassign $interceptor id procname
-          if {$id != $rmid} {
-            lappend newlist $interceptor
-          }
+      lappend chan.interceptors($chan) [list $id $procname]
+
+      return $id
+    }
+    remove {rmid} {
+      variable chan.interceptors
+
+      set newlist ""
+      foreach interceptor [set chan.interceptors($chan)] {
+        lassign $interceptor id procname
+        if {$id != $rmid} {
+          lappend newlist $interceptor
         }
-        set chan.interceptors($chan) $newlist
       }
-      default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
+      set chan.interceptors($chan) $newlist
     }
   }
 
@@ -640,7 +626,7 @@ namespace eval ::irc {
           return server
         } else { return -code error "argument is not a src" }
       }
-      server {
+      server {servername} {
         if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::src server servername\"" }
         lassign $args servername
         if ![irc::is src::servername $servername] { return -code error "argument is not a servername" }
diff --git a/src/ui.tcl b/src/ui.tcl
index f931260..27306db 100644
--- a/src/ui.tcl
+++ b/src/ui.tcl
@@ -1,30 +1,47 @@
 namespace eval ui {}
-namespace eval ui::basic {}
+namespace eval ui::basic {
+  variable toplevels
+}
 
 proc ui::basic::setup {mount} {
   global version
+  variable toplevels
+
+  set toplevels($mount) {}
 
   menu $mount.menu
-  $mount configure -menu "$mount.menu"
+  $mount configure -menu $mount.menu
 
   menu $mount.menu.conn
-  menu $mount.menu.server
+
+  menu $mount.menu.network
+  $mount.menu.network add command -label "Add a Network" -command ::ui::basic::addnetwork
+  $mount.menu.network add separator
 
   menu $mount.menu.me
   $mount.menu.me add command -label "About" -command [subst {
     tk_messageBox -title "About tclircc" \
-                  -message "tclircc $version" \
+                  -message "tclircc v${version}" \
                   -detail "by Aleteoryx\nhttps://amehut.dev/~aleteoryx/tclircc\n\nThis software is in the public domain." \
                   -type ok \
                   -parent $mount }]
 
-  $mount.menu add cascade -label "connections" -menu $mount.menu.conn
-  $mount.menu add cascade -label "networks" -menu $mount.menu.network
-  $mount.menu add cascade -label "tclircc" -menu $mount.menu.me
+  $mount.menu add cascade -label "Connections" -menu $mount.menu.conn
+  $mount.menu add cascade -label "Networks" -menu $mount.menu.network
+  $mount.menu add cascade -label "tclircc v${version}" -menu $mount.menu.me
+
+  menu_update
 }
 proc ui::basic::teardown {mount} {
+  variable toplevels
+  unset toplevels($mount)
   destroy $mount.menu
 }
+proc ui::basic::menu_update {} {
+  variable toplevels
+
+  set networks [::db::networks::ls core_db]
+}
 
 namespace eval ui::form {
   variable forms
diff --git a/src/util.tcl b/src/util.tcl
index ecda2aa..c6a0f16 100644
--- a/src/util.tcl
+++ b/src/util.tcl
@@ -3,3 +3,77 @@ proc rand_hex {} {
   global randchan
   return [binary encode hex [read randchan 8]]
 }
+
+proc lindex* {list args} {
+  lmap index $args {lindex $list {*}$index}
+}
+
+proc sproc {name args} {
+  if {[llength $args] == 1} {
+    set config [lindex $args 0]
+  } else {
+    set config $args
+  }
+  if {[llength $config] % 3 != 0 || $config == {}} {
+    return -code error "wrong # args: should be \"sproc name { subcommand args body ?subcommand args body ...? }\""
+  }
+
+  set config [lsort -stride 3 $config]
+  set subcommands [lmap {subcommand _ _} $config {expr {$subcommand}}]
+
+  set prefix_args {}
+  set prefix_body {}
+  if {[set subcmd_idx [lsearch $subcommands _prefix]] != -1} {
+    set prefix_idx [expr {$subcmd_idx * 3}]
+    lassign [lindex* $config $prefix_idx+1 $prefix_idx+2] prefix_args prefix_body
+    set config [lreplace $config $prefix_idx $prefix_idx+2]
+    set subcommands [lreplace $subcommands $subcmd_idx $subcmd_idx]
+  }
+
+  set qualifiers [namespace qualifiers $name]
+  if {[string range $name 0 1] == "::"} {
+    if {$qualifiers == {}} {
+      set namespace ::
+    } else {
+      set namespace $qualifiers
+    }
+  } else {
+    set parent [uplevel {namespace current}]
+    if {$qualifiers == {}} {
+      set namespace ${parent}
+    } else {
+      set namespace ${parent}::${qualifiers}
+    }
+  }
+
+  set name [namespace tail $name]
+
+  interp alias {} ${namespace}::${name} {} ::__sproc_impl $name $namespace $prefix_args $prefix_body $subcommands $config
+}
+proc __sproc_impl {name namespace prefix_args prefix_body subcommands config args} {
+  if {[llength $args] < [llength prefix_args] + 1} {
+    return -code error "wrong # args: should be \"$name [concat subcommand $prefix_args] ?arg ...?\""
+  }
+  set args [lassign $args subcommand]
+
+  # TODO: don't search the list twice, if possible
+  set subcommand [::tcl::prefix match -message subcommand $subcommands $subcommand]
+  set cmd_index [expr {[lsearch -sorted $subcommands $subcommand] * 3}]
+  lassign [lindex* $config $cmd_index+1 $cmd_index+2] sc_args sc_body
+  set sc_args [concat $prefix_args $sc_args]
+  set sc_body [string cat $prefix_body \n $sc_body]
+
+  if {[lindex $sc_args end] == "args"} {
+    if {[llength $args] >= [llength $sc_args] - 1} {
+      uplevel [list apply [list $sc_args $sc_body $namespace] {*}$args]
+    } else {
+      return -code error "wrong # args: should be \"$name $subcommand [concat [lrange $sc_args 0 end-1] {?arg ...?}]\""
+    }
+  } else {
+    if {[llength $args] == [llength $sc_args]} {
+      uplevel [list apply [list $sc_args $sc_body $namespace] {*}$args]
+    } else {
+      return -code error "wrong # args: should be \"$name [concat [list $subcommand] $sc_args]\""
+    }
+  }
+}
-- 
2.45.2