A src/conn.tcl => src/conn.tcl +3 -0
@@ 0,0 1,3 @@
+source src/deps.tcl
+source src/util.tcl
+source src/irc.tcl
M src/db/networks.tcl => src/db/networks.tcl +18 -0
@@ 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\"." }
+
+ }
+}
M src/deps.tcl => src/deps.tcl +1 -0
@@ 1,6 1,7 @@
set deps {
Tcl 8.6
Tk 8.6
+ Thread 2.8
sqlite3 3.37
tls 1.7
logger 0.9
M src/irc.tcl => src/irc.tcl +172 -186
@@ 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" }
M src/ui.tcl => src/ui.tcl +24 -7
@@ 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
M src/util.tcl => src/util.tcl +74 -0
@@ 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]\""
+ }
+ }
+}