#***
# [manpage_begin irc tclircc 0.0.1]
# [titledesc {Library irc.tcl}]
# [description]
# handler types:
# 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 global scope with dispatch set
# script <script> <interp> // irc::handler
# 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 log [logger::init irc]
variable logd [logger::init irc::dispatch]
variable logp [logger::init irc::proto]
variable chan.meta
variable chan.handlers
variable chan.interceptors
# documented
proc is {type value {cap {}}} {
# validation helper.
# cap is a list of negotiated capabilities.
switch -- $type {
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 }
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 }
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)" }
}
}
# documented
proc esc {type value} {
# for escaping specific things
switch -- $type {
tags::value {
string map {"\\" "\\\\"
"\n" {\n}
"\r" {\r}
{;} {\:}
{ } {\s}} $value
}
default { return -code error "unknown type \"$type\": must be tags::value" }
}
}
# documented
proc unesc {type value} {
# for unescaping specific things
# needs to be handled manually due to Quirkiness
switch -- $type {
tags::value {
set ret ""
set backslash false
foreach char [split $value ""] {
if !$backslash {
if {$char == "\\"} {
set backslash true
} else {
set ret $ret$char
}
} else {
switch $char {
n { set ret "$ret\n" }
r { set ret "$ret\r" }
: { set ret "$ret;" }
s { set ret "$ret " }
# covers backslash too
default { set ret $ret$char }
}
set backslash false
}
}
return $ret
}
default { return -code error "unknown type \"$type\": must be tags::value" }
}
}
# documented
proc connect {hostname port {usetls 0}} {
if $usetls {
if {[info commands ::tls::socket] == ""} { package require tls }
set chan [::tls::socket $hostname $port]
set proto ircs
} else {
set chan [socket $hostname $port]
set proto irc
}
irc::enroll $chan [dict create uri $proto://$hostname:$port \
proto $proto \
hostname $hostname \
port $port]
return $chan
}
# documented
proc enroll {chan {meta {}}} {
variable chan.meta
variable chan.handlers
variable chan.interceptors
fconfigure $chan -translation crlf -blocking 0
set chan.meta($chan) $meta
set chan.handlers($chan) {}
set chan.interceptors($chan) {}
}
# documented
proc 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" }
}
}
# nodoc
# helper function that rebrands dict command errors
proc int-dictsub args {
if [catch { uplevel [list dict {*}$args] } result options] {
return -options $options [regsub {dictionary$} $result "channel meta"]
} else {
return -options $options $result
}
}
# documented
proc meta {subcommand chan args} {
variable chan.meta
switch -- $subcommand {
exists {
if ![llength $args] { return -code error "wrong # args: should be \"irc::meta exists chan key ?key ...?\"" }
int-dictsub exists [set chan.meta($chan)] {*}$args
}
unset {
if ![llength $args] { return -code error "wrong # args: should be \"irc::meta unset chan key ?key ...?\"" }
int-dictsub unset chan.meta($chan) {*}$args
}
get {
int-dictsub get [set chan.meta($chan)] {*}$args
}
set {
if {[llength $args] < 2} { return -code error "wrong # args: should be \"irc::meta set chan key ?key ...? value\"" }
int-dictsub set chan.meta($chan) {*}$args
}
read {
if [llength $args] { return -code error "wrong # args: should be \"irc::meta read chan\"" }
set chan.meta($chan)
}
default { return -code error "unknown subcommand \"$subcommand\": must be exists, get, set, or unset" }
}
}
# nodoc
proc int-setaliases {interp} {
$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
proc int-onmsg {chan} {
set msg [gets $chan]
if {$msg == ""} { return }
variable logd
variable chan.meta
variable chan.handlers
variable chan.interceptors
irc::msg parse $msg tags src cmd params
set src ""
set srcparts ""
set srctype ""
if {$src != ""} { 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]
set matchedany false
foreach interceptor [set chan.interceptors($chan)] {
lassign $interceptor id procname
if {[uplevel #0 [list $procname $dispatch]]} {
${logd}::debug "message intercepted by interceptor \"$id\", procname \"$procname\""
${logd}::debug "contents: $msg"
return
}
}
foreach handler [set chan.handlers($chan)] {
set rest [lassign $handler patlist type id]
set matched false
foreach msgpat $patlist {
set parampats [lassign $patlist cmdpat]
# don't care about extra args to a command, so that the pattern
# for e.g. a message can just be "PRIVMSG"
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 }
set matchedany true
if [set code [catch {
switch -- $type {
chan {
lassign $rest writer interp
puts $writer $dispatch
flush $writer
}
tchan {
lassign $rest writer thread
puts $writer $dispatch
flush $writer
}
extern {
lassign $rest ochan ichan
puts $ochan $chan
puts $ochan $msg
flush $ochan
}
script {
set interp [lassign $rest script]
if [llength $interp] {
set interp [lindex $interp 0]
{*}$interp eval [list set dispatch $dispatch]
{*}$interp eval $script
} else {
uplevel #0 [list set dispatch $dispatch]
uplevel #0 $script
}
}
tscript {
lassign $rest script thread
thread::send -async $thread [list set dispatch $dispatch]
thread::send -async $thread $script
}
}
} result options]] {
if {$code == 1} {
${logd}::error "error in $type handler $id (pattern list: [list $patlist]): $result"
${logd}::error "errorInfo: [dict get $options -errorinfo]"
}
}
}
if !$matchedany {
${logd}::warn "unmatched command on channel \"$chan\": $msg"
}
}
# nodoc
proc int-rminterp {interp} {
interp delete $interp
}
# documented
proc listener {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]
}
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 {
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" }
}
}
# documented
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]
}
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
}
lappend chan.handlers($chan) [list $patlist script $id $script {*}$iot]
} 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]
}
return $id
}
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
}
}
set chan.handlers($chan) $newlist
}
default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
}
}
# nodoc
proc int-onextern {ichan chan} {
set msg [gets $ichan]
if {$msg == ""} return
puts $chan $msg
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))}]]
lappend chan.handlers($chan) [list $patlist extern $id $ochan $ichan]
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
}
}
set chan.handler($chan) $newlist
}
default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
}
}
# 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))}]]
lappend chan.interceptors($chan) [list $id $procname]
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
}
}
set chan.interceptors($chan) $newlist
}
default { return -code error "unknown subcommand \"$subcommand\": must be add or remove" }
}
}
# documented
proc 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]
}
}
}
}
# documented
proc src {subcommand args} {
switch -- $subcommand {
parse {
if {[llength $args] ni {1 2}} { return -code error "wrong # args: should be \"irc::src parse src ?partsVar?\"" }
lassign $args src
set partsVar ""
if {[llength $args] == 1} { set partsVar [lindex $args 1] }
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 $src] {
if [string length $partsVar] {
upvar $partsVar parts
set parts [dict create servername $src]
}
return server
} else { return -code error "argument is not a src" }
}
server {
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" }
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 args [lassign $args _ user]
if ![irc::is src::part $user] { return -code error "-user argument is not a user" }
set user "!$user"
}
set host ""
if {[lindex $args 0] == "-host"} {
set args [lassign $args _ host]
if ![irc::is src::part $host] { return -code error "-host argument is not a host" }
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" }
}
}
# documented
proc tags {subcommand args} {
switch -- $subcommand {
exists {
if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::tags exists tags key\"" }
lassign $args tags key
foreach tag [split $tags ";"] {
if { ![string first "$key=" $tag] || $tag == $key } { return true }
}
return false
}
remove {
if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::tags remove tags key\"" }
lassign $args tags key
set ret ""
foreach tag [split $tags ";"] {
if { [string first "$key=" $tag] && $tag != $key } {
append ret "$tag;"
}
}
string range $ret 0 end-1
}
get {
if {[llength $args] ni {1 2}} { return -code error "wrong # args: should be \"irc::tags get tags ?key?\"" }
set key [lassign $args tags]
if ![llength $key] {
set ret ""
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]]
lappend ret [list $key $value]
}
return $ret
}
lassign $key key
foreach tag [split $tags ";"] {
if {![string first "$key=" $tag]} {
return [irc::unesc tags::value [string range $tag [string first = $tag]+1 end]]
} elseif { $tag == $key } { return "" }
}
return -code error "key \"$key\" not known in tags"
}
set {
if {[llength $args] ni {2 3}} { return -code error "wrong # args: should be \"irc::tags set tags key ?value?\"" }
set value [lassign $args tags key]
set ret ""
set found false
foreach tag [split $tags ";"] {
if { !$found && ![string first "$key=" $tag] || $tag == $key } {
if [llength $value] {
append ret "$key=[irc::esc tags::value {*}$value];"
} else {
append ret "$key;"
}
set found true
} else {
append ret "$tag;"
}
}
if !$found {
if [llength $value] {
append ret "$key=[irc::esc tags::value {*}$value];"
} else {
append ret "$key;"
}
}
string range $ret 0 end-1
}
create {
set ret ""
dict for {key value} $args {
set ret [irc::tags set $ret $key $value]
}
return $ret
}
merge {
set ret ""
foreach tags $args {
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]
}
} elseif [irc::is misc::dict $tags] {
dict for {key value} $tags {
set ret [irc::tags set $ret $key $value]
}
} else {
return -code error "argument is not tags or a dict"
}
}
return $ret
}
dict {
if {[llength $args] != 1} { return -code error "wrong # args: should be \"irc::tags dict tags\"" }
lassign $args tags
set ret ""
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]]
dict set ret $key $value
}
return $ret
}
default { return -code error "unknown subcommand \"$subcommand\": must be create, dict, exists, get, merge, remove, or set" }
}
}
# documented
proc msg {subcommand args} {
switch -- $subcommand {
fmt {
if ![llength $args] { return -code error "wrong # args: should be \"irc::msg fmt ?-tags tags? ?-src src? cmd ?arg ...? \"" }
set msg ""
# TODO: unordered flag parsing
if {[lindex $args 0] == "-tags"} {
set args [lassign $args _ tags]
if {[llength $args] < 3} { return -code error "missing tags dictionary argument to -tags option" }
set msg "@[irc::tags merge $tags] "
}
if {[lindex $args 0] == "-src"} {
if {[llength $args] < 3} { return -code error "missing src argument to -src option" }
set args [lassign $args _ src]
if ![irc::is src $src] { return -code error "-src argument is not a src" }
append msg ":$src "
}
set args [lassign $args cmd]
if ![irc::is cmd $cmd] { return -code error "invalid irc command \"$cmd\"" }
append msg "[string toupper $cmd] "
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 args [lassign $args chan]
puts $chan "[irc::msg fmt {*}$args]\n"
flush $chan
}
# 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" }
lassign $args message tagsVar srcVar cmdVar paramsVar
upvar $tagsVar tags
upvar $srcVar src
upvar $cmdVar cmd
upvar $paramsVar 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" }
}
}
}
#***
# [manpage_end]