#!/bin/tclsh
namespace eval ::irc {
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 }
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}}
default { return -code error "unknown subcommand \"$subcommand\": must be command(|::named|::numeric), tags(|::tag|::key|::value), or misc::dict" }
}
}
proc ::irc::esc {type value} {
# for escaping specific things
switch -- $type {
tags::value {
string map {"\\" "\\\\"
"\n" {\n}
"\r" {\r}
{;} {\:}
{ } {\s}} $value
}
default { return -code error "unknown subcommand \"$subcommand\": must be tags::value" }
}
}
proc ::irc::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 [string cat $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 " "] }
# covers backslash too
default { set ret [string cat $ret $char] }
}
set backslash false
}
}
return $ret
}
default { return -code error "unknown subcommand \"$subcommand\": must be tags::value" }
}
}
proc ::irc::connect {hostname port {usetls 1}} {
if $usetls {
if {[info commands ::tls::socket] == ""} { package require tls }
::tls::socket $hostname $port
} else {
socket hostname port
}
}
proc ::irc::tags {subcommand args} {
switch -- $subcommand {
exists {
if {[llength $args] != 2} { return -code error "wrong # args: should be \"irc::tags exists tags key\"" }
set tags [lindex $args 0]
set key [lindex $args 1]
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\"" }
set tags [lindex $args 0]
set ret ""
set key [lindex $args 1]
foreach tag [split $tags ";"] {
if { [string first "$key=" $tag] && $tag != $key } {
set ret [string cat $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 tags [lindex $args 0]
set key [if {[llength $args] == 2} {lindex $args 1}]
if {$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
}
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 tags [lindex $args 0]
set ret ""
set key [lindex $args 1]
set value [if {[llength $args] == 3} { lindex $args 2 }]
set found false
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] ";"]
} else {
set ret [string cat $ret $key ";"]
}
set found true
} else {
set ret [string cat $ret $tag ";"]
}
}
if !$found {
if {$value != ""} {
set ret [string cat $ret $key = [::irc::esc tags::value $value] ";"]
} else {
set ret [string cat $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\"" }
set tags [lindex $args 0]
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" }
}
}
proc ::irc::cmd {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]
}
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 ...? \"" }
}
send { ... }
default { return -code error "unknown subcommand \"$subcommand\": must be fmt or send" }
}
}
}