#***
# [manpage_begin irc tclircc 0.0.1]
# [titledesc {Library irc.tcl}]
# [description]
# [para]
# This is a to-spec IRCv3 client library.
# It is designed to be freely extracted.
# 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
#***
# [section {Getting a channel}]
# [file irc.tcl] provides 2 ways to connect to an IRC server.
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
#***
# [subsection [concat [cmd irc::connect] [arg hostname] [arg port] [opt [arg usetls]]]]
#
# Connects to [arg hostname]:[arg port], and sets up all the necessary state.
# If [arg usetls] is set to true, the [package tls] module will be used to connect,
# instead of the builtin [cmd socket] command. If unset, [cmd socket] will be used.
#
# [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 {[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
}
#***
# [subsection [concat [cmd irc::enroll] [arg chan] [opt [arg meta]]]]
#
# Sets up the internal state necessary for chan to be used as an IRC socket.
# It is called internally by [cmd irc::connect].
# This command is exposed for the use-case where an IRC channel might have a more bespoke acquisition process than a simple socket connection.
#
# [para]
# [arg meta] is the initial state of the [sectref {channel metadata}].
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) {}
}
#***
# [section {Listening to it}]
# [file irc.tcl] provides an event dispatch system, via a [cmd fileevent] script registered on the IRC channel.
# Events are dispatched by matching their patterns against incoming messages.
#***
# [subsection [concat [cmd irc::listen] [arg subcommand] [arg chan]]]
# Enable or disable the [cmd fileevent] script for the dispatch system.
#
# [list_begin definitions]
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 "" }
}
}
#***
# [list_end]
#***
# [subsection [concat [cmd irc::listener] [arg subcommand] [arg chan] [opt [arg arg]...]]]
# Configure [cmd listener]-type event handlers.
# [para]
# [cmd listener]-type handlers are scripts, executed in either a sub-interpreter or a seperate thread.
# Interpreter listeners should yield themselves with [cmd after] during long operations, and never block for extended periods.
# If that is infeasible, threaded listeners are recommended.
# [para]
# [cmd listener]-type scripts are spawned with the variable [var dispatch] set to the channel they are to recieve dispatches over.
# Each line will be a [cmd dict] with contents as described in [sectref {Event Dispatch Contents}].
# Interpreters are given access to the [sectref {Dispatch-aliased IRC commands}], while threads are given the variable [var parent], the ID of the main thread.
# [para]
# When a listener is removed, it will recieve a message of just [const end].
# It should perform necessary cleanup quickly, as the application is likely exiting.
# Threads may simply [cmd thread::release] themselves, while interps may call the provided [cmd selfdestruct].
#
# [list_begin definitions]
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
}
}
#***
# [list_end]
#***
# [subsection [concat [cmd irc::handler] [arg subcommand] [arg chan] [opt [arg arg]...]]]
#
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 !$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 {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
}
}
#***
# [subsection [concat [cmd irc::is] [arg type] [arg value]]]
# Validation helper.
#
# [para]
#
proc is {type value} {
# 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" }
}
}
# 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
}
# nodoc
proc int-onextern {ichan chan} {
set msg [gets $ichan]
if {$msg == ""} return
puts $chan $msg
flush $chan
}
# documented
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]
fileevent $ichan readable [list ::irc::int-onextern $ichan $chan]
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.handlers($chan) $newlist
}
}
# documented
sproc interceptor {
_prefix {chan} {
variable chan.interceptors
}
add {procname} {
variable chan.interceptors
set id [format "%016x" [expr {round(rand() * (2**64))}]]
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
}
}
# 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 {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" }
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]