From 3d47eb23315b24f4a33ba1e1b0e75c69070a0c53 Mon Sep 17 00:00:00 2001 From: Aleteoryx Date: Fri, 2 Aug 2024 01:51:26 +0100 Subject: [PATCH] Getting started --- .gitignore | 3 + LICENSE | 13 +++ README.md | 14 ++++ irc.tcl | 236 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 266 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 README.md create mode 100755 irc.tcl diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b559326 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*~ +*.save +*.swp diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..f57f73c --- /dev/null +++ b/LICENSE @@ -0,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. diff --git a/README.md b/README.md new file mode 100644 index 0000000..c1ca7cf --- /dev/null +++ b/README.md @@ -0,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 diff --git a/irc.tcl b/irc.tcl new file mode 100755 index 0000000..b1a639f --- /dev/null +++ b/irc.tcl @@ -0,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" } + } + } +} -- 2.43.4