├── .gitignore ├── irken.png ├── screenshot.png ├── LICENSE ├── plugins ├── daybreak.tcl ├── reconnect.tcl ├── restorewinpos.tcl ├── rot13.tcl ├── filterjoins.tcl ├── debug.tcl ├── search.tcl ├── ijchain.tcl ├── ignore.tcl ├── aliases.tcl ├── dtnotify.tcl ├── inlineimages.tcl ├── popupmenus.tcl ├── friend.tcl └── chanlist.tcl ├── README.md ├── irken_test.tcl └── irken.tcl /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | -------------------------------------------------------------------------------- /irken.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dlowe-net/irken/HEAD/irken.png -------------------------------------------------------------------------------- /screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dlowe-net/irken/HEAD/screenshot.png -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2017 Daniel Lowe 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. -------------------------------------------------------------------------------- /plugins/daybreak.tcl: -------------------------------------------------------------------------------- 1 | ### daybreak Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | # Description: 4 | # 5 | # Inserts a line into every channel at midnight every day, to 6 | # disambiguate timestamps which do not include the date. 7 | # 8 | 9 | namespace eval ::irken::daybreak { 10 | namespace import ::irken::* 11 | 12 | proc timeuntilmidnight {} { 13 | set nextmidnight [clock add [clock scan [clock format [clock seconds] -format {%Y-%m-%d}] -format {%Y-%m-%d}] 1 day] 14 | return [expr {$nextmidnight * 1000 - [clock milliseconds]}] 15 | } 16 | 17 | proc outputbreak {} { 18 | set breaktext "- [clock format [clock seconds] -format {%Y-%m-%d}] -" 19 | foreach chanid [dict keys $::channelinfo] { 20 | irken::addchantext $chanid $breaktext -tags system 21 | } 22 | after [timeuntilmidnight] [namespace code {outputbreak}] 23 | } 24 | 25 | after [timeuntilmidnight] [namespace code {outputbreak}] 26 | } 27 | -------------------------------------------------------------------------------- /plugins/reconnect.tcl: -------------------------------------------------------------------------------- 1 | ### reconnect Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | # Description: 4 | # 5 | # Automatically reconnects a server that has been disconnected, using 6 | # limited exponential falloff plus jitter on failure. 7 | # 8 | 9 | namespace eval ::irken::reconnect { 10 | namespace import ::irken::* 11 | variable failures {} 12 | 13 | hook ready reconnect 50 {serverid} { 14 | variable failures 15 | dict unset failures $serverid 16 | } 17 | 18 | hook disconnection reconnect 50 {serverid} { 19 | variable failures 20 | 21 | dict incr failures $serverid 22 | set fails [dict get $failures $serverid] 23 | set capped [expr {min(10, $fails)}] 24 | set wait [expr {int(100 * (pow(2.0, $capped) + rand()))}] 25 | irken::addchantext $serverid [format "Reconnecting in %.2f seconds (attempt %d)..." [expr {$wait / 1000.0}] $fails] -tags system 26 | after $wait [list ::irken::connect $serverid] 27 | } 28 | } 29 | -------------------------------------------------------------------------------- /plugins/restorewinpos.tcl: -------------------------------------------------------------------------------- 1 | ### restorewinpos Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | # Description: 4 | # 5 | # Restores the position and size of the main window on startup. 6 | # 7 | namespace eval ::irken::restorewinpos { 8 | variable confpath "$::env(HOME)/.config/irken/restorewinpos.conf" 9 | 10 | proc restorewindows {geometry} { 11 | wm geometry . $geometry 12 | } 13 | 14 | proc savewindowpos {} { 15 | variable confpath 16 | if {![catch {open $confpath w} fp]} { 17 | puts $fp "restorewindows \"[wm geometry .]\"" 18 | close $fp 19 | } else { 20 | ::irken::addchantext $::active "Warning: unable to write to $confpath" -tags {fg_red italic} 21 | } 22 | } 23 | 24 | hook setupui restorewinpos 50 {} { 25 | variable confpath 26 | bind . [namespace code {savewindowpos}] 27 | if {[file exists $confpath]} { 28 | source $confpath 29 | } 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /plugins/rot13.tcl: -------------------------------------------------------------------------------- 1 | ### rot13 Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | # Description: 4 | # 5 | # Adds a popup menu that rot13s a selection in the main text area. 6 | # 7 | 8 | namespace eval ::irken::rot13 { 9 | namespace import ::irken::* 10 | 11 | hook setupui rot13 50 {} { 12 | .t.popup add command -label "Rot13 Text" -state disabled -command [namespace code {textreplacerot13}] 13 | .t tag config rot13 -background {pale turquoise} 14 | .t tag lower rot13 sel 15 | } 16 | 17 | hook textpopup rot13 50 {x y rootx rooty} { 18 | .t.popup entryconfigure "Rot13 Text" -state [expr {([.t tag ranges sel] eq "") ? "disabled":"normal"}] 19 | } 20 | 21 | proc rot13 {text} { 22 | return [string map {a n b o c p d q e r f s g t h u i v j w k x l y m z n a o b p c q d r e s f t g u h v i w j x k y l z m A N B O C P D Q E R F S G T H U I V J W K X L Y M Z N A O B P C Q D R E S F T G U H V I W J X K Y L Z M} $text] 23 | } 24 | 25 | proc textreplacerot13 {} { 26 | foreach {start end} [.t tag ranges sel] { 27 | set text [rot13 [.t get $start $end]] 28 | .t configure -state normal 29 | .t delete $start $end 30 | .t insert $start $text {rot13 line} 31 | .t configure -state disabled 32 | } 33 | } 34 | 35 | hook cmdROT13 rot13 50 {serverid arg} { 36 | hook call cmdMSG [serverpart $::active] "[channelpart $::active] [rot13 $arg]" 37 | } 38 | } 39 | -------------------------------------------------------------------------------- /plugins/filterjoins.tcl: -------------------------------------------------------------------------------- 1 | ### filterjoins Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | # Description: 4 | # 5 | # Intelligently filters out joins, parts, and quit messages from 6 | # your channel display. These messages will only be shown for nicks 7 | # that have spoken in the recent past. 8 | # 9 | # Set filterjoinslimit to specify the number of minutes that qualifies 10 | # as recent 11 | namespace eval ::irken::filterjoins { 12 | namespace import ::irken::* 13 | variable recentlimit 30 14 | variable lastspoke {} 15 | 16 | hook handlePRIVMSG filterjoins 70 {serverid msg} { 17 | # mark when someone speaks in a channel 18 | variable lastspoke 19 | dict set lastspoke $serverid [dict get $msg src] [clock seconds] 20 | } 21 | proc worthy {serverid nick} { 22 | variable lastspoke 23 | variable recentlimit 24 | if {[isself $serverid $nick]} { 25 | return 1 26 | } 27 | if {![dict exists $lastspoke $serverid $nick]} { 28 | return 0 29 | } 30 | if {[dict get $lastspoke $serverid $nick] < [clock seconds] - 60 * $recentlimit} { 31 | dict unset lastspoke $serverid $nick 32 | return 0 33 | } 34 | return 1 35 | } 36 | 37 | # Irken display priorities are set to 75, so return -code breaking here will 38 | # prevent the messages from being displayed. 39 | hook handleJOIN filterjoins 70 {serverid msg} { 40 | if {[worthy $serverid [dict get $msg src]]} { 41 | return 42 | } 43 | return -code break 44 | } 45 | hook handlePART filterjoins 70 {serverid msg} { 46 | if {[worthy $serverid [dict get $msg src]]} { 47 | return 48 | } 49 | return -code break 50 | } 51 | hook handleQUIT filterjoins 70 {serverid msg} { 52 | if {[worthy $serverid [dict get $msg src]]} { 53 | return 54 | } 55 | return -code break 56 | } 57 | } 58 | -------------------------------------------------------------------------------- /plugins/debug.tcl: -------------------------------------------------------------------------------- 1 | namespace eval ::irken::debug { 2 | 3 | variable enabled true 4 | 5 | hook cmdCOLORTEST debug 50 {serverid arg} { 6 | set text {} 7 | dict for {code color} $::codetagcolormap { 8 | append text "\x03,$code $color \x03 " 9 | } 10 | append text "\n" 11 | dict for {code color} $::codetagcolormap { 12 | append text "\x03$code $color \x03 " 13 | } 14 | append text "\n" 15 | append text "\x033\x02This\x02 is \x1dcolor \x1ftext\x1d with\x1f a http://www.\x02google\x02.com/ link embedded.\n" 16 | addchantext $::active "*" $text {} 17 | } 18 | 19 | proc setupwin {} { 20 | toplevel .debug 21 | wm title .debug "Irken Debug" 22 | text .debug.t -state disabled 23 | pack .debug.t -fill both -expand 1 24 | .debug.t tag config input -foreground blue 25 | .debug.t tag config output -foreground red 26 | bind .debug {if {"%W" == ".debug"} {set ::irken::debug::enabled false}} 27 | } 28 | 29 | hook cmdDEBUG debug 50 {serverid arg} { 30 | variable enabled 31 | 32 | if {$enabled} { 33 | set enabled false 34 | destroy .debug 35 | } else { 36 | set enabled true 37 | setupwin 38 | } 39 | } 40 | 41 | hook setupui debug 50 {} { 42 | variable enabled 43 | set enabled true 44 | setupwin 45 | } 46 | 47 | proc insert {tag text} { 48 | set atbottom [expr {[lindex [.debug.t yview] 1] == 1.0}] 49 | .debug.t configure -state normal 50 | .debug.t insert end $text [list $tag] 51 | if {$atbottom} { 52 | .debug.t yview end 53 | } 54 | .debug.t configure -state disabled 55 | } 56 | 57 | namespace eval ::irc { 58 | namespace export send 59 | proc send {serverid str} { 60 | variable ::irken::debug::enabled 61 | if {$::irken::debug::enabled} { 62 | ::irken::debug::insert output "$serverid <- $str\u21b5\n" 63 | } 64 | set chan [dict get $::serverinfo $serverid chan] 65 | try { 66 | puts $chan $str 67 | } on error {err} { 68 | ::irken::addchantext $serverid "WRITE ERROR: $err" -tags system 69 | } 70 | flush $chan 71 | } 72 | } 73 | 74 | namespace eval ::irken { 75 | proc recv {chan} { 76 | variable ::irken::debug::enabled 77 | if {[catch {gets $chan line} len] || [eof $chan]} { 78 | disconnected $chan 79 | } elseif {$len != 0 && [set msg [parseline $line]] ne ""} { 80 | if {$::irken::debug::enabled} { 81 | ::irken::debug::insert input "[dict get $::servers $chan] -> $line\u21b5\n" 82 | } 83 | hook call [expr {[hook exists "handle[dict get $msg cmd]"] ? "handle[dict get $msg cmd]":"handleUnknown"}] [dict get $::servers $chan] $msg 84 | } 85 | } 86 | } 87 | } 88 | -------------------------------------------------------------------------------- /plugins/search.tcl: -------------------------------------------------------------------------------- 1 | ### search Irken Plugin - show matching lines from current channel 2 | # 3 | # Description: 4 | # 5 | # Adds commands: 6 | # /search ... - Search buffer for regex 7 | 8 | namespace eval ::irken::search { 9 | namespace import ::irc::* ::irken::* 10 | 11 | hook cmdSEARCH search 50 {serverid arg} { 12 | if {![winfo exists .search]} { 13 | toplevel .search 14 | wm iconphoto .search [image create photo -format png -data $::irkenicon] 15 | text .search.t -wrap word -font Irken.Fixed -state normal \ 16 | -tabs [list \ 17 | [expr {25 * [font measure Irken.Fixed 0]}] right \ 18 | [expr {26 * [font measure Irken.Fixed 0]}] left] 19 | # copy all the tags from the channel display 20 | foreach tag [.t tag names] { 21 | set tagconf {} 22 | foreach conf [.t tag configure $tag] { 23 | if {[lindex $conf 4] ne ""} { 24 | lappend tagconf [lindex $conf 0] [lindex $conf 4] 25 | } 26 | } 27 | if {$tagconf ne ""} { 28 | .search.t tag configure $tag {*}$tagconf 29 | } 30 | foreach bindName [.t tag bind $tag] { 31 | .search.t tag bind $tag $bindName [.t tag bind $tag $bindName] 32 | } 33 | } 34 | pack .search.t -fill both -expand 1 35 | bind .search {destroy .search} 36 | bind .search {.search.t yview scroll -1 page} 37 | bind .search {.search.t yview scroll 1 page} 38 | bind .search {if {[set r [.search.t tag nextrange sel 0.0]] ne ""} {clipboard clear; clipboard append [.search.t get {*}$r]}} 39 | } else { 40 | .search.t configure -state normal 41 | .search.t delete 1.0 end 42 | } 43 | wm title .search "$::active Search Results: $arg" 44 | 45 | set found 0 46 | set idxs [.t search -all -nocase -regexp $arg 1.0] 47 | set linenums [lsort -unique [lmap idx $idxs {regexp -inline {^\d+} $idx}]] 48 | foreach linenum $linenums { 49 | # grab each tagged line and insert into our own text widget 50 | foreach {key value index} [.t dump -tag -text $linenum.0 $linenum.end] { 51 | set destline [expr {[regexp -inline {^\d+} [.search.t index end]] - 1}] 52 | set index [string cat $destline "." [regexp -inline {[0-9]+$} $index]] 53 | switch $key \ 54 | { 55 | text { .search.t insert end $value } 56 | tagon {set tagstart($value) $index} 57 | tagoff { 58 | if {[info exists tagstart($value)]} { 59 | .search.t tag add $value $tagstart($value) $index 60 | array unset tagstart $value 61 | } 62 | } 63 | } 64 | } 65 | # apply unadded tags 66 | foreach tag [array names tagstart] { 67 | .search.t tag add $tag $tagstart($tag) end 68 | array unset tagstart $tag 69 | } 70 | .search.t insert end "\n" {} 71 | } 72 | if {[llength $linenums] == 0} { 73 | .search.t insert end "No results found." -tags system 74 | } 75 | .search.t configure -state disabled 76 | } 77 | } 78 | -------------------------------------------------------------------------------- /plugins/ijchain.tcl: -------------------------------------------------------------------------------- 1 | ### ijchain Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | # Description: 4 | # 5 | # ijchain and ischain are bots bridging jabber and slack chat to the 6 | # #tcl channel on freenode.net. This plugin makes messages sent 7 | # through the bots appear as if they are occurring in the IRC 8 | # channel. 9 | 10 | namespace eval ::irken::ijchain { 11 | namespace import ::irc::* ::irken::* 12 | variable bots {ijchain ischain} 13 | 14 | proc decoratenick {bot nick} { 15 | if {$bot eq "ijchain"} { 16 | return [string cat $nick "@"] 17 | } 18 | return [string cat $nick "%"] 19 | } 20 | 21 | proc isbotnick {nick} { 22 | variable bots 23 | return [expr {[lsearch -exact $bots $nick] == -1}] 24 | } 25 | 26 | hook handleJOIN ijchain 75 {chanid msg} { 27 | variable bots 28 | if {[lindex [dict get $msg args] 0] ne "#tcl"} { 29 | return 30 | } 31 | if {[isself [irken::serverpart $chanid] [dict get $msg src]]} { 32 | foreach bot $bots { 33 | send [irken::serverpart $chanid] "PRIVMSG $bot :names" 34 | } 35 | return 36 | } 37 | if {[dict get $msg src] in $bots} { 38 | send [irken::serverpart $chanid] "PRIVMSG [dict get $msg src] :names" 39 | } 40 | } 41 | 42 | hook ctcpACTION ijchain 30 {chanid msg text} { 43 | set bot [dict get $msg src] 44 | if {[isbotnick $bot]} { 45 | return 46 | } 47 | if {[regexp -- {^(\S+) has become available$} $text -> nick]} { 48 | hook call handleJOIN [irken::serverpart $chanid] [dict replace $msg src [decoratenick $bot $nick]] 49 | return -code break 50 | } 51 | if {[regexp -- {^(\S+) has left$} $text -> nick]} { 52 | hook call handlePART [irken::serverpart $chanid] [dict replace $msg src [decoratenick $bot $nick] args [lrange [dict get $msg args] 0 0]] 53 | return -code break 54 | } 55 | if {[regexp -- {^(\S+) (.*)} $text -> nick text]} { 56 | return -code continue [list $chanid [dict replace $msg src [decoratenick $bot $nick]] $text] 57 | } 58 | } 59 | 60 | hook handlePRIVMSG ijchain 15 {serverid msg} { 61 | set bot [dict get $msg src] 62 | if {[isbotnick $bot]} { 63 | return 64 | } 65 | if {[ischannel [chanid $serverid [lindex [dict get $msg args] 0]]]} { 66 | # On channel 67 | if {[regexp -- {^<([^>]+)> (.*)} [lindex [dict get $msg args] 1] -> nick text]} { 68 | return -code continue [list $serverid [dict replace $msg src [decoratenick $bot $nick]]] 69 | } elseif {[regexp -- {^(\w+) (.*)} [lindex [dict get $msg args] 1] -> nick text]} { 70 | return -code continue [list $serverid [dict replace $msg src [decoratenick $bot $nick]]] 71 | } 72 | return 73 | } 74 | # Private message 75 | if {[regexp -- {^(\S+) whispers (.*)} [lindex [dict get $msg args] 1] -> nick text]} { 76 | set nick [decoratenick $nick] 77 | return -code break [list $serverid [dict replace $msg src $nick args [list $nick $text]]] 78 | } 79 | 80 | # Must be the names of correspondents 81 | foreach nick [split [lindex [dict get $msg args] 1] " "] { 82 | lappend names [decoratenick $bot $nick] 83 | } 84 | hook call handle353 $serverid \ 85 | [dict create args [list "ignore" "*" "#tcl" $names]] 86 | 87 | # Don't display this message 88 | return -code break 89 | } 90 | } 91 | -------------------------------------------------------------------------------- /plugins/ignore.tcl: -------------------------------------------------------------------------------- 1 | ### ignore Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | # Description: 4 | # 5 | # Filters out messages from a given nick. Adds two commands: 6 | # /IGNORE - View ignore list 7 | # /IGNORE - Add nick to ignore list 8 | # /UNIGNORE Remove nick from ignore list 9 | # 10 | 11 | namespace eval ::irken::ignore { 12 | variable ignorelist {} 13 | variable confpath "~/.config/irken/ignore.conf" 14 | 15 | proc ignorenicks {args} { 16 | variable ignorelist 17 | set targets {} 18 | foreach nick $args { 19 | if {[lsearch -exact $ignorelist $nick] == -1} { 20 | lappend targets $nick 21 | lappend ignorelist $nick 22 | } 23 | } 24 | return $targets 25 | } 26 | 27 | proc updateignoreconf {} { 28 | variable confpath 29 | variable ignorelist 30 | if {![catch {open $confpath w} fp]} { 31 | puts $fp "ignorenicks $ignorelist" 32 | close $fp 33 | } else { 34 | addchantext $::active "Warning: unable to write to $confpath" -tags {fg_red italic} 35 | } 36 | } 37 | 38 | hook handle001 ignore 10 {serverid msg} { 39 | variable confpath 40 | if {[file exists $confpath]} { 41 | source $confpath 42 | } 43 | } 44 | 45 | hook handlePRIVMSG ignore 40 {serverid msg} { 46 | variable ignorelist 47 | if {[lsearch -exact $ignorelist [dict get $msg src]] != -1} { 48 | return -code break 49 | } 50 | } 51 | 52 | hook handleNOTICE ignore 40 {serverid msg} { 53 | variable ignorelist 54 | if {[lsearch -exact $ignorelist [dict get $msg src]] != -1} { 55 | return -code break 56 | } 57 | } 58 | 59 | hook handleJOIN ignore 60 {serverid msg} { 60 | variable ignorelist 61 | if {[lsearch -exact $ignorelist [dict get $msg src]] != -1} { 62 | return -code break 63 | } 64 | } 65 | 66 | hook handlePART ignore 60 {serverid msg} { 67 | variable ignorelist 68 | if {[lsearch -exact $ignorelist [dict get $msg src]] != -1} { 69 | return -code break 70 | } 71 | } 72 | 73 | hook handleQUIT ignore 60 {serverid msg} { 74 | variable ignorelist 75 | if {[lsearch -exact $ignorelist [dict get $msg src]] != -1} { 76 | return -code break 77 | } 78 | } 79 | 80 | hook cmdIGNORE ignore 50 {serverid arg} { 81 | variable ignorelist 82 | if {$arg eq ""} { 83 | if {[llength $ignorelist] == 0} { 84 | addchantext $::active "You are not ignoring anyone." -tags italic 85 | } else { 86 | addchantext $::active "Ignoring: $ignorelist" -tags italic 87 | } 88 | return 89 | } 90 | set targets [ignorenicks [split $arg " "]] 91 | if {$targets eq ""} { 92 | addchantext $::active "No nicks added to ignore list." -tags italic 93 | } else { 94 | addchantext $::active "Added to ignore list: $targets" -tags italic 95 | updateignoreconf 96 | } 97 | } 98 | 99 | hook cmdUNIGNORE ignore 50 {serverid arg} { 100 | variable ignorelist 101 | if {$arg eq ""} { 102 | if {[llength $ignorelist] == 0} { 103 | addchantext $::active "You are not ignoring anyone." -tags italic 104 | } else { 105 | addchantext $::active "Ignoring: $ignorelist" -tags italic 106 | } 107 | return 108 | } 109 | set targets {} 110 | foreach nick [split $arg " "] { 111 | if {[lsearch -exact $ignorelist $nick] != -1} { 112 | lappend targets $nick 113 | set ignorelist [lsearch -all -not -exact $ignorelist $nick] 114 | } 115 | } 116 | if {$targets eq ""} { 117 | addchantext $::active "No nicks removed from ignore list." -tags italic 118 | } else { 119 | addchantext $::active "Removed from ignore list: $targets" -tags italic 120 | updateignoreconf 121 | } 122 | } 123 | } 124 | -------------------------------------------------------------------------------- /plugins/aliases.tcl: -------------------------------------------------------------------------------- 1 | ### aliases Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | # Description: 4 | # 5 | # Allows the user to create user-defined commands. These 6 | # user-defined commands are expanded using TCL rules. The variables 7 | # $1, $2, $3... expand to space delimited arguments in the alias 8 | # invocation. The variables $1_, $2_, $3_ expand to the rest of the 9 | # string, starting at the numbered word. 10 | # 11 | # Adds commands: 12 | # /ALIAS - list defined aliases 13 | # /ALIAS - show matching aliases 14 | # /ALIAS [;...] - add an alias 15 | # /UNALIAS - remove alias 16 | 17 | namespace eval ::irken::aliases { 18 | namespace import ::irken::* 19 | 20 | variable confpath "~/.config/irken/aliases.conf" 21 | variable aliases {} 22 | 23 | proc alias {alias cmd} { 24 | variable aliases 25 | dict set aliases $alias $cmd 26 | } 27 | 28 | proc updatealiases {} { 29 | variable aliases 30 | variable confpath 31 | if {![catch {open $confpath w} fp]} { 32 | dict for {alias cmd} $aliases { 33 | puts $fp "alias [list $alias] [list $cmd]" 34 | } 35 | close $fp 36 | } else { 37 | addchantext $::active "Warning: unable to write to $confpath" -tags {fg_red italic} 38 | } 39 | } 40 | 41 | hook setupui aliases 50 {} { 42 | variable confpath 43 | catch {source $confpath} 44 | } 45 | 46 | hook cmdALIAS aliases 50 {serverid arg} { 47 | variable ::irken::aliases::aliases 48 | regexp {^(\S*)\s?(.*)} $arg -> cmd expansion 49 | if {$expansion eq ""} { 50 | if {$aliases eq ""} { 51 | addchantext $::active "No aliases defined." -tags {system} 52 | return -code break 53 | } 54 | set keys [lsort [dict keys $aliases]] 55 | if {$cmd ne ""} { 56 | set keys [lsearch -regexp -nocase -all -inline $keys $cmd] 57 | } 58 | foreach key $keys { 59 | addchantext $::active "$key - [dict get $aliases $key]" -tags {system} 60 | } 61 | return -code break 62 | } 63 | if {[regexp {^/} $cmd]} { 64 | addchantext $::active "Aliases must not begin with a /" -tags system 65 | return 66 | } 67 | set cmd [string toupper $cmd] 68 | dict set aliases $cmd $expansion 69 | addchantext $::active "Alias $cmd set to $expansion" -tags {system} 70 | ::irken::aliases::updatealiases 71 | return -code break 72 | } 73 | 74 | hook cmdUNALIAS aliases 50 {serverid arg} { 75 | variable ::irken::aliases::aliases 76 | set arg [string toupper $arg] 77 | if {![dict exists $aliases $arg]} { 78 | addchantext $::active "No such alias $arg." -tags {system} 79 | return -code break 80 | } 81 | dict unset aliases $arg 82 | addchantext $::active "Alias $arg removed." -tags {system} 83 | ::irken::aliases::updatealiases 84 | return -code break 85 | } 86 | 87 | variable doingalias 0 88 | 89 | hook docmd aliases 25 {serverid cmd arg} { 90 | variable aliases 91 | variable doingalias 92 | set cmd [string toupper $cmd] 93 | if {![dict exists $aliases $cmd]} { 94 | return 95 | } 96 | if {$doingalias} { 97 | # Don't recurse 98 | addchantext $::active "Ignoring recursive alias $cmd $arg" -tags {system} 99 | return 100 | } 101 | set pos 0 102 | set argstarts [list 0] 103 | set argnum 1 104 | while {[regexp -indices -start $pos {\S+} $arg found]} { 105 | lassign $found start end 106 | set $argnum [string range $arg $start $end] 107 | set ${argnum}_ [string range $arg $start end] 108 | set pos [expr {$end + 1}] 109 | incr argnum 110 | } 111 | set doingalias 1 112 | foreach text [split [dict get $aliases $cmd] ";"] { 113 | hook call userinput [subst $text] 114 | } 115 | set doingalias 0 116 | } 117 | } 118 | -------------------------------------------------------------------------------- /plugins/dtnotify.tcl: -------------------------------------------------------------------------------- 1 | ### dtnotify Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | # Description: 4 | # 5 | # Displays desktop notification when nick is mentioned on a channel 6 | # or privmsg is received. 7 | # 8 | 9 | namespace eval ::irken::dtnotify { 10 | namespace import ::irken::* 11 | variable sendcmd "/usr/bin/notify-send" 12 | variable ignore {} 13 | variable servers {} 14 | variable confpath "~/.config/irken/dtnotify.conf" 15 | 16 | proc dtnotifyignore {args} { 17 | variable ignore 18 | set targets {} 19 | foreach nick $args { 20 | if {[lsearch -exact $ignore $nick] == -1} { 21 | lappend targets $nick 22 | lappend ignore $nick 23 | } 24 | } 25 | return $targets 26 | } 27 | 28 | proc updatedtnotifyconf {} { 29 | variable confpath 30 | variable ignore 31 | if {![catch {open $confpath w} fp]} { 32 | puts $fp "dtnotifyignore $ignore\n" 33 | close $fp 34 | } else { 35 | addchantext $::active "Warning: unable to write to $confpath" -tags {fg_red italic} 36 | } 37 | } 38 | 39 | proc execescape {str} { 40 | return [regsub -all {[|<>&]} $str {\\&}] 41 | } 42 | 43 | hook disconnection dtnotify 50 {serverid} { 44 | # remove from set of dtnotify-ready servers 45 | variable servers 46 | set servers [lsearch -all -not -exact $servers $serverid] 47 | } 48 | 49 | hook handle001 dtnotify 10 {serverid msg} { 50 | variable confpath 51 | variable servers 52 | if {[file exists $confpath]} { 53 | source $confpath 54 | } 55 | lappend servers $serverid 56 | } 57 | 58 | hook handlePRIVMSG dtnotify 90 {serverid msg} { 59 | variable ignore 60 | variable sendcmd 61 | variable servers 62 | if {[focus] ne ""} { 63 | # Don't send messages if irken window has focus 64 | return 65 | } 66 | if {[lsearch -exact $servers $serverid] == -1} { 67 | # Don't send messages until we are logged into server 68 | return 69 | } 70 | if {[lsearch -exact $ignore [dict get $msg src]] != -1} { 71 | # Don't send messages from dtnotify-ignored nicks 72 | return 73 | } 74 | if {[isself $serverid [lindex [dict get $msg args] 0]]} { 75 | # Dtnotify on private message 76 | exec -- $sendcmd -c im.received "'Message from [dict get $msg src]'" "'[execescape [lindex [dict get $msg args] 1]]'" 77 | return 78 | } 79 | if {[string first [dict get $::serverinfo $serverid nick] [lindex [dict get $msg args] 0]] != -1} { 80 | # Dtnotify on channel mention 81 | exec -- $sendcmd -c im.received "'Mention on [lindex [dict get $msg args] 0]'" "'\\<[dict get $msg src]\\> [execescape [lindex [dict get $msg args] 1]]'" 82 | return 83 | } 84 | } 85 | 86 | hook cmdDTNOTIFY dtnotify 50 {serverid arg} { 87 | variable ignore 88 | set args [lassign [split $arg " "] cmd] 89 | switch -exact -nocase -- $cmd { 90 | "ignore" { 91 | if {$args eq ""} { 92 | if {$ignore eq ""} { 93 | addchantext $::active "Desktop notification ignore list is empty" 94 | } else { 95 | addchantext $::active "Desktop notification ignore list: $ignore" 96 | } 97 | return 98 | } 99 | lappend ignore {*}$args 100 | updatedtnotifyconf 101 | addchantext $::active "Ignoring $args for desktop notifications" 102 | } 103 | "unignore" { 104 | foreach nick $args { 105 | set ignore [lsearch -all -not -exact $ignore $nick] 106 | } 107 | updatedtnotifyconf 108 | addchantext $::active "Unignoring $args for desktop notifications" 109 | } 110 | default { 111 | addchantext $::active "Usage /dtnotify (ignore|unignore) " 112 | } 113 | } 114 | } 115 | } 116 | -------------------------------------------------------------------------------- /plugins/inlineimages.tcl: -------------------------------------------------------------------------------- 1 | ### inlineimages Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | ## Description: 4 | # 5 | # When a link ending in jpg, gif, or png is posted, automatically 6 | # retrieves the images and displays them in-line. 7 | # 8 | ## Requirements: 9 | # 10 | # This plugin requires installation of tcllib and imagemagick. 11 | # 12 | 13 | package require tls 14 | package require http 15 | 16 | namespace eval ::irken::inlineimages { 17 | 18 | # an image needs to be inserted on these conditions: 19 | # - when selectchan is called, we need to swap out the images 20 | # - when a cached image url is inserted into ACTIVE text 21 | # - when an uncached image url is retrieved AND the channel is active 22 | 23 | # ::urlimages is a mapping from urls to images, used for caching image 24 | # data retrieved from the network. 25 | if {[info vars ::urlimages] eq ""} { 26 | set ::urlimages [dict create] 27 | } 28 | 29 | # ::chanimages is a per-channel list of {pos url}, used for 30 | # reconstructing the displayed images after channel selection. 31 | if {[info vars ::chanimages] eq ""} { 32 | set ::chanimages [dict create] 33 | } 34 | 35 | http::register https 443 tls::socket 36 | 37 | set ::charsinsertedperimage 2 38 | 39 | proc imageatpos {pos image} { 40 | .t image create "0.0 + $pos chars" -image $image -pady 5 41 | .t configure -state normal 42 | .t insert "0.1 + $pos chars" "\n" {} 43 | .t configure -state disabled 44 | } 45 | 46 | proc receiveimage {url token} { 47 | if {[::http::ncode $token] != 200} { 48 | ::http::cleanup $token 49 | return 50 | } 51 | if {[catch {::http::data $token} httpdata]} { 52 | ::http::cleanup $token 53 | return 54 | } 55 | if {[catch {open "|convert -geometry 300x300 - png:-" wb+} fp]} { 56 | ::http::cleanup $token 57 | return 58 | } 59 | puts -nonewline $fp $httpdata 60 | close $fp w 61 | set scaleddata [read $fp] 62 | close $fp r 63 | if {[catch {image create photo -data $scaleddata} scaled]} { 64 | ::http::cleanup $token 65 | return 66 | } 67 | dict set ::urlimages $url $scaled 68 | for {imagepos} [dict get? {} $::chanimages $active] { 69 | lassign $imagepos pos imageurl 70 | if {$url eq $imageurl} { 71 | imageatpos $imagepos $scaled 72 | } 73 | } 74 | ::http::cleanup $token 75 | } 76 | 77 | hook textinserted imgur 75 {chanid taggedtext} { 78 | foreach {newtext tag} $taggedtext { 79 | append text $newtext 80 | } 81 | # each image occupies one index in the text 82 | set imagepos [expr {$::charsinsertedperimage * [llength [dict get? {} $::chanimages $chanid]]}] 83 | incr imagepos -1 84 | foreach {chantext tag} [dict get $::channeltext $chanid] { 85 | incr imagepos [string length $chantext] 86 | } 87 | set start 0 88 | while {[regexp -indices -start $start -- {https?://[-a-zA-Z0-9@:%_/\+.~#?&=,:()]+?\.(?:jpg|gif|png)} $text urlrange]} { 89 | set url [string range $text {*}$urlrange] 90 | dict lappend ::chanimages $chanid [list $imagepos $url] 91 | if {[dict exists $::urlimages $url]} { 92 | if {$chanid eq $::active} { 93 | set image [dict get $::urlimages $url] 94 | if {$image ne ""} { 95 | imageatpos $imagepos $image 96 | } 97 | } 98 | } else { 99 | dict set ::urlimages $url "" 100 | http::geturl $url -binary 1 -command "receiveimage $url" 101 | } 102 | incr start [expr {[lindex $urlrange 1] + 1}] 103 | } 104 | } 105 | 106 | hook chanselected imgur 75 {chanid} { 107 | foreach {imagepos} [dict get? {} $::chanimages $chanid] { 108 | lassign $imagepos pos url 109 | set image [dict get? "" $::urlimages $url] 110 | if {$image ne ""} { 111 | imageatpos $pos $image 112 | } 113 | } 114 | } 115 | } 116 | -------------------------------------------------------------------------------- /plugins/popupmenus.tcl: -------------------------------------------------------------------------------- 1 | ### popupmenus Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | # Description: 4 | # 5 | # Adds popup menus for operations on servers, channels, and users. 6 | # 7 | 8 | namespace eval ::irken::popupmenus { 9 | namespace import ::irken::* 10 | 11 | variable target {} 12 | 13 | hook setupui popupmenus 50 {} { 14 | menu .nav.servermenu -tearoff 0 15 | .nav.servermenu add command -label "Server name" -state disabled 16 | .nav.servermenu add separator 17 | .nav.servermenu add command -label "Connect" -command [namespace code {serverconnect}] 18 | .nav.servermenu add command -label "Disconnect" -command [namespace code {serverdisconnect}] 19 | .nav tag bind server [namespace code {serverpopup %x %y %X %Y}] 20 | menu .nav.channelmenu -tearoff 0 21 | .nav.channelmenu add command -label "Channel name" -state disabled 22 | .nav.channelmenu add separator 23 | .nav.channelmenu add command -label "Join" -command [namespace code {channeljoin}] 24 | .nav.channelmenu add command -label "Part" -command [namespace code {channelpart}] 25 | .nav.channelmenu add separator 26 | .nav.channelmenu add command -label "Close" -command [namespace code {channelclose}] 27 | .nav tag bind channel [namespace code {channelpopup %x %y %X %Y}] 28 | menu .nav.directmenu -tearoff 0 29 | .nav.directmenu add command -label "Nick" -state disabled 30 | .nav.directmenu add separator 31 | .nav.directmenu add command -label "Whois" -command [namespace code {directwhois}] 32 | .nav.directmenu add separator 33 | .nav.directmenu add command -label "Close" -command [namespace code {directclose}] 34 | .nav tag bind direct [namespace code {directpopup %x %y %X %Y}] 35 | menu .users.usermenu -tearoff 0 36 | .users.usermenu add command -label "Nick" -state disabled 37 | .users.usermenu add separator 38 | .users.usermenu add command -label "Whois" -command [namespace code {directwhois}] 39 | .users.usermenu add command -label "Query" -command [namespace code {userquery}] 40 | .users.usermenu add separator 41 | .users.usermenu add command -label "Close" 42 | bind .users [namespace code {userpopup %x %y %X %Y}] 43 | } 44 | 45 | proc serverpopup {x y rootx rooty} { 46 | variable target 47 | set target [.nav identify item $x $y] 48 | .nav.servermenu entryconfigure 0 -label $target 49 | if {[.nav tag has disabled $target]} { 50 | .nav.servermenu entryconfigure 2 -state normal 51 | .nav.servermenu entryconfigure 3 -state disabled 52 | } else { 53 | .nav.servermenu entryconfigure 2 -state disabled 54 | .nav.servermenu entryconfigure 3 -state normal 55 | } 56 | tk_popup .nav.servermenu $rootx $rooty 57 | } 58 | 59 | proc serverdisconnect {} { 60 | variable target 61 | irken::disconnected [dict get $::serverinfo $target chan] 62 | } 63 | 64 | proc serverconnect {} { 65 | variable target 66 | irken::connect $target 67 | } 68 | 69 | proc channelpopup {x y rootx rooty} { 70 | variable target 71 | set target [.nav identify item $x $y] 72 | .nav.channelmenu entryconfigure 0 -label $target 73 | if {[.nav tag has disabled $target]} { 74 | .nav.channelmenu entryconfigure 2 -state normal 75 | .nav.channelmenu entryconfigure 3 -state disabled 76 | .nav.channelmenu entryconfigure 5 -state disabled 77 | } else { 78 | .nav.channelmenu entryconfigure 2 -state disabled 79 | .nav.channelmenu entryconfigure 3 -state normal 80 | .nav.channelmenu entryconfigure 5 -state normal 81 | } 82 | tk_popup .nav.channelmenu $rootx $rooty 83 | } 84 | 85 | proc channeljoin {} { 86 | variable target 87 | set serverid [irken::serverpart $target] 88 | set chan [irken::channelpart $target] 89 | irken::send $serverid "JOIN :$chan" 90 | } 91 | 92 | proc channelpart {} { 93 | variable target 94 | set serverid [irken::serverpart $target] 95 | set chan [irken::channelpart $target] 96 | irken::send $serverid "PART :$chan" 97 | 98 | } 99 | 100 | proc channelclose {} { 101 | variable target 102 | set serverid [irken::serverpart $target] 103 | set chan [irken::channelpart $target] 104 | irken::send $serverid "PART :$chan" 105 | irken::removechan $target 106 | } 107 | 108 | proc directpopup {x y rootx rooty} { 109 | variable target 110 | set target [.nav identify item $x $y] 111 | .nav.directmenu entryconfigure 0 -label $target 112 | tk_popup .nav.directmenu $rootx $rooty 113 | } 114 | 115 | proc userpopup {x y rootx rooty} { 116 | variable target 117 | set nick [.users identify item $x $y] 118 | set serverid [irken::serverpart [.nav selection]] 119 | set target [irken::chanid $serverid $nick] 120 | .users.usermenu entryconfigure 0 -label $target 121 | tk_popup .users.usermenu $rootx $rooty 122 | } 123 | 124 | proc directwhois {} { 125 | variable target 126 | set serverid [irken::serverpart $target] 127 | set nick [irken::channelpart $target] 128 | irken::send $serverid "WHOIS :$nick" 129 | } 130 | 131 | proc directclose {} { 132 | variable target 133 | irken::removechan $target 134 | } 135 | 136 | proc userquery {} { 137 | variable target 138 | irken::ensurechan $target "" {} 139 | .nav selection set $target 140 | irken::selectchan 141 | } 142 | } 143 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Irken 2 | ======= 3 | 4 | Irken is an attempt to build a small, functional, IRC client in Tcl/Tk. It 5 | aims to honor as much of IRC as possible while still remaining small enough to 6 | understand by tinkerers. 7 | 8 | Features 9 | -------- 10 | 11 | - supports multiple IRC servers 12 | - adjustable three-pane interface 13 | - highlights mentions of your nick 14 | - clickable hyperlinks 15 | - topic editing 16 | - event hooks for easy customization 17 | - nick tab completion 18 | - presence notification 19 | - command history 20 | - color and formatting 21 | 22 | ![Screenshot](https://raw.githubusercontent.com/dlowe-net/irken/master/screenshot.png) 23 | 24 | Running 25 | ------- 26 | 27 | These instructions are for Linux. Windows support is unlikely. 28 | 29 | 1. Install `tcl`, `tcllib`, `tcl-tls`, and `bwidget` - you need at least version 30 | 8.6 of TCL. For systems based on Debian (like Ubuntu or Linux 31 | Mint), you can run `sudo apt install tcl tcllib tcl-tls bwidget`. Feel 32 | free to contribute instructions for other distributions. 33 | 2. Copy or symlink any desired plugins into into `~/.config/irken/` You may 34 | have to make the directory. 35 | 3. Run `irken.tcl`. By default, it will create a configuration file that 36 | connects you to freenode.net and joins the #irken channel. 37 | 38 | Configuration 39 | ------------- 40 | 41 | On startup, if no configuration files are found, a file will be created at 42 | `~/.config/irken/irken.tcl` with a server entry. Any files ending with 43 | `.tcl` will in the configuration directory will be executed in alphabetical 44 | order. Since configuration is done with normal Tcl files, theoretically any 45 | customization can be achieved. 46 | 47 | Servers are configured with this command: 48 | 49 | server 50 | 51 | The server ID must not contain spaces. The options are these: 52 | 53 | * `-host` (required) server hostname 54 | * `-nick` (required) nick for connecting to server 55 | * `-port` (optional) server port for connection. Defaults to 6697 if `-insecure` is 56 | false, or 6667 if `-insecure` is true. 57 | * `-pass` (optional) password for server connection 58 | * `-insecure` (optional) use an un-encrypted connection if True 59 | * `-autoconnect` (optional) connect to server on startup if True 60 | * `-autojoin` (optional) a list of channels to join. specified like `{"#one" "#two"}` 61 | 62 | You may also wish to try some custom fonts, which you can do like this: 63 | 64 | font configure Irken.Fixed -family "Cousine" -size "10" 65 | 66 | Built-in commands 67 | ----------------- 68 | 69 | * `/CLOSE []` - remove the channel from the UI, leaving it if necessary 70 | * `/EVAL ` - evaluate a TCL command, and display the result 71 | * `/JOIN ` - join a channel on the current server 72 | * `/ME ` - send an action to the channel/person 73 | * `/MSG ` - opens a channel and sends a private message to another person. 74 | * `/PART []` - leave a channel on the current server 75 | * `/QUERY ` - open a channel to privately message another person 76 | * `/RELOAD` - reload the whole app. Used mostly for development. 77 | * `/SERVER ` - connect to a server. The server must already be configured. 78 | * `/` - sends the string verbatim to the server. 79 | 80 | Keyboard commands 81 | ----------------- 82 | 83 | * `Control-PageUp` / `Control-PageDown` - navigates to prev/next channel 84 | * `PageUp` / `PageDown` - pages up and down on the current window 85 | * `Up arrow` / `Down arrow` - on command line, goes into the past or future in the command history 86 | * `Tab` - on command line, completes nick at the cursor. Press tab again for 87 | next match. 88 | * `Return` - on topic line, sets the topic to whatever is in the text box 89 | * `Return` - on command line, either does the command or sends a message to the 90 | current channel. 91 | * `Control-space` - navigate to the next channel where there are unread 92 | messages. 93 | 94 | Included Plugins 95 | ---------------- 96 | 97 | Copy these to your .config/irken/ directory to activate. 98 | 99 | * `aliases` - Allows user-defined commands 100 | * `chanlist` - Adds a GUI for browsing the channel list returned by /LIST 101 | * `daybreak` - Every midnight, inserts the date into every channel so that you 102 | can tell on which day a given message was sent. 103 | * `dtnotify` - Creates a desktop notification when your nick is mentioned, using 104 | the /usr/bin/notify-send binary. Since the notification isn't controlled by 105 | irken, though, they tend to pile up. 106 | * `filterjoins` - Keeps track of who has talked in a channel, and hides 107 | join, part, and quit messages from those who haven't talked. 108 | * `friend` - Allows addition of "friends" per-server. Friends show up on the 109 | top of the user list in channels, their messages are highlighted in blue, and 110 | a message window is automatically opened for them on startup. 111 | * `ignore` - Allows you to ignore all messages from certain nicks. 112 | * `ijchain` - Implements integration with the ijchain and ischain bots 113 | in the freenode #tcl channel. 114 | * `inlineimages` - Displays images mentioned on IRC inline. 115 | * `popupmenus` - Add popup menus for operations on channels, servers, 116 | and users. 117 | * `restorewinpos` - Keeps track of your window position and opens it at the same 118 | place on startup. 119 | * `reconnect` - Automatically reconnects to servers when they 120 | disconnect. 121 | * `rot13` - Add popup menu command for decoding rot13 and a /rot13 command. 122 | * `search` - Adds /search command which outputs matching lines to 123 | a new window. 124 | 125 | Writing New Plugins 126 | ------------------- 127 | 128 | Plugins are implemented as Tcl files which are loaded on startup. Typically, a 129 | plugin will install hooks to add commands or respond to messages. Hooks are 130 | defined with the following command: 131 | 132 | hook 133 | 134 | When a hook's trigger occurs, each hook is called in order of priority. The 135 | hook's handle should be unique, and is used so that the hook may be redefined. 136 | 137 | A hook may return in one of three ways: 138 | 139 | - `return -code continue ` - continues processing to the next hook, but 140 | the parameter list will be set to the return value. 141 | - `return -code break` - stops hook processing. 142 | - normal return - continues processing to the next hook, ignoring the return 143 | value. 144 | 145 | In Irken, triggers are of the form `handleMESSAGE`, `ctcpMESSAGE`, or 146 | `cmdCOMMAND`. The priority of the normal irken handling of a hook is 50. 147 | These hooks should always execute, since much of the UI depends on them. The 148 | priority of normal irken message display is set to 75, so that plugins may 149 | block or change messages before they are displayed. 150 | 151 | `handleMESSAGE` hooks are passed a serverid and message, where message is a 152 | dict containing the fields: 153 | 154 | - `src`: the source of the message 155 | - `user`: username of the source 156 | - `host`: hostname of the source 157 | - `cmd`: command of the message 158 | - `args`: a list of the arguments for the command 159 | - `line`: the raw line from the server 160 | 161 | `cmdCOMMAND` hooks are passed a serverid and the string following the command. 162 | 163 | `tagchantext` hooks are called when a message is added to a channel. It is 164 | passed the text to be formatted and a list of ranges in the form `{ push 165 | }` or `{ pop }`. These hooks *must* return via `return -code 166 | continue`, with new ranges being appended to the old. 167 | 168 | Some useful hooks: 169 | 170 | - `handle001` - used for when the user is logged into the server and ready 171 | - `handlePRIVMSG` - used for when a message is received on a channel or privately 172 | - `cmdMSG` - used for sending all messages (but not actions) to a channel or 173 | privately. 174 | 175 | Make sure to look at the included plugins for inspiration! 176 | -------------------------------------------------------------------------------- /plugins/friend.tcl: -------------------------------------------------------------------------------- 1 | ### friend Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | # Description: 4 | # 5 | # Adds friending to IRC. Friended nicks occupy the highest spot on 6 | # channel userlists. They have a message channel open by default, 7 | # which also acts as an online/offline indicator. Their messages 8 | # are highlighted within a channel. 9 | # 10 | # Adds commands: 11 | # /FRIEND ... - Add nick as friend. 12 | # /UNFRIEND ... - Removes nick from friend list. 13 | 14 | namespace eval ::irken::friend { 15 | namespace import ::irc::* ::irken::* 16 | # Friends are stored as dicts> 17 | variable friends [dict create] 18 | variable confpath "~/.config/irken/friend.conf" 19 | variable icon {iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAAv0lEQVQ4y2NgGNQgcvLX/5FTvv7Hp4YFn+TLT/8JWsKES6Jj048WbGx0wIhLwqn1C4r1+6p5GHEakDL72/97r/6RFD5KYkwMc1K5GOGmkmIITDNKGMxJ5WJ002VpJaTZTZelFaYZaxjUrPr+9tjtv0LYNFupMr9rCeMUxhsLPByM03HZjk0Ow4A7L/9V4zLg7itMOQwDYAHJzQ6Jun3VPIzc7FADXv4jLiFZqTK/21yCiPfNJTyMVqrM7wZnhgMAIDJBRO161I8AAAAASUVORK5CYII=} 20 | 21 | proc friendnicks {serverid args} { 22 | variable friends 23 | set friendlist [dict get? {} friends $serverid] 24 | set targets {} 25 | 26 | foreach nick $args { 27 | if {$nick ni $friendlist} { 28 | lappend targets $nick 29 | dict lappend friends $serverid $nick 30 | } 31 | } 32 | return $targets 33 | } 34 | 35 | proc updatefriendconf {} { 36 | variable confpath 37 | variable friends 38 | if {![catch {open $confpath w} fp]} { 39 | dict for {serverid nicklist} $friends { 40 | if {$nicklist ne ""} { 41 | puts $fp "friendnicks $serverid [join $nicklist " "]" 42 | } 43 | } 44 | close $fp 45 | } else { 46 | addchantext $::active "Warning: unable to write to $confpath" -tags {fg_red italic} 47 | } 48 | } 49 | 50 | hook setupui friend 50 {} { 51 | variable confpath 52 | variable icon 53 | 54 | catch {source $confpath} 55 | .nav tag config friend -foreground blue 56 | .t tag config friend -foreground blue 57 | .users tag config f -foreground blue -image [image create photo -format png -data $icon] 58 | } 59 | 60 | hook handle001 friend 50 {serverid msg} { 61 | variable friends 62 | foreach nick [dict get? {} $friends $serverid] { 63 | ensurechan [chanid $serverid $nick] $nick {} 64 | } 65 | } 66 | 67 | # ISUPPORT handler 68 | hook handle005 friend 60 {serverid msg} { 69 | # we check to see if PREFIX is set, and modify the allowable 70 | # prefixes after the fact. Friends get the special ^ prefix 71 | # (hopefully unused by any server), which acts as a channel mode 72 | # and orders them at the top of the userlist. 73 | foreach param [lrange [dict get $msg args] 1 end] { 74 | lassign [split $param "="] key val 75 | if {$key eq "PREFIX"} { 76 | set newprefix [dict create {*}[linsert [dict get $::serverinfo $serverid prefix] 0 "$" "f"]] 77 | dict set ::serverinfo $serverid prefix $newprefix 78 | return 79 | } 80 | } 81 | } 82 | 83 | # RPL_NAMES 84 | hook handle353 friend 75 {serverid msg} { 85 | variable friends 86 | set chanid [chanid $serverid [lindex [dict get $msg args] 2]] 87 | foreach user [split [lindex [dict get $msg args] 3] " "] { 88 | if {[lsearch -exact [dict get? {} $friends $serverid] $user] != -1} { 89 | updateusermodes $chanid $user f {} 90 | } 91 | } 92 | } 93 | hook handleJOIN friend 60 {serverid msg} { 94 | variable friends 95 | dict lappend msg tag friend 96 | set chanid [chanid $serverid [lindex [dict get $msg args] 0]] 97 | if {[lsearch -exact [dict get? {} $friends $serverid] [dict get $msg src]] != -1} { 98 | updateusermodes $chanid [dict get $msg src] f {} 99 | } 100 | } 101 | hook handlePRIVMSG friend 35 {serverid msg} { 102 | variable friends 103 | if {[lsearch -exact [dict get? {} $friends $serverid] [dict get $msg src]] != -1} { 104 | dict lappend msg tag friend 105 | return -code continue [list $serverid $msg] 106 | } 107 | } 108 | 109 | hook handleNOTICE friend 40 {serverid msg} { 110 | variable friends 111 | if {[lsearch -exact [dict get? {} $friends $serverid] [dict get $msg src]] != -1} { 112 | dict lappend msg tag friend 113 | return -code continue [list $serverid $msg] 114 | } 115 | } 116 | 117 | hook handlePART friend 60 {serverid msg} { 118 | variable friends 119 | if {[lsearch -exact [dict get? {} $friends $serverid] [dict get $msg src]] != -1} { 120 | dict lappend msg tag friend 121 | return -code continue [list $serverid $msg] 122 | } 123 | } 124 | 125 | hook handleQUIT friend 60 {serverid msg} { 126 | variable friends 127 | if {[lsearch -exact [dict get? {} $friends $serverid] [dict get $msg src]] != -1} { 128 | dict lappend msg tag friend 129 | return -code continue [list $serverid $msg] 130 | } 131 | } 132 | 133 | hook cmdFRIEND friend 50 {serverid arg} { 134 | variable friends 135 | set friendlist [dict get? {} $friends $serverid] 136 | if {$arg eq ""} { 137 | if {[llength $friendlist] == 0} { 138 | addchantext $::active "You are not friends with anyone on $serverid." -tags italic 139 | } else { 140 | addchantext $::active "Friends on $serverid: $friendlist" -tags italic 141 | } 142 | return 143 | } 144 | set targets [friendnicks $serverid {*}[split $arg " "]] 145 | if {$targets eq ""} { 146 | addchantext $::active "No nicks added to friend list on $serverid." -tags italic 147 | return 148 | } 149 | addchantext $::active "Added to friend list on $serverid: $targets" -tags italic 150 | updatefriendconf 151 | foreach target $targets { 152 | ensurechan [chanid $serverid $target] $target {} 153 | } 154 | dict for {chanid info} $::channelinfo { 155 | if {[irken::serverpart $chanid] eq $serverid} { 156 | foreach target $targets { 157 | if {[lsearch -nocase -exact -index 0 [dict get $info users] $target] != -1} { 158 | updateusermodes $chanid $target f {} 159 | } 160 | } 161 | } 162 | } 163 | } 164 | 165 | hook cmdUNFRIEND friend 50 {serverid arg} { 166 | variable friends 167 | set friendlist [dict get? {} $friends $serverid] 168 | if {$arg eq ""} { 169 | if {[llength $friendlist] == 0} { 170 | addchantext $::active "You are not friends with anyone." -tags italic 171 | } else { 172 | addchantext $::active "Friends: $friendlist" -tags italic 173 | } 174 | return 175 | } 176 | set targets {} 177 | foreach nick [split $arg " "] { 178 | if {[lsearch -nocase -exact $friendlist $nick] != -1} { 179 | lappend targets $nick 180 | set friendlist [lsearch -all -not -exact $friendlist $nick] 181 | } 182 | } 183 | dict set friends $serverid $friendlist 184 | if {$targets eq ""} { 185 | addchantext $::active "No nicks removed from friend list." -tags italic 186 | } else { 187 | addchantext $::active "Removed from friend list: $targets" -tags italic 188 | updatefriendconf 189 | dict for {chanid info} $::channelinfo { 190 | if {[irken::serverpart $chanid] eq $serverid} { 191 | foreach target $targets { 192 | if {[lsearch -nocase -exact -index 0 [dict get $info users] $target] != -1} { 193 | updateusermodes $chanid $target {} f 194 | } 195 | } 196 | } 197 | } 198 | } 199 | } 200 | } 201 | -------------------------------------------------------------------------------- /plugins/chanlist.tcl: -------------------------------------------------------------------------------- 1 | ### chanlist Irken Plugin - copy to ~/.config/irken/ to use. 2 | # 3 | # Description: 4 | # 5 | # Queries a server for a channel list and displays its responses in 6 | # a new window. 7 | # 8 | 9 | namespace eval ::irken::chanlist { 10 | namespace import ::irken::* 11 | 12 | variable uparrow [image create photo -format png -data "iVBORw0KGgoAAAANSUhEUgAAAAsAAAALCAYAAACprHcmAAAALUlEQVQY02NgwAJERUX/YxNnxKfw9evXjDgVYzMRWQMjIauRNTASUojLSaMAAGohEUMw+q6EAAAAAElFTkSuQmCC"] 13 | variable downarrow [image create photo -format png -data "iVBORw0KGgoAAAANSUhEUgAAAAsAAAALCAYAAACprHcmAAAAN0lEQVQY02NgGAUIwMjAwMAgKir6n5DC169fMzLCOPg0vH79mhFuMj4NMIUYitE1ICvECXA5CQAmsRFDgJgREQAAAABJRU5ErkJggg=="] 14 | variable refreshicon [image create photo -format png -data "iVBORw0KGgoAAAANSUhEUgAAAA4AAAAOCAQAAAC1QeVaAAAA4klEQVQY02XQvSvEARzH8de5s9h0D5Yrm5TFyijZRIp/wEM3SBZ1ysCC2X9gs5hvlaKuhOUW43k6XPKQCX0Nv+vEvT/ju++3Tx8SslZV3Xp3alcfSKXAuANZv7xZ86kfpnwKDdsmTVhXF0LYp+BBOJJr3037EEKly7KCOzOaLZU26BnkuRTK/tKjpKbOsDlFnaTNZgw49N2hikZdUVdT0vNPbgjnnAnhWlm6rbLuhU0qQvgw1VZ5x0JDLuOx1W/PkAvdRszL+7KoyZYFS15bqyR5MpY8Sdbts+PEixtVK3oT9QOkwEmnoQCEDwAAAABJRU5ErkJggg=="] 15 | 16 | variable sortkey 1 17 | variable sortdesc 1 18 | # channels is an unordered dict of chanid -> {chan users topic} 19 | variable channels {} 20 | variable usemin 0 21 | variable usemax 0 22 | variable filtertext "" 23 | variable lastserverid "" 24 | variable lastquery {} 25 | 26 | proc updatechanlist {} { 27 | variable usemin 28 | variable usemax 29 | variable sortkey 30 | variable sortdesc 31 | variable filtertext 32 | variable filtermin 33 | variable filtermax 34 | variable channels 35 | if {$usemin} { 36 | .chanlist.filter.min configure -state active 37 | } else { 38 | .chanlist.filter.min configure -state disabled 39 | } 40 | if {$usemax} { 41 | .chanlist.filter.max configure -state active 42 | } else { 43 | .chanlist.filter.max configure -state disabled 44 | } 45 | 46 | set cmp [expr {$sortkey == 1 ? "-integer":"-ascii"}] 47 | set dir [expr {$sortdesc ? "-decreasing":"-increasing"}] 48 | set row -1 49 | .chanlist.chans.tv detach [.chanlist.chans.tv children {}] 50 | foreach {chanid values} [lsort $cmp $dir -stride 2 -index [list 1 $sortkey] $channels] { 51 | lassign $values chan users topic 52 | if {$usemin && $users < $filtermin} { 53 | continue 54 | } 55 | if {$usemax && $users > $filtermax} { 56 | continue 57 | } 58 | if {$filtertext ne "" && ![regexp -- $filtertext $chan] && ![regexp -- $filtertext $topic]} { 59 | continue 60 | } 61 | .chanlist.chans.tv move $chanid {} [incr row] 62 | } 63 | incr row 64 | set size [dict size $channels] 65 | if {$row == $size} { 66 | if {$size == 1} { 67 | .chanlist.info configure -text "1 channel" 68 | } else { 69 | .chanlist.info configure -text "$size channels" 70 | } 71 | } else { 72 | .chanlist.info configure -text "$row/[dict size $channels] channels displayed" 73 | } 74 | } 75 | 76 | proc numbersonly {newtext} { 77 | return [regexp {^\d*$} $newtext] 78 | } 79 | 80 | proc filtertextchanged {name1 name2 op} { 81 | if {[winfo exists .chanlist]} { 82 | updatechanlist 83 | } 84 | } 85 | 86 | proc updateheader {w} { 87 | variable sortdesc 88 | variable sortkey 89 | variable downarrow 90 | variable uparrow 91 | if {$sortdesc} { 92 | $w heading $sortkey -image $downarrow 93 | } else { 94 | $w heading $sortkey -image $uparrow 95 | } 96 | } 97 | 98 | proc headerclick {w col} { 99 | variable sortkey 100 | variable sortdesc 101 | if {$col == $sortkey} { 102 | set sortdesc [expr {!$sortdesc}] 103 | } else { 104 | $w heading $sortkey -image {} 105 | set sortkey $col 106 | } 107 | updateheader $w 108 | updatechanlist 109 | } 110 | 111 | proc channelclick {w x y} { 112 | switch [$w identify region $x $y] { 113 | "heading" { 114 | regexp {\#(\d+)} [$w identify column $x $y] -> col 115 | incr col -1 116 | headerclick $w $col 117 | } 118 | "cell" {$w selection set [list [$w identify item $x $y]]} 119 | } 120 | } 121 | proc doubleclick {w x y} { 122 | if {[$w identify region $x $y] == "cell"} { 123 | set cell [$w identify item $x $y] 124 | if {$cell == [$w selection]} { 125 | irc::send [irken::serverpart $cell] "JOIN [irken::channelpart $cell]" 126 | irken::ensurechan $cell "" {disabled} 127 | .nav selection set $cell 128 | irken::selectchan 129 | } else { 130 | $w selection set $cell 131 | } 132 | } 133 | } 134 | hook handle321 chanlist 50 {serverid msg} { 135 | # do nothing with LIST header 136 | } 137 | 138 | hook handle323 chanlist 50 {serverid msg} { 139 | # do nothing with LIST footer 140 | updatechanlist 141 | .chanlist.filter.refresh configure -state active 142 | } 143 | 144 | hook handle322 chanlist 50 {serverid msg} { 145 | # Allow the user to close the window to not see any more results 146 | if {![winfo exists .chanlist]} { 147 | return 148 | } 149 | variable channels 150 | lassign [dict get $msg args] target chan users topic 151 | set chanid [irken::chanid $serverid $chan] 152 | set values [list $chan $users $topic] 153 | if {[.chanlist.chans.tv exists $chanid]} { 154 | .chanlist.chans.tv item $chanid -values $values 155 | } else { 156 | .chanlist.chans.tv insert {} end -id $chanid -values $values 157 | } 158 | dict set channels $chanid $values 159 | } 160 | 161 | proc updatelist {} { 162 | variable lastserverid 163 | variable lastquery 164 | variable channels 165 | 166 | .chanlist.chans.tv delete [.chanlist.chans.tv children {}] 167 | set channels {} 168 | irc::send $lastserverid [string cat "LIST " {*}$lastquery] 169 | .chanlist.info configure -text "Retrieving channels..." 170 | .chanlist.filter.refresh configure -state disabled 171 | } 172 | 173 | proc buildlistwindow {} { 174 | variable filtertext 175 | variable refreshicon 176 | 177 | toplevel .chanlist 178 | wm iconphoto .chanlist [image create photo -format png -data $::irkenicon] 179 | # construct rest of window 180 | ttk::frame .chanlist.filter 181 | ttk::label .chanlist.filter.textl -text "Regex: " 182 | ttk::entry .chanlist.filter.text -textvariable ::irken::chanlist::filtertext 183 | trace add variable filtertext write [namespace code {filtertextchanged}] 184 | ttk::checkbutton .chanlist.filter.usemin -variable ::irken::chanlist::usemin -command [namespace code {updatechanlist}] -text "Min: " 185 | ttk::spinbox .chanlist.filter.min -from 1 -to 9999 -width 4 -state disabled -validate key -validatecommand [namespace code {numbersonly %P}] -textvariable ::irken::chanlist::filtermin 186 | .chanlist.filter.min set 1 187 | ttk::checkbutton .chanlist.filter.usemax -variable ::irken::chanlist::usemax -command [namespace code {updatechanlist}] -text "Max: " 188 | ttk::spinbox .chanlist.filter.max -from 1 -to 9999 -width 4 -state disabled -validate key -validatecommand [namespace code {numbersonly %P}] -textvariable ::irken::chanlist::filtermax 189 | .chanlist.filter.max set 9999 190 | bind .chanlist.filter.min [namespace code updatechanlist] 191 | bind .chanlist.filter.max [namespace code updatechanlist] 192 | 193 | ttk::button .chanlist.filter.refresh -image $refreshicon -command [namespace code {updatelist}] 194 | 195 | ttk::frame .chanlist.chans 196 | ttk::treeview .chanlist.chans.tv -selectmode browse -columns [list chan users topic] -show headings -yscrollcommand {.chanlist.chans.sb set} 197 | .chanlist.chans.tv heading #1 -text "Name" 198 | .chanlist.chans.tv column #1 -stretch 0 -width 150 -anchor w -minwidth 50 199 | .chanlist.chans.tv heading #2 -text "Users" 200 | .chanlist.chans.tv column #2 -stretch 0 -width 70 -anchor e -minwidth 50 201 | .chanlist.chans.tv heading #3 -text "Title" 202 | .chanlist.chans.tv column #3 -stretch 1 -anchor w 203 | 204 | ttk::scrollbar .chanlist.chans.sb -command {.chanlist.chans.tv yview} 205 | 206 | bind .chanlist.chans.tv [namespace code {channelclick %W %x %y}] 207 | bind .chanlist.chans.tv [namespace code {doubleclick %W %x %y}] 208 | 209 | ttk::label .chanlist.info -relief sunken -justify right 210 | 211 | pack .chanlist.filter -fill x -padx 5 -pady 5 212 | pack .chanlist.filter.textl -side left 213 | pack .chanlist.filter.text -fill x -expand 1 -side left 214 | pack .chanlist.filter.usemin -side left -padx 3 215 | pack .chanlist.filter.min -side left 216 | pack .chanlist.filter.usemax -side left -padx 3 217 | pack .chanlist.filter.max -side left 218 | pack .chanlist.filter.refresh -side left -padx 5 219 | 220 | pack .chanlist.chans -fill both -expand 1 221 | grid .chanlist.chans.tv .chanlist.chans.sb -sticky nsew 222 | grid rowconfigure .chanlist.chans .chanlist.chans.tv -weight 1 223 | grid columnconfigure .chanlist.chans .chanlist.chans.tv -weight 1 224 | updateheader .chanlist.chans.tv 225 | 226 | pack .chanlist.info -fill x 227 | 228 | bind .chanlist [namespace code teardownwindow] 229 | } 230 | 231 | proc teardownwindow {} { 232 | variable filtertext 233 | trace remove variable filtertext write [namespace code {filtertextchanged}] 234 | } 235 | 236 | hook cmdLIST chanlist 50 {serverid arg} { 237 | variable lastserverid 238 | variable lastquery 239 | 240 | if {![winfo exists .chanlist]} { 241 | buildlistwindow 242 | } 243 | set lastserverid $serverid 244 | set lastquery $arg 245 | set title "$serverid Channels" 246 | if {[llength $arg] > 0} { 247 | set title "$title ([join $arg])" 248 | } 249 | wm title .chanlist $title 250 | updatelist 251 | } 252 | } 253 | -------------------------------------------------------------------------------- /irken_test.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/tclsh 2 | 3 | source "irken.tcl" 4 | 5 | set ::tests {} 6 | 7 | proc test {name fixtures code} { 8 | proc test_$name {} $code 9 | lappend ::tests [list test_$name $fixtures] 10 | } 11 | 12 | proc assert {condition} { 13 | if {![uplevel 1 [list expr $condition]]} { 14 | return -code error "Assertion failed: $condition" 15 | } 16 | } 17 | 18 | proc asserteq {a b} { 19 | if {$a != $b} { 20 | return -code error "Assertion failed:\n[list $a] !=\n[list $b]" 21 | } 22 | } 23 | 24 | proc runtests {} { 25 | set testcount 0 26 | set passcount 0 27 | set failcount 0 28 | foreach test $::tests { 29 | lassign $test cmd fixtures 30 | foreach fixture $fixtures { 31 | try { 32 | {*}$fixture setup 33 | } on error {err} { 34 | puts stderr "Fixture failure in $fixture: $::errorInfo" 35 | exit 1 36 | } 37 | } 38 | try { 39 | incr testcount 40 | puts stdout "$cmd..." 41 | {*}$cmd 42 | } on error {err} { 43 | incr failcount 44 | puts stderr "Test failure in $cmd: $::errorInfo" 45 | } finally { 46 | foreach fixture [lreverse $fixtures] { 47 | {*}$fixture teardown 48 | } 49 | } 50 | } 51 | puts stdout "$testcount tests run, $failcount failed." 52 | exit [expr {$failcount == 0 ? 0:1}] 53 | } 54 | 55 | proc testserver {chan addr port} { 56 | fconfigure $chan -blocking 0 57 | dict set ::serverinfo "TestServer" schan $chan 58 | } 59 | 60 | proc irken_fixture {op} { 61 | if {$op eq "setup"} { 62 | irken::initvars 63 | irken::initui 64 | set ::serverchan [socket -server testserver -myaddr "localhost" 0] 65 | set chan [socket "localhost" [lindex [fconfigure $::serverchan -sockname] 2]] 66 | dict set ::servers $chan "TestServer" 67 | dict set ::serverinfo "TestServer" [dict merge [dict create chan $chan nick "test" casemapping "rfc1459"] $::ircdefaults] 68 | fconfigure $chan -blocking 0 69 | vwait ::serverinfo 70 | irken::ensurechan "TestServer" "" {} 71 | irken::ensurechan "TestServer/#test" "#test" {} 72 | irken::ensurechan "TestServer/target" "target" {} 73 | set ::active {} 74 | .nav selection set [irken::chanid "TestServer" "#test"] 75 | irken::selectchan 76 | return 77 | } 78 | catch {close [dict get $::serverinfo "TestServer" schan]} 79 | catch {close [dict get $::serverinfo "TestServer" chan]} 80 | catch {close $::serverchan} 81 | destroy {*}[lsearch -all -inline -not -exact [winfo children .] ".#BWidget"] 82 | } 83 | 84 | test hook {} { 85 | hook testevent lowpriority 5 {a} { 86 | set ::testval {} 87 | lappend ::testval l-$a 88 | } 89 | hook testevent hook 10 {a} { 90 | lappend ::testval h-$a 91 | } 92 | # basic hook call 93 | hook call testevent "foo" 94 | asserteq $::testval [list l-foo h-foo] 95 | 96 | # redefinition of a hook 97 | hook testevent hook 15 {a} { 98 | lappend ::testval "r-$a" 99 | } 100 | hook call testevent "foo" 101 | asserteq $::testval [list l-foo r-foo] 102 | 103 | # overriding a previous hook 104 | hook testevent override 20 {a} { 105 | lappend ::testval "h-$a" 106 | } 107 | hook call testevent "foo" 108 | asserteq $::testval [list l-foo r-foo h-foo] 109 | 110 | # stopping a hook chain 111 | hook testevent hook 10 {a} { 112 | lappend ::testval "stopped" 113 | return -code break 114 | } 115 | hook call testevent "foo" 116 | asserteq $::testval [list l-foo stopped] 117 | 118 | # changing argument for subsequent hooks 119 | hook testevent hook 10 {a} { 120 | return -code continue "bar" 121 | } 122 | hook call testevent "foo" 123 | asserteq $::testval "l-foo h-bar" 124 | } 125 | 126 | test irctolower {} { 127 | asserteq [irken::irctolower "ascii" "FOO"] "foo" 128 | asserteq [irken::irctolower "rfc1459" "FOO"] "foo" 129 | asserteq [irken::irctolower "strict-rfc1459" "FOO"] "foo" 130 | asserteq [irken::irctolower "ascii" "FOO\[\]^"] "foo\[\]^" 131 | asserteq [irken::irctolower "rfc1459" "FOO\[\]^"] "foo\{\}~" 132 | asserteq [irken::irctolower "strict-rfc1459" "FOO\[\]^"] "foo\{\}^" 133 | } 134 | 135 | test ircstrcmp {} { 136 | assert {[irken::ircstrcmp "ascii" "foo\[\]^" "foo\[\]^"] == 0} 137 | assert {[irken::ircstrcmp "ascii" "foo\[\]^" "foo\{\}~"] != 0} 138 | assert {[irken::ircstrcmp "rfc1459" "foo\[\]" "foo\{\}"] == 0} 139 | assert {[irken::ircstrcmp "strict-rfc1459" "foo\[\]" "foo\{\}"] == 0} 140 | assert {[irken::ircstrcmp "rfc1459" "foo\[\]^" "foo\{\}~"] == 0} 141 | assert {[irken::ircstrcmp "strict-rfc1459" "foo\[\]^" "foo\{\}~"] != 0} 142 | } 143 | 144 | test rankeduser {} { 145 | dict set ::serverinfo "TestServer" prefix {@ o + v} 146 | asserteq [irken::rankeduser "TestServer" [list foo [list o v]]] "0foo" 147 | asserteq [irken::rankeduser "TestServer" [list foo [list v]]] "1foo" 148 | asserteq [irken::rankeduser "TestServer" [list foo {}]] "2foo" 149 | } 150 | 151 | test colorcode {} { 152 | asserteq [irken::colorcode "normal text"] [list "normal text" {}] 153 | asserteq [irken::colorcode "\x02normal \x02text"] [list "normal text" {{0 push bold} {7 pop bold}}] 154 | asserteq [irken::colorcode "\x1dnormal \x1dtext"] [list "normal text" {{0 push italic} {7 pop italic}}] 155 | asserteq [irken::colorcode "\x1fnormal \x1ftext"] [list "normal text" {{0 push underline} {7 pop underline}}] 156 | asserteq [irken::colorcode "\x034rainbow \x03text"] [list "rainbow text" {{0 push fg_red} {8 pop fg_red}}] 157 | asserteq [irken::colorcode "\x034,5rainbow \x034,99text"] [list "rainbow text" {{0 push fg_red} {0 push bg_maroon} {8 pop bg_maroon}}] 158 | asserteq [irken::colorcode "\x0314,15rainbow \x03text"] [list "rainbow text" {{0 push fg_gray} {0 push bg_lgray} {8 pop fg_gray} {8 pop bg_lgray}}] 159 | asserteq [irken::colorcode "\x0304rainbow \x03text"] [list "rainbow text" {{0 push fg_red} {8 pop fg_red}}] 160 | asserteq [irken::colorcode "\x02bold\x02 normal \x02\x1dbold italic\x02 italic \x02bold italic\x1d bold"] \ 161 | [list "bold normal bold italic italic bold italic bold" \ 162 | {{0 push bold} {4 pop bold} {12 push bold} {12 pop bold} {12 push bolditalic} {23 pop bolditalic} {23 push italic} {31 pop italic} {31 push bolditalic} {42 pop bolditalic} {42 push bold}}] 163 | asserteq [irken::colorcode "\x02\x1dbold italic\x0f normal"] [list "bold italic normal" {{0 push bold} {0 pop bold} {0 push bolditalic} {11 pop bolditalic}}] 164 | asserteq [irken::colorcode "\x16reversed\x16 normal"] [list "reversed normal" {{0 push fg_white} {0 push bg_black} {8 pop fg_white} {8 pop bg_black}}] 165 | asserteq [irken::colorcode "\x16rev\x034,5-ersed\x16 col\x03or"] [list "rev-ersed color" {{0 push fg_white} {0 push bg_black} {3 pop fg_white} {3 push fg_maroon} {3 pop bg_black} {3 push bg_red} {9 pop fg_maroon} {9 push fg_red} {9 pop bg_red} {9 push bg_maroon} {13 pop fg_red} {13 pop bg_maroon}}] 166 | } 167 | 168 | test httpregexp {} { 169 | assert {[regexp $irken::httpregexp "testing text"] == 0} 170 | assert {[regexp $irken::httpregexp "http://example.com/"] == 1} 171 | assert {[regexp $irken::httpregexp "https://example.com/"] == 1} 172 | regexp $irken::httpregexp "https://example.com/." match 173 | asserteq $match "https://example.com/" 174 | regexp $irken::httpregexp "https://example.com/, " match 175 | asserteq $match "https://example.com/" 176 | assert {[regexp $irken::httpregexp "https://example.com/#foo\[bar\]%20"] == 1} 177 | } 178 | 179 | test regexranges {} { 180 | asserteq [irken::regexranges "testing text" te te] {{0 push te} {2 pop te} {8 push te} {10 pop te}} 181 | asserteq [irken::regexranges "x https://example.com/ x" $irken::httpregexp hlink] {{2 push hlink} {22 pop hlink}} 182 | } 183 | 184 | test combinestyles {} { 185 | asserteq [irken::combinestyles "rainbow text" {{0 push te} {2 pop te} {8 push te} {10 pop te} {4 push ing} {7 pop ing}}] \ 186 | [list "ra" te "in" {} "bow" ing " " {} "te" te "xt" {}] 187 | } 188 | 189 | test ischannel {} { 190 | set ::serverinfo [dict create "TestServer" $::ircdefaults] 191 | assert {[irken::ischannel [irken::chanid "TestServer" "#foo"]]} 192 | assert {[irken::ischannel [irken::chanid "TestServer" "#"]]} 193 | assert {[irken::ischannel [irken::chanid "TestServer" "&foo"]]} 194 | assert {![irken::ischannel [irken::chanid "TestServer" "foo"]]} 195 | assert {![irken::ischannel [irken::chanid "TestServer" "# foo"]]} 196 | assert {![irken::ischannel [irken::chanid "TestServer" "#\afoo"]]} 197 | dict set ::serverinfo "TestServer" channellen 2 198 | assert {[irken::ischannel [irken::chanid "TestServer" "#fo"]]} 199 | assert {![irken::ischannel [irken::chanid "TestServer" "#foo"]]} 200 | dict set ::serverinfo "TestServer" chantypes # 201 | assert {![irken::ischannel [irken::chanid "TestServer" "&fo"]]} 202 | } 203 | 204 | test parseline {} { 205 | set msg [irken::parseline ":nick!nick@irc.example.com PART #foo :Out of here!"] 206 | asserteq [dict get $msg cmd] "PART" 207 | asserteq [dict get $msg args] [list "#foo" "Out of here!"] 208 | set msg [irken::parseline ":nick!nick@irc.example.com QUIT :Out of here!"] 209 | asserteq [dict get $msg cmd] "QUIT" 210 | asserteq [dict get $msg args] [list "Out of here!"] 211 | set msg [irken::parseline ":nick!nick@irc.example.com JOIN #foo"] 212 | asserteq [dict get $msg cmd] "JOIN" 213 | asserteq [dict get $msg args] [list "#foo"] 214 | set msg [irken::parseline ":irc.example.com 333 nick #foo nick!user@2600::ffff:dddd:eeee:4444 1505726688"] 215 | asserteq [dict get $msg cmd] "333" 216 | asserteq [dict get $msg args] [list "nick" "#foo" "nick!user@2600::ffff:dddd:eeee:4444" "1505726688"] 217 | set msg [irken::parseline ":irc.example.com 353 nick = #foo :one two three four"] 218 | asserteq [dict get $msg cmd] "353" 219 | asserteq [dict get $msg args] [list "nick" "=" "#foo" "one two three four"] 220 | set msg [irken::parseline "@time=20211207T04:20:00Z :irc.example.com 353 nick = #foo :one two three four"] 221 | asserteq [dict get $msg cmd] "353" 222 | asserteq [dict get $msg args] [list "nick" "=" "#foo" "one two three four"] 223 | } 224 | 225 | test addchantext {irken_fixture} { 226 | irken::addchantext "TestServer/#test" "This is a test." -nick "tester" -tags self 227 | asserteq [lrange [dict get $::channeltext "TestServer/#test"] 2 end] [list "\ttester\t" "nick" "This is a test." {self line} "\n" {}] 228 | } 229 | 230 | test updateusermodes {irken_fixture} { 231 | irken::addchanuser "TestServer/#test" "test\[user\]" {o} 232 | asserteq [dict get $::channelinfo "TestServer/#test" users] [list [list "test\[user\]" {o}]] 233 | assert {[.users exists "test\[user\]"]} 234 | irken::updateusermodes "TestServer/#test" "test\[user\]" {v} {o} 235 | asserteq [dict get $::channelinfo "TestServer/#test" users] [list [list "test\[user\]" {v}]] 236 | } 237 | 238 | test addchanuser {irken_fixture} { 239 | irken::addchanuser "TestServer/#test" "test\[user\]" {} 240 | asserteq [dict get $::channelinfo "TestServer/#test" users] [list [list "test\[user\]" {}]] 241 | assert {[.users exists "test\[user\]"]} 242 | 243 | irken::addchanuser "TestServer/#test" "@test\[user\]" {} 244 | asserteq [dict get $::channelinfo "TestServer/#test" users] [list [list "test\[user\]" {o}]] 245 | assert {[.users exists "test\[user\]"]} 246 | assert {[.users tag has o "test\[user\]"]} 247 | } 248 | 249 | test remchanuser {irken_fixture} { 250 | set chanid [irken::chanid "TestServer" "#test"] 251 | irken::addchanuser $chanid "testuser" {} 252 | assert {[.users exists "testuser"]} 253 | irken::remchanuser $chanid "testuser" 254 | assert {![.users exists "testuser"]} 255 | irken::addchanuser $chanid "\\\\\\\\\\\\\\\\\\\\\\" {} 256 | irken::remchanuser $chanid "\\\\\\\\\\\\\\\\\\\\\\" 257 | assert {![.users exists "\\\\\\\\\\\\\\\\\\\\\\"]} 258 | 259 | } 260 | 261 | test removechan {irken_fixture} { 262 | assert {[dict exists $::channeltext "TestServer/#test"]} 263 | assert {[dict exists $::channelinfo "TestServer/#test"]} 264 | asserteq [.nav focus] "TestServer/#test" 265 | irken::removechan "TestServer/#test" 266 | assert {![dict exists $::channeltext "TestServer/#test"]} 267 | assert {![dict exists $::channelinfo "TestServer/#test"]} 268 | assert {![.nav exists "TestServer/#test"]} 269 | asserteq [.nav selection] "TestServer/target" 270 | asserteq [.nav focus] "TestServer/target" 271 | asserteq $::active "TestServer/target" 272 | } 273 | 274 | test closecmd {irken_fixture} { 275 | assert {[.nav exists "TestServer/#test"]} 276 | .cmd insert 1.0 "/close #test Testing" 277 | catch {irken::returnkey} _ 278 | asserteq [gets [dict get $::serverinfo "TestServer" schan]] "PART #test :Testing" 279 | assert {![.nav exists "TestServer/#test"]} 280 | asserteq [.nav selection] "TestServer/target" 281 | asserteq [.nav focus] "TestServer/target" 282 | asserteq $::active "TestServer/target" 283 | assert {![dict exists $::channeltext "TestServer/#test"]} 284 | assert {![dict exists $::channelinfo "TestServer/#test"]} 285 | } 286 | 287 | test closecmdwithuser {irken_fixture} { 288 | .nav selection set [irken::chanid "TestServer" "target"] 289 | irken::selectchan 290 | .cmd insert 1.0 "/close target" 291 | catch {irken::returnkey} _ 292 | assert {![.nav exists "TestServer/target"]} 293 | asserteq [.nav selection] "TestServer/#test" 294 | asserteq [.nav focus] "TestServer/#test" 295 | asserteq $::active "TestServer/#test" 296 | assert {![dict exists $::channeltext "TestServer/target"]} 297 | assert {![dict exists $::channelinfo "TestServer/target"]} 298 | } 299 | 300 | test handleMODE {irken_fixture} { 301 | irken::addchanuser [irken::chanid "TestServer" "#test"] "@target" {} 302 | asserteq [dict get $::channelinfo "TestServer/#test" users] [list [list "target" {o}]] 303 | hook call handleMODE "TestServer" [dict create src "foo" user "foo" host "foo.com" cmd "MODE" args [list "#test" -o target]] 304 | asserteq [dict get $::channelinfo "TestServer/#test" users] [list [list "target" {}]] 305 | assert {[.users exists "target"]} 306 | assert {![.users tag has o "target"]} 307 | hook call handleMODE "TestServer" [dict create src "foo" user "foo" host "foo.com" cmd "MODE" args [list "#test" +o target]] 308 | asserteq [dict get $::channelinfo "TestServer/#test" users] [list [list "target" {o}]] 309 | hook call handleMODE "TestServer" [dict create src "foo" user "foo" host "foo.com" cmd "MODE" args [list "#test" +v target]] 310 | asserteq [dict get $::channelinfo "TestServer/#test" users] [list [list "target" {o v}]] 311 | } 312 | 313 | test handleNICK {irken_fixture} { 314 | irken::addchanuser [irken::chanid "TestServer" "#test"] "target" {o} 315 | irken::ensurechan [irken::chanid "TestServer" "target"] "target" {} 316 | irken::addchantext "TestServer/target" "This is a test." 317 | set oldtext [dict get $::channeltext "TestServer/target"] 318 | hook call handleNICK "TestServer" [dict create src "target" user "foo" host "foo.com" cmd "NICK" args [list "other"]] 319 | assert {[.users exists "other"]} 320 | assert {![.users exists "target"]} 321 | asserteq $oldtext [dict get $::channeltext "TestServer/other"] 322 | asserteq [dict get $::channelinfo "TestServer/#test" users] [list [list "other" {o}]] 323 | assert {[dict exists $::channelinfo "TestServer/other"]} 324 | assert {[.nav exists "TestServer/other"]} 325 | assert {![.nav exists "TestServer/target"]} 326 | } 327 | 328 | test handleNICKuserselected {irken_fixture} { 329 | irken::ensurechan [irken::chanid "TestServer" "target"] "target" {} 330 | .nav selection set [irken::chanid "TestServer" "target"] 331 | irken::selectchan 332 | asserteq $::active "TestServer/target" 333 | hook call handleNICK "TestServer" [dict create src "target" user "foo" host "foo.com" cmd "NICK" args [list "other"]] 334 | irken::selectchan 335 | asserteq $::active "TestServer/other" 336 | assert {[.nav exists "TestServer/other"]} 337 | assert {![.nav exists "TestServer/target"]} 338 | } 339 | 340 | test handleNICKself {irken_fixture} { 341 | irken::ensurechan [irken::chanid "TestServer" "target"] "target" {} 342 | .nav selection set [irken::chanid "TestServer" "target"] 343 | irken::selectchan 344 | asserteq [.nick cget -text] "test" 345 | hook call handleNICK "TestServer" [dict create src "test" user "foo" host "foo.com" cmd "NICK" args [list "other"]] 346 | asserteq [dict get $::serverinfo "TestServer" nick] "other" 347 | asserteq [.nick cget -text] "other" 348 | } 349 | 350 | test handleKICKself {irken_fixture} { 351 | set chanid [irken::chanid "TestServer" "#test"] 352 | irken::ensurechan $chanid "#test" {} 353 | .nav selection set $chanid 354 | irken::selectchan 355 | hook call handleKICK "TestServer" [dict create src "kicker" user "foo" host "foo.com" cmd "KICK" args [list "#test" "test" "get out"]] 356 | asserteq [lrange [dict get $::channeltext "TestServer/#test"] 2 end] [list "\t*\t" "nick" "kicker kicks you from #test. (get out)" {system line} "\n" {}] 357 | } 358 | 359 | test handleKICKother {irken_fixture} { 360 | set chanid [irken::chanid "TestServer" "#test"] 361 | irken::ensurechan $chanid "#test" {} 362 | .nav selection set $chanid 363 | irken::selectchan 364 | hook call handleKICK "TestServer" [dict create src "kicker" user "foo" host "foo.com" cmd "KICK" args [list "#test" "target" "get out"]] 365 | asserteq [lrange [dict get $::channeltext "TestServer/#test"] 2 end] [list "\t*\t" "nick" "kicker kicks target from #test. (get out)" {system line} "\n" {}] 366 | } 367 | 368 | test disconnect {irken_fixture} { 369 | assert {![.nav tag has disabled "TestServer"]} 370 | set schan [dict get $::serverinfo "TestServer" schan] 371 | fconfigure $schan -blocking 0 372 | close $schan 373 | irken::recv [dict get $::serverinfo "TestServer" chan] 374 | assert {[.nav tag has disabled "TestServer"]} 375 | assert {[.nav tag has disabled "TestServer/#test"]} 376 | asserteq [lrange [dict get $::channeltext "TestServer"] 2 end] [list "\t*\t" {nick} "Server disconnected." {system line} "\n" {}] 377 | } 378 | 379 | if {[info exists argv0] && [file dirname [file normalize [info script]/...]] eq [file dirname [file normalize $argv0/...]]} { 380 | runtests 381 | } 382 | -------------------------------------------------------------------------------- /irken.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env wish 2 | # Irken - dlowe@dlowe.net 3 | package require tls 4 | package require BWidget 5 | 6 | proc ::tcl::dict::get? {default dict key args} {if {[dict exists $dict $key {*}$args]} {return [dict get $dict $key {*}$args]} {return $default}} 7 | namespace ensemble configure dict -map [dict merge [namespace ensemble configure dict -map] {get? ::tcl::dict::get?}] 8 | 9 | # Hooks 10 | # hook - adds hook, sorted by priority 11 | # hook call * - calls hook with given parameters 12 | # hook unset - removes hook with handle 13 | # hook exists - returns 1 if hook exists, otherwise 0 14 | # Defined hooks can return three ways: 15 | # return -code continue : replace hook parameter list with the return value 16 | # return -code break : stop processing hook 17 | # normal return : continue processing to next hook 18 | if {![info exists ::hooks]} {set ::hooks [dict create]} 19 | proc hook {op name args} { 20 | switch -- $op { 21 | "exists" {return [expr {[dict get? "" $::hooks $name] ne ""}]} 22 | "unset" { 23 | dict set ::hooks $name [lsearch -all -exact -inline -not [dict get? {} $::hooks $name] $name] 24 | return "" 25 | } 26 | "call" { 27 | foreach hookproc [dict get? {} $::hooks $name] { 28 | try {[lindex $hookproc 0] {*}$args 29 | } on continue {val} {set args $val} 30 | } 31 | return $args 32 | } 33 | default { 34 | lassign $args priority params code 35 | set procname "[uplevel 1 {namespace current}]::${op}_${name}" 36 | proc $procname $params $code 37 | set hook [lsearch -all -exact -inline -not -index 0 [dict get? {} $::hooks $op] $procname] 38 | dict set ::hooks $op [lsort -index 1 -integer [linsert $hook end [list $procname $priority]]] 39 | return $op 40 | } 41 | } 42 | } 43 | 44 | namespace eval ::irc { 45 | namespace export send 46 | proc send {serverid str} {set chan [dict get $::serverinfo $serverid chan]; try {puts $chan $str} on error {err} {::irken::addchantext $serverid "WRITE ERROR: $err" -tags system};flush $chan} 47 | } 48 | 49 | namespace eval ::irken { 50 | namespace import ::irc::* 51 | namespace export chanid addchantext ensurechan updateusermodes isself ischannel serverpart channelpart 52 | 53 | # A chanid is $serverid for the server channel, $serverid/$channel for channel display. 54 | proc chanid {serverid chan} { if {$chan eq ""} {return $serverid} {return [string cat $serverid "/" [irctolower [dict get $::serverinfo $serverid casemapping] $chan]]} } 55 | proc serverpart {chanid} {lindex [split $chanid {/}] 0} 56 | proc channelpart {chanid} {lindex [split $chanid {/}] 1} 57 | proc ischannel {chanid} {regexp -- "^\[[dict get $::serverinfo [serverpart $chanid] chantypes]\]\[^ ,\\a\]\{0,[dict get $::serverinfo [serverpart $chanid] channellen]\}\$" [channelpart $chanid]} 58 | proc globescape {str} {return [regsub -all {[][\\*?\{\}]} $str {\\&}]} 59 | 60 | set ::codetagcolormap [dict create 0 white 1 black 2 navy 3 green 4 red 5 maroon 6 purple 7 olive 8 yellow 9 lgreen 10 teal 11 cyan 12 blue 13 magenta 14 gray 15 lgray {} {}] 61 | set ::tagcolormap [dict create white white black black navy navy green green red red maroon maroon purple purple olive {dark olive green} yellow gold lgreen {spring green} teal {pale turquoise} cyan deepskyblue blue blue magenta magenta gray gray lgray {light grey} {} {}] 62 | 63 | proc initvars {} { 64 | # Set up fonts ahead of time so they can be configured 65 | catch {font create Irken.List {*}[font actual TkDefaultFont] -size 10} 66 | catch {font create Irken.Fixed {*}[font actual TkFixedFont] -size 10} 67 | 68 | # ::config is a dict keyed on serverid containing config for each server, loaded from a file. 69 | # ::servers is a dict keyed on chan containing the serverid 70 | # ::serverinfo is a dict keyed on serverid containing the chan, current nick, and other server-specific info 71 | # ::channeltext is a dict keyed on chanid containing channel text with tags 72 | # ::channelinfo is a dict keyed on chanid containing topic, user list, input history, place in the history index. 73 | # ::active is the chanid of the shown channel. 74 | # ::seennicks a list of chanid nicks that we have seen since the last presence check 75 | lassign {} ::config ::servers ::serverinfo ::channeltext ::channelinfo ::active ::seennicks ::ctcppings 76 | # ::starttime is used to obfuscate the system time in milliseconds for PINGs 77 | set ::starttime [clock milliseconds] 78 | } 79 | 80 | proc server {serverid args} {dict set ::config $serverid $args} 81 | 82 | proc loadconfig {} { 83 | set configdir "$::env(HOME)/.config/irken/" 84 | file mkdir $configdir 85 | set configpaths [glob -nocomplain -directory $configdir "*.tcl"] 86 | if {$configpaths eq {}} { 87 | if {[catch {open "$configdir/50irken.tcl" w} fp]} { 88 | puts stderr "Couldn't write default config. Exiting." 89 | exit 1 90 | } 91 | puts $fp {server "LiberaChat" -host irc.libera.chat -port 6697 -insecure false -nick tcl-$::env(USER) -user $::env(USER) -autoconnect True -autojoin {\#irken}} 92 | close $fp 93 | set configpaths [list "$configdir/50irken.tcl"] 94 | } 95 | foreach configpath [lsort $configpaths] { 96 | source $configpath 97 | } 98 | } 99 | 100 | hook openhlink irken 50 {hlink} {exec -ignorestderr -- xdg-open $hlink &} 101 | hook textpopup nanoirc 99 {x y rootx rooty} { 102 | .t.popup entryconfigure "Copy" -state [expr {([.t tag ranges sel] eq "") ? "disabled":"normal"}] 103 | tk_popup .t.popup $rootx $rooty 104 | } 105 | 106 | proc copytext {} { 107 | if {[set r [.t tag nextrange sel 0.0]] ne ""} { 108 | clipboard clear; clipboard append [.t get {*}$r] 109 | } 110 | } 111 | 112 | proc initui {} { 113 | catch {font create Irken.FixedItalic {*}[font actual Irken.Fixed] -slant italic} 114 | catch {font create Irken.FixedBold {*}[font actual Irken.Fixed] -weight bold} 115 | catch {font create Irken.FixedBoldItalic {*}[font actual Irken.Fixed] -weight bold -slant italic} 116 | wm iconphoto . [image create photo -format png -data $::irkenicon] 117 | ttk::style configure Treeview -rowheight [expr {8 + [font metrics Irken.List -linespace]}] -font Irken.List -indent 3 118 | ttk::panedwindow .root -orient horizontal 119 | .root add [ttk::frame .navframe -width 170] -weight 0 120 | .root add [ttk::frame .mainframe -width 300 -height 300] -weight 1 121 | .root add [ttk::frame .userframe -width 140] -weight 0 122 | ttk::treeview .nav -show tree -selectmode browse 123 | bind .nav <> [namespace code selectchan] 124 | .nav column "#0" -width 150 125 | .nav tag config server -image [image create photo -format png -data $::servericon] 126 | .nav tag config channel -image [image create photo -format png -data $::channelicon] 127 | .nav tag config direct -image [image create photo -format png -data $::usericon] 128 | .nav tag config disabled -foreground gray 129 | .nav tag config highlight -foreground green 130 | .nav tag config message -foreground orange 131 | .nav tag config unseen -foreground blue 132 | ttk::entry .topic -takefocus 0 -font Irken.Fixed 133 | DynamicHelp::add .topic -command {join [regexp -all -inline {\S(?:\S{0,79}|.{0,79}(?=\s+|$))} [.topic get]] "\n"} 134 | DynamicHelp::configure -font Irken.Fixed 135 | text .t -height 30 -wrap word -font Irken.Fixed -state disabled \ 136 | -tabs [list \ 137 | [expr {25 * [font measure Irken.Fixed 0]}] right \ 138 | [expr {26 * [font measure Irken.Fixed 0]}] left] 139 | .t tag config line -lmargin2 [expr {26 * [font measure Irken.Fixed 0]}] 140 | .t tag config nick -foreground steelblue 141 | .t tag config self -foreground gray30 142 | .t tag config highlight -foreground green 143 | .t tag config system -font Irken.FixedItalic 144 | .t tag config italic -font Irken.FixedItalic 145 | .t tag config bold -font Irken.FixedBold 146 | .t tag config bolditalic -font Irken.FixedBoldItalic 147 | .t tag config underline -underline 1 148 | dict for {tagcolor color} $::tagcolormap { 149 | .t tag config fg_$tagcolor -foreground $color 150 | .t tag config bg_$tagcolor -background $color 151 | } 152 | .t tag config hlink -foreground blue -underline 1 153 | .t tag bind hlink [namespace code {hook call openhlink [%W get {*}[%W tag prevrange hlink @%x,%y]]}] 154 | .t tag bind hlink {%W configure -cursor hand2} 155 | .t tag bind hlink {%W configure -cursor xterm} 156 | menu .t.popup -tearoff 0 157 | .t.popup add command -label "Copy" -command [namespace code {copytext}] 158 | bind .t [namespace code {hook call textpopup %x %y %X %Y}] 159 | ttk::frame .cmdline 160 | ttk::label .nick -padding 3 161 | text .cmd -height 1 -wrap none -font Irken.Fixed 162 | ttk::treeview .users -show tree -selectmode browse 163 | .users tag config q -foreground gray -image [image create photo -format png -data $::ownericon] 164 | .users tag config a -foreground orange -image [image create photo -format png -data $::adminicon] 165 | .users tag config o -foreground red -image [image create photo -format png -data $::opsicon] 166 | .users tag config h -foreground pink -image [image create photo -format png -data $::halfopsicon] 167 | .users tag config v -foreground blue -image [image create photo -format png -data $::voiceicon] 168 | .users column "#0" -width 140 169 | bind .users [namespace code {userclick}] 170 | ttk::label .chaninfo -relief groove -border 2 -justify center -padding 2 -anchor center 171 | pack .nav -in .navframe -fill both -expand 1 172 | pack .topic -in .mainframe -side top -fill x 173 | pack .nick -in .cmdline -side left 174 | pack .cmd -in .cmdline -side right -fill x -expand 1 175 | pack .cmdline -in .mainframe -side bottom -fill x -pady 5 176 | pack .t -in .mainframe -fill both -expand 1 177 | pack .chaninfo -in .userframe -side top -fill x -padx 10 -pady 5 178 | pack .users -in .userframe -fill both -expand 1 -padx 1 -pady 5 179 | pack .root -fill both -expand 1 180 | bind . {.t yview scroll -1 page} 181 | bind . {.t yview scroll 1 page} 182 | bind . {ttk::treeview::Keynav .nav up} 183 | bind . {ttk::treeview::Keynav .nav down} 184 | bind . [namespace code {nexttaggedchannel}] 185 | bind . {if {[set r [.t tag nextrange sel 0.0]] ne ""} {clipboard clear; clipboard append [.t get {*}$r]}} 186 | bind .topic [namespace code setcurrenttopic] 187 | bind .cmd [namespace code returnkey] 188 | bind .cmd [namespace code [list history up]] 189 | bind .cmd [namespace code [list history down]] 190 | bind .cmd [namespace code tabcomplete] 191 | bind .cmd [namespace code {stopimplicitentry %K}] 192 | 193 | hook call setupui 194 | # this is called after the setupui hook because earlier tags override 195 | # later tags. 196 | .users tag config user -foreground black -image [image create photo -format png -data $::blankicon] 197 | 198 | dict for {serverid serverconf} $::config { 199 | dict set ::serverinfo $serverid $::ircdefaults 200 | ensurechan $serverid "" [list disabled] 201 | } 202 | .nav selection set [lindex $::config 0] 203 | focus .cmd 204 | } 205 | 206 | proc initnetwork {} { 207 | if {$::config eq ""} { 208 | puts stderr "Fatal error: no server entries were found in configuration.\n" 209 | exit 1 210 | } 211 | 212 | tls::init -tls1 true -ssl2 false -ssl3 false 213 | 214 | dict for {serverid serverconf} $::config { 215 | if {[dict get? 0 $serverconf -autoconnect]} {connect $serverid} 216 | } 217 | after 500 [namespace code "sendpendingison"] 218 | } 219 | 220 | proc irctolower {casemapping str} { 221 | set upper [dict get {ascii 90 rfc1459 94 strict-rfc1459 93} $casemapping] 222 | return [join [lmap c [split $str ""] {scan $c %c i; format %c [expr {$i >= 65 && $i <= $upper ? $i+32:$i}]}] ""] 223 | } 224 | proc ircstrcmp {casemapping a b} {return [string compare [irctolower $casemapping $a] [irctolower $casemapping $b]]} 225 | proc irceq {casemapping a b} {return [expr {[ircstrcmp $casemapping $a $b] == 0}]} 226 | proc foldl {cmd list} {set r [lindex $list 0];foreach e [lrange $list 1 end] {set r [apply $cmd $r $e]};return $r} 227 | proc min {list} {foldl {{a b} {expr {$a < $b ? $a:$b}}} $list} 228 | proc rankeduser {serverid entry} { 229 | set modes [dict values [dict get $::serverinfo $serverid prefix]] 230 | return [min [linsert [lmap m [lindex $entry 1] {lsearch $modes $m}] end [llength $modes]]][lindex $entry 0] 231 | } 232 | proc usercmp {serverid a b} {return [ircstrcmp [dict get $::serverinfo $serverid casemapping] [rankeduser $serverid $a] [rankeduser $serverid $b]]} 233 | proc isself {serverid nick} {return [irceq [dict get $::serverinfo $serverid casemapping] [dict get $::serverinfo $serverid nick] $nick]} 234 | proc isserver {serverid nick} { 235 | if [dict exists $::serverinfo $serverid servername] { 236 | if {[irceq [dict get $::serverinfo $serverid casemapping] [dict get $::serverinfo $serverid servername] $nick]} { 237 | return true 238 | } 239 | } 240 | return [expr {$nick == "*"}] 241 | } 242 | 243 | proc setchantopic {chanid text} { 244 | dict set ::channelinfo $chanid topic $text 245 | if {$chanid eq $::active} { 246 | .topic delete 0 end 247 | .topic insert 0 $text 248 | } 249 | } 250 | 251 | proc updatechaninfo {chanid} { 252 | .chaninfo configure -text [expr {![ischannel $chanid] ? "":[.nav tag has disabled $chanid] ? "Unjoined":"[llength [dict get $::channelinfo $chanid users]] users"}] 253 | } 254 | 255 | proc stopimplicitentry {key} { 256 | dict unset ::channelinfo $::active historyidx 257 | dict unset ::channelinfo $::active tab 258 | } 259 | 260 | proc history {op} { 261 | set idx [set oldidx [dict get? {} $::channelinfo $::active historyidx]] 262 | set cmdhistory [dict get $::channelinfo $::active cmdhistory] 263 | switch -- $op { 264 | "up" {set idx [expr {$idx eq "" ? 0 : $idx == [llength $cmdhistory] - 1 ? $oldidx : $idx + 1}]} 265 | "down" {set idx [expr {$idx eq "" || $idx == 0 ? "" : $idx - 1}]} 266 | } 267 | if {$idx eq $oldidx} {return} 268 | dict set ::channelinfo $::active historyidx $idx 269 | .cmd delete 1.0 end 270 | if {$idx ne {}} {.cmd insert 1.0 [lindex $cmdhistory $idx]} 271 | return -code break 272 | } 273 | proc tabcomplete {} { 274 | if {![ischannel $::active]} {return -code break} 275 | lassign [list [dict get $::channelinfo $::active users]] userlist user 276 | if {[dict exists $::channelinfo $::active tab]} { 277 | lassign [dict get $::channelinfo $::active tab] tabprefix tablast tabstart tabend 278 | if {[set pos [lsearch -exact -index 0 $userlist $tablast]] != -1} { 279 | set user [lsearch -inline -nocase -start [expr {$pos+1}] -index 0 -glob $userlist "[globescape $tabprefix]*"] 280 | } 281 | } else { 282 | lassign [list [.cmd get 1.0 {end - 1 char}] [regexp -inline {\d+$} [.cmd index insert]]] s pt 283 | if {[string index $s $pt] eq " "} { 284 | set pt [expr {$pt - 1}] 285 | if {[string index $s $pt] eq " "} { 286 | return -code break 287 | } 288 | } 289 | lassign [list [string wordstart $s $pt] [string wordend $s $pt]] tabstart tabend 290 | set tabprefix [string trimright [string range $s $tabstart $tabend]] 291 | } 292 | if {$user eq ""} { 293 | set user [lsearch -inline -nocase -index 0 -glob $userlist "[globescape $tabprefix]*"] 294 | if {$user eq ""} { 295 | return -code break 296 | } 297 | } 298 | set str [expr {$tabstart == 0 ? "[lindex $user 0]: ":[lindex $user 0]}] 299 | .cmd delete 1.$tabstart 1.$tabend 300 | .cmd insert 1.$tabstart $str 301 | dict set ::channelinfo $::active tab [list $tabprefix [lindex $user 0] $tabstart [expr {$tabstart + [string length $str]}]] 302 | return -code break 303 | } 304 | proc setchanusers {chanid users} { 305 | dict set ::channelinfo $chanid users $users 306 | if {$chanid ne $::active} { 307 | return 308 | } 309 | updatechaninfo $chanid 310 | set r -1 311 | foreach item [lsort -command "usercmp [serverpart $chanid]" $users] { 312 | .users move [lindex $item 0] {} [incr r] 313 | } 314 | } 315 | 316 | proc updateusermodes {chanid user addmodes delmodes} { 317 | set users [dict get $::channelinfo $chanid users] 318 | if {[set pos [lsearch -exact -index 0 $users $user]] == -1} {return} 319 | set modes [lindex [lindex $users $pos] 1] 320 | foreach delmode $delmodes {set modes [lsearch -all -inline -not -exact $modes $delmode]} 321 | set modes [concat $modes $addmodes] 322 | if {$chanid eq $::active} { 323 | foreach delmode $delmodes {.users tag remove $delmode $user} 324 | foreach addmode $addmodes {.users tag add $addmode $user} 325 | } 326 | setchanusers $chanid [lreplace $users $pos $pos [list $user $modes]] 327 | } 328 | 329 | # users should be {nick modes} 330 | proc addchanuser {chanid user modes} { 331 | set prefixes [dict get $::serverinfo [serverpart $chanid] prefix] 332 | regexp -- [string cat "^(\[" [join [dict keys $prefixes] ""] "\]*)(.*)"] $user -> userprefixes nick 333 | set usermodes [concat $modes [lmap uprefix [split $userprefixes ""] {dict get $prefixes $uprefix}]] 334 | set users [dict get $::channelinfo $chanid users] 335 | if {[lsearch -exact -index 0 $users $nick] != -1} { 336 | updateusermodes $chanid $nick $usermodes {} 337 | return 338 | } 339 | # new user to channel 340 | if {$chanid eq $::active} {.users insert {} end -id $nick -text $nick -tag [concat $usermodes [list "user"]]} 341 | setchanusers $chanid [concat $users [list [list $nick $usermodes]]] 342 | } 343 | 344 | proc remchanuser {chanid user} { 345 | if {[dict exists $::channelinfo $chanid]} { 346 | set prefixes [dict keys [dict get $::serverinfo [serverpart $chanid] prefix]] 347 | set nick [string trimleft $user $prefixes] 348 | set users [dict get $::channelinfo $chanid users] 349 | dict set ::channelinfo $chanid users [lsearch -all -inline -not -exact -index 0 $users $nick] 350 | if {$chanid eq $::active && [.users exists $nick]} { 351 | .users delete [list $nick] 352 | } 353 | } 354 | } 355 | 356 | proc userclick {} { 357 | ensurechan [chanid [serverpart $::active] [.users selection]] [.users selection] {} 358 | .nav selection set [chanid [serverpart $::active] [.users selection]] 359 | } 360 | 361 | proc loopedtreenext {window item} { 362 | if {[set next [lindex [$window children $item] 0]] ne ""} { 363 | return $next 364 | } elseif {[set next [$window next $item]] ne ""} { 365 | return $next 366 | } elseif {[set next [$window next [$window parent $item]]] ne ""} { 367 | return $next 368 | } 369 | # loop back to top 370 | return [lindex [$window children {}] 0] 371 | } 372 | 373 | proc nexttaggedchannel {} { 374 | set curchan [.nav selection] 375 | set chan [loopedtreenext .nav $curchan] 376 | while {$chan ne $curchan} { 377 | if {[.nav tag has message $chan]} {break} 378 | set chan [loopedtreenext .nav $chan] 379 | } 380 | if {$chan ne $curchan} {.nav selection set $chan} 381 | } 382 | 383 | proc tagcolorchange {pos prefix defaultcol oldcol newcol} { 384 | set newcol [expr {$newcol eq "" ? $defaultcol:$newcol}] 385 | if {$oldcol eq $newcol} {return [list {} $oldcol]} 386 | set result {} 387 | if {$oldcol ne $defaultcol} {lappend result [list $pos pop [string cat $prefix _ $oldcol]]} 388 | if {$newcol ne $defaultcol} {lappend result [list $pos push [string cat $prefix _ $newcol]]} 389 | return [list $result $newcol] 390 | } 391 | 392 | proc colorcode {text} { 393 | lassign {0 "" "" 0 0 black white} pos bold italic underline reverse fg bg result tagranges 394 | set rest $text 395 | while {$rest ne ""} { 396 | switch -- [string index $rest 0] { 397 | "\x02" { 398 | if {[string cat $bold $italic] ne ""} { 399 | lappend tagranges [list $pos pop "$bold$italic"] 400 | } 401 | set bold [expr {$bold == "bold" ? "":"bold"}] 402 | if {[string cat $bold $italic] ne ""} { 403 | lappend tagranges [list $pos push "$bold$italic"] 404 | } 405 | } 406 | "\x1d" { 407 | if {[string cat $bold $italic] ne ""} { 408 | lappend tagranges [list $pos pop "$bold$italic"] 409 | } 410 | set italic [expr {$italic == "italic" ? "":"italic"}] 411 | if {[string cat $bold $italic] ne ""} { 412 | lappend tagranges [list $pos push "$bold$italic"] 413 | } 414 | } 415 | "\x1f" {set underline [expr {!$underline}]; lappend tagranges [list $pos [expr {$underline ? "push" : "pop"}] underline]} 416 | "\x0f" { 417 | if {[string cat $bold $italic] ne ""} {lappend tagranges [list $pos pop "$bold$italic"]} 418 | if {$underline} {lappend tagranges [list $pos pop underline]} 419 | if {$fg ne "black"} {lappend tagranges [list $pos pop fg_$fg]} 420 | if {$bg ne "white"} {lappend tagranges [list $pos pop bg_$bg]} 421 | lassign {"" "" 0 0 black white} bold italic underline reverse fg bg 422 | } 423 | "\x03" { 424 | set rest [string range $rest 1 end] 425 | if {[regexp -- {^0?(\d\d?)(,0?(\d\d?))?} $rest match fgnum _ bgnum]} { 426 | set rest [string range $rest [string length $match] end] 427 | if {$reverse} { 428 | lassign [list $bgnum $fgnum] fgnum bgnum 429 | } 430 | lassign [tagcolorchange $pos "fg" "black" $fg [dict get? "black" $::codetagcolormap $fgnum]] newtags fg 431 | lappend tagranges {*}$newtags 432 | lassign [tagcolorchange $pos "bg" "white" $bg [dict get? "white" $::codetagcolormap $bgnum]] newtags bg 433 | lappend tagranges {*}$newtags 434 | } else { 435 | lassign [tagcolorchange $pos "fg" "black" $fg "black"] newtags fg 436 | lappend tagranges {*}$newtags 437 | lassign [tagcolorchange $pos "bg" "white" $bg "white"] newtags bg 438 | lappend tagranges {*}$newtags 439 | } 440 | continue 441 | } 442 | "\x16" { 443 | lassign [list [expr {!$reverse}] $fg $bg] reverse newbg newfg 444 | lassign [tagcolorchange $pos "fg" "black" $fg $newfg] newtags fg 445 | lappend tagranges {*}$newtags 446 | lassign [tagcolorchange $pos "bg" "white" $bg $newbg] newtags bg 447 | lappend tagranges {*}$newtags 448 | } 449 | default { 450 | append result [string index $rest 0] 451 | incr pos 452 | } 453 | } 454 | set rest [string range $rest 1 end] 455 | } 456 | return [list $result $tagranges] 457 | } 458 | 459 | proc regexranges {text regex tag} { 460 | set ranges {} 461 | for {set start 0} {[regexp -indices -start $start -- $regex $text match]} {set start [expr {[lindex $match 1] + 1}]} { 462 | lappend ranges [list [lindex $match 0] push $tag] [list [expr {[lindex $match 1] + 1}] pop $tag] 463 | } 464 | return $ranges 465 | } 466 | 467 | # returns text into window with tags determined by potentially 468 | # overlapping styles. The "delete" tag is handled specially and 469 | # removes the text. Example: 470 | # combinestyles "text" {0 push red} {2 pop red} 471 | proc combinestyles {text ranges} { 472 | lassign {{} {} 0} result activetags textstart 473 | foreach rangetag [lsort -index 0 -integer $ranges] { 474 | lassign $rangetag pos op tag 475 | if {$textstart < $pos} { 476 | lappend result [string range $text $textstart $pos-1] $activetags 477 | } 478 | set textstart $pos 479 | if {$op eq "push"} { 480 | lappend activetags $tag 481 | } elseif {[set pos [lsearch -exact $activetags $tag]] != -1} { 482 | set activetags [lreplace $activetags $pos $pos] 483 | } 484 | } 485 | return [concat $result [list [string range $text $textstart end] $activetags]] 486 | } 487 | 488 | hook tagchantext irken-color 50 {text ranges} { 489 | lassign [colorcode $text] text newranges 490 | return -code continue [list $text [concat $ranges $newranges]] 491 | } 492 | set httpregexp {https?://[-A-Za-z0-9._~:/?#\[\]@!$%&'()*+,;=]+[-A-Za-z0-9_~:/#\[\]@$%&'()*+=]} 493 | hook tagchantext irken-http 60 {text ranges} { 494 | return -code continue [list $text [concat $ranges [regexranges $text $::irken::httpregexp hlink]]] 495 | } 496 | 497 | # addchantext inserts a line of text at the end of a channel's 498 | # buffer, updating the UI as necessary. If adding text to the 499 | # active channel, it inserts the text at the end of the widget. 500 | # Otherwise, it sets the highlighting for the channel in the nav 501 | # widget. It calls the tagchantext hook to split the text into 502 | # {text taglist} chunks. 503 | # 504 | # Usage: 505 | # addchantext [] 506 | # Options may be: 507 | # -time Sets the time of the message. Defaults to the current time. 508 | # -nick Sets the nick of the message Defaults to "*" 509 | # -tags Sets tags applied to the whole message. 510 | proc addchantext {chanid text args} { 511 | set textranges [combinestyles {*}[hook call tagchantext $text [lmap linetag "[dict get? {} $args -tags] line" {list 0 push $linetag}]]] 512 | # Using conditional expr instead of dict get? to avoid getting clock multiple times per message. 513 | set timestamp [expr {[dict exists $args -time] ? [dict get $args -time]:[clock seconds]}] 514 | lappend newtext "\[[clock format $timestamp -format %H:%M:%S]\]" {} "\t[dict get? * $args -nick]\t" "nick" {*}$textranges "\n" {} 515 | dict append ::channeltext $chanid " $newtext" 516 | if {$chanid ne $::active} { 517 | # Add all the tags passed in as -tag to the nav entry, plus unseen tag. 518 | foreach tag [concat "unseen" [dict get? {} $args -tags]] { 519 | .nav tag add $tag $chanid 520 | } 521 | hook call textinserted $chanid $newtext 522 | return 523 | } 524 | set atbottom [expr {[lindex [.t yview] 1] == 1.0}] 525 | .t configure -state normal 526 | .t insert end {*}$newtext 527 | if {$atbottom} { 528 | .t yview end 529 | } 530 | .t configure -state disabled 531 | hook call textinserted $chanid $newtext 532 | } 533 | 534 | proc selectchan {} { 535 | if {[set chanid [.nav selection]] eq $::active} { 536 | return 537 | } 538 | set ::active $chanid 539 | .nav focus $chanid 540 | foreach tag [.nav item $chanid -tags] { 541 | # Remove all inessential tags 542 | if {[lsearch -exact [list "server" "channel" "direct" "disabled"] $tag] == -1} { 543 | .nav tag remove $tag $chanid 544 | } 545 | } 546 | .t configure -state normal 547 | .t delete 1.0 end 548 | if {[dict get $::channeltext $chanid] ne ""} { 549 | .t insert end {*}[dict get $::channeltext $chanid] 550 | .t yview end 551 | } 552 | .t configure -state disabled 553 | .topic delete 0 end 554 | .topic insert 0 [dict get? "" $::channelinfo $chanid topic] 555 | .users delete [.users children {}] 556 | if {[ischannel $chanid]} { 557 | foreach user [lsort -command "usercmp [serverpart $chanid]" [dict get? {} $::channelinfo $chanid users]] { 558 | .users insert {} end -id [lindex $user 0] -text [lindex $user 0] -tag [concat [lindex $user 1] "user"] 559 | } 560 | } 561 | updatechaninfo $chanid 562 | if {[dict exists $::serverinfo [serverpart $chanid] nick]} { 563 | .nick configure -text [dict get $::serverinfo [serverpart $chanid] nick] 564 | } else { 565 | .nick configure -text [dict get $::config [serverpart $chanid] -nick] 566 | } 567 | wm title . "Irken - [serverpart $::active]/[.nav item $::active -text]" 568 | focus .cmd 569 | hook call chanselected $chanid 570 | } 571 | 572 | # ensurechan creates the data structures and ui necessary to support a 573 | # new channel for the chanid, if the channel does not already exist. 574 | # If the channel does exist, it updates the channel name in the UI if 575 | # name is specified. The name should only be specified in response to 576 | # server messages, so that it gets the correct capitalization. 577 | proc ensurechan {chanid name tags} { 578 | lappend ::seennicks $chanid 579 | if {[.nav exists $chanid]} { 580 | if {$name ne ""} {.nav item $chanid -text $name} 581 | return 582 | } 583 | # When no elements are given, lappend has a useful property of 584 | # leaving the value alone if the key exists, but creating a key 585 | # with an empty string when it doesn't. 586 | dict lappend ::channeltext $chanid 587 | dict set ::channelinfo $chanid [dict create cmdhistory {} historyidx {} topic {} users {}] 588 | if {[channelpart $chanid] eq ""} { 589 | .nav insert {} end -id $chanid -text $chanid -open True -tag [concat server $tags] 590 | return 591 | } 592 | 593 | set tag [expr {[ischannel $chanid] ? "channel":"direct"}] 594 | .nav insert [serverpart $chanid] end -id $chanid -text [expr {$name eq "" ? [channelpart $chanid]:$name}] -tag [concat $tag $tags] 595 | 596 | set items [lsort [.nav children [serverpart $chanid]]] 597 | for {set i 0} {$i < [llength $items]} {incr i} { 598 | .nav move [lindex $items $i] [serverpart $chanid] $i 599 | } 600 | } 601 | 602 | proc removechan {chanid} { 603 | dict unset ::channeltext $chanid 604 | dict unset ::channelinfo $chanid 605 | if {$::active eq $chanid} { 606 | ttk::treeview::Keynav .nav down 607 | selectchan 608 | if {$::active eq $chanid} { 609 | ttk::treeview::Keynav .nav up 610 | selectchan 611 | } 612 | } 613 | .nav delete [list $chanid] 614 | } 615 | 616 | proc sendpendingison {} { 617 | set servernicks [dict create] 618 | foreach chanid [dict keys $::channelinfo] { 619 | if {[channelpart $chanid] ne "" && ![ischannel $chanid] && ![.nav tag has disabled [serverpart $chanid]]} { 620 | dict lappend servernicks [serverpart $chanid] [channelpart $chanid] 621 | } 622 | } 623 | dict for {serverid nicks} $servernicks { 624 | foreach line [regexp -all -inline {\S(?:\S{0,200}|.{0,200}(?=\s+|$))} [join $nicks " "]] {send $serverid "ISON $line"} 625 | } 626 | after 500 [namespace code "updatepresence"] 627 | } 628 | 629 | proc updatepresence {} { 630 | foreach chanid [dict keys $::channelinfo] { 631 | if {[channelpart $chanid] ne "" && ![ischannel $chanid] && ![.nav tag has disabled $chanid] && [lsearch $::seennicks $chanid] == -1} { 632 | .nav tag add disabled $chanid 633 | addchantext $chanid "[channelpart $chanid] has logged out." -tags system 634 | } 635 | } 636 | set ::seennicks {} 637 | after 60000 [namespace code "sendpendingison"] 638 | } 639 | 640 | set ::ircdefaults [dict create casemapping "rfc1459" chantypes "#&" channellen "200" prefix [dict create @ o + v]] 641 | 642 | proc connect {serverid} { 643 | if {[catch {dict get $::config $serverid -host} host]} { 644 | addchantext $serverid "Fatal error: $serverid has no -host option $host." -tags system 645 | return 646 | } elseif {![dict exists $::config $serverid -nick]} { 647 | addchantext $serverid "Fatal error: $serverid has no -nick option." -tags system 648 | return 649 | } elseif {![dict exists $::config $serverid -user]} { 650 | addchantext $serverid "Fatal error: $serverid has no -user option." -tags system 651 | return 652 | } 653 | set insecure [dict get? 0 $::config $serverid -insecure] 654 | set port [dict get? [expr {$insecure ? 6667:6697}] $::config $serverid -port] 655 | 656 | addchantext $serverid "Connecting to $serverid ($host:$port)..." -tags system 657 | set chan [if {$insecure} {socket -async $host $port} {tls::socket -async $host $port}] 658 | fileevent $chan writable [namespace code [list connected $chan]] 659 | dict set ::servers $chan $serverid 660 | dict set ::serverinfo $serverid [dict merge [dict create chan $chan nick [dict get $::config $serverid -nick]] $::ircdefaults] 661 | } 662 | 663 | proc connected {chan} { 664 | set serverid [dict get $::servers $chan] 665 | if {[set err [chan configure $chan -error]] ne ""} { 666 | close $chan 667 | addchantext $serverid "Connection failure: $err" -tags system 668 | hook call disconnection $serverid 669 | return 670 | } 671 | chan configure $chan -blocking 0 -buffering line -encoding iso8859-1 672 | fileevent $chan writable {} 673 | fileevent $chan readable [namespace code [list recv $chan]] 674 | .nav tag remove disabled [concat [list $serverid] [.nav children $serverid]] 675 | hook call connected $serverid 676 | after 60000 [namespace code [list sendping $serverid $chan]] 677 | addchantext $serverid "Connected." -tags system 678 | # IRCv3 states that the client should send a single CAP REQ, 679 | # followed by PASS, NICK, and USER, and only then the rest 680 | # of the capability negotiations. Servers seem to be flexible 681 | # in this regard, but this does things in the proper order. 682 | 683 | # Note that the client sends multiple CAP REQ requests instead 684 | # of one because a) it's doing so blindly and b) the requested 685 | # capabilities are rejected as a whole if one of them isn't 686 | # present. 687 | send $serverid "CAP REQ :multi-prefix" 688 | if {[dict exists $::config $serverid -pass]} { 689 | send $serverid "PASS [dict get $::config $serverid -pass]" 690 | } 691 | send $serverid "NICK [dict get $::config $serverid -nick]" 692 | send $serverid "USER [dict get $::config $serverid -user] 0 * :Irken user" 693 | send $serverid "CAP REQ :znc.in/server-time-iso\nCAP REQ :server-time\nCAP END" 694 | } 695 | 696 | proc disconnected {chan} { 697 | close $chan 698 | set serverid [dict get $::servers $chan] 699 | dict unset ::servers $chan 700 | .nav tag add disabled [concat [list $serverid] [.nav children $serverid]] 701 | addchantext $serverid "Server disconnected." -tags system 702 | hook call disconnection $serverid 703 | } 704 | 705 | proc sendping {serverid chan} { 706 | if {[dict exists $::servers $chan]} { 707 | # Server channel closed 708 | return 709 | } 710 | set now [expr {[clock milliseconds] - $::starttime}] 711 | send $serverid "PING :keepalive-$now" 712 | after 5000 [namespace code [list expectpong $serverid $chan $now]] 713 | } 714 | 715 | proc expectpong {serverid chan lastping} { 716 | if {![dict exists $::servers $chan]} { 717 | # Server channel closed 718 | return 719 | } 720 | if {[dict get? $lastping ::serverinfo $serverid lastpong] < $lastping} { 721 | addchantext $serverid "Server didn't respond to keepalive after 5s." -tags system 722 | disconnected $chan 723 | return 724 | } 725 | after 55000 [namespace code [list sendping $serverid $chan]] 726 | } 727 | 728 | hook handlePONG irken 50 {serverid msg} { 729 | if {[string equal -length 10 "keepalive-" [lindex [dict get $msg args] 1]]} { 730 | set now [expr {[clock milliseconds] - $::starttime}] 731 | set pingtime [string range [lindex [dict get $msg args] 1] 10 end] 732 | dict set ::serverinfo $serverid lastpong $now 733 | addchantext $serverid "Lag time: [expr {$now - $pingtime}]" -tags system 734 | } 735 | } 736 | hook handle001 irken 50 {serverid msg} { 737 | dict set ::serverinfo $serverid servername [dict get $msg src] 738 | dict set ::serverinfo $serverid nick [lindex [dict get $msg args] 0] 739 | .nick configure -text [lindex [dict get $msg args] 0] 740 | foreach chan [dict get? {} $::config $serverid -autojoin] { 741 | ensurechan [chanid $serverid $chan] "" disabled 742 | send $serverid "JOIN $chan" 743 | } 744 | } 745 | hook handle005 irken 50 {serverid msg} { 746 | foreach param [lrange [dict get $msg args] 1 end] { 747 | lassign [split $param "="] key val 748 | if {[lsearch -exact {CASEMAPPING CHANTYPES CHANNELLEN PREFIX} $key] != -1} { 749 | switch -- $key { 750 | "PREFIX" { 751 | if {[regexp -- "^\\((\[^\)\]*)\\)(.*)" $val -> modes prefixes]} { 752 | dict set ::serverinfo $serverid prefix \ 753 | [dict create {*}[concat {*}[lmap p [split $prefixes ""] m [split $modes ""] {list $p $m}]]] 754 | } 755 | } 756 | default {dict set ::serverinfo $serverid [string tolower $key] $val} 757 | } 758 | } 759 | } 760 | } 761 | hook handle301 irken 50 {serverid msg} { 762 | lassign [dict get $msg args] nick awaymsg 763 | addchantext [chanid $serverid $nick] "$nick is away: $awaymsg" -tags system 764 | } 765 | hook handle303 irken 50 {serverid msg} { 766 | foreach nick [split [lindex [dict get $msg args] 1] " "] { 767 | set chanid [chanid $serverid $nick] 768 | if {[.nav exists $chanid]} { 769 | ensurechan $chanid $nick {} 770 | if {[.nav tag has disabled $chanid]} { 771 | .nav tag remove disabled $chanid 772 | addchantext $chanid "[channelpart $chanid] has logged in." -tags system 773 | } 774 | } 775 | } 776 | } 777 | hook handle305 irken 50 {serverid msg} { 778 | addchantext $::active "You are no longer marked as being away." -tags system 779 | } 780 | hook handle306 irken 50 {serverid msg} { 781 | addchantext $::active "You have been marked as being away." -tags system 782 | } 783 | hook handle328 irken 50 {serverid msg} { 784 | lassign [dict get $msg args] target chan url 785 | addchantext [chanid $serverid $chan] "Channel URL is $url." -tags system 786 | } 787 | hook handle331 irken 50 {serverid msg} { 788 | set chanid [chanid $serverid [lindex [dict get $msg args] 1]] 789 | setchantopic $chanid "" 790 | addchantext $chanid "No channel topic set." -tags system 791 | } 792 | hook handle332 irken 50 {serverid msg} { 793 | lassign [dict get $msg args] target chan topic 794 | set chanid [chanid $serverid $chan] 795 | ensurechan $chanid $chan {} 796 | setchantopic $chanid $topic 797 | if {$topic ne ""} { 798 | addchantext $chanid "Channel topic: $topic" -tags system 799 | } else { 800 | addchantext $chanid "No channel topic set." -tags system 801 | } 802 | } 803 | hook handle333 irken 50 {serverid msg} { 804 | set chanid [chanid $serverid [lindex [dict get $msg args] 1]] 805 | set nick [lindex [dict get $msg args] 2] 806 | if {[llength [dict get $msg args]] == 4} { 807 | set time [lindex [dict get $msg args] 3] 808 | addchantext $chanid "Topic set by $nick at [clock format $time]." -tags system 809 | } else { 810 | addchantext $chanid "Topic set by $nick." -tags system 811 | } 812 | } 813 | hook handle353 irken 50 {serverid msg} { 814 | set chanid [chanid $serverid [lindex [dict get $msg args] 2]] 815 | foreach user [split [lindex [dict get $msg args] 3] " "] { 816 | addchanuser $chanid $user {} 817 | } 818 | } 819 | hook handle366 irken 50 {serverid msg} {return} 820 | hook handle372 irken 50 {serverid msg} { 821 | addchantext $serverid [lindex [dict get $msg args] 1] -tags system 822 | } 823 | hook handle376 irken 50 {serverid msg} { 824 | hook call ready $serverid 825 | } 826 | hook handle422 irken 50 {serverid msg} { 827 | hook call ready $serverid 828 | } 829 | hook handleJOIN irken 50 {serverid msg} { 830 | set chan [lindex [dict get $msg args] 0] 831 | set chanid [chanid $serverid $chan] 832 | ensurechan $chanid $chan {} 833 | addchanuser $chanid [dict get $msg src] {} 834 | if {[isself $serverid [dict get $msg src]]} { 835 | .nav tag remove disabled $chanid 836 | } 837 | } 838 | hook handleJOIN irken-display 75 {serverid msg} { 839 | set chan [lindex [dict get $msg args] 0] 840 | if {![isself $serverid [dict get $msg src]]} { 841 | addchantext [chanid $serverid $chan] "[dict get $msg src] has joined $chan" -tags system 842 | } 843 | } 844 | hook handleKICK irken 50 {serverid msg} { 845 | lassign [dict get $msg args] chan target 846 | set chanid [chanid $serverid $chan] 847 | remchanuser $chanid $target 848 | if {[isself $serverid $target]} { 849 | .nav tag add disabled $chanid 850 | } 851 | } 852 | hook handleKICK irken-display 75 {serverid msg} { 853 | lassign [dict get $msg args] chan target note 854 | set note [expr {$note ne "" ? " ($note)":""}] 855 | addchantext [chanid $serverid $chan] [format "%s kicks %s from %s.%s" [dict get $msg src] [expr {[isself $serverid $target] ? "you":$target}] $chan $note] -tags system 856 | } 857 | hook handleMODE irken 50 {serverid msg} { 858 | set args [lassign [dict get $msg args] target] 859 | set chanid [chanid $serverid $target] 860 | set msgdest [expr {[ischannel $chanid] ? $chanid:$serverid}] 861 | if {[lsearch -exact [dict get $msg src] "!"] == -1} { 862 | addchantext $msgdest "Mode for $target set to [lrange [dict get $msg args] 1 end]" -tags system 863 | } else { 864 | addchantext $msgdest "[dict get $msg src] sets mode for $target to [lrange [dict get $msg args] 1 end]" -tags system 865 | } 866 | if {[ischannel $chanid]} { 867 | lassign {} changes params 868 | foreach arg $args { 869 | if {[regexp {^([-+])(.*)} $arg -> op terms]} { 870 | lappend changes {*}[lmap term [split $terms ""] {list $op $term}] 871 | } else { 872 | lappend params $arg 873 | } 874 | } 875 | set modes [dict values [dict get $::serverinfo $serverid prefix]] 876 | foreach change $changes { 877 | if {[lindex $change 1] in $modes} { 878 | set params [lassign $params param] 879 | if {[lindex $change 0] eq "+"} { 880 | updateusermodes $chanid $param [lindex $change 1] {} 881 | } else { 882 | updateusermodes $chanid $param {} [lindex $change 1] 883 | } 884 | } 885 | } 886 | } 887 | } 888 | hook handleNICK irken 50 {serverid msg} { 889 | set oldnick [dict get $msg src] 890 | set newnick [lindex [dict get $msg args] 0] 891 | if {[isself $serverid $oldnick]} { 892 | dict set ::serverinfo $serverid nick $newnick 893 | if {[serverpart $::active] eq $serverid} { 894 | .nick configure -text $newnick 895 | } 896 | } 897 | foreach chanid [dict keys $::channelinfo] { 898 | if {![ischannel $chanid] || [serverpart $chanid] ne $serverid} { 899 | continue 900 | } 901 | set user [lsearch -exact -inline -index 0 [dict get $::channelinfo $chanid users] $oldnick] 902 | if {$user eq ""} { 903 | continue 904 | } 905 | remchanuser $chanid $oldnick 906 | addchanuser $chanid $newnick [lindex $user 1] 907 | } 908 | set oldchanid [chanid $serverid $oldnick] 909 | set newchanid [chanid $serverid $newnick] 910 | if {[dict exists $::channelinfo $oldchanid] && ![dict exists $::channelinfo $newchanid]} { 911 | dict set ::channelinfo $newchanid [dict get $::channelinfo $oldchanid] 912 | dict set ::channeltext $newchanid [dict get $::channeltext $oldchanid] 913 | dict unset ::channeltext $oldchanid 914 | dict unset ::channelinfo $oldchanid 915 | .nav insert $serverid [.nav index $oldchanid] -id $newchanid {*}[.nav item $oldchanid] -text $newnick 916 | .nav delete [list $oldchanid] 917 | if {$::active eq $oldchanid} { 918 | .nav selection set $newchanid 919 | } 920 | } 921 | } 922 | hook handleNICK irken-display 75 {serverid msg} { 923 | set oldnick [dict get $msg src] 924 | set newnick [lindex [dict get $msg args] 0] 925 | foreach chanid [dict keys $::channelinfo] { 926 | if {![ischannel $chanid] || [serverpart $chanid] ne $serverid} { 927 | return 928 | } 929 | set user [lsearch -exact -inline -index 0 [dict get $::channelinfo $chanid users] $oldnick] 930 | if {$user eq ""} {return} 931 | addchantext $chanid "$oldnick is now known as $newnick" -tags system 932 | } 933 | set newchanid [chanid $serverid $newnick] 934 | if {[dict exists $::channelinfo $newchanid]} { 935 | addchantext $newchanid "$oldnick is now known as $newnick" -tags system 936 | } 937 | } 938 | hook handleNOTICE irken 50 {serverid msg} { 939 | hook call handlePRIVMSG $serverid $msg 940 | } 941 | hook handlePART irken 50 {serverid msg} { 942 | set chanid [chanid $serverid [lindex [dict get $msg args] 0]] 943 | remchanuser $chanid [dict get $msg src] 944 | if {[isself $serverid [dict get $msg src]]} { 945 | if {[.nav exists $chanid]} { 946 | .nav tag add disabled $chanid 947 | dict set ::channelinfo $chanid users {} 948 | if {$chanid eq $::active} { 949 | .users delete [.users children {}] 950 | updatechaninfo $chanid 951 | } 952 | } 953 | } 954 | } 955 | hook handlePART irken-display 75 {serverid msg} { 956 | lassign [dict get $msg args] chan note 957 | set note [expr {$note ne "" ? " ($note)":""}] 958 | set chanid [chanid $serverid $chan] 959 | if {[isself $serverid [dict get $msg src]]} { 960 | if {[dict exists $::channelinfo $chanid]} { 961 | addchantext $chanid "You have left $chan.$note" -tags system 962 | } 963 | } else { 964 | addchantext $chanid "[dict get $msg src] has left $chan.$note" -tags system 965 | } 966 | } 967 | hook handlePING irken 50 {serverid msg} {send $serverid "PONG :[dict get $msg args]"} 968 | hook handlePRIVMSG irken-privmsg 20 {serverid msg} { 969 | # We handle privmsgs specially here, since there's some duplicate 970 | # work between a CTCP ACTION and a normal PRIVMSG. 971 | dict set msg chan [string trimleft [lindex [dict get $msg args] 0] [dict keys [dict get $::serverinfo $serverid prefix]]] 972 | if {[isself $serverid [dict get $msg chan]]} { 973 | # direct message - so chan is source, not target 974 | dict set msg chan [dict get $msg src] 975 | } 976 | dict lappend msg tag "message" 977 | if {[isself $serverid [dict get $msg src]]} { 978 | dict lappend msg tag "self" 979 | } 980 | if {[string first [dict get $::serverinfo $serverid nick] [lindex [dict get $msg args] 1]] != -1} { 981 | dict lappend msg tag "highlight" 982 | } 983 | return -code continue [list $serverid $msg] 984 | } 985 | hook handlePRIVMSG irken 50 {serverid msg} { 986 | if {[isserver $serverid [dict get $msg chan]]} { 987 | set chanid $serverid 988 | } else { 989 | set chanid [chanid $serverid [dict get $msg chan]] 990 | ensurechan $chanid [dict get $msg chan] {} 991 | } 992 | if {[regexp {^\001([A-Za-z0-9]+) ?(.*?)\001?$} [lindex [dict get $msg args] 1] -> cmd text]} { 993 | hook call ctcp$cmd $chanid $msg $text 994 | return -code break 995 | } 996 | addchantext $chanid [lindex [dict get $msg args] 1] -time [dict get $msg time] -nick [dict get $msg src] -tags [dict get? {} $msg tag] 997 | } 998 | hook handleQUIT irken 50 {serverid msg} { 999 | foreach chanid [lsearch -all -inline -glob [dict keys $::channelinfo] "$serverid/*"] { 1000 | if {[lsearch -exact -index 0 [dict get $::channelinfo $chanid users] [dict get $msg src]] != -1} { 1001 | remchanuser $chanid [dict get $msg src] 1002 | dict lappend msg affectedchans $chanid 1003 | } 1004 | } 1005 | # The user isn't going to be in the channels, so a message with 1006 | # annotation is passed for the display hook. 1007 | return -code continue [list $serverid $msg] 1008 | } 1009 | hook handleQUIT irken-display 75 {serverid msg} { 1010 | set note [expr {[set note [lindex [dict get $msg args] 0]] eq "" ? "":" ($note)"}] 1011 | foreach chanid [dict get? {} $msg affectedchans] { 1012 | addchantext $chanid "[dict get $msg src] has quit$note" -tags system 1013 | } 1014 | set chanid [chanid $serverid [dict get $msg src]] 1015 | if {[.nav exists $chanid]} { 1016 | .nav tag add disabled $chanid 1017 | addchantext $chanid "[dict get $msg src] has quit$note" -tags system 1018 | } 1019 | 1020 | } 1021 | hook handleTOPIC irken 50 {serverid msg} { 1022 | set chanid [chanid $serverid [lindex [dict get $msg args] 0]] 1023 | set topic [lindex [dict get $msg args] 1] 1024 | setchantopic $chanid $topic 1025 | addchantext $chanid "[dict get $msg src] sets title to $topic" -tags system 1026 | } 1027 | hook handleUnknown irken 50 {serverid msg} { 1028 | addchantext $serverid "[dict get $msg line]" -tags system 1029 | } 1030 | 1031 | proc ctcpreply {chanid msg cmd text} { 1032 | if {[dict get $msg cmd] ne "NOTICE"} { 1033 | return 0 1034 | } 1035 | addchantext $chanid "CTCP $cmd reply: $text" -time [dict get $msg time] -tags system 1036 | return 1 1037 | } 1038 | 1039 | hook ctcpACTION irken 50 {chanid msg text} { 1040 | addchantext $chanid "[dict get $msg src] $text" -time [dict get $msg time] -tags [dict get? {} $msg tag] 1041 | } 1042 | hook ctcpCLIENTINFO irken 50 {chanid msg text} { 1043 | if {[ctcpreply $chanid $msg "CLIENTINFO" $text]} { 1044 | return -code break 1045 | } 1046 | addchantext $chanid "CTCP CLIENTINFO request" -time [dict get $msg time] -tags system 1047 | send [serverpart $chanid] "NOTICE [dict get $msg src] :\001ACTION CLIENTINFO PING TIME VERSION\001" 1048 | } 1049 | hook ctcpPING irken 50 {chanid msg text} { 1050 | if {[dict get $msg cmd] eq "NOTICE"} { 1051 | if {[dict exists $::ctcppings "[dict get $msg src]-$text"]} { 1052 | set rtt [expr {[clock milliseconds] - $::starttime - [dict get $::ctcppings "[dict get $msg src]-$text"]}] 1053 | addchantext $chanid "CTCP PING reply: $text (${rtt}ms)" -time [dict get $msg time] -tags system 1054 | } else { 1055 | addchantext $chanid "CTCP PING reply: $text" -time [dict get $msg time] -tags system 1056 | } 1057 | return -code break 1058 | } 1059 | addchantext $chanid "CTCP PING request: $text" -time [dict get $msg time] -tags system 1060 | send [serverpart $chanid] "NOTICE [dict get $msg src] :\001PING $text\001" 1061 | } 1062 | hook ctcpTIME irken 50 {chanid msg text} { 1063 | if {[ctcpreply $chanid $msg "TIME" $text]} { 1064 | return -code break 1065 | } 1066 | addchantext $chanid "CTCP TIME request" -time [dict get $msg time] -tags system 1067 | send [serverpart $chanid] "NOTICE [dict get $msg src] :\001TIME [clock format [clock seconds] -gmt 1]\001" 1068 | } 1069 | hook ctcpVERSION irken 50 {chanid msg text} { 1070 | if {[ctcpreply $chanid $msg "VERSION" $text]} { 1071 | return -code break 1072 | } 1073 | addchantext $chanid "CTCP VERSION request" -time [dict get $msg time] -tags system 1074 | send [serverpart $chanid] "NOTICE [dict get $msg src] :\001VERSION Irken 1.0\001" 1075 | } 1076 | 1077 | proc parseline {line} { 1078 | if {[catch {encoding convertfrom utf-8 $line} line]} { 1079 | return "" 1080 | } 1081 | if {![regexp {^(?:@(\S*) )?(?::([^ !]*)(?:!([^ @]*)(?:@([^ ]*))?)?\s+)?(\S+)\s*((?:[^:]\S*(?:\s+|$))*)(?::(.*))?} $line -> tags src user host cmd args trailing]} { 1082 | return "" 1083 | } 1084 | set args [split [string trimright $args] " "] 1085 | if {$trailing ne ""} {lappend args $trailing} 1086 | set msg [dict create tags [concat {*}[lmap t [split $tags ";"] {split $t "="}]] src $src user $user host $host cmd $cmd args $args line $line] 1087 | dict for {k v} [dict get $msg tags] { 1088 | # escaped non-special characters unescape to themselves 1089 | regsub -all {\\([^; rn\\])} v "\\1" v 1090 | dict set msg tags $k [string map {\\: ";" \\s " " \\r "\r" \\n "\n" \\\\ "\\"} v] 1091 | } 1092 | if {[dict exists $msg tags time]} { 1093 | dict set msg time [clock scan [regsub {^(\d+)-(\d+)-(\d+)T(\d+):(\d+):(\d+)(?:\.\d+)?} [dict get $msg tags time] {\1\2\3T\4\5\6}]] 1094 | } else { 1095 | dict set msg time [clock seconds] 1096 | } 1097 | return $msg 1098 | } 1099 | 1100 | proc recv {chan} { 1101 | if {[catch {gets $chan line} len] || [eof $chan]} { 1102 | disconnected $chan 1103 | } elseif {$len != 0 && [set msg [parseline $line]] ne ""} { 1104 | hook call [expr {[hook exists "handle[dict get $msg cmd]"] ? "handle[dict get $msg cmd]":"handleUnknown"}] [dict get $::servers $chan] $msg 1105 | } 1106 | } 1107 | 1108 | hook cmdCLOSE irken 50 {serverid arg} { 1109 | set chanid [expr {[llength $arg] > 0 ? [chanid $serverid [lindex $arg 0]]:$::active}] 1110 | if {![dict exists $::channelinfo $chanid]} { 1111 | addchantext $::active "No such channel [lindex $arg 0]" -tags system 1112 | return -code break 1113 | } 1114 | if {[channelpart $chanid] eq ""} { 1115 | addchantext $::active "Closing a server window is not allowed." -tags system 1116 | return -code break 1117 | } 1118 | if {[ischannel $chanid] && ![.nav tag has disabled $chanid]} { 1119 | send $serverid "PART [channelpart $chanid] :[lrange $arg 1 end]" 1120 | } 1121 | removechan $chanid 1122 | } 1123 | hook cmdEVAL irken 50 {serverid arg} { 1124 | addchantext $::active "$arg -> [namespace eval :: $arg]" -tags system 1125 | } 1126 | hook cmdCTCP irken 50 {serverid arg} { 1127 | if {![regexp {^(\S+) +(\S+) *(.*)} $arg -> target cmd arg]} { 1128 | addchantext $::active "Usage: /CTCP []" -tags system 1129 | return -code break 1130 | } 1131 | set cmd [string toupper $cmd] 1132 | if {$cmd eq "PING"} { 1133 | if {$arg eq ""} {set arg [expr {[clock milliseconds] - $::starttime}]} 1134 | dict set ::ctcppings "$target-$arg" [expr {[clock milliseconds] - $::starttime}] 1135 | } 1136 | if {$arg ne ""} {set arg [string cat " " $arg]} 1137 | if {$cmd eq "ACTION"} { 1138 | addchantext $::active "[dict get $::serverinfo $serverid nick]$arg" -tags self 1139 | } else { 1140 | addchantext $::active "sent CTCP $cmd$arg" -tags {self system} 1141 | } 1142 | send $serverid "PRIVMSG $target :\001$cmd$arg\001" 1143 | } 1144 | hook cmdME irken 50 {serverid arg} { 1145 | if {[channelpart $::active] eq ""} { 1146 | addchantext $::active "This isn't a channel." -tags system 1147 | return 1148 | } 1149 | hook call cmdCTCP $serverid "[channelpart $::active] ACTION $arg" 1150 | } 1151 | hook cmdJOIN irken 50 {serverid arg} { 1152 | ensurechan [chanid $serverid $arg] "" disabled 1153 | .nav selection set [chanid $serverid $arg] 1154 | send $serverid "JOIN $arg" 1155 | } 1156 | hook cmdQUIT irken 50 {serverid arg} { 1157 | send $serverid "QUIT :$arg" 1158 | } 1159 | hook cmdMSG irken 50 {serverid arg} { 1160 | if {[regexp -- {^(\S+) (.*)$} $arg -> target text]} { 1161 | foreach line [split $text "\n"] { 1162 | send $serverid "PRIVMSG $target :$line" 1163 | ensurechan [chanid $serverid $target] "" {} 1164 | addchantext [chanid $serverid $target] "$line" -nick [dict get $::serverinfo $serverid nick] -tags self 1165 | } 1166 | } else { 1167 | addchantext $::active "Usage: /MSG " -tags system 1168 | } 1169 | } 1170 | hook cmdQUERY irken 50 {serverid arg} { 1171 | if {$arg eq ""} { 1172 | addchantext $::active "Query: missing nick." -tags system 1173 | return -code break 1174 | } 1175 | if {[ischannel [chanid $serverid $arg]]} { 1176 | addchantext $::active "Can't query a channel." -tags system 1177 | return -code break 1178 | } 1179 | ensurechan [chanid $serverid $arg] "" {} 1180 | } 1181 | hook cmdRELOAD irken 50 {serverid arg} { 1182 | namespace eval :: {source $::argv0} 1183 | addchantext $::active "Irken reloaded." -tags system 1184 | } 1185 | hook cmdSERVER irken 50 {serverid arg} { 1186 | if {![dict exists $::config $arg]} { 1187 | addchantext $::active "$arg is not a server." -tags system 1188 | return 1189 | } 1190 | connect $arg 1191 | } 1192 | 1193 | hook docmd irken 50 {serverid cmd arg} { 1194 | set hook "cmd[string toupper $cmd]" 1195 | if {[hook exists $hook]} { 1196 | hook call $hook $serverid $arg 1197 | } else { 1198 | send $serverid "$cmd $arg" 1199 | } 1200 | } 1201 | 1202 | hook userinput irken 50 {text} { 1203 | if {![dict exists $::serverinfo [serverpart $::active]]} { 1204 | addchantext $::active "Server is disconnected." -tags system 1205 | return 1206 | } 1207 | foreach text [split $text "\n"] { 1208 | if {[regexp {^/(\S+)\s*(.*)} $text -> cmd text]} { 1209 | hook call docmd [serverpart $::active] [string toupper $cmd] $text 1210 | } elseif {$text ne ""} { 1211 | if {[channelpart $::active] eq ""} { 1212 | addchantext $::active "This isn't a channel." -tags system 1213 | } else { 1214 | hook call docmd [serverpart $::active] "MSG" "[channelpart $::active] $text" 1215 | .t yview end 1216 | } 1217 | } 1218 | } 1219 | } 1220 | 1221 | proc returnkey {} { 1222 | set text [.cmd get 1.0 {end - 1 char}] 1223 | hook call userinput $text 1224 | dict set ::channelinfo $::active cmdhistory [concat [list $text] [dict get $::channelinfo $::active cmdhistory]] 1225 | .cmd delete 1.0 end 1226 | return -code break 1227 | } 1228 | 1229 | proc setcurrenttopic {} { 1230 | if {![ischannel $::active]} { 1231 | addchantext $::active "This isn't a channel." -tags system 1232 | return 1233 | } 1234 | send [serverpart $::active] "TOPIC [channelpart $::active] :[.topic get]" 1235 | focus .cmd 1236 | } 1237 | 1238 | proc irken {} { 1239 | initvars 1240 | loadconfig 1241 | initui 1242 | initnetwork 1243 | } 1244 | 1245 | # Embedded png icons - terrible, but not as terrible as a graphic library dependency 1246 | set ::servericon {iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QA/wD/AP+gvaeTAAACaUlEQVQ4jXVTv0/bQBT+zrEdObIrtbJEHKWiRSVThFBRIwQd24GCmkwsVbcO/TH2H/CG1G6IlY2lJQ2txNalW1GGdCgRgiFhKI1ARiaJrIt9Z18HsIUpfNJb7t733fvee0dwga2trXuqqn7Wdf2+JEkC18DzPOr7/qtqtfo9PiMX5GVd11fL5fKYqqoQ4lo+AGB/f991HOdTtVp9AwDSxfmzmZmZsVwuh0wmA1mWb4ypqanbAJ7EghIAcM4BAFEUYe/vHjzqQQiRxOnpKYIgwPHx8TlJkkhKgDEGxhjaf9ro3VnGl8M1cM5TwRhDGIbgnMNxHNMwDBMAZADJRUEvoNV5gbvaQzDGEt8nJydQFAW9Xg+maYIQopTL5W/z8/M7cmyBMQY5I6NWfIvLtgBgfHwcADA5OQnOOWRZJoVCwVxaWrqVqoCQxNqNEELAdV2p1Wp9WFlZOa9ACAHGGBzHSSVLkgTTNBEEAVRVRRAE0DQNhmEcdbvd9W63i8RCGIYoFospgSiKMBqN4LouDMPA2dkZLMsC5zxZlMQCYwz9fj8h7+7uglKKiYkJMMagaRo8z0MQBKlFky4LxCPr9/tQVRULCwvodDpx55HP55O8VAWj0ehru91+rmmaBACDwUDJ5/MaIYRQSsXBwcEw/h9RFAlK6Y9YIGm7bdu5bDab5Zw/sizrY6VSedBsNpXZ2dmj7e3tQ0LIyyiKPN/3Q9u2B/8JxNjY2Fidm5t73Gg0fM/z1kql0rtKpaLU6/VflNLXtm1Hl/MzV2ZsWJb1dHNz8/dwOHxv2/bP6enpHue8VKvVmouLiztXH/wHBL5LdDruUzgAAAAASUVORK5CYII=} 1247 | set ::channelicon {iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAQAAAC1+jfqAAAAAmJLR0QA/4ePzL8AAAF6SURBVCjPZU9NM0IBFH3MsCpj7CztLPwIW6z9DEsbKxvGWDRGU6ZhwcI0pSTTxCPivTeiKU3RF0l59V56pFKiJsc14+uNe+Zu7j3n3nMYRlXsgJcPKj55fz7Qxfwvq4bPvaCOGuSm26RWDnF+/tI1IzUbKEGmFpTpzj8ELvtKyoOahCcoyKMA36Oj92ft1AaVKu7hb0TfirTOUu8WVRf280WI4EqHJRFpXCMDW0LlwX4Wp/FmwXoefk8iCU9zfVxFcE3YsYVt1jZoa/vBw15Vrb0a1izSZza4Mxwqu+EFe2vt/j7e79o4luVWhf4KCLQVxHEDseXJuqecWiI4eAkVCicghjJe8EwRP/GAdGtPso4xllQGUVJ5KWYeEiGPO9wiRabvYDlhzLkYTuHHEXkPEzFOl6K4QAQhIpmvGOOyUVqru8DRSKD+hYAE1kVyoeubHdUtrNQ22w7SXn4hglU4Kib+J+piz8KkntOnDBljbkk0pPVxvX1uBB0fzyc6FzEmMTIAAAAASUVORK5CYII=} 1248 | set ::usericon {iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAQAAAC1+jfqAAAAAmJLR0QA/4ePzL8AAAD/SURBVBgZlcHLSgJhGIDhL2gC9x0uqJZuhIKCrqEbCLqGTouoXVKB0VDhppXS4IwLReefLM1Bp0wN7cQEEha9rUShv0XPI/+SmLCjdjRniN7llO92aXPtpiZFx9t755VHGuR2Rcc7eeaJFnUKZ6KTXW/zQICPvSM6F4vVvk+Fq8/ksuhZQQkPqyl/yZsZLAqn8ltqPLNy47T6t5Spf5TS6SXGZFQh2/l+I+SFDk3u8L+clAwdznhhjYCAgBpVynjkwv1pGTiYK5JHoVAoFIo8RY5mZWBrwemlUSgUCoXCwultzsvQWmwjGXePG2bX7Cbu4+72+WpMNAyJSEQMGfED1Mesk3W69Y4AAAAASUVORK5CYII=} 1249 | set ::blankicon {iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QA/wD/AP+gvaeTAAAAEklEQVQ4jWNgGAWjYBSMAggAAAQQAAF/TXiOAAAAAElFTkSuQmCC} 1250 | set ::opsicon {iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QA/wD/AP+gvaeTAAAAy0lEQVQ4jcXSQUoDQRCF4c+QASV9EmPMXoagqNdJ7haCK0VyA5XcIE72DRFlEMZFkMjQmRlwkQe1aLrfT1X149g6qZ0zXGOECis847sLbBLYjIgzyhnlBTFQIO9i/nigqmq1oBqwbYJkgU3K/BcSeEc/BbgfEw+Zf2tIxG3d3MPlDWdtM95xinEK8C/18PrEZ9vDR77wkrrLAsWiYf75bolrB5YI+YBtCjLff+NVW5d5oBgSp5RTyvNdkNZN5nqU+/ZRhjcsdYzycfQDtB1ssjiVxGkAAAAASUVORK5CYII=} 1251 | set ::voiceicon {iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QA/wD/AP+gvaeTAAAAcElEQVQ4jc2SOwqAMBAFB0vjkRSC95aAHklTr0USsFjNRxAXHmkyA29Z+OvYmFbY+JB6yQTmgEVgExg8MDfAElMuUeByiQ19nQKnOLnbSRcekXzD5z8j9LteYZVQL78HRVIOK5J6OI19c0gXSTv87ZxXSlezPrPf8wAAAABJRU5ErkJggg==} 1252 | set ::ownericon {iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAMAAAAoLQ9TAAAAYFBMVEUAAAAAAAAAAAAAAAAAAAAAAAAAAAAFBQUHBwcHBwcHBwcICAgICAgICAgHBwcKCgoPDw8GBgYGBgYtLS0sLCwtLS1GRkZHR0dHR0dmZmZ0dHR1dXV3d3d9fX2AgID///9uPZFLAAAAGXRSTlMAECQnKCtKlJWWv7/BxtDd9PX29vf4/Pz9+gKGIQAAAAFiS0dEHwUNEL0AAABVSURBVBjTY2AgBzDy8QMBHyNcgENEEghEOWF8FiFpOSCQEWSFCvCIy4GBBC+EzyYgCxGQFWDDLsDABdUixg01g0lICsSXFmKGWcMuDLJWhAO3w0gFADKmB8TUOG0DAAAAAElFTkSuQmCC} 1253 | set ::adminicon {iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABmJLR0QA/wD/AP+gvaeTAAAAwUlEQVQ4jc2SPw4BYRDFf9ZmsSSocAFROorGESTcQUehcAEFiYRGo9O5AUqJagsSLTa7rH+fQrObrPCtgpdMMTN5b15mBv4NMVlC2JMoGEKwAZZBHYhCDisdZwEUAwncBoh+lXtKx05EGQEZKQExfIbZRdRLOLqGrak0gIgfIeQj4MFqC7Ue1txgfzhSASbuvvK5NYRfXX1F2NnQHON0plyugtbpTBtw3g76eon5LGZSZ0aQM4YV1kBZmuiC9Cv/Hg+kzEMtu4oFIwAAAABJRU5ErkJggg==} 1254 | set ::halfopsicon {iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAMAAAAoLQ9TAAAAZlBMVEUAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAADAwMNCQkJBwcJBwkPCwwPDAwNCwswJCYIBgcKCAhGNTgHBgYTDg8HBQWPa3GOa3FcRUmLaW/PnKXhqbPnrrjqsLr+v8r/wMv///+JHHLqAAAAGXRSTlMABAUHIjU3Q0pajZCQp67T7/Pz9PX1+vz949IxUAAAAAFiS0dEIcRsDRYAAABJSURBVBjTY2AgEjCyIvOYOXgFxTjhXDY+EQEJGWkhFpgAt6SsAhCI8zNBBXikQHwFeWEuVAEFOVF2/AIILRiGYliL4TAsTscPAEbMB+2tsxn5AAAAAElFTkSuQmCC} 1255 | set ::irkenicon {iVBORw0KGgoAAAANSUhEUgAAABQAAAAUCAMAAAC6V+0/AAAATlBMVEUAAAD/v4D/35//1Zz/15f/1pj/2Zn/2Jz/2Zv/15v/15v/2Zv/2Jz/2Zv/2Jv/2Zv/2Zv/2Jv/2Jr/2Jv/2Jv/2Zv/2Jv/2Jv/2Jv///9JcTGKAAAAGHRSTlMABAgSICU8SEpmc3+IkpeZs83Q3d7o+v4PPFCqAAAAAWJLR0QZ7G61iAAAAEBJREFUGNNj4OFHBRwMQCCBBviGvKCgMAyIgsREuBhQACMvUJCdAR1wikkIYAgysImKs2KKsghxYwoyMDEzUAwA7hYS0qRY31oAAAAASUVORK5CYII=} 1256 | } 1257 | 1258 | # Start up irken when executed as file 1259 | if {[info exists argv0] && [file dirname [file normalize [info script]/...]] eq [file dirname [file normalize $argv0/...]] && ![info exists ::active]} {::irken::irken} 1260 | --------------------------------------------------------------------------------