A => .gitignore +3 -0
@@ 1,3 @@
+*~
+*.save
+*.swp
A => LICENSE +13 -0
@@ 1,13 @@
+This repository is dedicated entirely to the public domain. The creator
+waives all intellectual property rights to the work as much as is
+possible in the given jurisdiction.
+
+In other words, do whatever.
+
+THE SOFTWARE IS PROVIDED “AS IS” AND THE AUTHOR DISCLAIMS ALL
+WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES
+OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE
+FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY
+DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
+AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
+OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
A => README.md +14 -0
@@ 1,14 @@
+# tclircc
+
+TCL-based IRC client. Probably a testing grounds for client-side protocol
+extensions.
+
+I'd like to get some friends off discord, and there are some things to IRC that
+make it inaccessible for them. Plus I just want to write my own IRC client.
+
+Current feature plans:
+
+- PFPs
+- Attachments with UI integration
+- GUI object upload management(dctc+bot)
+- Functional scrollback
A => irc.tcl +236 -0
@@ 1,236 @@
+#!/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" }
+ }
+ }
+}