@@ 1,22 1,47 @@
#!/bin/tclsh
+# handler types:
+# chan <chanid> <interp> // irc::listener
+# passes to a pipe to a sub-interpreter
+# 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 <script> <interp> // irc::handler
+# script is to be executed inside interp with dispatch as locals
+# handler: <patlist> <type> <id> <type args...>
+
namespace eval ::irc {
+ variable chanmeta
+
proc ::irc::is {type value {cap {}}} {
# validation helper.
# cap is a list of negotiated capabilities.
switch -- $type {
- command { regexp {^([a-zA-Z]+|[0-9]{3})$} $value }
- command::named { regexp {^[a-zA-Z]+$} $value }
- command::numeric { regexp {^[0-9]{3}$} $value }
+ cmd { regexp {^([a-zA-Z]+|[0-9]{3})$} $value }
+ cmd::named { regexp {^[a-zA-Z]+$} $value }
+ cmd::numeric { regexp {^[0-9]{3}$} $value }
tags { regexp {^\+?([^\r\n\0 ;/]/)?[a-zA-Z0-9\-]+(=[^\r\n\0; ]*)?(;\+?([^\r\n\0 ;/]/)?[a-zA-Z0-9\-]+(=[^\r\n\0; ]*)?)*$} $value }
tags::tag { regexp {^\+?([^\r\n\0 ;/]/)?[a-zA-Z0-9\-]+(=[^\r\n\0; ]*)?$} $value }
tags::key { regexp {^\+?([^\r\n\0 ;/]/)?[a-zA-Z0-9\-]+$} $value }
tags::value { regexp {^[^\r\n\0; ]*$} $value }
- misc::dict { expr {![string is list $value] || [llength $value] % 2 == 1}}
+ src { regexp {^([^$: ,*?!@.][^ ,*?!@.]*(![^$: ,*?!@][^ ,*?!@]*)?(@[^$: ,*?!@][^ ,*?!@]*)?|[^$: ,*?!@][^ ,*?!@]*)$} $value }
+ src::user { regexp {^[^$: ,*?!@.][^ ,*?!@.]*(![^$: ,*?!@][^ ,*?!@]*)?(@[^$: ,*?!@][^ ,*?!@]*)?$} $value }
+ src::servername { regexp {^[^$: ,*?!@][^ ,*?!@]*$} $value }
+ src::part { regexp {^[^$: ,*?!@][^ ,*?!@]*$} $value }
+
+ nick { regexp {^[^$: ,*?!@.][^ ,*?!@.]*$} $value }
+
+ msg::param { regexp {^[^\0\n\r: ]+$} $value }
+ msg::trailing { regexp {^[^\0\n\r]+$} $value }
- default { return -code error "unknown subcommand \"$subcommand\": must be command(|::named|::numeric), tags(|::tag|::key|::value), or misc::dict" }
+ misc::dict { expr {![string is list $value] || [llength $value] % 2 == 0}}
+
+ default { return -code error "unknown type \"$type\": must be cmd(|::named|::numeric), misc::dict, src(|::server|::user), or tags(|::key|::tag|::value)" }
}
}
@@ 31,7 56,7 @@ namespace eval ::irc {
{ } {\s}} $value
}
- default { return -code error "unknown subcommand \"$subcommand\": must be tags::value" }
+ default { return -code error "unknown type \"$type\": must be tags::value" }
}
}
@@ 47,17 72,17 @@ namespace eval ::irc {
if {$char == "\\"} {
set backslash true
} else {
- set ret [string cat $ret $char]
+ set ret $ret$char
}
} else {
switch $char {
- n { set ret [string cat $ret "\n"] }
- r { set ret [string cat $ret "\r"] }
- : { set ret [string cat $ret ";"] }
- s { set ret [string cat $ret " "] }
+ n { set ret "$ret\n" }
+ r { set ret "$ret\r" }
+ : { set ret "$ret;" }
+ s { set ret "$ret " }
# covers backslash too
- default { set ret [string cat $ret $char] }
+ default { set ret $ret$char }
}
set backslash false
}
@@ 66,16 91,246 @@ namespace eval ::irc {
return $ret
}
- default { return -code error "unknown subcommand \"$subcommand\": must be tags::value" }
+ default { return -code error "unknown type \"$type\": must be tags::value" }
}
}
proc ::irc::connect {hostname port {usetls 1}} {
+ variable chanmeta
if $usetls {
if {[info commands ::tls::socket] == ""} { package require tls }
- ::tls::socket $hostname $port
+ set chan [::tls::socket $hostname $port]
+ set proto ircs
} else {
- socket hostname port
+ set chan [socket $hostname $port]
+ set proto irc
+ }
+
+ irc::enroll $chan [dict create uri $proto://$hostname:$port \
+ proto $proto \
+ hostname $hostname \
+ port $port]
+ }
+
+ proc ::irc::enroll {chan {meta {}}}
+ fconfigure $chan -translation crlf -blocking 0
+ dict set meta chan $chan
+ dict set meta handlers {}
+ set chanmeta($chan) $meta
+ }
+
+ proc ::irc::listen {subcommand chan} {
+ switch -- $subcommand {
+ on {
+ fileevent $chan readable [list ::irc::int-onmsg $chan]
+ }
+ off {
+ 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" }
+ }
+ }
+
+ proc ::irc::int-setaliases {interp} {
+ $interp alias irc::is
+ $interp alias irc::msg
+ $interp alias irc::listener
+ $interp alias irc::esc
+ $interp alias irc::unesc
+ $interp alias irc::src
+ $interp alias irc::tags
+ }
+
+ proc ::irc::int-onmsg {chan} {
+ set msg [gets $chan]
+ if {$msg == ""} { return }
+
+ variable chanmeta
+
+ irc::msg parse $msg tags src cmd params
+ set srctype [irc::src parse $src srcparts]
+
+ set dispatch [dict create rawmsg $msg \
+ chan $chan \
+ tags $tags \
+ src $src \
+ srctype $srctype \
+ srcparts $srcparts \
+ cmd $cmd \
+ params $params \
+ meta [dict remove [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]
+
+ set matched false
+ foreach msgpat $patlist {
+ set cmdpat [lindex [lindex $handler 0] 0]
+ set parampats [lrange [lindex $handler 0] 1 end]
+
+ if {[llength $parampats] > [llength $params]} { continue }
+ if ![string match $cmdpat $cmd] { continue }
+
+ set bailed false
+ foreach parampat $parampats param [lrange $params 0 [llength $parampats]-1] {
+ if ![string match $parampat $param] { set bailed true; break }
+ }
+ if $bailed { continue }
+
+ set matched true
+ break
+ }
+ if !$matched { continue }
+
+ switch -- $type {
+ chan {
+ set chanid [lindex $handler 3]
+ puts $chanid $dispatch
+ flush $chanid
+ }
+ extern {
+ set ochanid [lindex $handler 3]
+ puts $ochanid $chan
+ puts $ochanid $msg
+ flush $ochanid
+ }
+ script {
+ set script [lindex $handler 3]
+ if {[llength $handler] == 5} {
+ set interp [lindex $handler 4]
+ } else {
+ set interp [interp create]
+ irc::int-setaliases $interp
+ interp share {} $chan $interp
+ }
+ $interp eval dict with $dispatch {}
+ $interp eval after 0 $script
+ }
+ }
+ }
+ }
+
+ 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\"" }
+ set patlist [lindex $args 0]
+ set script [lindex $args 1]
+ set id [format "%016x" [expr {round(rand() * (2**64))}]]
+
+ set interp [interp create]
+ irc::int-setaliases $interp
+ interp share {} $chan $interp
+
+ set pipe [chan pipe]
+ set reader [lindex $pipe 0]
+ interp transfer {} $reader $interp
+ $interp eval set chan $reader
+ $interp eval after 0 $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\"" }
+ set newlist ""
+ foreach handler [dict get chanmeta($chan) handlers] {
+ if {[lindex $handler 2] != $args} {
+ lappend newlist $handler
+ } else {
+ puts [lindex $handler 3] end
+ flush [lindex $handler 3]
+ }
+ }
+ 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
+ }
+ 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]
+ }
+ }
+ }
+ }
+ default { return -code error "unknown subcommand \"$subcommand\": must be add, patlist, or remove" }
+ }
+ }
+
+ proc ::irc::src {subcommand args} {
+ switch -- $subcommand {
+ parse {
+ if {[llength $args] ni {1 2}} { return -code error "wrong # args: should be \"irc::src parse src ?partsVar?\"" }
+ set src [lindex $args 0]
+ set partsVar ""
+ if {[llength $args] == 1} { set partsVar [lindex $args 1] }
+
+ if [irc::is src::user] {
+ 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] {
+ if [string length $partsVar] {
+ upvar $partsVar parts
+ set parts [dict create servername $src]
+ }
+ return server
+ } else { return -code error "argument is not a src" }
+ }
+ servername {
+ if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::src server servername\"" }
+ if ![irc::is src::servername $args] { return -code error "argument is not a servername" }
+ return $args
+ }
+ user {
+ if {[llength $args] ni {1 3 5}} { return -code error "wrong # args: should be \"irc::src user ?-user user? ?-host host? nick\"" }
+
+ set user ""
+ if {[lindex $args 0] == "-user"} {
+ set user [lindex $args 1]
+ if ![irc::is src::part $user] { return -code error "-user argument is not a user" }
+ set args [lrange $args 2 end]
+ set user "!$user"
+ }
+ set host ""
+ if {[lindex $args 0] == "-host"} {
+ set host [lindex $args 1]
+ if ![irc::is src::part $host] { return -code error "-host argument is not a host" }
+ set args [lrange $args 2 end]
+ set host "@$host"
+ }
+
+ if {[llength $args] != 1} { return -code error "bad option: should be \"irc::src user ?-user user? ?-host host? nick\"" }
+
+ if ![irc::is src::nick $args] { return -code error "argument is not a nick" }
+
+ return $args$user$host
+ }
+ default { return -code error "unknown subcommand \"$subcommand\": must be parse, servername, or user" }
}
}
@@ 99,7 354,7 @@ namespace eval ::irc {
foreach tag [split $tags ";"] {
if { [string first "$key=" $tag] && $tag != $key } {
- set ret [string cat $ret $tag ";"]
+ append ret "$tag;"
}
}
@@ 115,7 370,7 @@ namespace eval ::irc {
foreach tag [split $tags ";"] {
set split [string first = $tag]
set key [string range $tag 0 $split-1]
- set value [::irc::unesc tags::value [string range $tag $split+1 end]]
+ set value [irc::unesc tags::value [string range $tag $split+1 end]]
lappend ret [list $key $value]
}
return $ret
@@ 123,7 378,7 @@ namespace eval ::irc {
foreach tag [split $tags ";"] {
if {![string first "$key=" $tag]} {
- return [::irc::unesc tags::value [string range $tag [string first = $tag]+1 end]]
+ return [irc::unesc tags::value [string range $tag [string first = $tag]+1 end]]
} elseif { $tag == $key } { return "" }
}
@@ 140,21 395,21 @@ namespace eval ::irc {
foreach tag [split $tags ";"] {
if { !$found && ![string first "$key=" $tag] || $tag == $key } {
if {$value != ""} {
- set ret [string cat $ret $key = [::irc::esc tags::value $value] ";"]
+ append ret "$key=[irc::esc tags::value $value];"
} else {
- set ret [string cat $ret $key ";"]
+ append ret "$key;"
}
set found true
} else {
- set ret [string cat $ret $tag ";"]
+ append ret "$tag;"
}
}
if !$found {
if {$value != ""} {
- set ret [string cat $ret $key = [::irc::esc tags::value $value] ";"]
+ append ret "$key=[irc::esc tags::value $value];"
} else {
- set ret [string cat $ret $key ";"]
+ append ret "$key;"
}
}
@@ 164,7 419,7 @@ namespace eval ::irc {
create {
set ret ""
dict for {key value} $args {
- set ret [::irc::tags set $ret $key $value]
+ set ret [irc::tags set $ret $key $value]
}
return $ret
}
@@ 172,16 427,16 @@ namespace eval ::irc {
set ret ""
foreach tags $args {
- if [::irc::is tags $tags] {
+ if [irc::is tags $tags] {
foreach tag [split $tags ";"] {
set split [string first = $tag]
set key [string range $tag 0 $split-1]
- set value [::irc::unesc tags::value [string range $tag $split+1 end]]
- set ret [::irc::tags set $ret $key $value]
+ set value [irc::unesc tags::value [string range $tag $split+1 end]]
+ set ret [irc::tags set $ret $key $value]
}
- } elseif [::irc::is misc::dict $tags] {
+ } elseif [irc::is misc::dict $tags] {
dict for {key value} $tags {
- set ret [::irc::tags set $ret $key $value]
+ set ret [irc::tags set $ret $key $value]
}
} else {
return -code error "argument is not tags or a dict"
@@ 197,7 452,7 @@ namespace eval ::irc {
foreach tag [split $tags ";"] {
set split [string first = $tag]
set key [string range $tag 0 $split-1]
- set value [::irc::unesc tags::value [string range $tag $split+1 end]]
+ set value [irc::unesc tags::value [string range $tag $split+1 end]]
dict set ret $key $value
}
return $ret
@@ 206,31 461,110 @@ namespace eval ::irc {
}
}
- proc ::irc::cmd {subcommand args} {
+ proc ::irc::msg {subcommand args} {
switch -- $subcommand {
fmt {
- if [llength $args] {
- set tags ""
- if {[lindex $args 0] == "-tags"} {
- if {[llength $args] < 3} { return -code error "missing tags dictionary argument to -tags option" }
- set tags [::irc::tags merge [lindex $args 0]]
- set args [lrange $args 2 end]
- }
- # TODO: source generation/parsing, actual command formatting
- set source ""
- if {[lindex $args 0] == "-tags"} {
- if {[llength $args] < 3} { return -code error "missing tags map argument to -tags option" }
- set tags [lindex $args 0]
- set args [lrange $args 2 end]
- }
+ if ![llength $args] { return -code error "wrong # args: should be \"irc::msg fmt ?-tags tags? ?-src src? cmd ?arg ...? \"" }
+
+ set msg ""
- set cmd [lindex $args 0]
- if ![::irc::is command $cmd] { return -code error "invalid irc command \"$cmd\"" }
- set cmd [string toupper $cmd]
- } else { return -code error "wrong # args: should be \"irc::cmd fmt ?-tags tags? ?-source source? command ?arg ...? \"" }
+ # TODO: unordered flag parsing
+ if {[lindex $args 0] == "-tags"} {
+ if {[llength $args] < 3} { return -code error "missing tags dictionary argument to -tags option" }
+ set msg "@[irc::tags merge [lindex $args 1]] "
+ set args [lrange $args 2 end]
+ }
+
+ if {[lindex $args 0] == "-src"} {
+ if {[llength $args] < 3} { return -code error "missing src argument to -src option" }
+ set src [lindex $args 1]
+ if ![irc::is src $src] { return -code error "-src argument is not a src" }
+ append msg ":$src "
+ set args [lrange $args 2 end]
+ }
+
+ set cmd [lindex $args 0]
+ if ![irc::is cmd $cmd] { return -code error "invalid irc command \"$cmd\"" }
+ append msg "[string toupper $cmd] "
+
+ set args [lrange $args 1 end]
+
+ if ![llength $args] { return [string range $msg 0 end-1] }
+
+ set trailing [lindex $args end]
+ set params [lrange $args 0 end-1]
+
+ foreach param $params {
+ if ![irc::is msg::param $param] { return -code error "invalid irc parameter \"$param\"" }
+ append msg "$param "
+ }
+
+ if ![irc::is msg::trailing $trailing] { return -code error "invalid irc trailing \"$trailing\"" }
+ append msg ":$trailing"
+
+ return $msg
+ }
+ send {
+ if {[llength $args] < 2} { return -code error "wrong # args: should be \"irc::msg send chan ?-tags tags? ?-src src? cmd ?arg ...? \"" }
+ set chan [lindex $args 0]
+ set args [lrange $args 1 end]
+ puts $chan "[irc::msg fmt {*}$args]\n"
+ flush $chan
}
- send { ... }
- default { return -code error "unknown subcommand \"$subcommand\": must be fmt or send" }
+
+ # this parser is pretty lazy, and does not do validation.
+ # there's no risks, but it might behave oddly with a broken server.
+ parse {
+ if {[llength $args] != 5} { return -code error "wrong # args: should be irc::msg parse message tagsVar srcVar cmdVar paramsVar" }
+ set message [lindex $args 0]
+ upvar [lindex $args 1] tags
+ upvar [lindex $args 2] src
+ upvar [lindex $args 3] cmd
+ upvar [lindex $args 4] params
+
+ # tags
+ set tags ""
+ if ![string first @ $message] {
+ set tagsend [string first " " $message]
+ set tags [string range $message 1 $tagsend-1]
+ set message [string range $message $tagsend+1 end]
+ }
+
+ # src
+ set src ""
+ if ![set srcend [string first : $message]] {
+ set srcend [string first " " $message]
+ set src [string range $message 1 $srcend-1]
+ set message [string range $message $srcend+1 end]
+ }
+
+ # solo command
+ if {[string first " " $message] == -1} {
+ set cmd $message
+ set params ""
+ return
+ }
+
+ # command w/ args
+ set cmdend [string first " " $message]
+ set cmd [string range $message 0 $cmdend-1]
+ set message [string range $message $cmdend+1 end]
+
+ # trailing
+ set trailing ""
+ if {[set trailingstart [string first : $message]] != -1} {
+ set trailing [list [string range $message $trailingstart+1 end]]
+ set message [string range $message 0 $trailingstart-1]
+ }
+
+ # params
+ regsub { +} [string trim $message " "] " " message
+ set params [concat [split $message " "] $trailing]
+ }
+ default { return -code error "unknown subcommand \"$subcommand\": must be fmt, parse, or send" }
}
}
}
+
+irc::msg parse [gets stdin] tags src cmd params
+puts "tags: \"$tags\"\nsrc: \"$src\"\nparams: \"$cmd\"\nparams: \"$params\""