#!/bin/sh
# \
if [ -x "$HOME/.roxirc/.wish" ]; then exec $HOME/.roxirc/.wish "$0" -- "$@"; elif [ `which tclkit` ]; then exec tclkit "$0" -- "$@"; elif [ `which wish` ]; then exec wish "$0" -- "$@"; else echo "Please make sure tclkit or wish is in your PATH or link $HOME/.roxirc/.wish to wish 8.3 or newer"; exit; fi;
# Copyright (c) 1997-2003 Aaron Faupell (roxirc@lighter.net)
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
# 3. All advertising materials mentioning features or use of this software
# must display the following acknowledgement:
# This product includes software developed by Aaron Faupell
# 4. The name of Aaron Faupell may not be used to endorse or promote
# products derived from this software without specific prior written
# permission.
#
# THIS SOFTWARE IS PROVIDED BY AARON FAUPELL ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL AARON FAUPELL BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
# In addition to the above, please do not remove the version reply.
# Improvments and bug fixes are welcome.
# Version 2.0b (1/1/04)
# Description: main program file
package provide roxirc 2.0
if {[info level] > 0} {return}
if {[catch {package require Tk 8.3}]} {
puts stderr "Unable to locate Tk 8.3 or newer.\nPlease make sure that Tk 8.3 or newer is installed\nand that [info nameofexecutable] is linked to the correct version\nor link $env(HOME)/.roxirc/.wish to the correct wish"
exit
}
wm withdraw .
proc SetDefaults {} {
global prefs env info tcl_platform
array set prefs {
geom,channel 600x350
geom,status 550x375
geom,chat 500x300
font,chantopic {fixed 10}
font,cmdline {fixed 10}
font,menu {fixed 10}
font,status {fixed 10}
font,chan {fixed 10}
font,nicklist {fixed 10}
font,chat {fixed 10}
name {My config script is missing}
away {Finding my config script}
awayreason {auto away}
nick {"roxirc" "roxirc_" "roxirc-"}
chan #freebsd
quit RoxIRC
server irc.ef.net:EFnet
port 6667
notify {}
showmotd 1
autoaway 0
autounaway 2
ts 0
history 30
scrollback 200
host ""
underline 1
bold 1
ial 1
margin 0
urlcommand {}
dccpacketsize 512
dccfileautoclose 0
dccchatautoclose 0
dcchighport 65535
dcclowport 1025
netsplit 1
urls 1
maxbeeps 3
nicklist 1
menubar 1
topic 1
unsafedcc 0
dcctimeout 600
iconifyqueries 0
flood 1
floodlines 5
floodtime 1000
flooddelay 600
floodmaxq 25
reconnect 5
showops 1
opsinchan 0
authdelay 750
tsformat [%R]
gmt 0
}
set prefs(defaultdccdir) $env(HOME)
set prefs(defaultlogdir) $env(HOME)
if {$tcl_platform(platform) == "windows"} {
set prefs(defaultdccdir) $env(USERPROFILE)\\Desktop
set prefs(defaultlogdir) [file dirname [info script]]\\logs
}
if {[info exists ::starkit::topdir]} {set prefs(defaultlogdir) [file nativename [file dirname $::starkit::topdir]/logs]}
set prefs(ident) $tcl_platform(user)
array set info {
set,history num
set,showmotd bool
set,autoaway num
set,autounaway {num 0 2}
set,awayreason string
set,port num
set,name string
set,ts bool
set,bold {bool cmd bold}
set,underline {bool cmd underline}
set,margin {num cmd margin}
set,scrollback num
set,host string
set,urlcommand string
set,dccpacketsize {num 256 16384}
set,dccfileautoclose bool
set,dccchatautoclose bool
set,defaultdccdir string
set,dcchighport num
set,dcclowport num
set,unsafedcc bool
set,dcctimeout num
set,defaultlogdir string
set,netsplit bool
set,urls bool
set,maxbeeps num
set,ial {bool cmd ial}
set,nicklist bool
set,menubar bool
set,topic bool
set,iconifyqueries bool
set,flood bool
set,floodlines {num 2 100}
set,floodtime {num 100 10000}
set,flooddelay {num 100 5000}
set,floodmaxq {num 5 500}
set,showops {bool cmd showops}
set,opsinchan {bool cmd opsinchan}
set,reconnect {num 5 300}
set,authdelay {num 0 3000}
set,tsformat string
set,gmt bool
set,ident string
}
set info(config) $env(HOME)/.roxirc
set info(on) "{text 3} {action 3} {notice 3} {join 2} {part 2} {quit 2} {nick 2} {kick 3} {mode 2} {umode 0} {op 3} {deop 3}
{voice 3} {ban 2} {unban 2} {exception 2} {unexception 2} {devoice 3} {wallops 2} {topic 2} {away 0} {unaway 0}
{notify 1} {unnotify 1} {connect 0} {disconnect 0} {invite 2} {chatrequest 1} {chatconnect 1} {chat 2}
{chatclose 1} {filerequest 2} {getconnect 2} {getfail 2} {getdone 2} {sendconnect 2} {sendfail 2} {senddone 2}"
}
proc SetVars {} {
global notify me server away urls info prefs tcl_platform
set notify(+online) ""
set me -
set server -
set away 0
set urls ""
set info(connect) ""
set info(send,last) [clock clicks -milliseconds]
set info(send,num) 0
option add *Text.wrap word widgetDefault
if {$tcl_platform(platform) == "unix"} {
option add *background #c0c0c0 widgetDefault
option add *activeBackground #c0c0c0 widgetDefault
option add *highlightBackground #c0c0c0 widgetDefault
option add *selectBorderWidth 0 widgetDefault
option add *selectBackground #999999 widgetDefault
option add *selectColor navy widgetDefault
option add *Toplevel.borderWidth 1 widgetDefault
option add *Toplevel.relief raised widgetDefault
option add *Scrollbar.width 13 widgetDefault
option add *Scrollbar.borderWidth 0 widgetDefault
option add *Scrollbar.elementBorderWidth 2 widgetDefault
option add *Scrollbar.highlightThickness 0 widgetDefault
option add *Listbox.highlightThickness 0 widgetDefault
option add *Menubutton.borderWidth 1 widgetDefault
option add *Menu.activeBorderWidth 1 widgetDefault
option add *Menu*Menu.borderWidth 1 widgetDefault
option add *Text.cursor left_ptr widgetDefault
option add *Button.borderWidth 1 widgetDefault
option add *Button.highlightThickness 0 widgetDefault
option add *menubar.relief raised widgetDefault
option add *menubar.borderWidth 1 widgetDefault
} elseif {$tcl_platform(platform) == "windows"} {
option add *Text.cursor arrow
option add *Button.padY 0 widgetDefault
option add *Button.padX 1m widgetDefault
option add *Menubutton.padY 4 widgetDefault
option add *menubar.relief groove widgetDefault
option add *menubar.borderWidth 2 widgetDefault
font create fixed -family fixedsys -size 8
if {$tcl_platform(osVersion) > 5.0} {
option add *Menubutton.activeBackground SystemHighlight widgetDefault
option add *Menubutton.activeForeground SystemHighlightText widgetDefault
option add *Menubutton.borderWidth 0 widgetDefault
} else {
option add *Menubutton.borderWidth 1 widgetDefault
}
}
}
proc ParseCommandline {} {
global argv argc
set oargv $argv
set num 0
unset argv
while {[set cur [lrange $oargv $num end]] != ""} {
switch -glob -- [lindex $cur 0] {
-h {
incr num 2
set argv(h) [lindex $cur 1]
}
-f {
incr num 2
set argv(f) [lindex $cur 1]
}
-* {
puts stderr "Unknown option [lindex $cur 0]"
incr num
}
default {
if {[expr {$argc - $num}] > 2} {
puts stderr "Too many arguments"
return [array get argv]
} else {
if {[string match *.* [lindex $oargv $num]]} {
set argv(server) [lindex $oargv $num]
} else {
set argv(nick) [lindex $oargv $num]
}
}
incr num 1
}
}
}
return [array get argv]
}
proc LoadFile {file} {
global procs errorInfo
set ft [file tail $file]
set ns ::scripts::$ft
if {![catch {namespace eval $ns [list source $file]} msg]} {
namespace import -force ${ns}::*
if {[info commands ${ns}::*] == ""} {namespace delete $ns}
return 1
}
if {[regexp "\\\(file \\\".*/$ft\\\" line (\\\d*)" $errorInfo --> match]} {append msg " on line $match"}
foreach proc [array names procs] {
if {$ft == $procs($proc)} {
catch {rename ::$proc ""}
catch {rename ::backup::${ft}::$proc ::$proc}
unset procs($proc)
}
}
catch {namespace delete ::backup::$ft}
namespace delete $ns
echo on
puts stderr "Error loading $file: $msg"
Echo .0 "\[ error \] Error loading $file: $msg" {error default}
return 0
}
proc procs {args} {
global procs
set file [file tail [info script]]
foreach x $args {
if {[info exists procs($x)] && $procs($x) != $file} {
error "proc $x conflicts with script \"$procs($x)\""
}
set procs($x) $file
if {[info procs $x] != "" && [info commands ::backup::${file}::$x] == ""} {
namespace eval ::backup::$file {}
rename $x ::backup::${file}::$x
}
namespace eval ::scripts::${file} "namespace export $x"
}
}
proc FirstRun {} {
global info
foreach x {"/usr/local/roxirc" "/usr/local/doc/roxirc" "/usr/local/share/doc/roxirc"} {
if {[file isdirectory $x]} {set installpath $x}
}
if {[catch {file mkdir $info(config)} err]} {
Echo .0 "\[ error \] Could not create directory $info(config): [geterror $err]" {error default}
Echo .0 "\[ error \] Please create $info(config) and copy the files included with the distribution to $info(config), or see http://roxirc.lighter.net/ for example files" {error default}
return
}
Echo .0 "\[ info \] Created configuration directory $info(config)" {info default}
if {![info exists installpath]} {
Echo .0 "\[ error \] Could not find install path, please copy the files included with the distribution to $info(config) or see http://roxirc.lighter.net/ for example files" {error default}
} else {
foreach file [glob -nocomplain [file join $installpath *]] {
set to [string map {-example "" -initial ""} [file tail $file]]
if {[catch {file copy $file [file join info(config) $to]} err]} {set fail $err}
}
if {![info exists file]} {set fail "no files"}
}
if {[info exists fail] && [info exists installpath]} {
Echo .0 "\[ error \] Could not copy files from $installpath: [geterror $fail]" {error default}
Echo .0 "\[ info \] Please see http://roxirc.lighter.net/ for example files" {info default}
} elseif {![info exists fail] && [info exists installpath]} {
foreach x [glob -nocomplain [file join $info(config) *]] {
catch {file attributes $x -permissions 0644}
}
Echo .0 "\[ info \] Please edit the config file $info(config)/config for configuration options" {info default}
}
Echo .0 "\[ info \] See /set, /color, and /help for other settings /save when youre done, and http://roxirc.lighter.net/ for more information" {info default}
}
proc SourceFiles {} {
global prefs notify env menu ignore on info argv
set autoload 1
set startup 1
SetDefaults
WindowMenu
if {[info exists argv(f)]} {
set info(config) [abspath $argv(f)]
} elseif {![file isdirectory $info(config)]} {
FirstRun
}
namespace eval ::scripts {}
if {[file isdirectory $info(config)]} {
set files [glob -nocomplain -types f $info(config)/*]
foreach file [lsort $files] {LoadFile $file}
} elseif {[file isfile $info(config)]} {
LoadFile $info(config)
} else {
Echo .0 "\[ error \] No such file or directory: $info(config)" {error default}
}
if {[info exists argv(h)]} {set prefs(host) $argv(h)}
if {[info exists argv(nick)]} {set prefs(nick) [linsert $prefs(nick) 0 $argv(nick)]}
if {[info exists argv(server)]} {command_server .0 $argv(server)}
}
proc startup {} {
upvar 3 startup start autoload auto
if {!$start && $auto} {return -code return}
}
proc noautoload {} {
upvar 3 autoload auto
if {$auto} {return -code return}
}
proc !xresources {} {
option readfile [info script] userDefault
return -code return
}
proc echo {cmd} {
if {$cmd == "off"} {
if {[info procs __Echo] == ""} {
rename ::Echo __Echo
proc Echo {args} {}
}
} else {
if {[info procs __Echo] != ""} {
rename Echo {}
rename __Echo Echo
}
}
}
proc configfile {name} {
global $name
set data [read [set fh [open [info script] r]]]
close $fh
array set $name $data
catch {unset ${name}(configfile) ${name}(#)}
return -code return
}
proc WindowMenu {} {
global menu
set menu(window) {
command "New Window" /newwin
command "New RoxIRC" "global argv0 ; exec $argv0 &"
command "Save Settings" /save
separator
menu Extras
command "Url List" /url
command "Notify List" NotifyWindow
end
menu Position
command Remember "/position s"
command Forget "/position f"
command Reset "/position r"
end
menu Options
checkbutton Timestamp {options(ts,$window)} {ts $window}
checkbutton Logging... {options(log,$window)} {if {$options(log,$window)} {set options(log,$window) 0; /log on} else {set options(log,$window) 1; /log off}}
checkbutton Popup {options(popup,$window)} {}
separator
checkbutton Nicklist {options(nicklist,$window)} {/option nicklist $options(nicklist,$window)}
checkbutton Topic {options(topic,$window)} {/option topic $options(topic,$window)}
checkbutton Menubar {options(menubar,$window)} {/option menubar $options(menubar,$window)}
end
menu Buffer
command Save... /savebuf
command Clear /clear
end
separator
command Hide /hide
command Close /close
menu Disconnect
tcl {set r ""; foreach a $prefs(quit) {lappend r "command \"$a\" \"/disconnect $a\""}; return [join $r]}
end
menu Quit
tcl {set r ""; foreach a $prefs(quit) {lappend r "command \"$a\" \"/quit $a\""}; return [join $r]}
end
command Exit /quit
}
}
proc AddToPrefs {var type default} {
global prefs info
if {![info exists prefs($var)]} {set prefs($var) $default}
if {![info exists info(set,$var)]} {
set info(set,$var) $type
} elseif {$info(set,$var) != $type} {
error "Cannot redefine preferences: $var"
}
}
proc RemoveFromPrefs {var} {
global prefs info
catch {unset info(set,$var)}
catch {unset prefs($var)}
}
proc command_admin {window line} {
Send "ADMIN $line"
}
proc setaliasvars {} {
global info
upvar nick nick nicks nicks channel channel window window
set channel ""
set nicks ""
set nick ""
if {[info exists info(channel,$window)]} {set channel $info(channel,$window)}
if {[info exists info(nick,$window)]} {set nick $info(nick,$window)}
if {[winfo exists $window.middle.right.nicks]} {
set win $window.middle.right.nicks
foreach x [$win curselection] {lappend nicks [string trimleft [$win get $x] "@+"]}
set nick [$win get anchor]
}
}
proc command_alias {window line} {
set line [split [string trimleft $line]]
set name [trim [lindex $line 0] /]
if {[string trim [join $line]] == ""} {
set aliases ""
foreach x [info procs command_*] {
if {[string range [string trimleft [info body $x]] 0 5] == "#alias"} {
lappend aliases [string range $x 8 end]
}
}
Echo $window "\[ info \] Aliases: [join $aliases]" {info default}
} elseif {[llength $line] < 2} {
if {[info procs command_[globescape $name]] == "" || [string range [string trimleft [info body command_$name]] 0 5] != "#alias"} {
Echo $window "\[ error \] No such alias: $name" {error default}
} else {
Echo $window "alias $name: [string range [info body command_$name] [expr {[string first "\n#\000\n" [info body command_$name]] + 4}] [string last "\n#\000\n" [info body command_$name]]]" alias
}
} elseif {[info commands command_$name] != "" && [string range [string trim [info body command_$name]] 0 5] != "#alias"} {
Echo $window "\[ error \] Cannot add alias $name: command exists" {error default}
} else {
eval [list proc command_$name {window line} "#alias\nglobal options prefs away me server info names\nsetaliasvars\nif \{\[catch \{\n#\000\n[join [lrange $line 1 end]]\n#\000\n\} err\]\} \{\n\Echo \$window \"\\\[ error \\\] Error while executing alias $name: \[geterror \$err\]\" \{error default\}\n\}"]
Echo $window "+alias $name: [join [lrange $line 1 end]]" alias
}
}
proc command_ame {window line} {
foreach x [activechannelwindows] {
command_me $x $line
}
}
proc command_amsg {window line} {
global info
foreach x [activechannelwindows] {
command_msg $x "$info(channel,$x) $line"
}
}
proc command_away {window line} {
catch {unset ::autoaway}
Send "AWAY :$line"
}
proc command_ban {window line} {
global info userhost
set line [rele [split $line]]
if {[ischannelname [lindex $line 0]]} {
set chan [lindex $line 0]
set nick [lindex $line 1]
set mask [lindex $line 2]
} elseif {[info exists info(channel,$window)]} {
set chan $info(channel,$window)
set nick [lindex $line 0]
set mask [lindex $line 1]
}
if {![info exists chan] || $nick == ""} {
Echo $window {[ info ] Ban usage: /ban [<channel>] <nick>|<ban> [<mask_number>]} {info default}
return
}
if {[string match {*\?*} $nick] || [string match {*!*} $nick] || [string match {*\**} $nick] || [string match {*@*} $nick]} {
Send "MODE $chan +b $nick"
return
}
if {$mask == ""} {set mask 3}
if {[set address [address $nick $mask]] != ""} {
Send "MODE $chan +b $address"
} else {
Echo $window {[ info ] Getting users address...} {info default}
getaddress $nick "Send \"MODE $chan +b \[addressmask \"%address\" $mask\]\""
}
}
proc command_beep {window line} {
set line [rele [split $line]]
if {[set times [lindex $line 0]] == ""} {
bell
return
}
if {[set delay [lindex $line 1]] == ""} {set delay 500}
if {[string is integer -strict $delay] && [string is integer -strict $times]} {
if {$times > 1} {
after $delay [list command_beep $window "[expr {$times - 1}] $delay"]
}
bell
}
}
proc command_bind {window line} {
if {[string trim $line] == ""} {
foreach x [lsort [bind cmdline]] {
if {[string match "DoBinding *" [bind cmdline $x]]} {
Echo $window "binding [string map {< "" > "" Control- ^ Key- ""} $x]: [lindex [bind cmdline $x] 2]" bind
}
}
return
}
set line [split [string trimleft $line]]
set keysym [string map {^ Control-} [lindex $line 0]]
if {[set command [join [lrange $line 1 end]]] == ""} {
set tmp ""
if {[lindex [bind cmdline <$keysym>] 0] == "DoBinding"} {
set tmp [lindex [bind cmdline <$keysym>] 2]
}
Echo $window "binding [string map {Control- ^ Key- ""} $keysym]: $tmp" bind
return
}
if {[bind cmdline <$keysym>] != "" && [lindex [bind cmdline <$keysym>] 0] != "DoBinding"} {
Echo $window "\[ error \] Error creating binding $keysym: cannot replace builtin binding" {error default}
return
}
if {$command == "\"\""} {
bind cmdline <$keysym> ""
Echo $window "-binding [string map {Control- ^ Key- ""} $keysym]" bind
return
}
if {[catch {bind cmdline <$keysym> [list DoBinding %W $command]} err]} {
Echo $window "\[ error \] Error creating binding [string map {Control- ^ Key- ""} $keysym]: [geterror $err]" {error default}
return
}
bind Entry <$keysym> {}
Echo $window "+binding [string map {Control- ^ Key- ""} $keysym]: $command" bind
}
proc command_bk {window line} {
global info
set line [rele [split $line]]
set chan [lindex $line 0]
set msg ""
if {[info exists info(channel,$window)] && ![ischannelname $chan]} {
set chan $info(channel,$window)
set nick [lindex $line 0]
set msg [join [lrange $line 1 end]]
} else {
set nick [lindex $line 1]
set msg [join [lrange $line 2 end]]
}
if {[info exists info(window,$chan)] && [ison $chan $nick]} {
KickWindow $info(window,$chan) $nick
if {$msg != ""} {
.kb.right.bottom.entry delete 0 end
.kb.right.bottom.entry insert end $msg
}
}
}
proc command_clear {window line} {
global info
set line [rele [split $line]]
if {[set tmp [windowname [lindex $line 0]]] != ""} {
set window $tmp
set line [lrange $line 1 end]
} elseif {[string tolower [lindex $line 0]] == "all"} {
set line [join [lrange $line 1 end]]
foreach x [textwindows] {command_clear $x $line}
return
}
$info(text,$window) configure -state normal
if {$line == ""} {$info(text,$window) delete 1.0 end}
if {[string is integer -strict $line] && $line > 0} {$info(text,$window) delete end-${line}l end}
if {[string is integer -strict $line] && $line < 0} {$info(text,$window) delete 1.0 1.0+[string trimleft $line -]l}
$info(text,$window) configure -state disabled
}
proc command_close {window line} {
set line [rele [split [string tolower $line]]]
set close ""
if {$line == ""} {
set close $window
} else {
foreach x $line {
if {[set tmp [windowname $x]] != ""} {
lappend close $tmp
} else {
foreach w [winfo children .] {
if {$w != ".0" && [string match "roxirc $x*" [string tolower [wm title $w]]]} {
lappend close $w
}
}
}
}
}
foreach x $close {
if {$x == "" || $x == ".0"} {continue}
if {[wm protocol $x WM_DELETE_WINDOW] != ""} {
eval [wm protocol $x WM_DELETE_WINDOW]
} else {
destroy $x
}
}
}
proc command_color {window line} {
global info prefs
set line [rele [split $line]]
if {$line == ""} {return}
if {[string match "-f*" [lindex $line 0]]} {
set ground "foreground"
set tag [string tolower [lindex $line 1]]
set line [lrange $line 1 end]
} elseif {[string match "-b*" [lindex $line 0]]} {
set ground "background"
set tag [string tolower [lindex $line 1]]
set line [lrange $line 1 end]
} elseif {[string match "-sb*" [lindex $line 0]] || [string match "-selectb*" [lindex $line 0]]} {
set ground "selectbackground"
set tag [string tolower [lindex $line 1]]
set line [lrange $line 1 end]
} elseif {[string match "-sf*" [lindex $line 0]] || [string match "-selectf*" [lindex $line 0]]} {
set ground "selectforeground"
set tag [string tolower [lindex $line 1]]
set line [lrange $line 1 end]
} else {
set ground "foreground"
set tag [string tolower [lindex $line 0]]
}
# for backwards compatibility
if {[info exists prefs(color,$tag)]} {
set prefs(color,$tag,foreground) $prefs(color,$tag)
unset prefs(color,$tag)
}
if {[lindex $line 1] == "\"\"" && ($tag == "nicklist" || $tag == "chan" || $tag == "query" || $tag == "chantopic" || $tag == "cmdline" || $tag == "status")} {
Echo $window "\[ error \] \"\" is not a valid color for $tag" {error default}
return
} elseif {[lindex $line 1] == "\"\""} {
set color ""
} elseif {[lindex $line 1] == ""} {
if {[info exists prefs(color,$tag,$ground)]} {
set color [tk_chooseColor -initialcolor $prefs(color,$tag,$ground) -title "RoxIRC $tag $ground color"]
} elseif {[info exists prefs(color,default,$ground)]} {
set color [tk_chooseColor -initialcolor $prefs(color,default,$ground) -title "RoxIRC $tag $ground color"]
} else {
set color [tk_chooseColor -initialcolor [$info(text,$window) cget -$ground] -title "RoxIRC $tag color"]
}
if {$color == ""} {return}
} else {
set color [lindex $line 1]
}
if {[catch {.0.bottom configure -background $color}]} {
Echo $window "\[ error \] $color is not a valid color" {error default}
return
}
switch -exact -- $tag {
+nicklist {
foreach x [activechannelwindows] {
set end [$x.middle.right.nicks index end]
for {set index 0} {$index < $end} {incr index} {
if {[isvoice $info(channel,$x) [string trimleft [$x.middle.right.nicks get $index] +]]} {
$x.middle.right.nicks itemconfigure $index -$ground $color
}
}
}
}
@nicklist {
foreach x [activechannelwindows] {
set end [$x.middle.right.nicks index end]
for {set index 0} {$index < $end} {incr index} {
if {[isop $info(channel,$x) [string trimleft [$x.middle.right.nicks get $index] @]]} {
$x.middle.right.nicks itemconfigure $index -$ground $color
}
}
}
}
nicklist {
foreach x [channelwindows] {$x.middle.right.nicks configure -$ground $color}
}
chan {
foreach x [channelwindows] {$info(text,$x) configure -$ground $color}
}
query {
foreach x [querywindows] {$info(text,$x) configure -$ground $color}
}
dccchat {
foreach x [dccwindows] {$info(text,$x) configure -$ground $color}
}
status {
.0.middle.text configure -$ground $color
}
cmdline {
foreach x [textwindows] {
$x.bottom.cmdline configure -$ground $color
if {$ground == "foreground"} {$x.bottom.cmdline configure -insertbackground $color -highlightcolor $color}
}
}
chantopic {
foreach x [channelwindows] {$x.middle.left.topic configure -$ground $color}
}
all {
foreach x [textwindows] {$info(text,$x) configure -$ground $color}
}
default {
if {$ground == "selectforeground" || $ground == "selectbackground"} {
Echo $window "\[ info \] /color: $ground is only valid for the following objects: chan nicklist +nicklist @nicklist query dcc cmdline chantopic" {info default}
return
}
foreach x [textwindows] {$info(text,$x) tag configure $tag -$ground $color}
}
}
if {$color == ""} {
catch {unset prefs(color,$tag,$ground)}
} else {
if {$tag == "all"} {
array set prefs [list color,dccchat,$ground $color color,query,$ground $color color,chan,$ground $color color,status,$ground $color]
} else {
set prefs(color,$tag,$ground) $color
}
foreach x [textwindows] {
foreach tag {hilight ts search sel} {$info(text,$x) tag raise $tag}
}
}
}
proc command_ctcp {window line} {
set line [split $line]
if {[string trim $line] != ""} {
if {[string tolower [lindex $line 1]] == "ping" && [lindex $line 2] == ""} {
command_ping $window [lindex $line 0]
return
}
Echo .0 "\[ ctcp \] -> [lindex $line 0] [string toupper [lindex $line 1]] [lrange $line 2 end]" {ctcp default}
Send "PRIVMSG [lindex $line 0] :\001[string toupper [lindex $line 1]] [lrange $line 2 end]\001"
}
}
proc command_dcc {window line} {
global irc info dcc prefs env
set line [rele [split $line]]
switch -- [string tolower [lindex $line 0]] {
chat {
if {[set nick [lindex $line 1]] == ""} {
Echo $window {[ info ] Dcc usage: /dcc chat <nick>} {info default}
return
}
if {![info exists irc]} {
Echo $window {[ server ] You are not connected to a server} {server default}
return
}
set tmp [split [lindex [fconfigure $irc -sockname] 0] .]
set ip [format %u 0x[format %02X%02X%02X%02X [lindex $tmp 0] [lindex $tmp 1] [lindex $tmp 2] [lindex $tmp 3]]]
set id [CreateDccId c]
foreach tmp [getdccid [list nick $nick] "type chat"] {
if {$dcc($tmp,state) == 0 || $dcc($tmp,state) == 2} {
catch {close $dcc($tmp,sock)}
catch {destroy .dialog$tmp}
ClearDcc $id
} elseif {$dcc($tmp,state) == 1} {
Send "PRIVMSG $dcc($tmp,nick) :\001DCC CHAT chat $ip $dcc($tmp,port)\001"
Echo .0 "\[ dcc \] Sent DCC Chat request to $dcc($tmp,nick)" {dcc default}
Echo .$tmp "\[ dcc \] Sent DCC Chat request to $dcc($tmp,nick)" {dcc default}
wm deiconify .$tmp
raise .$tmp
return $id
} elseif {$dcc($tmp,state) == 3} {
wm deiconify .$tmp
raise .$tmp
return
} elseif {$dcc($tmp,state) == 4} {
set id $tmp
}
}
set port [expr {round(rand() * ($prefs(dcchighport) - $prefs(dcclowport)) + $prefs(dcclowport))}]
if {[catch {socket -server [list AcceptDccChat $id] -myaddr $ip $port} sock]} {
if {[winfo exists .$id]} {
Echo .$id "\[ error \] Could not create listening socket: [geterror $sock]" {error default}
set dcc($id,state) 4
} else {
Echo .0 "\[ error \] Could not create listening socket: [geterror $sock]" {error default}
}
return
}
array set dcc [list $id,nick $nick $id,state 1 $id,sock $sock $id,port $port $id,type chat]
CreateDccChat $id
Send "PRIVMSG $dcc($id,nick) :\001DCC CHAT chat $ip $dcc($id,port)\001"
after [expr {$prefs(dcctimeout) * 1000}] [list CleanupDccChat $id]
Echo .0 "\[ dcc \] Sent DCC Chat request to $dcc($id,nick)" {dcc default}
Echo .$id "\[ dcc \] Sent DCC Chat request to $dcc($id,nick)" {dcc default}
return $id
}
send {
if {[set nick [lindex $line 1]] == ""} {
Echo $window {[ info ] Dcc usage: /dcc send <nick> [<file>]} {info default}
return
}
if {![info exists irc]} {
Echo $window {[ server ] You are not connected to a server} {server default}
return
}
if {[set fn [lindex $line 2]] == ""} {
set fn [tk_getOpenFile -initialdir $env(HOME) -title "RoxIRC Send file to $nick"]
}
if {$fn == ""} {return}
set fn [abspath $fn]
if {[catch {open $fn r} fh]} {
Echo $window "\[ error \] Cannot open $fn for reading: [geterror $fh]" {error default}
return
}
fconfigure $fh -translation binary
if {[set tmp [getdccid [list nick $nick] [list file $fn] "type send"]] != ""} {
if {$dcc($tmp,state) == 1} {
close $dcc($tmp,sock)
close $dcc($tmp,fh)
unset dcc($tmp,sock) dcc($tmp,fh) dcc($tmp,port)
} else {
close $fh
wm deiconify .$tmp
raise .$tmp
return
}
}
set id [CreateDccId f]
array set dcc [list $id,fh $fh $id,file $fn $id,nick $nick $id,size [file size $fn] $id,type send]
set tmp [split [lindex [fconfigure $irc -sockname] 0] .]
set ip [format %u 0x[format %02X%02X%02X%02X [lindex $tmp 0] [lindex $tmp 1] [lindex $tmp 2] [lindex $tmp 3]]]
set dcc($id,port) [expr {round(rand() * ($prefs(dcchighport) - $prefs(dcclowport)) + $prefs(dcclowport))}]
if {[catch {socket -server [list AcceptDccSend $id] -myaddr $ip $dcc($id,port)} sock]} {
Echo .0 "\[ error \] Could not create listening socket: [geterror $sock]" {error default}
close $dcc($id,fh)
ClearDcc $id
return
}
CreateDccFile send $id
set dcc($id,sock) $sock
set dcc($id,state) 1
Send "PRIVMSG $dcc($id,nick) :\001DCC SEND [file tail $dcc($id,file)] $ip $dcc($id,port) $dcc($id,size)\001"
after [expr {$prefs(dcctimeout) * 1000}] [list CleanupDccSend $id]
Echo .0 "\[ dcc \] Sent DCC Send request to $dcc($id,nick): $dcc($id,file) ([kb $dcc($id,size)])" {dcc default}
return $id
}
accept {
if {[set nick [lindex $line 1]] == ""} {
Echo $window {[ info ] Dcc usage: /dcc accept <nick>} {info default}
return
}
if {[set tmp [getdccid [list nick $nick] "type chat"]] == ""} {
Echo $window "\[ dcc \] No chat requests from $nick found" {dcc default}
return
}
foreach id $tmp {
if {$dcc($id,state) == 3} {
wm deiconify .$id
raise .$id
return
} elseif {$dcc($id,state) == 2} {
close $dcc($id,sock)
IncomingDccChat2 1 $id
} elseif {$dcc($id,state) == 0 || $dcc($id,state) == 4} {
catch {destroy .dialog$id}
IncomingDccChat2 1 $id
}
}
}
get {
if {[set nick [lindex $line 1]] == ""} {
Echo $window {[ info ] Dcc usage: /dcc get <nick> [<file>] [<saveas>]} {info default}
return
}
if {[set file [lindex $line 2]] == ""} {
if {[set list [getdccid [list nick $nick] "type get" "state 0"]] == ""} {
Echo $window "\[ dcc \] No pending sends from $nick found" {dcc default}
return
}
foreach x $list {command_dcc $window "get $nick $dcc($x,file)"}
return
}
if {[set id [getdccid [list nick $nick] "type get" [list file $file]]] == ""} {
Echo $window "\[ dcc \] No send of $file from $nick found" {dcc default}
return
}
if {$dcc($id,state) == 3} {
wm deiconify .$id
raise .$id
return
} elseif {$dcc($id,state) == 2} {
close $dcc($id,sock)
} else {
catch {destroy .dialog$id}
}
if {[set fn [lindex $line 3]] == ""} {set fn $file}
if {[file dirname $fn] == "."} {set fn $prefs(defaultdccdir)/$fn}
set fn [abspath $fn]
if {[catch {open $fn w} fh]} {
Echo $window "\[ error \] Cannot open $fn for writing: [geterror $fh]" {error default}
return
}
if {[info exists dcc($id,fh)]} {close $dcc($id,fh)}
set host [expr {$prefs(unsafedcc) ? $dcc($id,ip) : [lindex [split $dcc($id,who) @] 1]}]
if {[catch {socket -async $host $dcc($id,port)} sock]} {
Echo .0 "\[ dcc \] Could not connect to $host: [geterror $sock]" {dcc default}
close $fh
return
}
CreateDccFile get $id
.$id.1.host configure -text "ip: [string range $host end-14 end]"
array set dcc [list $id,file $fn $id,fh $fh $id,sock $sock $id,state 2]
fconfigure $fh -translation binary
fconfigure $sock -blocking 0 -buffering none -translation binary
fileevent $sock writable [list DccFileConnect $id]
}
resume {
if {[set fn [lindex $line 2]] == ""} {
Echo $window {[ info ] Dcc usage: /dcc resume <nick> <file>} {info default}
return
}
set nick [lindex $line 1]
if {[set id [getdccid [list nick $nick] "type get" [list file $fn]]] == ""} {
Echo $window "\[ dcc \] No send of $fn from $nick found" {dcc default}
return
}
if {[file pathtype $fn] != "absolute"} {set fn $prefs(defaultdccdir)/$fn}
set fn [abspath $fn]
if {![info exists dcc($id,fh)]} {
if {![file isfile $fn]} {
Echo $window "\[ error \] $fn does not exist" {error default}
return
}
if {[catch {open $fn a} fh]} {
Echo $window "\[ error \] Cannot open $fn for writing: [geterror $fh]" {error default}
return
}
fconfigure $fh -translation binary
}
if {$dcc($id,state) == 3} {
wm deiconify .$id
raise .$id
return
} elseif {$dcc($id,state) == 2} {
close $dcc($id,sock)
} else {
catch {destroy .dialog$id}
}
array set dcc [list $id,fh $fh $id,file $fn $id,state 2]
CreateDccFile get $id
.$id.1.size configure -text "size: [kb $dcc($id,size)]"
.$id.bottom.status configure -text "Requesting resume..."
Send "PRIVMSG $dcc($id,nick) :\001DCC RESUME [file tail $dcc($id,file)] $dcc($id,port) [file size $fn]\001"
}
close {
switch -- [string tolower [lindex $line 1]] {
send {
if {[set nick [lindex $line 2]] == ""} {return}
if {[set file [lindex $line 3]] == ""} {
set file <any>
set found [getdccid [list nick $nick] "type send"]
} else {
set found [getdccid [list nick $nick] "type send" [list file $file]]
}
if {$found == ""} {
Echo $window "\[ dcc \] No DCC sends of $file to $nick found" {dcc default}
return
}
foreach id $found {
Echo .0 "\[ dcc \] Send of $dcc($id,file) to $dcc($id,nick) closed ($dcc($id,scale)%)" {dcc default}
Event sendfail "id id nick nick dcc($id,ip) ip dcc($id,file) file" $dcc($id,nick) $dcc($id,file)
DccFileDone $id
}
}
chat {
foreach id [getdccid [list nick [lindex $line 2]] "type chat"] {
set nick $dcc($id,nick)
Event chatclose "id id nick nick dcc($id,ip) ip" $dcc($id,nick)
if {[DccChatAutoClose $id]} {
Echo .0 "\[ dcc \] Chat connection with $nick closed" {dcc default}
} else {
Echo .$id "\[ dcc \] Chat connection closed" {dcc default}
}
}
if {![info exists id]} {
Echo $window "\[ dcc \] No chat connections with [lindex $line 2] found" {dcc default}
}
}
get {
if {[set nick [lindex $line 2]] == ""} {return}
if {[set file [lindex $line 3]] == ""} {
set file <any>
set found [getdccid [list nick $nick] "type get"]
} else {
set found [getdccid [list nick $nick] "type get" [list file $file]]
}
foreach id $found {
Echo .0 "\[ dcc \] Get of $dcc($id,file) from $dcc($id,nick) closed ($dcc($id,scale)%)" {dcc default}
Event getfail "id id nick nick dcc($id,ip) ip dcc($id,file) file" $dcc($id,nick) $dcc($id,file)
DccFileDone $id
}
if {![info exists id]} {
Echo $window "\[ dcc \] No DCC gets of $file from $nick found" {dcc default}
}
}
default {
if {[lindex $line 1] == ""} {
Echo $window {[ info ] Dcc usage: /dcc close chat|send|get <nick> [<file>]} {info default}
} else {
Echo $window "\[ error \] Unknown dcc type \"[lindex $line 1]\"" {error default}
}
}
}
}
"" {
lappend tmp "Nick IP Type File % Rate"
foreach x [array names dcc *,nick] {
set id [lindex [split $x ,] 0]
if {[string match c* $id]} {
set i [expr {([info exists dcc($id,ip)] && [info exists dcc($id,sock)]) ? $dcc($id,ip) : {?.?.?.?}}]
lappend tmp [list $dcc($id,nick) $i Chat - - -]
} elseif {[string match f* $id]} {
set i [expr {([info exists dcc($id,ip)] && [info exists dcc($id,sock)]) ? $dcc($id,ip) : {?.?.?.?}}]
lappend tmp [list $dcc($id,nick) $i $dcc($id,type) [file tail $dcc($id,file)] $dcc($id,scale)% [lindex [.$id.2.kbps cget -text] 1]kbps]
}
}
foreach x $tmp {
Echo $window "\[ dcc \] [format "%-11s %-15s %-4s %-20s %-4s %s" [lindex $x 0] [lindex $x 1] [lindex $x 2] [lindex $x 3] [lindex $x 4] [lindex $x 5]]" {dcc default}
}
}
default {
Echo $window "\[ dcc \] Unknown dcc type \"[lindex $line 0]\"" {dcc default}
}
}
}
proc command_describe {window line} {
global me info dcc
set line [split [string trimleft $line]]
set to [lindex $line 0]
set line [join [lrange $line 1 end]]
multiline $to $line
set to2 [string tolower $to]
if {[info exists info(window,$to2)]} {
Echo $info(window,$to2) "* $me $line" {me action}
} elseif {[string match "=*" $to2]} {
if {[set tmp [getdccid [list nick [string range 1 end $to2]] "type chat"]] != "" && $dcc($tmp,state) == 3} {
DccSend .$tmp "\001ACTION $line\001"
Echo .$tmp "* $me $line" {action me}
}
return
} elseif {[info exists info(query,$to2)]} {
Echo $info(query,$to2) "* $me $line" {me action}
wm deiconify $info(query,$to2)
raise $info(query,$to2)
} else {
Echo .0 "-> **$to $line" {me action}
}
Send "PRIVMSG $to :\001ACTION $line\001"
}
proc command_disconnect {window line} {
global irc info server me away
if {$line == ""} {set line "<insert witty, contrived message here>"}
Send "QUIT :$line"
if {[info exists irc]} {
catch {close $irc}
unset irc
after cancel autoaway
foreach x [textwindows] {Echo $x {[ server ] Disconnected} {default server}}
if {[info exists info(time,server)]} {
Echo .0 "\[ info \] Connected to server for: [dur [expr {[clock seconds] - $info(time,server)}]]" {info default}
unset info(time,server)
}
foreach x [textwindows] {Echo $x {[ server ] You are not connected to a server} {default server}}
}
foreach x [after info] {
if {[lindex [lindex [after info $x] 0] 0] == "command_server"} {after cancel $x}
}
foreach x [file channels sock*] {
if {![catch {fileevent $x readable} out] && [string match "Connect*" $out]} {
catch {close $x}
}
}
Event disconnect {}
foreach x [activechannelwindows] {DeleteChannel $info(channel,$x) $x}
set server -
set me -
set away 0
.0.menubar.modes configure -text -
UpdateAllTitles
}
proc command_echo {window line} {
set line2 [split [string trimleft $line]]
if {[set tmp [windowname [lindex $line2 0]]] != ""} {
set window $tmp
set line [join [lrange $line2 1 end]]
} elseif {[string tolower [lindex $line2 0]] == "all"} {
set window all
set line [join [lrange $line2 1 end]]
}
Echo $window $line
}
proc command_exec {window line} {
set line [split $line]
switch -glob -- [lindex $line 0] {
-o* {
doexec $window [join [lrange $line 1 end]] "event generate [current] <<command>>"
}
-m* {
set nick [lindex $line 1]
set line [join [lrange $line 2 end]]
if {[set t [windowname $nick]] != ""} {
doexec $window $line "event generate $t <<command>>"
return
}
doexec $window $line "Echo .0 \"-> *$nick* \$line\" me ; Send \"PRIVMSG $nick :\$line\""
}
-in {
if {![catch {fileevent [string map {% file} [lindex $line 1]] readable} out] && [string match "execcallback *" $out]} {
catch {puts [string map {% file} [lindex $line 1]] [join [lrange $line 2 end]]}
} else {
Echo $window "\[ error \] [lindex $line 1] is not an executed process identifier" {error default}
}
}
-[1-9]* {
if {![catch {fileevent [string map {% file} [lindex $line 1]] readable} out] && [string match "execcallback *" $out]} {
foreach pid [pid [string map {% file} [lindex $line 1]]] {
catch {exec kill [lindex $line 0] $pid}
}
} else {
Echo $window "\[ error \] [lindex $line 1] is not an executed process identifier" {error default}
}
}
"" {
foreach x [file channels file*] {
if {![catch {fileevent $x readable} out] && [string match "execcallback *" $out]} {
Echo $window "\[ info \] %[string map {file ""} $x] [lindex $out 2]" {info default}
}
}
if {![info exists x]} {
Echo $window {[ info ] There are no processes being executed} {info default}
}
}
default {
doexec $window [join $line] "Echo $window \$line"
}
}
}
proc doexec {window cmd callback} {
global tcl_platform
set redir {}
if {$tcl_platform(platform) == "unix"} {set redir "2>@ stdout"}
if {[catch {open "|$cmd $redir" r+} exec]} {
Echo $window "\[ error \] Error executing command: [geterror $exec]" {error default}
return
}
fconfigure $exec -buffering none -blocking 0
fileevent $exec readable [list execcallback $exec $cmd $window $callback]
}
proc execcallback {h name window cmd} {
if {[eof $h]} {
fconfigure $h -blocking 1
catch {close $h} out
global errorCode
if {[lindex $errorCode 0] == "CHILDSTATUS"} {
Echo $window "\[ info \] $name exited with return code [lindex $errorCode 2]" {info default}
return
} elseif {[lindex $errorCode 0] == "CHILDKILLED"} {
Echo $window "\[ info \] $name was killed: [geterror $out]" {info default}
return
}
} elseif {[catch {gets $h} out]} {
global errorInfo
Echo $window "\[ error \] Error executing command: $errorInfo" {error default}
catch {close $h}
return
}
if {$out != ""} {
global line
foreach line [split $out "\n"] {eval $cmd}
catch {unset line}
}
}
proc command_font {window line} {
global info prefs
set line [rele [split $line]]
set prefs(font,all) {}
if {[set tmp [windowname [lindex $line 0]]] != ""} {
set font [lrange $line 1 end]
set win $tmp
} elseif {[info exists prefs(font,[lindex $line 0])]} {
set font [lrange $line 1 end]
set win [lindex $line 0]
} else {
set font $line
set win $window
}
unset prefs(font,all)
if {$font == "" && [info exists prefs(font,$win)]} {
set font [font actual $prefs(font,$win)]
Echo $window "\[ info \] $win font is \"[lindex $font 1] [lindex $font 3]\"" {info default}
return
} elseif {$font == ""} {
set font [font actual f[string trimleft $window .]]
Echo $window "\[ info \] Font is currently \"[lindex $font 1] [lindex $font 3]\"" {info default}
return
}
if {[llength $font] > 1 && [string is integer -strict [lindex $font end]]} {
set font [list [lrange $font 0 end-1] [lindex $font end]]
} else {
set font [list $font]
}
if {$win == ".0"} {set win status}
switch -exact -- $win {
status {
set tmp [lindex [$info(text,.0) yview] 1]
fontconfigure .0 $font
if {$tmp == 1} {$info(text,.0) see end}
}
chan {
foreach x [channelwindows] {
set tmp [lindex [$info(text,$x) yview] 1]
fontconfigure $x $font
if {$tmp == 1} {$info(text,$x) see end}
}
}
chat {
foreach x "[querywindows] [dccwindows]" {
set tmp [lindex [$info(text,$x) yview] 1]
fontconfigure $x $font
if {$tmp == 1} {$info(text,$x) see end}
}
}
cmdline {
foreach x [textwindows] {$x.bottom.cmdline configure -font $font}
}
chantopic {
foreach x [channelwindows] {
$x.middle.left.topic configure -font $font
$x.middle.right.label configure -font $font
}
}
nicklist {
foreach x [channelwindows] {
$x.middle.right.nicks configure -font $font
$x.middle.right.label configure -font $font
}
}
menu {
proc __mfc {win} {upvar font font; $win configure -font $font; foreach sadfg [winfo children $win] {__mfc $sadfg}}
foreach x [textwindows] {
foreach t {window user channel personal server misc query dcc} {
if {[winfo exists $x.menubar.$t]} {
$x.menubar.$t configure -font $font
__mfc $x.menubar.$t.menu
}
}
$x.menubar.modes configure -font $font
}
rename __mfc {}
.0.menubar.modes configure -font $font
}
all {
foreach x {status chat chan} {command_font $window "$x [join $font]"}
return
}
default {
set tmp [lindex [$info(text,$win) yview] 1]
fontconfigure $win $font
if {$tmp == 1} {$info(text,$win) see end}
return
}
}
set prefs(font,$win) $font
}
proc command_help {window line} {
global procs
set line [rele [split [string tolower $line]]]
if {$line == ""} {
Echo $window "Available commands:" {help default}
Echo $window [lsort [string map {command_ ""} [info commands command_*]]] {help default}
Echo $window "Type \"/help <command>\" for more information" {help default}
return
}
if {[info exists procs($line)] && [info commands ::scripts::$procs($line)::help] != ""} {
::scripts::$procs($line)::help $window $line
return
} elseif {[info exists procs(command_$line)] && [info commands ::scripts::$procs(command_$line)::help] != ""} {
::scripts::$procs(command_$line)::help $window $line
return
} elseif {[namespace children ::scripts ::scripts::$line] != ""} {
::scripts::${line}::help $window $line
return
}
set startup 0
set autoload 0
proc helpload2 {} {
global info
upvar 2 help help
set startup 0
set autoload 0
foreach x [list "$info(config)/help" "/usr/local/share/doc/roxirc" "/usr/local/doc/roxirc" "/usr/local/roxirc"] {
if {[file isfile $x]} {
catch {source $x}
break
}
}
}
proc helpload {} {helpload2}
helpload
rename helpload {}
rename helpload2 {}
after cancel {catch {unset help}}
after 600000 {catch {unset help}}
if {[info exists help($line)]} {
Echo $window "Help on $line:" {help default}
foreach x [rele [split $help($line) "\n"]] {Echo $window "$x" {help default}}
return
}
Echo $window "No help on \"$line\"" {help default}
}
proc command_hide {window line} {
global info
set line [rele [split $line]]
if {[string tolower $line] == "all"} {
foreach x [textwindows] {
if {$x != $window} {command_hide $x ""}
}
return
}
set hide ""
if {[string trim $line] == ""} {
set hide $window
} else {
foreach x $line {
if {[set win [windowname $x]] != ""} {
lappend hide $win
} else {
foreach w [winfo children .] {
if {[info exists info(text,$w)] && [string match "roxirc $x*" [string tolower [wm title $w]]]} {
lappend hide $w
}
}
}
}
}
set last 0
foreach a $hide {
foreach x [textwindows] {
if {[wm state $x] != "withdrawn" && $x != $a} {
wm withdraw $a
set last 1
}
}
}
if {!$last} {
Echo $window "\[ error \] You must have at least one window showing" {error default}
}
}
proc command_ial {window line} {
global ial prefs
set line [rele [split $line]]
switch -regexp -- [lindex $line 0] {
search|find {
set line [join [lrange $line 1 end]]
set num 0
foreach {x y} [array get ial] {
if {[string match -nocase $line $y]} {
Echo $window "\[ info \] [lindex [split $x ,] 0] $y" {info default}
incr num
}
}
Echo $window "\[ info \] Found $num matches for \"$line\" out of [array size ial] in IAL" {info default}
}
clear|flush {
catch {unset ial}
Echo $window "\[ info \] IAL cleared" {info default}
}
on {
Echo $window "\[ info \] IAL is now ON" {info default}
set prefs(ial) 1
}
off {
Echo $window "\[ info \] IAL is now OFF" {info default}
catch {unset ial}
set prefs(ial) 0
}
"" {
if {$prefs(ial)} {
Echo $window "\[ info \] IAL is ON, [array size ial] entries" {info default}
} else {
Echo $window "\[ info \] IAL is OFF" {info default}
}
}
}
}
proc command_ignore {window line} {
global ignore
set line [rele [split $line]]
set types [list ALL MSGS NOTICES PUBLIC INVITES CTCP]
if {[set mask [lindex $line 0]] == ""} {
foreach type [array names ignore] {
Echo $window "\[ ignore \] Ignoring $type from [join $ignore($type)]" {ignore default}
}
if {![info exists type]} {
Echo $window {[ ignore ] Ignore list is empty} {ignore default}
}
return
}
set type [string toupper [lrange $line 1 end]]
if {$mask == "-clear"} {
if {$type == ""} {set type $types}
foreach x [string toupper $type] {
if {[lsearch -exact $types $x] == -1} {
Echo $window "\[ ignore \] Unknown type $x" {ignore default}
continue
}
if {![info exists ignore($x)]} {continue}
foreach y $ignore($x) {command_ignore $window "$y none"}
}
return
}
if {![string match {*\**} $mask] && ![string match {*\?*} $mask]} {set mask [globescape $mask]}
if {![string match *@* $mask] && ![string match *!* $mask]} {
if {[string match *.* $mask]} {
set mask *@$mask
} else {
set mask $mask!*
}
}
if {$type == "NONE"} {
set found 0
foreach type $types {
if {[info exists ignore($type)]} {
for {set i 0} {$i < [llength $ignore($type)]} {incr i} {
if {[string equal -nocase $mask [lindex $ignore($type) $i]]} {
Echo $window "\[ ignore \] Removed ignore of [lindex $ignore($type) $i] from $type" {ignore default}
set ignore($type) [lreplace $ignore($type) $i $i]
set found 1
incr i -1
}
}
}
}
foreach type $types {
if {[info exists ignore($type)] && [string trim $ignore($type)] == ""} {unset ignore($type)}
}
if {!$found} {Echo $window "\[ ignore \] $mask is not in ignore list" {ignore default}}
return
}
if {$type == ""} {set type ALL}
foreach x $type {
if {[lsearch -exact $types $x] == -1} {
Echo $window "\[ ignore \] Unknown type $type" {ignore default}
return
}
}
foreach x $type {
if {[info exists ignore($x)] && [lsearch -exact $ignore($x) $mask] != "-1"} {
Echo $window "\[ ignore \] Already ignoring $x from $mask" {ignore default}
return
}
lappend ignore($x) $mask
}
Echo $window "\[ ignore \] Now ignoring $type from $mask" {ignore default}
}
proc Ignore {type nick} {
global ignore
if {[info exists ignore($type)]} {
foreach x $ignore($type) {
if {[string match -nocase $x $nick]} {return -code return}
}
}
if {[info exists ignore(ALL)]} {
foreach x $ignore(ALL) {
if {[string match -nocase $x $nick]} {return -code return}
}
}
}
proc command_info {window line} {
global info
Echo $window "\[ info \] RoxIRC 2.0b by RockShox (09/20/03)" {info default}
Echo $window "\[ info \] roxirc@lighter.net - http://roxirc.lighter.net/" {info default}
Echo $window "\[ info \] Client uptime: [dur [expr {[clock seconds] - $info(time,client)}]]" {info default}
if {[info exists info(time,server)]} {
Echo $window "\[ info \] Connected to server for: [dur [expr {[clock seconds] - $info(time,server)}]]" {info default}
}
}
proc command_invite {window line} {
global info
set line [rele [split $line]]
if {[info exists info(channel,$window)] && ![ischannelname [lindex $line 1]]} {
Send "INVITE [join $line] $info(channel,$window)"
} else {
Send "INVITE [join $line]"
}
}
proc command_join {window line} {
global info
foreach x [split [lindex [split $line] 0] ,] {
if {[info exists info(window,$x)] && [winfo exists $info(window,$x)]} {
wm deiconify $info(window,$x)
raise $info(window,$x)
}
}
Send "JOIN $line"
}
proc command_kick {window line} {
global info
set line [split [string trimleft $line]]
if {[info exists info(channel,$window)] && ![ischannelname [lindex $line 0]]} {
Send "KICK $info(channel,$window) [lindex $line 0] :[join [lrange $line 1 end]]"
} else {
Send "KICK [lindex $line 0] [lindex $line 1] :[join [lrange $line 2 end]]"
}
}
proc command_knock {window line} {
Send "KNOCK $line"
}
proc command_links {window line} {
Send "LINKS $line"
}
proc command_list {window line} {
Send "LIST $line"
}
proc command_load {window line} {
global away prefs me server notify env info
set autoload 0
set startup 0
set files ""
if {[string trim $line] == ""} {
set s ""
foreach x [namespace children ::scripts] {lappend s [namespace tail $x]}
Echo $window "\[ info \] Loaded scripts: [join $s]" {info default}
return
}
foreach file $line {
if {[file isfile $file]} {
lappend files [abspath $file]
} elseif {[file dirname $file] == "." && [file isfile $info(config)/$file]} {
lappend files $info(config)/$file
} elseif {[file isdirectory $file]} {
append files " [join [glob -nocomplain $file/*]]"
} else {
Echo $window "\[ error \] No such file or directory: $file" {error default}
}
}
foreach file $files {
if {[LoadFile $file]} {
if {$window != ".0"} {
Echo .0 "\[ info \] Loaded $file" {info default}
}
Echo $window "\[ info \] Load: $file loaded succesfully" {info default}
}
}
}
proc command_log {window line} {
global options prefs env
set line [rele [split $line]]
if {[set tmp [windowname [lindex $line 0]]] != ""} {
set window $tmp
set line [lrange $line 1 end]
}
switch -exact -- [string tolower [lindex $line 0]] {
on {
if {[set fn [lindex $line 1]] != ""} {
if {[file dirname $fn] == "."} {set fn $prefs(defaultlogdir)/$fn}
set fn [abspath $fn]
} else {
set fn [tk_getSaveFile -title "RoxIRC Choose logfile" -initialdir $prefs(defaultlogdir) -filetypes {{All *} {Logs *.log} {Text *.txt}}]
if {$fn == ""} {return}
}
if {$options(log,$window)} {command_log $window off}
if {[catch {open $fn {WRONLY CREAT APPEND}} fh]} {
Echo $window "\[ error \] Cannot open $fn for writing: [geterror $fh]" {error default}
return
} else {
fconfigure $fh -buffersize 2048
Echo $window "\[ info \] Now logging to $fn" {info default}
array set options [list ln,$window $fn lfh,$window $fh log,$window 1]
puts $fh "Logging started on [clock format [clock seconds] -format "%D at %R %Z" -gmt $prefs(gmt)]"
}
}
off {
if {!$options(log,$window)} {
Echo $window {[ info ] Logging is already OFF} {info default}
return
}
EndLogging $window
unset options(ln,$window) options(lfh,$window)
set options(log,$window) 0
Echo $window {[ info ] Logging stopped} {info default}
}
flush {
if {$options(log,$window)} {
flush $options(lfh,$window)
Echo $window "\[ info \] Flushed log to $options(ln,$window)" {info default}
} else {
Echo $window {[ info ] Logging is OFF} {info default}
}
}
"" {
if {$options(log,$window)} {
Echo $window "\[ info \] Logging to $options(ln,$window)" {info default}
} else {
Echo $window {[ info ] Logging is OFF} {info default}
}
}
default {
Echo $window {[ info ] /log commands: ON OFF FLUSH} {info default}
}
}
}
proc command_lusers {window line} {
Send "LUSERS $line"
}
proc command_me {window line} {
global me info dcc
multiline "" $line
if {[info exists info(channel,$window)]} {
Send "PRIVMSG $info(channel,$window) :\001ACTION $line\001"
Echo $window "* $me $line" {me action}
} elseif {[info exists info(nick,$window)]} {
Send "PRIVMSG $info(nick,$window) :\001ACTION $line\001"
Echo $window "* $me $line" {me action}
} elseif {[info exists $dcc([string trimleft $window .],state)]} {
if {$dcc([string trimleft $window .],state) != 3} {
Echo $window {[ info ] This dcc is not connected} {info default}
return
}
DccSend $window "\001ACTION $line\001"
Echo $window "* $me $line" {me action}
} else {
Echo $window {[ info ] You have no channel joined in this window} {info default}
}
}
proc command_mode {window line} {
global info
set line [rele [split $line]]
if {[ischannelname [lindex $line 0]]} {
set channel [lindex $line 0]
set line [lrange $line 1 end]
} elseif {[info exists info(channel,$window)]} {
set channel $info(channel,$window)
} else {
Send "MODE [join $line]"
return
}
if {[llength $line] == 0 && [set win [windowname $channel]] != ""} {
ModeWindow $win
} else {
Send "MODE $channel [join $line]"
}
}
proc command_motd {window line} {
Send "MOTD $line"
}
proc command_msg {window line} {
global info me dcc
set line [split [string trimleft $line]]
set to [lindex $line 0]
set line [join [lrange $line 1 end]]
multiline $to $line
set to2 [string tolower $to]
if {[info exists info(query,$to2)]} {
Echo $info(query,$to2) "<$me> $line" me
wm deiconify $info(query,$to2)
raise $info(query,$to2)
} elseif {[string match "=*" $to2]} {
if {[set tmp [getdccid [list nick [string range 1 end $to2]] "type chat"]] != "" && $dcc($tmp,state) == 3} {
DccSend .$tmp $line
Echo .$tmp "<$me> $line" me
}
return
} elseif {[info exists info(window,$to2)]} {
Echo $info(window,$to2) "<$me> $line" me
} else {
Echo .0 "-> *$to* $line" me
}
Send "PRIVMSG $to :$line"
}
proc command_names {window line} {
Send "NAMES $line"
}
proc command_newwin {window line} {
CreateChannel ""
}
proc command_nick {window line} {
Send "NICK $line"
}
proc command_notice {window line} {
global info me
set line [split $line " "]
set to [lindex $line 0]
set line [join [lrange $line 1 end]]
multiline $to $line
set to2 [string tolower $to]
if {[info exists info(query,$to2)]} {
Echo $info(query,$to2) "+$me+ $line" me
raise $info(query,$to2)
} elseif {[info exists info(window,$to2)]} {
Echo $info(window,$to2) "-$me- $line" me
} else {
Echo .0 "-> +$to+ $line" me
}
Send "NOTICE $to :$line"
}
proc command_notify {window line} {
global prefs notify
set line [rele [split $line]]
if {$line == ""} {
if {$prefs(notify) != ""} {
foreach x $notify(+online) {
Echo $window "\[ notify \] Online: $x [lindex $notify([string tolower $x]) 0] ([dur [expr {[clock seconds] - [lindex $notify([string tolower $x]) 1]}]])" {notify default}
}
set off {}
foreach x [lsort -dictionary $prefs(notify)] {
if {[lsearch -exact [string tolower $notify(+online)] [string tolower $x]] == -1} {lappend off $x}
}
Echo $window "\[ notify \] Offline: [join [lsort -dictionary $off]]" {notify default}
} else {
Echo $window "\[ notify \] Notify list is empty" {notify default}
}
return
}
foreach x $line {
if {[string match -* $x]} {
set x [string range $x 1 end]
if {[set index [lsearch -exact [string tolower $prefs(notify)] [string tolower $x]]] != -1} {
Echo .0 "\[ notify \] [lindex $prefs(notify) $index] removed from notification list" {notify default}
set prefs(notify) [lreplace $prefs(notify) $index $index]
catch {unset notify([string tolower $x])}
if {[set index [lsearch -exact [string tolower $notify(+online)] [string tolower $x]]] != -1} {
set notify(+online) [lreplace $notify(+online) $index $index]
}
}
} elseif {[lsearch -exact [string tolower $prefs(notify)] [string tolower $x]] == -1} {
lappend prefs(notify) $x
Echo .0 "\[ notify \] $x added to notification list" {notify default}
}
}
DoNotifyWindow refresh
if {$prefs(notify) != ""} {Send "ISON [join $prefs(notify)]"}
}
proc command_on {window line} {
global on info
set line [string trimleft $line]
if {[string trim $line] == ""} {
foreach x $info(on) {
if {[info exists on([lindex $x 0])]} {
foreach a $on([lindex $x 0]) {Echo $window "on [lindex $x 0] $a" on}
}
}
if {[array size on] == 0} {Echo $window {[ info ] No events defined} {info default}}
return
}
if {[string match "-*" $line]} {
set type [trim [lindex [split $line] 0] -]
if {$type == "all"} {
foreach x $info(on) {command_on $window -[lindex $x 0]}
return
}
if {[info exists on($type)]} {
set num 0
set line [string range $line [expr {[string length $type] + 2}] end]
foreach x $on($type) {
if {[string match -nocase [globescape $line]* [join $x]]} {
Echo $window "-on $type $x" on
set on($type) [lreplace $on($type) $num $num]
incr num -1
}
incr num
}
if {[string trim $on($type)] == ""} {unset on($type)}
}
return
}
if {[llength [rele [split $line]]] == 1} {
set line [rele [split $line]]
if {[lsearch -glob $info(on) "$line *"] == -1} {
Echo $window "\[ error \] on: unknown event: $line" {error default}
} elseif {![info exists on($line)]} {
Echo $window "\[ info \] on: no $line events defined" {info default}
} else {
foreach a $on($line) {Echo $window "on $line $a" on}
}
return
}
foreach x $info(on) {
set type [lindex $x 0]
if {[string match "$type*" $line]} {
set args [lindex $x 1]
set line [split $line [string index $line [string length $type]]]
set a [lrange $line 1 $args]
if {[set blah [join [lrange $line [expr {$args + 1}] end]]] == ""} {
Echo $window "\[ error \] on $type requires [expr {$args + 1}] arguments" {error default}
return
}
if {[catch {eval proc __onevent args \{$blah\}} err]} {
Echo $window "\[ error \] Error in event expression: $err" {error default}
return
}
rename __onevent {}
lappend a $blah
lappend on($type) $a
Echo $window "+on $type $a" on
return
}
}
Echo $window "\[ error \] on: unknown event: [lindex [split $line] 0]" {error default}
}
proc command_option {window line} {
global options info
set line [rele [split $line]]
if {[set tmp [windowname [lindex $line 0]]] != ""} {
set window $tmp
set line [lrange $line 1 end]
}
if {[set cmd [lindex $line 0]] == ""} {
set opt "popup, menubar"
if {[winfo exists $window.middle.right.nicks]} {append opt ", nicklist, topic"}
Echo $window "\[ info \] Options are: $opt" {info default}
return
}
if {![info exists options($cmd,$window)]} {
Echo $window "\[ info \] Unknown option $cmd" {info default}
return
}
if {[set line [lrange $line 1 end]] == ""} {
Echo $window "\[ info \] [string totitle $cmd] is [string map {0 OFF 1 ON} $options($cmd,$window)]"
return
}
if {![string is boolean -strict $line]} {
Echo $window "\[ error \] Invalid value for $cmd, must be boolean" {error default}
return
}
switch -- $cmd {
popup {
set options(popup,$window) [expr {$line ? 1 : 0}]
Echo $window "\[ info \] Pop up on activity is [string map {0 OFF 1 ON} $options(popup,$window)]" {info default}
}
menubar {
set options(menubar,$window) [expr {$line ? 1 : 0}]
if {$options(menubar,$window)} {
pack forget $window.menubar $window.middle $window.bottom
pack $window.menubar -side top -fill x
pack $window.bottom -side bottom -fill x
pack $window.middle -side top -expand 1 -fill both
} else {
pack forget $window.menubar
}
}
nicklist {
if {![winfo exists $window.middle.right.nicks]} {
Echo $window {[ error ] Nicklist option is only valid for channel windows} {error default}
return
}
set options(nicklist,$window) [expr {$line ? 1 : 0}]
if {$options(nicklist,$window)} {
reattachnick $window
catch {$window.menubar.user configure -state normal}
} else {
pack forget $window.middle.right
catch {destroy $window.n}
catch {$window.menubar.user configure -state disabled}
}
}
topic {
if {![winfo exists $window.middle.left.topic]} {
Echo $window {[ error ] Topic option is only valid for channel windows} {error default}
return
}
set options(topic,$window) [expr {$line ? 1 : 0}]
if {$options(topic,$window)} {
pack forget $window.middle.left.text $window.middle.left.topic $window.middle.left.scroll
pack $window.middle.left.topic -side top -fill x
pack $window.middle.left.scroll -side right -fill y
pack $window.middle.left.text -expand 1 -fill both
} else {
pack forget $window.middle.left.topic
}
}
}
}
proc command_part {window line} {
global info
set line [string trim $line]
if {$line == "all"} {
Send "JOIN 0"
} elseif {![ischannelname $line]} {
if {[info exists info(channel,$window)]} {
Send "PART $info(channel,$window) :$line"
}
} else {
set line [split $line]
Send "PART [lindex $line 0] :[join [lrange $line 1 end]]"
}
}
proc command_ping {window line} {
foreach x [rele [split $line]] {
Echo .0 "\[ ctcp \] -> $x PING" {ctcp default}
Send "PRIVMSG $x :\001PING [clock clicks -milliseconds]\001"
}
}
proc command_position {window line} {
global prefs info options dcc
set line [rele [split $line]]
set cmd [lindex $line 0]
if {[set tmp [windowname [lindex $line 0]]] != ""} {
set window $tmp
set cmd [lindex $line 1]
}
set name [realname $window]
if {($name == "" || $name == "status") && ![string match r* $cmd]} {return}
switch -glob -- $cmd {
s* {
set prefs(geom,$name) ""
lappend prefs(geom,$name) "wm geometry \$window [wm geometry $window]"
lappend prefs(geom,$name) "/ts $options(ts,$window)"
lappend prefs(geom,$name) "set options(popup,\$window) $options(popup,$window)"
lappend prefs(geom,$name) "/option menubar $options(menubar,$window)"
if {$options(log,$window)} {lappend prefs(geom,$name) "/log on $name $options(ln,$window)"}
if {[info exists info(window,$name)]} {
if {[winfo exists $window.n]} {
lappend prefs(geom,$name) {detachnick $window 0 0 0 0}
lappend prefs(geom,$name) "wm geometry \$window.n [wm geometry $window.n]"
} else {
lappend prefs(geom,$name) "/option nicklist $options(nicklist,$window)"
}
lappend prefs(geom,$name) "/option topic $options(topic,$window)"
}
Echo $window {[ info ] Window settings saved} {info default}
}
r* {
if {$name != "status" && $name != "" && [info exists prefs(geom,$name)]} {
catch {eval [join $prefs(geom,$name) \;]}
} elseif {[string match {.[1-9]*} $window]} {
catch {wm geometry $window $prefs(geom,channel)}
} elseif {[string equal .0 $window]} {
catch {wm geometry $window $prefs(geom,status)}
} elseif {[string match .q* $window] || [string match .c* $window]} {
catch {wm geometry $window $prefs(geom,chat)}
}
}
f* {
catch {unset prefs(geom,$name)}
Echo $window {[ info ] Window settings forgotten} {info default}
}
default {
Echo $window {[ info ] Position commands: save forget reset} {info default}
}
}
}
proc command_qbk {window line} {
global prefs info
set line [rele [split $line]]
if {[info exists info(channel,$window)] && ![ischannelname [lindex $line 0]]} {
set chan $info(channel,$window)
} else {
set chan [lindex $line 0]
set line [lrange $line 1 end]
}
foreach x $line {
command_ban $window "$chan $x"
command_kick $window "$chan $x [lindex $prefs(kick) 0]"
}
}
proc command_quiet {window line} {
echo off
set list [list $line]
if {[info script] != ""} {set list [split $line \n]}
foreach x $list {
set x [string trimleft $x]
set cmd [lindex [split $x] 0]
catch {$cmd [string range $x [expr {[string length $cmd] + 1}] end]} ret
}
echo on
return $ret
}
proc command_query {window line} {
global prefs
set line [split [string trimleft $line]]
if {[lindex $line 0] != ""} {CreateChat [lindex $line 0]}
if {[join [lrange $line 1 end]] != ""} {command_msg $window [join $line]}
}
proc command_quit {window line} {
CloseClient $line
}
proc command_quote {window line} {
Send $line
}
proc command_reload {window line} {
global prefs env info menu argv info
set autoload 1
set startup 0
catch {unset prefs}
catch {unset menu}
SetDefaults
WindowMenu
if {$line != ""} {
set load [rele [split $line]]
} else {
if {[info exists argv(f)]} {set info(config) [abspath $argv(f)]}
set load [list $info(config)]
}
foreach x $load {
if {[file isdirectory $x]} {
foreach f [lsort [glob -nocomplain -types f $x/*]] {LoadFile $f}
} elseif {[file isfile $x]} {
LoadFile $x
} else {
Echo .0 "\[ error \] No such file or directory: $x" {error default}
}
}
if {[info exists argv(h)]} {set prefs(host) $argv(h)}
if {[info exists argv(nick)]} {set prefs(nick) [linsert $prefs(nick) 0 $argv(nick)]}
foreach win [textwindows] {
foreach x [$info(text,$win) tag names] {
$info(text,$win) tag configure $x -foreground {} -background {}
}
foreach m "window user channel personal server dcc query misc" {
catch {destroy $win.menubar.$m}
}
$win.bottom.cmdline configure -font $prefs(font,cmdline)
colorconfigure $win.bottom.cmdline cmdline
ConfigureTags $win
}
fontconfigure .0 $prefs(font,status)
colorconfigure .0.middle.text status
MakeMenu .0 "window personal server misc"
.0.menubar.window.menu delete 10
.0.menubar.window.menu.1 delete 0 1
.0.menubar.window.menu.2 delete 4 5
foreach win [channelwindows] {
fontconfigure $win $prefs(font,chan)
$win.middle.left.topic configure -font $prefs(font,chantopic)
colorconfigure $win.middle.left.text chan
colorconfigure $win.middle.right.nicks nicklist
colorconfigure $win.middle.left.topic chantopic
MakeMenu $win "window user channel personal server misc"
set end [$win.middle.right.nicks index end]
for {set index 0} {$index < $end} {incr index} {
if {[isop $info(channel,$win) [string trimleft [$win.middle.right.nicks get $index] @]]} {
itemconfigure $win @nicklist $index
} elseif {[isvoice $info(channel,$win) [string trimleft [$win.middle.right.nicks get $index] +]]} {
itemconfigure $win +nicklist $index
} else {
break
}
}
}
foreach win [querywindows] {
fontconfigure $win $prefs(font,chat)
colorconfigure $win.middle.text query
MakeMenu $win "window query personal misc"
$win.menubar.window.menu.2 delete 4 5
}
foreach win [dccwindows] {
fontconfigure $win $prefs(font,chat)
colorconfigure $win.middle.text dccchat
MakeMenu $win "window dcc personal misc"
$win.menubar.window.menu.2 delete 4 5
}
}
proc command_reply {window line} {
set line [split [string trimleft $line]]
Send "NOTICE [lindex $line 0] :\001[string toupper [lindex $line 1]] [join [lrange $line 2 end]]\001"
Echo .0 "\[ ctcp \] [string toupper [lindex $line 1]] reply -> [lindex $line 0]" {ctcp default}
}
proc command_save {window line} {
global prefs info
if {[set file [lindex [rele [split $line]] 0]] == ""} {set file $info(config)/prefs}
if {[catch {open $file w} fh]} {
Echo .0 "\[ error \] Could not open $file for writing: [geterror $fh]" {error default}
return
}
puts $fh "configfile prefs\n\n# \{ do not edit this file! \}\n# \{ see /set /color /font and /save \}\n\n"
foreach var [lsort [array names prefs geom,*]] {
if {$var != "geom,status" && $var != "geom,channel" && $var != "geom,chat"} {
puts $fh "$var \{$prefs($var)\}"
}
}
foreach x [array names info set,*] {
set x [string range $x 4 end]
puts $fh "$x \{$prefs($x)\}"
}
foreach {x y} [array get prefs font,*] {puts $fh "$x \{$y\}"}
foreach x "notify color,* options,*" {
foreach {name val} [array get prefs $x] {
puts $fh "$name \{$val\}"
}
}
close $fh
Echo .0 "\[ info \] Settings saved to $file" {info default}
}
proc command_savebuf {window line} {
global info prefs
set line [rele [split $line]]
if {[set tmp [windowname [lindex $line 0]]] != ""} {
set window $tmp
set line [lrange $line 1 end]
}
if {[set file [lindex $line 0]] == ""} {
set file [tk_getSaveFile -title "RoxIRC Save Buffer" -initialdir $prefs(defaultlogdir) -filetypes {{All *} {Logs *.log} {Text *.txt}}]
}
if {$file == ""} {return}
if {[file dirname $file] == "."} {set file $prefs(defaultlogdir)/$file}
set file [abspath $file]
if {[catch {open $file w} fn]} {
Echo $window "\[ error \] Cannot open $file for writing: [geterror $fn]" {error default}
return
}
puts -nonewline $fn [$info(text,$window) get 1.0 end]
close $fn
Echo $window "\[ info \] Buffer saved to $file" {info default}
}
proc command_say {window blah} {
set ::line $blah
event generate $window <<command>>
}
proc command_search {window line} {
global info
$info(text,$window) tag remove search 1.0 end
if {$line == ""} {return}
set blah 1.0
set pos 1.0
while {$blah != ""} {
set blah [$info(text,$window) search -nocase -elide -count len -- $line $pos end]
if {$blah == ""} {break}
set pos [$info(text,$window) index $blah+${len}c]
$info(text,$window) tag add search $blah $pos
}
if {[$info(text,$window) tag nextrange search 1.0] != "" && [lindex [$info(text,$window) yview] 1] == "1"} {
$info(text,$window) yview search.first
} elseif {[lindex [$info(text,$window) tag nextrange search [set a [expr {int([$info(text,$window) index @0,0])}].0]+1l] 1] != ""} {
$info(text,$window) yview [lindex [$info(text,$window) tag nextrange search $a+1l] 1]
}
}
proc command_server {window line} {
global prefs info
set tmp ""
set line [rele [split $line " :"]]
set server [string tolower [lindex $line 0]]
if {$server == ""} {return}
set port [lindex $line 1]
set pass [join [lrange $line 2 end]]
foreach x [split [string tolower $prefs(server)] "\n"] {
set x [split [string trim $x] :]
lappend network([lindex $x 1]) [lindex $x 0]
set host([lindex $x 0]) $x
}
if {[info exists network($server)]} {
set tmp [lindex $network($server) [expr {round(rand() * ([llength $network($server)] - 1))}]]
set info(connect) [list $server]
OpenSock [string trim [lindex $tmp 0]] [getport [lindex $tmp 2]] [lindex $tmp 3]
} else {
if {[info exists host($server)]} {
if {$port == "" && [lindex $host($server) 2] != ""} {
set port [lindex $host($server) 2]
}
if {$pass == "" && [lindex $host($server) 3] != ""} {
set pass [lindex $host($server) 3]
}
if {[lindex $host($server) 1] != ""} {
set info(connect) [list [lindex $host($server) 1]]
} else {
set info(connect) [list $server $port $pass]
}
} else {
set info(connect) [list $server $port $pass]
}
OpenSock [string trim $server] [getport $port] $pass
}
}
proc command_set {window line} {
global prefs info
set line [split [string trimleft $line]]
set tmp [string tolower [lindex $line 0]]
if {$tmp == ""} {
foreach x [lsort [array names info set,*]] {
set x [string range $x 4 end]
Echo $window "\[ info \] [string toupper $x] set to \"$prefs($x)\"" {info default}
}
return
}
if {![info exists info(set,$tmp)]} {
Echo $window "\[ error \] No such variable \"[string toupper $tmp]\"" {error default}
if {$tmp != "" && [array names info set,*$tmp*] != ""} {
Echo $window "\[ info \] Matching variables: [string toupper [string map {"set," ""} [array names info set,*$tmp*]]]" {info default}
}
return
}
if {[llength [rele $line]] == "1"} {
if {[info exists prefs($tmp)]} {
Echo $window "\[ info \] [string toupper [string trim $line]] set to \"$prefs($tmp)\"" {info default}
}
return
}
set type [split $info(set,$tmp)]
set val [join [lrange $line 1 end]]
for {set i 0} {$i < [llength $type]} {incr i} {
switch [lindex $type $i] {
cmd {
[lindex $type [expr {$i + 1}]] $window $val
}
bool {
if {![string is boolean -strict $val]} {
Echo $window "\[ error \] Invalid value for [string toupper [lindex $line 0]], must be boolean" {error default}
return
}
if {$val} {
set val 1
} else {
set val 0
}
}
num {
if {![string is integer -strict $val]} {
Echo $window "\[ error \] Invalid value for [string toupper [lindex $line 0]], must be a number" {error default}
return
}
if {[string is integer -strict [lindex $type [expr {$i + 1}]]] && [string is integer -strict [lindex $type [expr {$i + 2}]]]} {
if {$val < [lindex $type [expr {$i + 1}]] || $val > [lindex $type [expr {$i + 2}]]} {
Echo $window "\[ error \] Invalid value for [string toupper [lindex $line 0]], must be from [lindex $type [expr {$i + 1}]] to [lindex $type [expr {$i + 2}]]" {error default}
return
}
incr i
}
}
}
}
if {$val == "\"\""} {
Echo $window "\[ info \] [string toupper $tmp] \"$prefs($tmp)\" -> \"\"" {info default}
set prefs($tmp) ""
} else {
Echo $window "\[ info \] [string toupper $tmp] \"$prefs($tmp)\" -> \"$val\"" {info default}
set prefs($tmp) $val
}
}
proc command_show {window line} {
global info
if {[set line [rele [split $line]]] == ""} {
set num 1
foreach x [textwindows] {
if {[wm state $x] == "withdrawn"} {
set title [split [wm title $x]]
if {[string match ".q*" $x]} {
set title [lrange $title 1 2]
} elseif {[string match ".c*" $x]} {
set title [lrange $title 1 3]
} else {
set title [lindex $title 1]
}
Echo $window "$num) $title" {}
incr num
}
}
if {$num == 1} {Echo $window {[ info ] There are no hidden windows} {info default}}
return
}
if {[string tolower $line] == "all"} {
foreach x [textwindows] {
if {[wm state $x] == "withdrawn"} {
wm geometry $x [winfo geometry $x]
wm deiconify $x
}
}
return
}
set show ""
foreach x $line {
if {[set win [windowname $x]] != ""} {
lappend show $win
} elseif {[string is integer -strict $x]} {
set num 1
foreach a [textwindows] {
if {[wm state $a] == "withdrawn"} {
if {$num == $x} {
lappend show $a
continue
}
incr num
}
}
} else {
foreach w [winfo children .] {
if {[info exists info(text,$w)] && [wm state $w] == "withdrawn" && [string match "roxirc $x*" [string tolower [wm title $w]]]} {
lappend show $w
}
}
}
}
foreach x $show {
wm geometry $x [winfo geometry $x]
wm deiconify $x
}
}
proc command_sping {window line} {
global server
if {[set line [string trim $line]] == ""} {set line $server}
Send "PING [clock clicks -milliseconds] :$line"
}
proc command_stats {window line} {
Send "STATS $line"
}
proc command_tcl {window line} {
global info prefs dcc ignore help server me irc env notify userhost last ial names history options on away tcl_traceExec errorInfo errorCode
if {[catch {set out [eval $line]} msg]} {
Echo $window "\[ error \] Error while executing tcl command: $msg" {error default}
} elseif {[string trim $out] != ""} {
Echo $window $out {}
}
}
proc command_timer {window line} {
set line [split $line]
if {[string trim [join $line]] == ""} {
set num 0
foreach x [after info] {
if {[lindex [set tmp [lindex [after info $x] 0]] 0] == "DoTimer"} {
Echo $window "timer[lindex $tmp 1] [lindex $tmp 3]/[lindex $tmp 4] [dur [lindex $tmp 2] 1000] [lindex $tmp 5]" timer
incr num
}
}
if {$num == 0} {
Echo $window "\[ info \] There are no active timers" {info default}
}
} elseif {[lindex $line 0] == "stop" || [lindex $line 0] == "cancel" || [lindex $line 0] == "off"} {
foreach x [after info] {
if {[lindex [set tmp [lindex [after info $x] 0]] 0] == "DoTimer" && ([lindex $tmp 1] == [lindex $line 1] || [lindex $line 1] == "all" || [string match [lindex $line 1] [lindex $tmp 5]])} {
after cancel $x
Echo $window "-timer[lindex $tmp 1] [lindex $tmp 3]/[lindex $tmp 4] [dur [lindex $tmp 2] 1000] [lindex $tmp 5]" timer
}
}
} else {
set delay [lindex $line 1]
set times [lindex $line 0]
set command [join [lrange $line 2 end]]
if {[string match *s $delay]} {
set delay [expr {1000 * [string trimright $delay s]}]
} elseif {[string match *m $delay]} {
set delay [expr {60000 * [string trimright $delay m]}]
} elseif {[string match *h $delay]} {
set delay [expr {3600000 * [string trimright $delay h]}]
}
if {[string is integer -strict $delay] && [string is integer -strict $times]} {
set num 1
foreach x [after info] {
if {[lindex [lindex [after info $x] 0] 0] == "DoTimer"} {
set temp([lindex [lindex [after info $x] 0] 1]) ""
}
}
while {[info exists temp($num)]} {incr num}
if {$times < 0} {set times 0}
after $delay [list DoTimer $num $delay $times $times $command]
Echo $window "+timer$num $times [dur $delay 1000] $command" timer
return $num
} else {
Echo $window "\[ info \] Timer usage: /timer <times> <delay> <command>" {info default}
}
}
}
proc command_topic {window line} {
global info
set line [split $line]
if {[info exists info(channel,$window)] && ![ischannelname [lindex $line 0]]} {
set chan $info(channel,$window)
set line [join $line]
} else {
set chan [lindex $line 0]
set line [join [lrange $line 1 end]]
}
if {[string trim $line] == ""} {
Send "TOPIC $chan"
} elseif {[string trim $line] == ":"} {
Send "TOPIC $chan :"
} else {
Send "TOPIC $chan :$line"
}
}
proc command_ts {window line} {
global options
set line [rele [split $line]]
if {[set tmp [windowname [lindex $line 0]]] != ""} {
set window $tmp
set win $tmp
set to [lindex $line 1]
} elseif {[string tolower [lindex $line 0]] == "channels"} {
set win [channelwindows]
set to [lindex $line 1]
} elseif {[string tolower [lindex $line 0]] == "chats"} {
set win "[querywindows] [dccwindows]"
set to [lindex $line 1]
} elseif {[string tolower [lindex $line 0]] == "all"} {
set win [textwindows]
set to [lindex $line 1]
} else {
set win $window
set to [lindex $line 0]
}
if {$to == ""} {
set to 2
} elseif {[string is boolean $to] && $to} {
set to 1
} elseif {[string is boolean $to]} {
set to 0
} else {
Echo $window {[ info ] Usage: /ts [on|off]} {info default}
return
}
foreach x $win {
if {$to > 1} {
set options(ts,$x) [expr {!$options(ts,$x)}]
} else {
set options(ts,$x) $to
}
ts $x
}
}
proc command_trace {window line} {
Send "TRACE $line"
}
proc command_umode {window line} {
Send "MODE $::me $line"
}
proc command_unalias {window line} {
set line [rele [split [string tolower $line]]]
if {$line == ""} {
set aliases ""
foreach x [info commands command_*] {
if {[string range [string trimleft [info body $x]] 0 5] == "#alias"} {
lappend aliases [string range $x 8 end]
}
}
Echo $window "\[ info \] Aliases: [join $aliases]" {info default}
return
}
foreach x $line {
if {[info procs command_$x] == "" || [string range [string trimleft [info body command_$x]] 0 5] != "#alias"} {
Echo $window "\[ error \] Cannot unalias $x: no such alias" {error default}
continue
}
catch {rename command_$x ""}
Echo $window "-alias $x" alias
}
}
proc command_unload {window line} {
global procs
if {[string trim $line] == ""} {
set s ""
foreach x [namespace children ::scripts] {
if {[set t [info commands ${x}::unload]] != ""} {
lappend s [namespace tail $x]
}
}
if {$s != ""} {
Echo $window "\[ info \] Currently unloadable scripts: [join $s]" {info default}
} else {
Echo $window "\[ info \] There are no unloadable scripts" {info default}
}
return
}
foreach x [rele [split $line]] {
if {[info commands ::scripts::${x}::unload] != ""} {
if {[catch {::scripts::${x}::unload} err]} {
Echo $window "\[ error \] Could not unload $x: [geterror $err]" {error default}
} else {
foreach proc [array names procs] {
if {$x == $procs($proc)} {
catch {rename ::$proc ""}
if {[info commands ::backup::${x}::$proc] != ""} {
rename ::backup::${x}::$proc ::$proc
}
unset procs($proc)
}
}
catch {namespace delete ::backup::${x}}
namespace delete ::scripts::${x}
if {$window != ".0"} {
Echo .0 "\[ info \] Unloaded $x" {info default}
}
Echo $window "\[ info \] Unload: $x unloaded succesfully" {info default}
}
} elseif {[info commands ::scripts::${x}::*] != ""} {
Echo $window "\[ error \] $x is not unloadable" {error default}
} else {
Echo $window "\[ error \] Could not unload $x: no such script" {error default}
}
}
}
proc command_url {window line} {
global urls prefs
switch -exact -- [lindex [split $line] 0] {
on {
set prefs(urls) 1
Echo $window "\[ info \] Url catcher is now ON" {info default}
}
off {
set prefs(urls) 0
Echo $window "\[ info \] Url catcher is now OFF" {info default}
}
clear {
set urls ""
Echo $window "\[ info \] Url list cleared" {info default}
}
last {
global prefs
set url [lindex [rele [split [lindex $urls end]]] 3]
eval exec [string map {"\$url" $url} $prefs(urlcommand)] &
}
"" {
UrlWindow
}
}
}
proc command_users {window line} {
Send "USERS $line"
}
proc command_wall {window line} {
global info names me
set line [string trimleft $line]
if {[info exists info(channel,$window)] && ![ischannelname [lindex $line 0]]} {
set chan $info(channel,$window)
} else {
set chan [lindex $line 0]
set line [join [lrange [split $line] 1 end]]
}
Echo $window "-> +@$chan+: $line" me
foreach {a b c d e f g} [array names names [globescape $chan],*,o] {
Send "NOTICE [string map [list [string tolower $me] "" $chan, "" ,o ""] [join [list $a $b $c $d $e $f $g] ,]] :\[@$chan\] $line"
}
}
proc command_who {window line} {
Send "WHO $line"
}
proc command_whois {window line} {
Send "WHOIS $line"
}
proc command_whowas {window line} {
Send "WHOWAS $line"
}
proc raw_001 {header line} {
global me server prefs info showmotd notify away autoaway
Registered
set info(time,server) [clock seconds]
set notify(+online) ""
set me [lindex $header end]
if {!$prefs(showmotd)} {set showmotd 1}
UpdateAllTitles
catch {unset autoaway}
if {$away} {
set autoaway 1
Send "AWAY :$prefs(awayreason)"
}
set away 0
foreach x [array names info channel,*] {
if {[winfo exists $info(window,$info($x))]} {
Send "JOIN $info($x)"
} elseif {[info exists info($x)]} {
DeleteChannel $info($x)
}
}
after cancel autoaway
if {$prefs(autoaway) > 0} {after [expr {$prefs(autoaway) * 60000}] autoaway}
if {$prefs(notify) != ""} {
after 3000 [list Send "ISON [join $prefs(notify)]"]
}
Echo .0 "\[ server \] $line" {server default}
array unset info server,*
after 1000 [list Event connect {}]
after 1000 [list Parse ": 005 :"]
}
proc raw_002 {header line} {}
proc raw_003 {header line} {
Echo .0 "\[ server \] $line" {server default}
}
proc raw_004 {header line} {
Echo .0 "\[ server \] User modes available: [lindex $header 5] Channel modes: $line" {server default}
}
proc raw_005 {header line} {
global info
foreach x [lrange $header 3 end] {
set x [split $x =]
set info(server,[string tolower [lindex $x 0]]) [lindex $x 1]
}
after cancel [list Event connect {}]
after cancel [list Parse ": 005 :"]
Event connect {}
}
proc raw_221 {header line} {
if {$line == "+"} {
.0.menubar.modes configure -text "-"
} else {
.0.menubar.modes configure -text [string trimleft $line +]
}
}
proc raw_301 {header line} {
global info
set nick [lindex $header end]
if {![info exists info(query,[string tolower $nick])]} {
Echo .0 "\[ away \] $nick is away: $line" {away default}
}
}
proc raw_302 {header line} {
global userhost
foreach x [split $line] {
set nick [string trimright [lindex [split $x =] 0] *]
set address [string range [lindex [split $x =] 1] 1 end]
foreach x [common $nick] {ialadd $x $nick $address}
if {[info exists userhost([string tolower $nick])]} {
set cmd [string map [list %address [escape $nick!$address]] $userhost([string tolower $nick])]
catch {eval $cmd}
unset userhost([string tolower $nick])
}
}
}
proc raw_303 {header line} {
global prefs notify away on info
foreach x $notify(+online) {
if {[lsearch -exact [split [string tolower $line]] [string tolower $x]] == -1} {
if {![info exists notify([string tolower $x])]} {continue}
set address [lindex $notify([string tolower $x]) 0]
Echo .0 "\[ notify \] Signoff by $x ($address) at [clock format [clock seconds] -format "%R" -gmt $prefs(gmt)] ([dur [expr {[clock seconds] - [lindex $notify([string tolower $x]) 1]}]])" {notify default}
if {[info exists info(query,[string tolower $x])]} {
Echo $info(query,[string tolower $x]) "\[ notify \] Signoff by $x ($address) at [clock format [clock seconds] -format "%R" -gmt $prefs(gmt)] ([dur [expr {[clock seconds] - [lindex $notify([string tolower $x]) 1]}]])" {notify default}
}
unset notify([string tolower $x])
set index [lsearch -exact [string tolower $notify(+online)] [string tolower $x]]
set notify(+online) [lreplace $notify(+online) $index $index]
DoNotifyWindow refresh
Event unnotify "x nick address address" $x!$address
}
}
foreach x [split $line] {
if {$x == ""} {continue}
if {[lsearch -exact [string tolower $notify(+online)] [string tolower $x]] == -1} {
getaddress $x [list notifyon $x %address [clock seconds]]
lappend notify(+online) $x
}
}
}
proc raw_305 {header line} {
global prefs away autoaway
Echo .0 "\[ away \] $line" {away default}
set away 0
catch {unset autoaway}
if {$prefs(autoaway) > 0} {
after [expr {$prefs(autoaway) * 60000}] autoaway
}
UpdateAllTitles
Event unaway {}
}
proc raw_306 {header line} {
global away autoaway
set away 1
after cancel autoaway
Echo .0 "\[ away \] $line[expr {[info exists autoaway] ? { (auto)} : {}}]" {away default}
UpdateAllTitles
Event away {}
}
proc raw_311 {header line} {
Echo [current] "\[ whois \] [lindex $header 3] is [lindex $header 4]@[lindex $header 5] ($line)" {whois default}
}
proc raw_312 {header line} {
global last
if {$last == "314"} {
Echo [current] "\[ whowas \] [lindex $header 3] was on server [lindex $header end] until $line" {whowas default}
} else {
Echo [current] "\[ whois \] [lindex $header 3] on server [lindex $header end] ($line)" {whois default}
}
}
proc raw_313 {header line} {
Echo [current] "\[ whois \] [lindex $header end] $line" {whois default}
}
proc raw_314 {header line} {
Echo [current] "\[ whowas \] [lindex $header 3] was [lindex $header 4]@[lindex $header 5] ($line)" {whowas default}
}
proc raw_315 {header line} {
Echo [current] "\[ who \] [lindex $header end] $line" {who default}
}
proc raw_317 {header line} {
global prefs
if {[lindex $header 5] != ""} {
Echo [current] "\[ whois \] [lindex $header 3] has been idle [dur [lindex $header 4]], signed on [clock format [lindex $header end] -format "%D at %T" -gmt $prefs(gmt)]" {whois default}
} else {
Echo [current] "\[ whois \] [lindex $header 3] has been idle [dur [lindex $header 4]]" {whois default}
}
}
proc raw_318 {header line} {}
proc raw_319 {header line} {
Echo [current] "\[ whois \] [lindex $header end] on channels [string trim $line]" {whois default}
}
proc raw_320 {header line} {
Echo [current] "\[ whois \] [lindex $header end] $line" {whois default}
}
proc raw_321 {header line} {
global chanlist
set chanlist ""
ListWindow
proc listwindowupdate {} {update idletasks; after 1000 listwindowupdate}
listwindowupdate
}
proc raw_322 {header line} {
if {![winfo exists .list]} {return}
global chanlist
set chan [lindex $header 3]
set users [lindex $header 4]
if {$chan == "*"} {return}
if {$users == ""} {set users 0}
lappend chanlist [list $chan $users $line]
if {[string length $chan] > 20} {
set chan [string range $chan 0 16]...
}
.list.middle.list insert end [format "%-20s %5s %s" $chan $users $line]
.list.bottom.status configure -text "Listing... [.list.middle.list index end]"
}
proc raw_323 {header line} {
if {[winfo exists .list]} {
.list.bottom.status configure -text "[.list.middle.list index end] channels"
}
after cancel {listwindowupdate}
if {[info commands listwindowupdate] == ""} {
Echo .0 {[ server ] Channel list is empty} {server default}
} else {
rename listwindowupdate {}
}
}
proc raw_324 {header line} {
global info
set chan [string tolower [lindex $header 3]]
set mode [string trimleft [string trim "[join [lrange $header 4 end]] $line"] +]
if {[info exists info(window,$chan)] && [winfo exists $info(window,$chan)]} {
if {$line != "+"} {
$info(window,$chan).menubar.modes configure -text $mode
} else {
$info(window,$chan).menubar.modes configure -text "-"
}
} else {
Echo .0 "\[ channel \] $chan modes: $line" {channel default}
}
}
proc raw_329 {header line} {
global info prefs
set chan [string tolower [lindex $header 3]]
global join$chan
if {![info exists join$chan]} {return}
unset join$chan
if {[info exists info(window,$chan)]} {
Echo $info(window,$chan) "\[ channel \] $chan was created on [clock format $line -format "%D at %T" -gmt $prefs(gmt)]" {channel default}
} else {
Echo .0 "\[ channel \] $chan was created on [clock format $line -format "%D at %T" -gmt $prefs(gmt)]" {channel default}
}
}
proc raw_332 {header line} {
global info
set chan [string tolower [lindex $header end]]
Echo $info(window,$chan) "\[ topic \] $line" {topic default}
InsertDisabled $info(window,$chan).middle.left.topic $line
}
proc raw_331 {header line} {
global info
set chan [string tolower [lindex $header end]]
if {[info exists info(window,$chan)]} {
Echo $info(window,$chan) {[ topic ] No topic is set} {topic default}
} else {
Echo .0 "\[ topic \] $chan no topic is set" {topic default}
}
}
proc raw_333 {header line} {
global info prefs
set nick [lindex $header 4]
if {[string match "*!*" $nick]} {set nick "[lindex [split $nick !] 0] ([lindex [split $nick !] 1])"}
Echo $info(window,[string tolower [lindex $header 3]]) "\[ topic \] set by $nick on [clock format $line -format "%D at %T" -gmt $prefs(gmt)]" {topic default}
}
proc raw_338 {header line} {
if {[set host [lindex $header 4]] != ""} {
Echo [current] "\[ whois \] [string totitle $line] $host" {whois default}
} else {
Echo [current] "\[ whois \] $line" {whois default}
}
}
proc raw_341 {header line} {
Echo .0 "\[ invite \] Invited [lindex $header 3] to $line" {invite default}
}
proc raw_352 {header line} {
set blah ""
set hops [lindex $line 0]
if {[string match *@* [lindex $header end]]} {
lappend blah @[lindex $header 3]
} elseif {[string match *+* [lindex $header end]]} {
lappend blah +[lindex $header 3]
} elseif {[lindex $header 3] != "*"} {
lappend blah [lindex $header 3]
}
if {[string index [lindex $header end] 0] == "G"} {
lappend blah Away
} elseif {[string index [lindex $header end] 0] == "H"} {
lappend blah Here
}
lappend blah "$hops hops"
if {[string match "*\\\**" [lindex $header end]]} {
lappend blah Oper
}
set line [string range $line [expr {[string length $hops] + 1}] end]
Echo [current] "\[ who \] [lindex $header 7]![lindex $header 4]@[lindex $header 5] ($line) on [lindex $header 6], [join $blah ", "]" {who default}
}
proc raw_353 {header line} {
global names info last
set chan [string tolower [lindex $header end]]
if {[info exists info(window,$chan)]} {
if {$last != "353"} {array unset names [globescape $chan],*}
foreach nick [split $line] {
if {$nick == ""} {continue}
if {[string match {@*} $nick]} {
set nick [string trimleft $nick @]
set names($chan,[string tolower $nick],o) $nick
} elseif {[string match {+*} $nick]} {
set nick [string trimleft $nick +]
set names($chan,[string tolower $nick],v) $nick
} else {
set names($chan,[string tolower $nick],n) $nick
}
lappend names($chan,[string tolower $nick],a) $nick
}
} else {
Echo .0 "( 353 ) $chan: $line" numeric
}
}
proc raw_365 {header line} {}
proc raw_364 {header line} {
if {![winfo exists .links]} {
global prefs
toplevel .links
wm geometry .links [expr {round([winfo width .0] * .70)}]x[expr {round([winfo height .0] * .80)}]
wm title .links "RoxIRC Links"
wm iconname .links "Links [lindex $header end] \[RoxIRC\]"
frame .links.top
frame .links.buttons -bd [.links cget -bd] -relief raised
pack .links.buttons -side bottom -fill x -ipady 3
pack .links.top -ipadx 1 -ipady 1 -side top -fill both -expand 1
scrollbar .links.top.scrolly -orient v -command ".links.top.list yview"
scrollbar .links.top.scrollx -orient h -command ".links.top.list xview"
listbox .links.top.list -bd 1 -relief sunken -font fixed -yscrollcommand ".links.top.scrolly set" -xscrollcommand ".links.top.scrollx set"
bind .links.top.list <Double-Button-1> {command_server .0 [lindex [split [.links.top.list get [.links.top.list curselection]]] 0]}
bind .links <Escape> ".links.buttons.done invoke"
pack .links.top.scrolly -side right -fill y
pack .links.top.scrollx -side bottom -fill x
pack .links.top.list -fill both -expand 1
button .links.buttons.save -text Save -command "SaveListbox .links.top.list" -font $prefs(font,menu)
button .links.buttons.done -text Done -command "destroy .links" -font $prefs(font,menu)
pack .links.buttons.save -side left -padx 5
pack .links.buttons.done -side right -padx 5
}
.links.top.list insert 0 "[string repeat " " [lindex [split $line] 0]][lindex $header 3] ([join [string range [split $line] 2 end]])"
}
proc raw_366 {header line} {
global info
set chan [string tolower [lindex $header end]]
if {[info exists info(window,$chan)]} {
ListFill $info(window,$chan)
UpdateTitle $info(window,$chan)
}
}
proc raw_367 {header line} {
global banlist
if {[llength $header] < 5} {
lappend banlist [list $line unknown [clock seconds] b]
} else {
lappend banlist "[lrange $header 4 end] $line b"
}
}
proc raw_348 {header line} {
global banlist
if {[llength $header] < 5} {
lappend banlist [list $line unknown [clock seconds] e]
} else {
lappend banlist "[lrange $header 4 end] $line e"
}
}
proc raw_349 {header line} {
BanWindow [string tolower [lindex $header end]]
}
proc raw_368 {header line} {
BanWindow [string tolower [lindex $header end]]
}
proc raw_369 {header line} {}
proc raw_372 {header line} {
global showmotd
if {![info exists showmotd]} {Echo .0 "\[ motd \] $line" {motd default}}
}
proc raw_375 {header line} {
global showmotd
if {![info exists showmotd]} {Echo .0 "\[ motd \] $line" {motd default}}
}
proc raw_376 {header line} {
global showmotd
if {[info exists showmotd]} {
unset showmotd
} else {
Echo .0 "\[ motd \] $line" {motd default}
}
}
proc raw_377 {header line} {
global showmotd
if {![info exists showmotd]} {Echo .0 "\[ motd \] $line" {motd default}}
}
proc raw_401 {header line} {
Echo .0 "( 401 ) [lindex $header end] $line" numeric
Send "WHOWAS [lindex $header end]"
}
proc raw_404 {header line} {
global info
set chan [lindex $header end]
if {[info exists info(window,$chan)]} {
if {[string match *m* [lindex [$info(window,$chan).menubar.modes cget -text] 0]]} {
Echo $info(window,$chan) {[ channel ] Cannot send to channel} {channel default}
} else {
Echo $info(window,$chan) "\[ channel \] [lindex $header 0] is desynched (cannot send to channel)" {channel default}
}
} else {
Echo .0 "\[ channel \] $chan cannot send to channel" {channel default}
}
}
proc raw_422 {header line} {
global showmotd
if {[info exists showmotd]} {unset showmotd}
Echo .0 {[ motd ] No MOTD} {motd default}
}
proc raw_431 {header line} {
global info connecting
if {[info exists connecting] && [lindex $header 2] == "*" || [lindex $header 2] == ""} {
Echo .0 {[ info ] All your alternate nicks are in use, choose a new one} {info default}
.0.bottom.cmdline delete 0 end
.0.bottom.cmdline insert 0 "/nick "
} else {
Echo .0 "( 431 ) $line" numeric
}
}
proc raw_433 {header line} {
global info prefs me connecting
if {[lindex $header 2] == "*"} {
Echo .0 "\[ server \] Nickname is already in use: [lindex $header end]" {server default}
if {$me != "-" && [info exists connecting] && [lindex $header end] != $me && [lsearch -exact $prefs(nick) [lindex $header end]] > -1} {
Send "NICK $me"
} elseif {[set index [lsearch -exact $prefs(nick) [lindex $header end]]] != -1} {
Send "NICK [unescape [lindex $prefs(nick) [expr {$index + 1}]]]"
} else {
Send "NICK [unescape [lindex $prefs(nick) 0]]"
}
} else {
Echo .0 "( 433 ) [lindex $header end] $line" numeric
}
}
proc raw_437 {header line} {
global info
set chan [lindex $header end]
if {[info exists info(window,$chan)]} {
Echo $info(window,$chan) "\[ channel \] $line" {channel default}
after 30000 [list Send "JOIN $chan"]
} else {
Echo .0 "\[ channel \] $chan $line" {channel default}
}
}
proc raw_443 {header line} {
Echo .0 "\[ invite \] [lindex $header 3] $line [lindex $header 4]" {invite default}
}
proc raw_471 {header line} {
global info
set channel [lindex $header end]
Echo .0 "\[ channel \] Cannot join $channel: full" {channel default}
if {[info exists info(window,$channel)]} {DeleteChannel $channel $info(window,$channel)}
}
proc raw_473 {header line} {
global info
set channel [lindex $header end]
Echo .0 "\[ channel \] Cannot join $channel: not invited" {channel default}
if {[info exists info(window,$channel)]} {DeleteChannel $channel $info(window,$channel)}
}
proc raw_474 {header line} {
global info
set channel [lindex $header end]
Echo .0 "\[ channel \] Cannot join $channel: banned" {channel default}
if {[info exists info(window,$channel)]} {DeleteChannel $channel $info(window,$channel)}
}
proc raw_475 {header line} {
global info
set channel [lindex $header end]
Echo .0 "\[ channel \] Cannot join $channel: wrong key" {channel default}
if {[info exists info(window,$channel)]} {DeleteChannel $channel $info(window,$channel)}
}
proc raw_JOIN {header line} {
global me info names
set channel [string tolower $line]
set nick [lindex [split [lindex $header 0] !] 0]
set address [lindex [split [lindex $header 0] !] 1]
if {[string equal -nocase $me $nick]} {
if {![info exists info(window,$channel)]} {
CreateChannel $channel
} else {
InsertDisabled $info(window,$channel).middle.left.topic {}
}
Send "MODE $channel"
set ::join$channel {}
after 15000 [list catch [list unset join$channel]]
} elseif {[winfo exists $info(window,$channel)]} {
set names($channel,[string tolower $nick],a) $nick
ListAdd $info(window,$channel) $nick
ialadd $channel $nick $address
}
Echo $info(window,$channel) "\[ join \] $nick ($address)" {join default}
Event join "nick nick address address channel channel" $channel $nick!$address
}
proc raw_PART {header line} {
global me info
set nick [lindex [split [lindex $header 0] !] 0]
set address [lindex [split [lindex $header 0] !] 1]
lappend header $line
set channel [string tolower [lindex $header 2]]
set line [lindex $header 3]
set msg {}
if {$line != ""} {set msg " ($line)"}
Echo $info(window,$channel) "\[ part \] $nick ($address)$msg" {part default}
Event part "nick nick address address channel channel line line" $channel $nick!$address
if {[string equal -nocase $nick $me]} {
DeleteChannel $channel $info(window,$channel)
} elseif {[winfo exists $info(window,$channel)]} {
DeleteUser $channel $nick
}
}
proc raw_QUIT {header line} {
global info netsplit prefs
set nick [lindex [split [lindex $header 0] !] 0]
set address [lindex [split [lindex $header 0] !] 1]
Event quit "nick nick address address line line" "$nick!$address $line"
if {$prefs(netsplit) && [string match "*?.??*.??* *?.??*.??*" $line] && [llength $line] == 2} {
catch {after cancel netsplit}
after 4000 netsplit
foreach x [common $nick] {
if {![info exists netsplit($info(window,$x))]} {
Echo $info(window,$x) "\[ quit \] Netsplit: [lindex $line 0] -> [lindex $line 1]" {netsplit quit default}
}
lappend netsplit($info(window,$x)) $nick
DeleteUser $x $nick
}
return
}
foreach x [common $nick] {
Echo $info(window,$x) "\[ quit \] $nick ($address) ($line)" {quit default}
DeleteUser $x $nick
}
}
proc netsplit {} {
global netsplit
foreach x [array names netsplit] {
Echo $x "\[ quit \] Netsplit: [join [lsort -dictionary $netsplit($x)]] ([llength $netsplit($x)])" {netsplit quit default}
}
unset netsplit
}
proc raw_PRIVMSG {header line} {
global me info away
set to [string tolower [lindex $header 2]]
set nick [lindex [split [lindex $header 0] !] 0]
set address [lindex [split [lindex $header 0] !] 1]
if {[string match \001*\001 $line]} {
if {[info exists ::flood]} {return}
Ignore CTCP $nick!$address
set line [string trim $line "\001"]
set ctcp [lindex [rele [split $line]] 0]
set line [string range $line [expr {[string length $ctcp] + 1}] end]
if {[info commands ctcp_$ctcp] != ""} {
ctcp_$ctcp $header $line
} else {
if {[string equal -nocase $to $me]} {
Echo .0 "\[ ctcp \] Unknown ctcp [string trim "$ctcp $line"] from $nick!$address" {ctcp default}
} else {
Echo $info(window,$to) "\[ ctcp \] Unknown ctcp [string trim "$ctcp $line"] from $nick!$address" {ctcp default}
}
}
return
}
if {[info exists info(window,$to)]} {
ialadd $to $nick $address
Ignore PUBLIC $nick!$address
set c {}
if {[isop $to $nick]} {
set c @
} elseif {[isvoice $to $nick]} {
set c +
}
Echo $info(window,$to) < "<> $c<>" $c $c $nick "${c}nicks nicks" > "<> $c<>" " $line" margin
#Echo $info(window,$to) "<$nick> $line" {}
} elseif {[string equal -nocase $me $to]} {
Ignore MSGS $nick!$address
if {$away && ![info exists info(query,[string tolower $nick])]} {
Echo .0 "*$nick!$address* $line" privmsg
} else {
Echo [UpdateChat $nick!$address] "<$nick> $line" {}
}
} else {
Echo .0 "*$nick/$to* $line" privmsg
}
Event text "nick nick address address to target line line" $to $nick!$address $line
}
proc raw_NOTICE {header line} {
global me info server connecting
set nick [lindex [split [lindex $header 0] !] 0]
set address [lindex [split [lindex $header 0] !] 1]
set channel [string tolower [lindex $header 2]]
if {[string match "\001*\001" $line]} {
set line [string trim $line "\001"]
set reply [lindex [rele [split $line]] 0]
set line [string range $line [expr {[string length $reply] + 1}] end]
if {[info commands reply_$reply] != ""} {
reply_$reply $header $line
} else {
Echo .0 "\[ ctcp \] $reply reply from $nick: $line" {ctcp default}
}
return
}
if {[info exists info(window,$channel)]} {
Ignore NOTICES $nick!$address
Echo $info(window,$channel) "-$nick- $line" {}
ialadd $channel $nick $address
} elseif {[string match *.* $nick]} {
regsub {^\*\*\* Notice -- |^\*\*\* } $line {} line
if {[info exists connecting]} {
Echo .0 "\[ server \] $line" {server default}
} elseif {[string equal -nocase $server $nick]} {
Echo .0 "\[ snotice \] $line" {snotice default}
} else {
Echo .0 "\[ snotice \] from $nick: $line" {snotice default}
}
} elseif {[string equal -nocase $me $channel]} {
Ignore NOTICES $nick!$address
if {[info exists info(query,[string tolower $nick])]} {
Echo $info(query,[string tolower $nick]) "+$nick+ $line" {privmsg}
} else {
Echo .0 "+$nick+ $line" privmsg
}
} else {
Ignore NOTICES $nick!$address
Echo .0 "+$nick/$channel+ $line" privmsg
}
Event notice "nick nick address address channel target line line" $channel $nick!$address $line
}
proc raw_MODE {header line} {
global info me names
if {[string equal -nocase $me [lindex $header 2]]} {
Echo .0 "\[ mode \] $me sets umode $line" {mode default}
Send "MODE $me"
foreach mchar [split $line {}] {
if {$mchar == "+" || $mchar == "-"} {set dir $mchar; continue}
lappend mode $dir$mchar
}
Event umode "mode mode"
return
}
lappend header $line
set channel [string tolower [lindex $header 2]]
if {![winfo exists $info(window,$channel)]} {return}
set nick [lindex [split [lindex $header 0] !] 0]
set address [lindex [split [lindex $header 0] !] 1]
set mode [lindex $header 3]
set line [lrange $header 4 end]
Echo $info(window,$channel) "\[ mode \] $nick sets mode $mode [join $line]" {mode default}
if {![string match *.* $nick]} {ialadd $channel $nick $address}
set i 0
set do {}
foreach mchar [split $mode {}] {
if {$mchar == "+" || $mchar == "-"} {set dir $mchar; continue}
lappend newmode $dir$mchar
if {[string match {[ohvbekl]} $mchar]} {
if {$mchar == "l" && $dir == "-"} {continue}
lappend do $dir$mchar [lindex $line $i]
incr i
}
}
set key {}
set limit {}
foreach {mchar arg} $do {
switch -glob -- $mchar {
+o {
if {![isop $channel $arg]} {
set names($channel,[string tolower $arg],o) $arg
ListChange $info(window,$channel) $arg $arg
Event op "nick nick address address channel channel arg onick" $channel $nick!$address $arg
}
}
-o {
if {[isop $channel $arg]} {
unset names($channel,[string tolower $arg],o)
ListChange $info(window,$channel) $arg $arg
Event deop "nick nick address address channel channel arg onick" $channel $nick!$address $arg
}
}
+v {
if {![isvoice $channel $arg]} {
set names($channel,[string tolower $arg],v) $arg
ListChange $info(window,$channel) $arg $arg
Event voice "nick nick address address channel channel arg vnick" $channel $nick!$address $arg
}
}
-v {
if {[isvoice $channel $arg]} {
unset names($channel,[string tolower $arg],v)
ListChange $info(window,$channel) $arg $arg
Event devoice "nick nick address address channel channel arg vnick" $channel $nick!$address $arg
}
}
?b {Event [string map {+ {} - un} $mchar]an "nick nick address address channel channel arg ban" $channel $nick!$address}
?e {Event [string map {+ {} - un} $mchar]xception "nick nick address address channel channel arg exception" $channel $nick!$address}
?k {set key $arg}
?l {set limit $arg}
}
}
if {![regexp {^[ohvbe+-]+$} $mode]} {
after cancel [list Send "MODE $channel"]
after 350 [list Send "MODE $channel"]
Event mode "nick nick address address channel channel newmode mode key key limit limit" $channel $nick!$address
}
if {[string match -nocase *$me* [join $line]]} {UpdateTitle $info(window,$channel)}
}
proc raw_NICK {header line} {
global me info names
set nick [lindex [split [lindex $header 0] !] 0]
set address [lindex [split [lindex $header 0] !] 1]
Event nick "nick nick address address line newnick" $nick!$address $line
set nick2 [string tolower $nick]
foreach x [common $nick] {
if {[isop $x $nick]} {
unset names($x,$nick2,o)
set names($x,[string tolower $line],o) $line
}
if {[isvoice $x $nick]} {
unset names($x,$nick2,v)
set names($x,[string tolower $line],v) $line
}
unset names($x,$nick2,a)
set names($x,[string tolower $line],a) $line
Echo $info(window,$x) "\[ nick \] $nick is now known as $line" {nick default}
ListChange $info(window,$x) $nick $line
ialdel $x $nick
ialadd $x $line $address
}
if {[string equal -nocase $nick $me]} {
set me $line
UpdateAllTitles
Echo .0 "\[ nick \] Your nick is now $line" {nick default}
}
if {[info exists info(query,$nick2)]} {
set win $info(query,$nick2)
unset info(query,$nick2)
set info(query,[string tolower $line]) $win
set info(nick,$win) [string tolower $line]
wm title $win "RoxIRC Query $line"
wm iconname $win "Query $line \[RoxIRC\]"
}
}
proc raw_KICK {header line} {
global me info away
set channel [string tolower [lindex $header 2]]
if {![winfo exists $info(window,$channel)]} {return}
set knick [lindex $header end]
set nick [lindex [split [lindex $header 0] !] 0]
set address [lindex [split [lindex $header 0] !] 1]
Event kick "nick nick address address channel channel knick knick" $channel $nick!$address $knick
if {[string equal -nocase $knick $me]} {
set win $info(window,$channel)
Echo $win "\[ kick \] You were kicked from $channel by $nick!$address ($line)" {kick default}
DeleteChannel $channel $win
if {!$away} {
dialog ${win}kick "RoxIRC Rejoin?" "You were kicked from $channel\nDo you want to rejoin?" kickrejoin 1 "Yes [list 1 $channel]" "No 0"
}
} else {
DeleteUser $channel $knick
Echo $info(window,$channel) "\[ kick \] $nick kicked $knick ($line)" {kick default}
}
}
proc kickrejoin {args} {
if {[lindex $args 0] == 1} {
Send "JOIN [lindex $args 1]"
}
}
proc raw_TOPIC {header line} {
global info on
set channel [string tolower [lindex $header end]]
set nick [lindex [split [lindex $header 0] !] 0]
set address [lindex [split [lindex $header 0] !] 1]
if {$line == ""} {
Echo $info(window,$channel) "\[ topic \] $nick has removed the topic" {topic default}
} else {
Echo $info(window,$channel) "\[ topic \] $nick has changed the topic to \"$line\"" {topic default}
}
catch {InsertDisabled $info(window,$channel).middle.left.topic $line}
Event topic "nick nick address address channel channel line line" $channel $nick!$address
}
# drop this with 8.3 support
proc InsertDisabled {win line} {
global tcl_version
$win configure -state normal
$win delete 0 end
$win insert end $line
$win configure -state disabled
if {$tcl_version >= 8.4} {$win configure -state readonly}
}
proc raw_INVITE {header line} {
set nick [lindex [split [lindex $header 0] !] 0]
set address [lindex [split [lindex $header 0] !] 1]
Ignore INVITES $nick!$address
Echo .0 "\[ invite \] $nick!$address invites you to $line" {invite default}
Event invite "nick nick address address line channel" $nick!$address $line
}
proc raw_WALLOPS {header line} {
set nick [lindex [split [lindex $header 0] !] 0]
set address [lindex [split [lindex $header 0] !] 1]
Echo .0 "\[ wallops \] : $line" {wallops default}
Event wallops "nick nick address address line line" $nick!$address $line
}
proc raw_AUTH {header line} {
if {[string range $line 0 3] == "*** "} {
set line [string range $line 4 end]
}
Echo .0 "\[ server \] $line" {server default}
}
proc raw_KILL {header line} {
foreach x [textwindows] {Echo $x "\[ kill \] You were killed by [lindex $header 0] $line" {kill default}}
}
proc raw_PONG {header line} {
if {![catch {set pong [format %0.2fs [expr {([clock clicks -milliseconds] - $line) / 1000.000}]]}]} {
Echo .0 "\[ server \] Ping reply from [lindex $header 0]: $pong" {server default}
}
}
proc raw_* {header line} {
Parse "[lindex [split $header] 0] $::me :$line"
}
proc SaveListbox {path} {
global env
set file [tk_getSaveFile -title "RoxIRC Save Listbox" -initialdir $env(HOME) -filetypes {{All *} {Text *.txt}}]
if {$file == ""} {return}
if {[catch {open $file w} fn]} {
Echo .0 "\[ error \] Cannot open $file for writing: [geterror $fn]" {error default}
return
}
puts $fn [join [$path get 0 end] "\n"]
close $fn
Echo .0 "\[ info \] [lrange [split [wm title [winfo toplevel $path]]] 1 end] saved to $file" {info default}
}
proc DoBinding {window command} {
global away server me info prefs dcc
set window [winfo toplevel $window]
switch -exact [string index $window 1] {
0 {}
q {
if {![info exists info(nick,$window)]} {return}
set nick $info(nick,$window)
}
c {set nick $dcc([string trimleft $window .],nick)}
default {
set channel ""
if {[info exists info(channel,$window)]} {set channel $info(channel,$window)}
set nicks [selected $window]
set nick [lindex $nicks 0]
}
}
if {[catch {eval $command} err]} {
Echo $window "\[ error \] Error in binding: [geterror $err] while executing $command" {error default}
}
}
proc DoTimer {num delay left times command} {
global me server away info prefs
if {[catch {eval $command} error]} {
Echo .0 "\[ error \] Error in timer $num: $error" {error default}
return
}
if {$times == 0} {
incr left
} elseif {$left > 1} {
incr left -1
} else {
return
}
after $delay [list DoTimer $num $delay $left $times $command]
}
proc Event {name upvars args} {
global on me away server info prefs
if {![info exists on($name)]} {return}
if {$upvars != ""} {eval upvar $upvars}
set a {}
set v {}
foreach {x y} $upvars {
lappend a $y
lappend v [set $y]
}
foreach x $on($name) {
set match 1
set matched [lrange $x 0 end-1]
foreach first $matched second $args {
if {[set error [catch {string match -nocase [subst -nobackslashes $first] [unescape $second]} match]]} {
Echo .0 "\[ error \] Error processing $name event: $match" {error default}
}
if {$error || !$match} {break}
}
if {!$match} {continue}
set proc on[clock clicks]
eval proc $proc \{$a\} \{global server me away prefs info\; [lindex $x end]\; rename $proc \{\}\}
after 1 [list DoEvent $name $matched $proc $v]
}
}
proc DoEvent {name matched proc values} {
if {[catch {eval $proc $values} err]} {
Echo .0 "\[ error \] Error executing $name event: $err" {error default}
}
}
proc BanWindow {chan} {
global banlist info prefs tcl_platform
if {![info exists banlist]} {
if {[info exists info(window,$chan)]} {
Echo $info(window,$chan) {[ channel ] Banlist is empty} {channel default}
} else {
Echo .0 "\[ channel \] $chan banlist is empty" {channel default}
}
return
}
if {[winfo exists .bans]} {
if {$chan == [lindex [split [wm title .bans]] 2]} {
set geom [winfo geometry .bans]
}
destroy .bans
}
toplevel .bans
wm title .bans "RoxIRC Banlist $chan"
wm iconname .bans "Banlist $chan \[RoxIRC\]"
bind .bans <Return> ".bans.buttons.ok invoke"
bind .bans <Escape> ".bans.buttons.cancel invoke"
frame .bans.top
frame .bans.buttons -bd [.bans cget -bd] -relief raised
frame .bans.mid
pack .bans.buttons -side bottom -fill x -ipady 3
pack .bans.mid -side bottom -fill x -ipady 3
pack .bans.top -ipadx 1 -ipady 1 -side top -fill both -expand 1
scrollbar .bans.top.scrolly -orient v -command ".bans.top.list yview"
scrollbar .bans.top.scrollx -orient h -command ".bans.top.list xview"
listbox .bans.top.list -bd 1 -relief sunken -font fixed -yscrollcommand ".bans.top.scrolly set" -xscrollcommand ".bans.top.scrollx set" -selectmode extended
listbox .bans.top.old
label .bans.mid.num -bd 1 -relief sunken -text " [llength $banlist] bans " -font $prefs(font,menu)
button .bans.mid.del -text "Remove" -command "DoBanWindow 0" -font $prefs(font,menu)
button .bans.mid.all -text "Remove All" -command "DoBanWindow 1" -font $prefs(font,menu)
pack .bans.top.scrolly -side right -fill y
pack .bans.top.scrollx -side bottom -fill x
pack .bans.top.list -fill both -expand 1
pack .bans.mid.num -side left -padx 5
pack .bans.mid.del -side left -padx 10
pack .bans.mid.all -side left -padx 5
button .bans.buttons.ok -default active -text "Ok" -width 5 -command "DoBanWindow $chan" -font $prefs(font,menu)
button .bans.buttons.cancel -text "Cancel" -command "destroy .bans" -font $prefs(font,menu)
pack .bans.buttons.ok -side left -padx 5
pack .bans.buttons.cancel -side right -padx 5
set l1 0
set l2 0
foreach x $banlist {
if {[string length [lindex $x 0]] > $l1} {set l1 [string length [lindex $x 0]]}
if {[string length [lindex $x 1]] > $l2} {set l2 [string length [lindex $x 1]]}
.bans.top.old insert end [lindex $x 0]
}
foreach x $banlist {
.bans.top.list insert end [format " %s %-${l1}s %-${l2}s %s" [lindex $x 3] [lindex $x 0] [lindex $x 1] [clock format [lindex $x 2] -format "%D %T" -gmt $prefs(gmt)]]
}
unset banlist
wm withdraw .bans
update idletasks
if {[info exists geom]} {
wm geometry .bans $geom
} elseif {[info exists info(window,$chan)]} {
set win $info(window,$chan)
set cw [winfo width $win]
set ch [winfo height $win]
set bw [expr {round($cw * .666)}]
set bh [expr {round($ch * .666)}]
set x [expr {(($cw / 2) + [winfo rootx $win]) - ($bw / 2)}]
set y [expr {(($ch / 2) + [winfo rooty $win]) - ($bh / 2)}]
wm geometry .bans ${bw}x$bh+$x+$y
} else {
wm geometry .bans [expr {round([winfo width .0] * .666)}]x[expr {round([winfo height .0] * .666)}]
}
wm deiconify .bans
}
proc DoBanWindow {type} {
switch -exact -- $type {
0 {
foreach x [lsort -integer -decreasing [.bans.top.list curselection]] {.bans.top.list delete $x}
}
1 {.bans.top.list delete 0 end}
default {
set bans ""
set new ""
set old [.bans.top.old get 0 end]
foreach x [.bans.top.list get 0 end] {
lappend new [lindex [split $x] 3]
}
foreach x $old {
if {[lsearch -exact $new $x] == -1} {lappend bans $x}
if {[llength $bans] == 4} {
Send "MODE $type -bbbb [join $bans]"
set bans ""
}
}
if {[llength $bans] > 0} {Send "MODE $type -[string repeat b [llength $bans]] [join $bans]"}
destroy .bans
}
}
}
proc KickWindow {win address} {
global prefs info userhost
set nick [lindex [split $address !] 0]
if {$nick == $address} {set address [address $nick]}
if {$address == ""} {
Echo $win {[ info ] Getting users address...} {info default}
getaddress $nick [list KickWindow $win %address]
return
}
if {[winfo exists .kb]} {destroy .kb}
toplevel .kb
wm title .kb "RoxIRC Kick/Ban $nick from $info(channel,$win)"
wm iconname .kb "Kick/Ban \[RoxIRC\]"
bind .kb <Escape> ".kb.buttons.cancel invoke"
bind .kb <Return> ".kb.buttons.bk invoke"
frame .kb.buttons -relief raised -bd [.kb cget -bd]
frame .kb.left
frame .kb.right
frame .kb.left.top
frame .kb.right.top
frame .kb.left.bottom
frame .kb.right.bottom
pack .kb.buttons -side bottom -fill x -ipady 3
pack .kb.left -side left -fill both -expand 1
pack .kb.right -side right -fill both -expand 1
pack .kb.left.bottom -fill x -side bottom
pack .kb.right.bottom -fill x -side bottom
pack .kb.left.top -fill both -expand 1 -side top
pack .kb.right.top -fill both -expand 1 -side top
listbox .kb.left.top.list -exportselection 0 -font $prefs(font,menu)
listbox .kb.right.top.list -exportselection 0 -font $prefs(font,menu)
foreach x "1 2 3 4 5 6" {
.kb.left.top.list insert end " [addressmask $address $x]"
}
foreach x $prefs(kick) {
.kb.right.top.list insert end " $x "
}
label .kb.left.bottom.label -text "Ban: "
label .kb.right.bottom.label -text "Kick: "
entry .kb.left.bottom.entry
entry .kb.right.bottom.entry
button .kb.buttons.ban -text "Ban" -command [list DoKickWindow $info(channel,$win) $nick 0] -font $prefs(font,menu)
button .kb.buttons.bk -default active -text "Ban/Kick" -command [list DoKickWindow $info(channel,$win) $nick 1] -font $prefs(font,menu)
button .kb.buttons.kick -text "Kick" -command [list DoKickWindow $info(channel,$win) $nick 2] -font $prefs(font,menu)
#checkbutton .kb.buttons.ignore -text "Ignore"
button .kb.buttons.cancel -text "Cancel" -command "destroy .kb" -font $prefs(font,menu)
pack .kb.buttons.ban -side left -padx 5
pack .kb.buttons.bk -side left
pack .kb.buttons.kick -side left -padx 5
#pack .kb.buttons.ignore -side left
pack .kb.buttons.cancel -side right -padx 5
pack .kb.left.top.list -fill both -expand 1
pack .kb.right.top.list -fill both -expand 1
pack .kb.left.bottom.label -side left
pack .kb.left.bottom.entry -side left -expand 1 -fill x
pack .kb.right.bottom.label -side left
pack .kb.right.bottom.entry -side left -expand 1 -fill x
bind .kb.left.top.list <ButtonRelease> {.kb.left.bottom.entry delete 0 end ; .kb.left.bottom.entry insert end [string trim [.kb.left.top.list get [.kb.left.top.list curselection]]]}
bind .kb.right.top.list <ButtonRelease> {.kb.right.bottom.entry delete 0 end ; .kb.right.bottom.entry insert end [string trim [.kb.right.top.list get [.kb.right.top.list curselection]]]}
.kb.right.top.list selection set 0
.kb.left.top.list selection set 2
.kb.left.bottom.entry insert end [string trim [.kb.left.top.list get 2]]
.kb.right.bottom.entry insert end [string trim [.kb.right.top.list get 0]]
wm withdraw .kb
update idletasks
set cw [winfo width $win]
set ch [winfo height $win]
set bw [expr {round($cw * .6)}]
set bh [expr {round($ch * .6)}]
set x [expr {(($cw / 2) + [winfo rootx $win]) - ($bw / 2)}]
set y [expr {(($ch / 2) + [winfo rooty $win]) - ($bh / 2)}]
wm geometry .kb ${bw}x$bh+$x+$y
wm deiconify .kb
}
proc DoKickWindow {chan nick type} {
global info
set ban [.kb.left.bottom.entry get]
set kick [.kb.right.bottom.entry get]
destroy .kb
if {($type == "0" || $type == "1") && $ban != ""} {Send "MODE $chan -o+b $nick $ban"}
if {$type == "1" || $type == "2"} {Send "KICK $chan $nick :$kick"}
#if {$ignore && $ban != ""} {command_ignore .0 $ban}
}
proc ModeWindow {win} {
global info prefs mmode
if {![info exists info(channel,$win)]} {return}
set chan $info(channel,$win)
set blah [lindex [split [$win.menubar.modes cget -text]] 0]
if {[winfo exists .mode]} {destroy .mode}
toplevel .mode
wm title .mode "RoxIRC Modes $chan"
wm iconname .mode "Modes $chan \[RoxIRC\]"
wm transient .mode $win
frame .mode.buttons -bd [.mode cget -bd] -relief raised
frame .mode.kl -bd 1 -relief sunken
frame .mode.left -bd 1 -relief sunken
frame .mode.right -bd 1 -relief sunken
pack .mode.buttons -side bottom -fill x
pack .mode.kl -side bottom -fill x -padx 3 -pady 3
pack .mode.left -side left -fill both -padx 3 -pady 3 -expand 1
pack .mode.right -side right -fill both -padx 3 -pady 3 -expand 1
foreach x "n t s i m p" side "left left left right right right" {
checkbutton .mode.$side.$x -font fixed -highlightthickness 0 -text $x -variable mmode($x) -relief raised -bd 1 -anchor w -padx 10
if {[string first $x $blah] != -1} {.mode.$side.$x select}
pack .mode.$side.$x -side top -padx 3 -pady 3 -fill x -ipady 3
}
label .mode.kl.k -text "k" -font $prefs(font,menu)
label .mode.kl.l -text "l" -font $prefs(font,menu)
entry .mode.kl.le -width 10 -font $prefs(font,menu) -highlightthickness 0
entry .mode.kl.ke -width 10 -font $prefs(font,menu) -highlightthickness 0
set mmode(k) ""
set mmode(l) ""
foreach x [chanmodes $info(channel,$win)] {
if {[lindex $x 0] == "k" || [lindex $x 0] == "l"} {
.mode.kl.[lindex $x 0]e insert end [lindex $x 1]
set mmode([lindex $x 0]) [lindex $x 1]
}
}
pack .mode.kl.k -side left -pady 3 -padx 2
pack .mode.kl.ke -side left -pady 3 -padx 4 -expand 1 -fill x
pack .mode.kl.le -side right -pady 3 -padx 4 -expand 1 -fill x
pack .mode.kl.l -side right -pady 3 -padx 2
button .mode.buttons.ok -default active -text "Ok" -width 5 -command [list DoModeWindow $chan] -font $prefs(font,menu)
button .mode.buttons.cancel -text "Cancel" -command "DoModeWindow 0" -font $prefs(font,menu)
pack .mode.buttons.ok -side left -padx 5 -pady 2
pack .mode.buttons.cancel -side right -padx 5 -pady 2
bind .mode <Return> ".mode.buttons.ok invoke"
bind .mode <Escape> ".mode.buttons.cancel invoke"
wm withdraw .mode
update idletasks
set x [expr {(([winfo width $win] / 2) + [winfo rootx $win]) - ([winfo reqwidth .mode] / 2)}]
set y [expr {(([winfo height $win] / 2) + [winfo rooty $win]) - ([winfo reqheight .mode] / 2)}]
wm geometry .mode +$x+$y
wm deiconify .mode
}
proc DoModeWindow {chan} {
global mmode
if {$chan == "0"} {
destroy .mode
unset mmode
return
}
set l [.mode.kl.le get]
set k [.mode.kl.ke get]
destroy .mode
set tmp(0) ""
set tmp(1) ""
foreach x "n t m i s p" {append tmp($mmode($x)) $x}
if {$l != "" && $mmode(l) != $l} {
Send "MODE $chan +l $l"
} elseif {$l == ""} {
append tmp(0) l
}
if {$mmode(k) != "" && $mmode(k) != $k} {
Send "MODE $chan -k $mmode(k)"
}
if {$k != "" && $mmode(k) != $k} {
Send "MODE $chan +k $k"
}
Send "MODE $chan -$tmp(0)"
Send "MODE $chan +$tmp(1)"
unset mmode
}
proc NotifyWindow {} {
if {[winfo exists .notify]} {
wm deiconify .notify
raise .notify
return
}
global notify prefs
toplevel .notify
wm title .notify "RoxIRC Notify List"
wm iconname .notify "Notify List \[RoxIRC\]"
frame .notify.bottom -bd [.notify cget -bd] -relief raised
button .notify.bottom.delete -text Remove -command "DoNotifyWindow remove" -font $prefs(font,menu)
entry .notify.bottom.entry -width 10 -highlightthickness 0 -font $prefs(font,menu)
bind .notify.bottom.entry <Return> "DoNotifyWindow add"
label .notify.bottom.label -text "Add:" -font $prefs(font,menu)
pack .notify.bottom -side bottom -fill x -ipadx 4 -ipady 3
pack .notify.bottom.label -side left -padx 5
pack .notify.bottom.entry -side left
pack .notify.bottom.delete -side right -padx 4
frame .notify.top
scrollbar .notify.top.scrollx -orient h -command ".notify.top.list xview"
scrollbar .notify.top.scrolly -orient v -command ".notify.top.list yview"
listbox .notify.top.list -bd 1 -yscrollcommand ".notify.top.scrolly set" -xscrollcommand ".notify.top.scrollx set" -font fixed
bind .notify.top.list <Double-Button-1> "DoNotifyWindow double"
bind .notify <Escape> "destroy .notify"
pack .notify.top -side top -fill both -expand 1
pack .notify.top.scrolly -side right -fill y
pack .notify.top.scrollx -side bottom -fill x
pack .notify.top.list -expand 1 -fill both
DoNotifyWindow refresh
wm withdraw .notify
update idletasks
wm geometry .notify [expr {round([winfo width .0] * .700)}]x[expr {round([winfo height .0] * .700)}]
wm deiconify .notify
}
proc DoNotifyWindow {cmd} {
if {![winfo exists .notify]} {return}
switch -exact -- $cmd {
refresh {
global notify prefs
.notify.top.list delete 0 end
set l1 0
foreach x $notify(+online) {
if {[string length $x] > $l1} {set l1 [string length $x]}
}
.notify.top.list insert end " Online:"
foreach x [lsort -dictionary $notify(+online)] {
.notify.top.list insert end [format " %s %-${l1}s %s" \[[clock format [lindex $notify([string tolower $x]) 1] -format "%R" -gmt $prefs(gmt)]\] $x [lindex $notify([string tolower $x]) 0]]
}
.notify.top.list insert end "" " Offline:"
foreach x [lsort -dictionary $prefs(notify)] {
if {[lsearch -exact [string tolower $notify(+online)] [string tolower $x]] == "-1"} {
.notify.top.list insert end " \[--:--\] [unescape $x]"
}
}
}
add {
if {[set nick [.notify.bottom.entry get]] == ""} {return}
.notify.bottom.entry delete 0 end
command_notify .0 $nick
}
remove {
if {[set tmp [.notify.top.list curselection]] == ""} {return}
set line [.notify.top.list get $tmp]
if {![string match " *line:" $line]} {
command_notify .0 -[lindex [split $line] 4]
}
}
double {
if {[set tmp [.notify.top.list curselection]] == ""} {return}
set nick [.notify.top.list get $tmp]
if {![string match " *line:" $nick]} {
command_query .0 [lindex [split $nick] 4]
}
}
}
}
proc UrlWindow {} {
if {[winfo exists .urls]} {
wm deiconify .notify
raise .urls
return
}
global urls prefs
toplevel .urls
wm title .urls "RoxIRC URL List"
wm iconname .urls "URLs \[RoxIRC\]"
frame .urls.bottom -bd [.urls cget -bd] -relief raised
button .urls.bottom.save -text Save -command "SaveListbox .urls.top.list" -font $prefs(font,menu)
button .urls.bottom.last -text Last -command "DoUrlWindow last" -font $prefs(font,menu)
button .urls.bottom.delete -text Delete -command "DoUrlWindow delete" -font $prefs(font,menu)
button .urls.bottom.clear -text Clear -command "DoUrlWindow clear" -font $prefs(font,menu)
pack .urls.bottom.save -side left -padx 4
pack .urls.bottom.last -side left -padx 4
pack .urls.bottom -side bottom -fill x -ipadx 4 -ipady 3
pack .urls.bottom.delete -side right -padx 4
pack .urls.bottom.clear -side right -padx 4
frame .urls.top
scrollbar .urls.top.scrollx -orient h -command ".urls.top.list xview"
scrollbar .urls.top.scrolly -orient v -command ".urls.top.list yview"
listbox .urls.top.list -bd 1 -yscrollcommand ".urls.top.scrolly set" -xscrollcommand ".urls.top.scrollx set" -selectmode extended -font fixed -listvar urls
bind .urls.top.list <Double-Button-1> "DoUrlWindow double"
bind .urls <Escape> "destroy .urls"
pack .urls.top -side top -fill both -expand 1
pack .urls.top.scrolly -side right -fill y
pack .urls.top.scrollx -side bottom -fill x
pack .urls.top.list -expand 1 -fill both
wm withdraw .urls
update idletasks
.urls.top.list see end
wm geometry .urls [expr {round([winfo width .0] * .900)}]x[expr {round([winfo height .0] * .700)}]
wm deiconify .urls
}
proc DoUrlWindow {cmd args} {
global prefs urls
switch -exact -- $cmd {
double {
set tmp [.urls.top.list curselection]
if {$tmp == ""} {return}
set url [lindex [rele [split [.urls.top.list get [lindex $tmp 0]]]] 3]
eval exec [string map {"\$url" $url} $prefs(urlcommand)] &
}
last {
.urls.top.list selection clear 0 end
.urls.top.list selection set end
.urls.top.list see end
DoUrlWindow double
}
clear {set urls ""}
delete {
foreach x [lsort -integer -decreasing [.urls.top.list curselection]] {
.urls.top.list delete $x
}
.urls.top.list selection set $x
}
}
}
proc ListWindow {} {
global prefs
if {[winfo exists .list]} {destroy .list}
toplevel .list
wm title .list "RoxIRC Channel listing"
wm iconname .list "Channel list \[RoxIRC\]"
wm protocol .list WM_DELETE_WINDOW "DoListWindow destroy"
frame .list.top -relief raised -borderwidth 1
frame .list.middle
frame .list.bottom
pack .list.top -fill x -side top
pack .list.bottom -fill x -side bottom
pack .list.middle -fill both -expand 1
scrollbar .list.middle.scroll -orient v -command ".list.middle.list yview"
listbox .list.middle.list -width 65 -bd 1 -font fixed -yscrollcommand ".list.middle.scroll set"
pack .list.middle.scroll -side right -fill y
pack .list.middle.list -side left -fill both -expand 1
label .list.top.label1 -text "Channel" -anchor center -font fixed -width 20 -borderwidth 1 -relief raised
label .list.top.label2 -text "Users" -anchor center -font fixed -width 5 -borderwidth 1 -relief raised
label .list.top.label3 -text "Topic" -anchor center -font fixed -borderwidth 1 -relief raised
pack .list.top.label1 -side left
pack .list.top.label2 -side left
pack .list.top.label3 -side left -fill x -expand 1
button .list.bottom.done -text "Done" -command "DoListWindow destroy" -font $prefs(font,menu)
label .list.bottom.status -relief sunken -borderwidth 1 -font $prefs(font,menu)
button .list.bottom.filter -text "Filter" -command "DoListWindow filter" -font $prefs(font,menu)
entry .list.bottom.re -width 15 -highlightthickness 0
frame .list.bottom.pad -width 10
pack .list.bottom.status -side left -padx 2 -ipadx 3 -ipady 2 -pady 2
pack .list.bottom.pad -side left
pack .list.bottom.re -side left -padx 2
pack .list.bottom.filter -side left -padx 2
pack .list.bottom.done -side right -padx 15 -pady 2
bind .list.top.label1 <Button-1> "DoListWindow sortchan"
bind .list.top.label2 <Button-1> "DoListWindow sortusers"
bind .list.middle.list <Double-Button-1> "DoListWindow double"
bind .list <Escape> "DoListWindow destroy"
foreach letter {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
bind .list <KeyPress-$letter> "set a \[lsearch -glob \[.list.middle.list get 0 end\] #$letter*] \; .list.middle.list selection clear 0 end \; .list.middle.list selection set \$a \; .list.middle.list see \$a"
}
bind .list.bottom.re <Return> "DoListWindow filter"
update idletasks
}
proc DoListWindow {action args} {
global chanlist
switch -exact -- $action {
destroy {
catch {unset chanlist}
destroy .list
}
sortchan {
.list.middle.list delete 0 end
foreach x [lsort -dictionary -index 0 $chanlist] {
set chan [lindex $x 0]
if {[string length $chan] > 20} {set chan [string range $chan 0 16]...}
.list.middle.list insert end [format "%-20s %5s %s" $chan [lindex $x 1] [lindex $x 2]]
}
}
sortusers {
.list.middle.list delete 0 end
foreach x [lsort -integer -decreasing -index 1 $chanlist] {
set chan [lindex $x 0]
if {[string length $chan] > 20} {set chan [string range $chan 0 16]...}
.list.middle.list insert end [format "%-20s %5s %s" $chan [lindex $x 1] [lindex $x 2]]
}
}
double {
set line [rele [split [.list.middle.list get [.list.middle.list curselection]]]]
set chan [lsearch -glob $chanlist "[string range [lindex $line 0] 0 16]* [lindex $line 1] *"]
Send "JOIN [lindex $chanlist $chan]"
}
filter {
if {[set re [.list.bottom.re get]] == ""} {DoListWindow sortchan; return}
if {[catch {regexp $re teststring}]} {return}
.list.middle.list delete 0 end
foreach x [lsort -dictionary -index 0 $chanlist] {
set chan [lindex $x 0]
if {[regexp $re $chan]} {
if {[string length $chan] > 20} {set chan [string range $chan 0 16]...}
.list.middle.list insert end [format "%-20s %5s %s" $chan [lindex $x 1] [lindex $x 2]]
}
}
}
}
}
proc notifyon {nick address time} {
global notify info prefs
Echo .0 "\[ notify \] Signon by $nick ($address) at [clock format $time -format "%R" -gmt $prefs(gmt)]" {notify default}
if {[info exists info(query,[string tolower $nick])]} {
Echo $info(query,[string tolower $nick]) "\[ notify \] Signon by $nick ($address) at [clock format $time -format "%R" -gmt $prefs(gmt)]" {notify default}
}
set notify([string tolower $nick]) [list $address $time]
DoNotifyWindow refresh
Event notify "nick nick address address" $nick!$address
}
proc raw_ {header line} {
switch -- $header {
ERROR {Echo .0 "\[ server \] $line" {server default}}
}
}
proc auth {fh pass} {
global prefs me prefs
if {[catch {fileevent $fh writable}]} {return}
if {[fileevent $fh writable] != ""} {
after $prefs(authdelay) [list auth $fh $pass]
fileevent $fh writable {}
return
}
if {$pass != ""} {
catch {puts $fh "PASS $pass"}
}
if {$me != "-"} {
set nick "NICK $me"
} else {
set nick "NICK [unescape [lindex $prefs(nick) 0]]"
}
catch {
puts $fh "USER $prefs(ident) host domain :$prefs(name)"
puts $fh $nick
}
}
proc reply_PING {header line} {
upvar nick nick address address
if {[catch {expr {([clock clicks -milliseconds] - $line) / 1000.000}} time]} {
Echo .0 "\[ ctcp \] Invalid PING reply from $nick!$address: $line" {ctcp default}
} else {
Echo .0 "\[ ctcp \] PING reply from $nick: [format %0.2f $time]s" {ctcp default}
}
}
proc ctcp_PING {header line} {
global me info
set who [lindex $header 0]
set nick [lindex [split $who !] 0]
if {[string length $line] > 25} {return}
if {[string equal -nocase [lindex $header 2] $me]} {
Echo .0 "\[ ctcp \] PING from $who" {ctcp default}
} else {
Echo $info(window,[string tolower [lindex $header 2]]) "\[ ctcp \] PING by $nick" {ctcp default}
}
Send "NOTICE $nick :\001PING $line\001"
}
proc ctcp_VERSION {header line} {
global me info tcl_platform
set nick [lindex [split [lindex $header 0] !] 0]
set to [string tolower [lindex $header 2]]
if {[string equal -nocase $to $me]} {
Echo .0 "\[ ctcp \] VERSION from [lindex $header 0]" {ctcp default}
} elseif {[info exists info(window,$to)]} {
Echo $info(window,$to) "\[ ctcp \] VERSION by $nick" {ctcp default}
return
} else {
Echo .0 "\[ ctcp \] VERSION by $nick to $to" {ctcp default}
return
}
#Send "NOTICE $nick :\001VERSION RoxIRC 2.0b $tcl_platform(os) $tcl_platform(osVersion)\001"
Send "NOTICE $nick :\001VERSION RoxIRC 2.0b\001"
}
proc ctcp_CLIENTINFO {header line} {
global me info
set to [lindex $header 2]
set nick [lindex [split [lindex $header 0] !] 0]
set ci CLIENTINFO
set tmp [rele [split $line]]
if {[lindex $tmp 0] != ""} {
append ci " ([lindex $tmp 0])"
}
if {[string equal -nocase $to $me]} {
Echo .0 "\[ ctcp \] $ci from [lindex $header 0]" {ctcp default}
} else {
Echo $info(window,[string tolower $to]) "\[ ctcp \] $ci by $nick" {ctcp default}
return
}
switch -- [string toupper [lindex $tmp 0]] {
ACTION {Send "NOTICE $nick :\001CLIENTINFO ACTION contains action descriptions for atmosphere\001"}
CLIENTINFO {Send "NOTICE $nick :\001CLIENTINFO CLIENTINFO gives information about available CTCP commands\001"}
PING {Send "NOTICE $nick :\001CLIENTINFO PING returns the arguments it receives\001"}
VERSION {Send "NOTICE $nick :\001CLIENTINFO VERSION shows client type and version\001"}
DCC {Send "NOTICE $nick :\001CLIENTINFO DCC requests a direct_client_connection\001"}
"" {Send "NOTICE $nick :\001CLIENTINFO [string toupper [string map {ctcp_ ""} [info commands ctcp_*]]]\001"}
}
}
proc ctcp_DCC {header line} {
global away dcc info
set tmp [rele [split $line]]
switch -- [string tolower [lindex $tmp 0]] {
send {IncomingDccFile $header $line}
chat {IncomingDccChat $header $line}
resume {ResumeDccSend $header $line}
accept {AcceptDccResume $header $line}
default {Echo .0 "\[ dcc \] Unknown DCC command [lindex $tmp 0] from [lindex $header 0]" {dcc default}}
}
}
proc ctcp_ACTION {header line} {
global info me away on ial
set nick [lindex [split [lindex $header 0] !] 0]
set address [lindex [split [lindex $header 0] !] 1]
set channel [string tolower [lindex $header 2]]
if {[string equal -nocase $channel $me]} {
if {$away && ![info exists info(query,[string tolower $nick])]} {
Echo .0 "** $nick $line" privmsg
} else {
Echo [UpdateChat $nick!$address] "* $nick $line" action
}
} else {
#Echo $info(window,$channel) "* $nick $line" action
Echo $info(window,$channel) {* } action $nick "action nicks" " $line" "action margin"
ialadd $channel $nick $address
}
Event action "nick nick address address channel target line line" $channel $nick!$address $line
}
proc ialadd {chan nick address} {
global ial prefs
if {$prefs(ial)} {
set ial($chan,[string tolower $nick]) $nick!$address
}
}
proc ialdel {chan nick} {
global ial prefs
if {$prefs(ial)} {
catch {unset ial($chan,[string tolower $nick])}
}
}
proc periodic {} {
after 60000 periodic
event generate .0 <<periodic>>
}
proc checkison {} {
global prefs irc connecting
if {$prefs(notify) != "" && [info exists irc] && ![info exists connecting]} {
Send "ISON [join $prefs(notify)]"
}
}
proc getdccid {{one {type *}} args} {
global dcc
set list {}
if {[lindex $one 1] != "*"} {set one [list [lindex $one 0] [globescape [lindex $one 1]]]}
foreach x [array names dcc *,[lindex $one 0]] {
if {![string match [lindex $one 1] $dcc($x)]} {continue}
set id [lindex [split $x ,] 0]
set num 0
foreach a $args {
set name [lindex $a 0]
if {![info exists dcc($id,$name)] || ![string equal -nocase $dcc($id,$name) [lindex $a 1]]} {break}
incr num
}
if {$num == [llength $args]} {lappend list $id}
}
return $list
}
proc isop {channel nick} {
global names info
return [expr {[info exists info(window,$channel)] && [info exists names($channel,[string tolower $nick],o)]}]
}
proc isvoice {channel nick} {
global names info
return [expr {[info exists info(window,$channel)] && [info exists names($channel,[string tolower $nick],v)]}]
}
proc ison {channel nick} {
global names info ial
return [expr {[info exists info(window,$channel)] && [info exists names($channel,[string tolower $nick],a)]}]
}
proc channels {} {
global info
set blah {}
foreach x [activechannelwindows] {lappend blah $info(channel,$x)}
return $blah
}
proc queries {} {
set chans {}
foreach {x y} [array get ::info nick,*] {lappend chans $y}
return $chans
}
proc common {nick} {
global info
set chans {}
foreach x [activechannelwindows] {
if {[ison $info(channel,$x) $nick]} {lappend chans $info(channel,$x)}
}
return $chans
}
proc address {nick {mask 5}} {
global ial
if {[set tmp [lindex [array names ial *,[globescape [string tolower $nick]]] 0]] != ""} {
return [addressmask $ial($tmp) $mask]
}
return {}
}
proc nicks {channel} {
global info
if {[info exists info(window,$channel)] && [winfo exists $info(window,$channel)]} {
return [$info(window,$channel).middle.right.nicks get 0 end]
}
return ""
}
proc ops {channel} {
global info
set r {}
if {[info exists info(window,$channel)] && [winfo exists $info(window,$channel)]} {
foreach x [GetList $info(window,$channel) v] {lappend r [string trimleft $x @]}
}
return $r
}
proc voiced {channel} {
global info
set r {}
if {[info exists info(window,$channel)] && [winfo exists $info(window,$channel)]} {
foreach x [GetList $info(window,$channel) v] {lappend r [string trimleft $x +]}
}
return $r
}
proc regular {channel} {
global info
if {[info exists info(window,$channel)] && [winfo exists $info(window,$channel)]} {
return [GetList $info(window,$channel) n]
}
return {}
}
proc selected {win} {
global info
if {[info exists info(window,$win)]} {set win $info(window,$win)}
if {![winfo exists $win.middle.right.nicks]} {return ""}
set r {}
foreach x [$win.middle.right.nicks curselection] {lappend r [string trimleft [$win.middle.right.nicks get $x] @+]}
return $r
}
proc searchial {glob {channel *}} {
set match {}
if {$channel != "*"} {set channel [globescape $channel]}
foreach {x y} [array get ::ial $channel,*] {
if {[string match -nocase $glob $y]} {lappend match $y}
}
return $match
}
proc getaddress {nick command} {
global userhost
if {[set a [address $nick]] != ""} {
catch {eval [string map [list %address [escape $a]] $command]}
return
}
set userhost([string tolower $nick]) $command
Send "USERHOST $nick"
}
proc umode {} {
return [split [.0.menubar.modes cget -text] {}]
}
proc chanmodes {channel} {
global info
if {[info exists info(window,$channel)]} {
if {[set m [$info(window,$channel).menubar.modes cget -text]] == "-"} {return {}}
if {[llength [split $m]] == 1} {return [split $m {}]}
set m [split $m]
set r [split [string range [lindex $m 0] 0 end-[expr {[llength $m] - 1}]] {}]
for {set i 0} {$i < [expr {[llength $m] - 1}]} {incr i} {
lappend r [list [string index [lindex $m 0] end-$i] [lindex $m end-$i]]
}
return $r
}
return {}
}
proc curtimer {} {
if {[string match "DoTimer *" [info level 1]]} {return [lrange [info level 1] 1 end]}
return {}
}
proc curevent {} {
if {![string match "DoEvent *" [info level 1]]} {return {}}
eval return \{[join [lrange [info level 1] 1 2]]\}
}
proc timers {} {
set ret {}
foreach x [after info] {
if {[lindex [set tmp [lindex [after info $x] 0]] 0] == "DoTimer"} {lappend ret [lrange $tmp 1 end]}
}
return $ret
}
proc aliases {{name {}}} {
set a {}
if {$name == ""} {
foreach x [info procs command_*] {
if {[string range [string trimleft [info body $x]] 0 5] == "#alias"} {lappend a [string range $x 8 end]}
}
return $a
}
if {[info procs command_[globescape $name]] != "" && [string range [string trimleft [info body command_$name]] 0 5] == "#alias"} {
set body [info body command_$name]
set a [string range $body [expr {[string first "\n#\000\n" $body] + 4}] [expr {[string last "\n#\000\n" $body] - 1}]]
}
return $a
}
proc bindings {} {
set b {}
foreach x [bind cmdline] {
if {[string match "DoBinding *" [set do [bind cmdline $x]]]} {
lappend b [list $x [lindex $do 2]]
}
}
return $b
}
proc topic {channel} {
global info
if {![info exists info(window,$channel)]} {return {}}
return [$info(window,$channel).middle.left.topic get]
}
proc addressmask {address mask} {
switch -exact -- $mask {
1 {
set ident [string trimleft [lindex [split [lindex [split $address @] 0] !] 1] ~]
set ident [string range $ident [expr {[string length $ident] - 9}] end]
return *!*$ident@[lindex [split $address @] 1]
}
2 {return *!*@[lindex [split $address @] 1]}
3 {
set tmp [lindex [split $address @] 1]
set ident [string trimleft [lindex [split [lindex [split $address @] 0] !] 1] ~]
set ident [string range $ident [expr {[string length $ident] - 9}] end]
if {[regexp {^((([0-9]){1,3}\.){3})([0-9]){1,3}$} $tmp -> a]} {
set domain $a*
} elseif {[regexp {^((([0-9a-z]){1,4}:){6})([0-9a-z]){1,4}:([0-9a-z]){1,4}$} $tmp -> a]} {
set domain $a*
} elseif {[llength [split $tmp .]] > 2} {
set domain *.[join [lrange [split $tmp .] end-1 end] .]
} else {
set domain $tmp
}
return *!*$ident@$domain
}
4 {
set tmp [lindex [split $address @] 1]
if {[regexp {^((([0-9]){1,3}\.){3})([0-9]){1,3}$} $tmp -> a]} {
set domain $a*
} elseif {[regexp {^((([0-9a-z]){1,4}:){6})([0-9a-z]){1,4}:([0-9a-z]){1,4}$} $tmp -> a]} {
set domain $a*
} elseif {[llength [split $tmp .]] > 2} {
set domain *.[join [lrange [split $tmp .] end-1 end] .]
} else {
set domain $tmp
}
return *!*@$domain
}
5 {return $address}
6 {return [lindex [split $address !] 0]!*@*}
}
}
proc globescape {line} {
return [string map {* \\* ? \\? \\ \\\\ \[ \\\[ \] \\\]} $line]
}
proc kb {bytes} {
if {$bytes < 1024} {return "$bytes bytes"}
if {$bytes >= 1048576} {
return [format %3.2f [expr {$bytes / 1048576.0000}]]mb
}
return [format %3.2f [expr {$bytes / 1024.0000}]]kb
}
proc dur {in {div 1}} {
set in [expr {double($in) / $div}]
set d [expr {int($in / 86400.000)}]
set h [expr {int(($in - ($d * 86400)) / 3600.000)}]
set m [expr {int(($in - ($d * 86400) - ($h * 3600)) / 60.000)}]
set s [string trimright [string trimright [format %.3f [expr {$in - ($d * 86400) - ($h * 3600) - ($m * 60)}]] 0] .]
foreach x "d h m s" {
if {[set $x] > 0} {
append return [set $x]$x
}
}
if {[info exists return]} {return $return}
return 0s
}
proc multiline {arg line} {
if {[string first "\n" $line] != "-1"} {
set cmd [info level -1]
set win [lindex $cmd 1]
set cmd [lindex $cmd 0]
if {$arg != ""} {set arg "$arg "}
foreach x [rele [split $line "\n"]] {$cmd $win "$arg$x"}
return -code return
}
}
proc abspath {file} {
if {[file pathtype $file] != "absolute"} {set file [pwd]/$file}
return $file
}
proc rele {list} {
# remove empty list elements
while {[set pos [lsearch $list ""]] > -1} {
set list [lreplace $list $pos $pos]
}
return $list
}
proc inttoquad {in args} {
upvar [lindex $args 0] return
if ![catch {
set ip [format %08X $in]
set ip [format %u 0x[string range $ip 0 1]].[format %u 0x[string range $ip 2 3]].[format %u 0x[string range $ip 4 5]].[format %u 0x[string range $ip 6 7]]
} err] {
set return $ip
return 1
}
set return $err
return 0
}
proc CreateDccId {prefix} {
global dcc
set id $prefix[lindex [split [expr {rand()}] .] 1]
if {[array names dcc $id,*] != ""} {
set id [CreateDccId $prefix]
}
return $id
}
proc IncomingDccChat {header line} {
global away dcc prefs
set who [lindex $header 0]
if {![inttoquad [lindex $line 2] ip]} {
Echo .0 "\[ dcc \] Invalid CHAT request from $who: bad ip" {dcc default}
return
}
set nick [lindex [split $who !] 0]
set id [CreateDccId c]
foreach tmp [getdccid [list nick $nick] "type chat"] {
if {$dcc($tmp,state) == 3} {
return
} elseif {$dcc($tmp,state) == 2} {
close $dcc($tmp,sock)
unset $dcc($tmp,sock)
set dcc($id,ip) $ip
set dcc($id,port) [lindex $line 3]
IncomingDccChat2 1 $tmp
return
} elseif {$dcc($tmp,state) == 0 || $dcc($tmp,state) == 4} {
set id $tmp
catch {destroy .dialog$id}
after cancel [list DccIncomingChatTimedout $id]
}
}
array set dcc [list $id,ip $ip $id,port [lindex $line 3] $id,who $who $id,nick $nick $id,state 0 type chat]
set address [lindex [split $who !] 1]
Echo .0 "\[ dcc \] Chat request from $who \[$dcc($id,ip):$dcc($id,port)\]" {dcc default}
Event chatrequest "id id nick nick address address" $who
after [expr {$prefs(dcctimeout) * 1000}] [list DccIncomingChatTimedout $id]
if {$away} {
Echo .0 "\[ dcc \] To accept it, type \"/dcc accept $dcc($id,nick)\"" {dcc default}
} else {
dialog .dialog$id "RoxIRC DCC Request" "Accept DCC Chat from\n$who?" IncomingDccChat2 0 "Yes [list 1 $id]" "No [list 0 $id]"
}
}
proc IncomingDccChat2 {choice id} {
global dcc prefs
if {!$choice} {
Send "NOTICE $dcc($id,nick) :\001DCC REJECT chat <any>\001"
return
}
set host [expr {$prefs(unsafedcc) ? $dcc($id,ip) : [lindex [split $dcc($id,who) @] 1]}]
if {[catch {socket -async $host $dcc($id,port)} sock]} {
Echo .0 "\[ dcc \] Could not connect to $host: [geterror $sock]" {dcc default}
return
}
CreateDccChat $id
fconfigure $sock -blocking 0 -buffering none -translation lf
fileevent $sock writable [list DccChatConnect $id $host]
array set dcc [list $id,sock $sock $id,state 2]
}
proc DccIncomingChatTimedout {id} {
catch {destroy .dialog$id}
ClearDcc $id
}
proc DccSend {window line} {
global dcc
set id [string trimleft $window .]
if {![info exists dcc($id,sock)]} {
Echo $window "\[ error \] Error writing to socket: no socket" {error default}
} elseif {[catch {puts $dcc($id,sock) $line} err]} {
Echo $window "\[ error \] Error writing to socket: [geterror $err]" {error default}
}
}
proc AcceptDccChat {id sock addr port} {
global dcc
close $dcc($id,sock)
array set dcc [list $id,sock $sock $id,ip $addr $id,state 3]
fconfigure $sock -blocking 0 -buffering none -translation lf
fileevent $sock readable [list DccChat $id]
Echo .$id "\[ dcc \] Chat connection to $addr established" {dcc default}
bind .$id <<command>> {foreach x [rele [split $line "\n"]] {DccSend %W $x ; Echo %W "<$me> $x" me}}
wm title .$id "RoxIRC DCC Chat $dcc($id,nick)@$addr"
Event chatconnect "id id dcc($id,nick) nick addr ip" $dcc($id,nick)
}
proc DccChatConnect {id host} {
global info dcc
set port $dcc($id,port)
if {[set err [fconfigure $dcc($id,sock) -error]] != ""} {
if {[DccChatAutoClose $id]} {
Echo .0 "\[ dcc \] Connection to $host:$port failed: [geterror $err]" {dcc default}
} else {
Echo .$id "\[ dcc \] Connection to $host:$dcc($id,port) failed: [geterror $err]" {dcc default}
set dcc($id,state) 4
unset dcc($id,sock) dcc($id,port) dcc($id,ip)
}
return
}
fileevent $dcc($id,sock) writable {}
fileevent $dcc($id,sock) readable [list DccChat $id]
set peer [fconfigure $dcc($id,sock) -peername]
bind .$id <<command>> {foreach x [rele [split $line "\n"]] {DccSend %W $x ; Echo %W "<$me> $x" me}}
array set dcc [list $id,ip [lindex $peer 0] $id,state 3]
Echo .$id "\[ dcc \] Chat connection to [lindex $peer 1] established" {dcc default}
wm title .$id "RoxIRC DCC Chat $dcc($id,nick)@$dcc($id,ip)"
Event chatconnect "id id dcc($id,nick) nick dcc($id,ip) ip" $dcc($id,nick)
}
proc DccChat {id} {
global dcc
if {[eof $dcc($id,sock)] || [catch {gets $dcc($id,sock)} tmp]} {
set tmp "Chat connection to $dcc($id,nick)@$dcc($id,ip) [expr {[info exists tmp] ? "lost: [geterror $tmp]" : "closed"}]"
close $dcc($id,sock)
Event chatclose "id id dcc($id,nick) nick dcc($id,ip) ip" $dcc($id,nick)
if {[DccChatAutoClose $id]} {
Echo .0 "\[ dcc \] $tmp" {dcc default}
} else {
Echo .$id "\[ dcc \] $tmp" {dcc default}
set dcc($id,state) 4
unset dcc($id,sock) dcc($id,ip) dcc($id,port)
}
} elseif {$tmp != ""} {
if {[string match "\001ACTION *\001" $tmp]} {
Echo .$id "* $dcc($id,nick) [string range [string trim $tmp "\x01"] 7 end]" action
} else {
Echo .$id "<$dcc($id,nick)> $tmp" {}
}
Event chat "id id dcc($id,nick) nick dcc($id,ip) ip tmp line" $dcc($id,nick) $tmp
}
}
proc DccChatAutoClose {id} {
global dcc info
if {$dcc($id,close)} {
CloseDccChatWindow $id
return 1
}
catch {close $dcc($id,sock)}
bind .$id <<command>> {Echo %W {[ info ] This dcc is not connected} {info default}}
return 0
}
proc CleanupDccChat {id} {
global dcc
if {[info exists dcc($id,state)] && $dcc($id,state) < 3} {
set nick $dcc($id,nick)
if {[winfo exists .$id] && [DccChatAutoClose $id]} {
Echo .0 "\[ dcc \] Timeout waiting for chat connection from $nick" {dcc default}
return
}
Echo .$id {[ dcc ] Timeout waiting for connection} {dcc default}
unset dcc($id,sock) dcc($id,port)
set dcc($id,state) 4
}
}
proc DccCleanupIncomingFile {id} {
global dcc
if {[winfo exists .dialog$id]} {
destroy .dialog$id
ClearDcc $id
} elseif {![info exists dcc($id,sock)]} {
ClearDcc $id
}
}
proc IncomingDccFile {header line} {
global dcc away prefs
set who [lindex $header 0]
set line [rele [split $line]]
if {![string is integer -strict [lindex $line end]]} {
set line [lrange $line 0 end-1]
}
set nick [lindex [split $who !] 0]
set address [lindex [split $who !] 1]
set file [string trimleft [file tail [string trim [join [lrange $line 1 end-3] _] \"]] .]
if {![string is integer -strict [lindex $line end]]} {
Echo .0 "\[ dcc \] Invalid SEND request from $who: bad filesize" {dcc default}
return
}
if {![inttoquad [lindex $line end-2] ip]} {
Echo .0 "\[ dcc \] Invalid SEND request from $who: bad remote address" {dcc default}
return
}
set id [CreateDccId f]
if {[set tmp [getdccid [list nick $nick] [list file $file] "type get"]] != ""} {
if {$dcc($tmp,state) == 3} {
return
} elseif {$dcc($tmp,state) == 2} {
close $dcc($tmp,sock)
unset dcc($tmp,sock)
set dcc($id,ip) $ip
set dcc($id,port) [lindex $line end-1]
IncomingDccFile2 2 $tmp
return
} elseif {$dcc($tmp,state) == 0} {
set id $tmp
catch {destroy .dialog$id}
after cancel [list DccCleanupIncomingFile $id]
}
}
array set dcc [list $id,type get $id,state 0 $id,who $who $id,nick $nick $id,file $file $id,size [lindex $line end] $id,port [lindex $line end-1] $id,ip $ip]
Echo .0 "\[ dcc \] Send request from $dcc($id,who) \[$dcc($id,ip):$dcc($id,port)\] $dcc($id,file) ([kb $dcc($id,size)])" {dcc default}
after [expr {$prefs(dcctimeout) * 1000}] [list DccCleanupIncomingFile $id]
Event filerequest "dcc($id,nick) nick dcc($id,ip) ip dcc($id,file) file dcc($id,size) size address address" $dcc($id,who) $dcc($id,file)
if {$away} {
Echo .0 "\[ dcc \] To accept it, type \"/dcc get $dcc($id,nick) $dcc($id,file) \[newname\]\"" {dcc default}
if {[file exists $prefs(defaultdccdir)/$dcc($id,file)] && [file size $prefs(defaultdccdir)/$dcc($id,file)] < $dcc($id,size)} {
Echo .0 "\[ dcc \] File exists and is smaller, use /dcc resume $dcc($id,nick) $dcc($id,file)" {dcc default}
} elseif {[file exists $prefs(defaultdccdir)/$dcc($id,file)]} {
Echo .0 "\[ dcc \] WARNING: file exists" {dcc default}
}
return
}
if {[file exists $prefs(defaultdccdir)/$dcc($id,file)] && [file size $prefs(defaultdccdir)/$dcc($id,file)] < $dcc($id,size)} {
dialog .dialog$id "RoxIRC DCC Request" "Accept DCC Send of\n$dcc($id,file)\nfrom\n$dcc($id,who)?\nWARNING file exists" IncomingDccFile2 2 "Yes [list 2 $id]" "Rename [list 1 $id]" "Resume [list 3 $id]" "No [list 0 $id]"
} elseif {[file exists $prefs(defaultdccdir)/$dcc($id,file)]} {
dialog .dialog$id "RoxIRC DCC Request" "Accept DCC Send of\n$dcc($id,file)\nfrom\n$dcc($id,who)?\nWARNING file exists" IncomingDccFile2 1 "Yes [list 2 $id]" "Rename [list 1 $id]" "No [list 0 $id]"
} else {
dialog .dialog$id "RoxIRC DCC Request" "Accept DCC Send of\n$dcc($id,file)\nfrom\n$dcc($id,who)?" IncomingDccFile2 0 "Yes [list 2 $id]" "Rename [list 1 $id]" "No [list 0 $id]"
}
}
proc ClearDcc {id} {
array unset ::dcc $id,*
}
proc IncomingDccFile2 {choice id} {
global dcc prefs
set open w
if {$choice == "1"} {
if {[set fn [tk_getSaveFile -initialdir $prefs(defaultdccdir) -title "RoxIRC Save As" -initialfile $dcc($id,file)]] == ""} {
Send "NOTICE $dcc($id,nick) :\001DCC REJECT send $dcc($id,file)\001"
ClearDcc $id
return
}
} elseif {$choice == "2"} {
set fn $dcc($id,file)
} elseif {[lindex $choice 0] == "3"} {
set fn $dcc($id,file)
set open a
} else {
Send "NOTICE $dcc($id,nick) :\001DCC REJECT send $dcc($id,file)\001"
ClearDcc $id
return
}
if {[file dirname $fn] == "."} {set fn $prefs(defaultdccdir)/$fn}
set fn [abspath $fn]
while {[catch {open $fn $open} fh]} {
Echo .0 "\[ error \] Cannot open $fn for writing: [geterror $fh]" {error default}
if {[set fn [tk_getSaveFile -initialdir $prefs(defaultdccdir) -title "RoxIRC Save As" -initialfile $dcc($id,file)]] == ""} {
Send "NOTICE $dcc($id,nick) :\001DCC REJECT send $dcc($id,file)\001"
ClearDcc $id
return
}
if {[file dirname $fn] == "."} {set fn $prefs(dccdefaultdir)/$fn}
set fn [abspath $fn]
}
fconfigure $fh -translation binary
array set dcc [list $id,file $fn $id,fh $fh]
if {$choice == "3"} {
CreateDccFile get $id
.$id.bottom.status configure -text "Requesting resume..."
Send "PRIVMSG $dcc($id,nick) :\001DCC RESUME $dcc($id,file) $dcc($id,port) [file size $dcc($id,file)]\001"
return
}
set host [expr {$prefs(unsafedcc) ? $dcc($id,ip) : [lindex [split $dcc($id,who) @] 1]}]
if {[catch {socket -async $host $dcc($id,port)} sock]} {
Echo .0 "\[ dcc \] Could not connect to $host: [geterror $sock]" {dcc default}
return
}
CreateDccFile get $id
array set dcc [list $id,sock $sock $id,state 2]
fconfigure $sock -blocking 0 -buffering none -translation binary
fileevent $sock writable [list DccFileConnect $id]
}
proc geterror {err} {
if {[string first ": " $err] == -1} {return $err}
return [string trimleft [join [lrange [split $err :] 1 end] :]]
}
proc AcceptDccResume {header line} {
global dcc prefs
if {[set id [lindex [getdccid [list port [lindex $line 2]] [list nick [lindex [split [lindex $header 0] !] 0]] {type get} {state 2}] 0]] != ""} {
set host [expr {$prefs(unsafedcc) ? $dcc($id,ip) : [lindex [split $dcc($id,who) @] 1]}]
if {[catch {socket -async $host $dcc($id,port)} sock]} {
Echo .0 "\[ dcc \] Could not connect to $host: [geterror $sock]" {dcc default}
.$id.bottom.status configure -text "Connection to $host failed: [geterror $sock]"
DccFileDone $id
return
}
array set dcc [list $id,sock $sock $id,state 2]
fconfigure $sock -blocking 0 -buffering none -translation binary
.$id.bottom.status configure -text "Connecting for resume..."
fileevent $sock writable [list DccFileConnect $id]
}
}
proc ResumeDccSend {header line} {
global dcc
if {[set id [lindex [getdccid [list nick [lindex [split [lindex $header 0] !] 0]] [list port [lindex $line 2]] {state 1} {type send}] 0]] == ""} {return}
seek $dcc($id,fh) [lindex $line 3]
Send "PRIVMSG $dcc($id,nick) :\001DCC ACCEPT [lindex $line 1] $dcc($id,port) [tell $dcc($id,fh)]\001"
}
proc DccFileDone {id} {
global dcc
if {![info exists dcc($id,state)]} {return}
catch {unset dcc($id,last) dcc($id,start)}
catch {close $dcc($id,fh)}
catch {close $dcc($id,sock)}
if {[file exists $dcc($id,file)] && [file size $dcc($id,file)] == 0} {
file delete $dcc($id,file)
}
if {$dcc($id,close)} {destroy .$id}
set dcc($id,state) 4
if {$dcc($id,state) >= 3 || $dcc($id,type) == "send"} {ClearDcc $id}
}
proc DccFileConnect {id} {
global dcc
fileevent $dcc($id,sock) writable {}
if {[set err [fconfigure $dcc($id,sock) -error]] != ""} {
Echo .0 "\[ dcc \] Get of [file tail $dcc($id,file)] from $dcc($id,nick) failed: [geterror $err]" {dcc default}
.$id.bottom.status configure -text "Get failed: [geterror $err]"
DccFileDone $id
return
}
fileevent $dcc($id,sock) readable [list DccFileGet $id]
array set dcc [list $id,start [clock seconds] $id,state 3 $id,ip [lindex [fconfigure $dcc($id,sock) -peername] 0]]
.$id.1.host configure -text "ip: $dcc($id,ip)"
.$id.bottom.status configure -text "Receiving..."
UpdateDccFileWindow $id
Event getconnect "id id dcc($id,nick) nick dcc($id,ip) ip dcc($id,file) file" $dcc($id,nick) $dcc($id,file)
}
proc DccFileGet {id} {
global dcc
if {[eof $dcc($id,sock)]} {
if {[tell $dcc($id,fh)] < $dcc($id,size)} {
.$id.bottom.status configure -text "Get failed: connection lost"
Echo .0 "\[ dcc \] Get of [file tail $dcc($id,file)] from $dcc($id,nick) failed: connection lost" {dcc default}
} else {
.$id.bottom.status configure -text "Received succesfully"
if {[set el [expr {[clock seconds] - $dcc($id,start)}]] <= 0} {set el 1}
Echo .0 "\[ dcc \] Sucessfully received [kb $dcc($id,size)] of [file tail $dcc($id,file)] from $dcc($id,nick) in [dur $el] ([format %3.2f [expr {($dcc($id,size) / 1024.00) / $el}]]kbps)" {dcc default}
Event getdone "id id dcc($id,nick) nick dcc($id,ip) ip dcc($id,file) file" $dcc($id,nick) $dcc($id,file)
DccFileDone $id
return
}
} elseif {[catch {read $dcc($id,sock)} tmp]} {
Echo .0 "\[ dcc \] Get of [file tail $dcc($id,file)] from $dcc($id,nick) failed: [geterror $tmp]" {dcc default}
.$id.bottom.status configure -text "Get failed: [geterror $tmp]"
} elseif {[catch {puts -nonewline $dcc($id,fh) $tmp} err]} {
Echo .0 "\[ error \] Error writing to file $dcc($id,file): $err" {error default}
.$id.bottom.status configure -text "Write failed"
} else {
catch {puts -nonewline $dcc($id,sock) [binary format I* [tell $dcc($id,fh)]]}
set dcc($id,last) [clock seconds]
return
}
Event getfail "id id dcc($id,nick) nick dcc($id,ip) ip dcc($id,file) file" $dcc($id,nick) $dcc($id,file)
DccFileDone $id
}
proc UpdateDccFileWindow {id} {
global dcc
after cancel [list UpdateDccFileWindow $id]
if {![info exists dcc($id,state)]} {return}
if {$dcc($id,state) == 3 && [info exists dcc($id,last)] && [expr [clock seconds].00 - $dcc($id,last)] > 2.5} {
.$id.2.kbps configure -text "kbps: 0"
.$id.graph configure -label "Time remaining: ?"
.$id.bottom.status configure -text "Stalled"
.$id.2.elapsed configure -text "elapsed: [dur [expr {[clock seconds] - $dcc($id,start)}]]"
} elseif {$dcc($id,state) == 3 && [set el [expr {[clock seconds] - $dcc($id,start)}]] >= 1} {
.$id.2.elapsed configure -text "elapsed: [dur $el]"
if {[set tell [tell $dcc($id,fh)]] > 0} {
if {$dcc($id,type) == "get"} {
.$id.bottom.status configure -text "Receiving..."
.$id.2.r configure -text "received: [kb $tell]"
if {$tell > $dcc($id,size)} {.$id.bottom.status configure -text "WARNING: received > filesize"}
} else {
.$id.bottom.status configure -text "Sending..."
.$id.2.r configure -text "sent: [kb $tell]"
}
.$id.2.kbps configure -text "kbps: [format %3.2f [expr ($tell / 1024.00) / $el]]"
set dcc($id,scale) [expr {(double($tell) / $dcc($id,size)) * 100.0 - 0.0001}]
.$id.graph configure -label "Time remaining: [dur [expr {round(($el / ($dcc($id,scale) / 100.00)) - $el)}]]"
}
}
update idletasks
after 500 [list UpdateDccFileWindow $id]
}
proc DccFileSend {id} {
global dcc
if {[eof $dcc($id,sock)]} {
.$id.bottom.status configure -text "Send failed: connection reset"
Echo .0 "\[ dcc \] Send of $dcc($id,file) to $dcc($id,nick) failed: connection reset" {dcc default}
Event sendfail "id id dcc($id,nick) nick dcc($id,ip) ip dcc($id,file) file" $dcc($id,nick) $dcc($id,file)
DccFileDone $id
} elseif {[catch {binary scan [read $dcc($id,sock)] I* ack} err]} {
.$id.bottom.status configure -text "Send failed: socket read error"
Echo .0 "\[ dcc \] Send of $dcc($id,file) to $dcc($id,nick) failed: read error: [geterror $err]" {dcc default}
Event sendfail "id id dcc($id,nick) nick dcc($id,ip) ip dcc($id,file) file" $dcc($id,nick) $dcc($id,file)
DccFileDone $id
} elseif {$ack != ""} {
set ack [lindex $ack end]
if {[eof $dcc($id,fh)]} {
if {$ack == [tell $dcc($id,fh)]} {
.$id.bottom.status configure -text "Sent sucessfully"
if {[set el [expr {[clock seconds] - $dcc($id,start)}]] <= 0} {set el 1}
Echo .0 "\[ dcc \] Sucessfully sent [kb $dcc($id,size)] of $dcc($id,file) to $dcc($id,nick) in [dur $el] ([format %3.2f [expr ($dcc($id,size) / 1024.00) / $el]]kbps)" {dcc default}
Event senddone "id id dcc($id,nick) nick dcc($id,ip) ip dcc($id,file) file" $dcc($id,nick) $dcc($id,file)
DccFileDone $id
}
return
}
if {$ack < [tell $dcc($id,fh)]} {return}
if {$ack > [tell $dcc($id,fh)]} {
.$id.bottom.status configure -text "Send failed: last ack > sent"
Echo .0 "\[ dcc \] Send of $dcc($id,file) to $dcc($id,nick) failed: last ack > sent" {dcc default}
Event sendfail "id id dcc($id,nick) nick dcc($id,ip) ip dcc($id,file) file" $dcc($id,nick) $dcc($id,file)
DccFileDone $id
} else {
DccSendPacket $id
}
}
}
proc DccSendPacket {id {offset {}}} {
global prefs dcc
set dcc($id,last) [clock seconds]
if {$offset != ""} {seek $dcc($id,fh) $offset}
fcopy $dcc($id,fh) $dcc($id,sock) -size $prefs(dccpacketsize) -command DccSendPacketCallback
}
proc DccSendPacketCallback {args} {}
proc AcceptDccSend {id sock ip port} {
global dcc
close $dcc($id,sock)
fconfigure $sock -blocking 0 -buffering none -translation binary
fileevent $sock readable [list DccFileSend $id]
array set dcc [list $id,sock $sock $id,ip $ip $id,start [clock seconds] $id,state 3]
.$id.1.host configure -text "ip: $ip"
.$id.bottom.status configure -text "Sending..."
Event sendconnect "id id dcc($id,nick) nick dcc($id,ip) ip dcc($id,file) file" $dcc($id,nick) $dcc($id,file)
DccSendPacket $id
UpdateDccFileWindow $id
}
proc CleanupDccSend {id} {
global dcc
if {[winfo exists .$id] && [info exists dcc($id,state)] && $dcc($id,state) == 1} {
.$id.bottom.status configure -text "Timeout waiting for connection"
Echo .0 "\[ dcc \] Timeout waiting for connection from $dcc($id,nick) for $dcc($id,file)" {dcc default}
DccFileDone $id
}
}
proc activechannelwindows {} {
global info
set chans ""
foreach x [array names info window,*] {
lappend chans $info($x)
}
return $chans
}
proc channelwindows {} {
global info
set chans ""
for {set i 1} {$i <= 30} {incr i} {
if {[winfo exists .$i]} {lappend chans .$i}
}
return $chans
}
proc textwindows {} {
global info
set win ""
foreach x [array names info text,*] {
lappend win [lindex [split $x ,] 1]
}
return $win
}
proc querywindows {} {
global info
set chans ""
foreach x [winfo children .] {
if {[string match .q* $x]} {lappend chans $x}
}
return $chans
}
proc dccwindows {} {
global dcc
set chats ""
foreach x [array names dcc c*,nick] {
lappend chats .[lindex [split $x ,] 0]
}
return $chats
}
proc windowname {in} {
global info dcc
set in [string tolower $in]
if {[info exists info(window,$in)]} {
return $info(window,$in)
} elseif {[info exists info(query,$in)]} {
return $info(query,$in)
} elseif {$in == "current"} {
return [current]
} elseif {$in == "status"} {
return .0
} elseif {[string match =* $in] && [set tmp [getdccid [list nick [string range $in 1 end]] "type chat"]] != ""} {
return .$tmp
}
return {}
}
proc realname {in} {
global info dcc
set in [string tolower $in]
if {[info exists info(channel,$in)]} {
return $info(channel,$in)
} elseif {[info exists info(nick,$in)]} {
return $info(nick,$in)
} elseif {$in == "current"} {
return [realname [current]]
} elseif {$in == ".0"} {
return status
} elseif {[info exists dcc(.$in,nick)]} {
return =$dcc(.$in,nick)
}
return {}
}
proc ischannelname {name} {
global info
if {![info exists info(server,chantypes)]} {set info(server,chantypes) "#&"}
return [string match "\[$info(server,chantypes)\]*" $name]
}
proc DeleteUser {chan nick} {
global names info ial
set nick2 [string tolower $nick]
catch {unset names($chan,$nick2,a)}
catch {unset names($chan,$nick2,v)}
catch {unset names($chan,$nick2,o)}
ListDelete $info(window,$chan) $nick
ialdel $chan $nick
}
proc Complete {win} {
global names info
set line [$win get]
set a [string range $line 0 [expr {[$win index insert] - 1}]]
set b [string range $line [$win index insert] end]
set win [winfo toplevel $win]
set word [lindex [split $a] end]
set match ""
if {[string trim $word] == ""} {return}
if {[string match "/*" $word]} {
set match [split [string map {command_ /} [info commands command_*]]]
} elseif {[info exists info(channel,$win)]} {
set match [string map {@ "" + ""} [$win.middle.right.nicks get 0 end]]
lappend match $info(channel,$win)
} elseif {[info exists info(nick,$win)]} {
lappend match $info(nick,$win)
}
set found {}
set gword [string tolower [globescape $word]]
while {[set index [lsearch -glob [string tolower $match] "$gword*"]] != -1} {
lappend found [lindex $match $index]
set match [lrange $match [expr {$index + 1}] end]
}
set break 0
if {[llength $found] > 1} {
set o [lindex $found 0]
for {set i [string length $word]} {$i < 31} {incr i} {
foreach x $found {
if {[string tolower [string index $x $i]] != [string tolower [string index $o $i]]} {
set found [string range $x 0 [expr {$i - 1}]]
set break 1
}
}
if {$break} {break}
}
} else {
set found [lindex $found 0]
}
if {$found != ""} {
$win.bottom.cmdline delete 0 end
$win.bottom.cmdline insert end [string range $a 0 [expr {[string length $a] - [string length $word] - 1}]]
$win.bottom.cmdline insert end $found
if {!$break && [llength [split [$win.bottom.cmdline get]]] == 1} {
if {![string match "/*" [$win.bottom.cmdline get]] && ![string match "#*" $found]} {
$win.bottom.cmdline insert end ":"
}
}
if {!$break} {$win.bottom.cmdline insert end " "}
$win.bottom.cmdline icursor end
$win.bottom.cmdline insert end $b
} elseif {![catch {$info(text,$win) search -backwards -nocase -regexp -elide -- "( |^)$word" @65535,65535 @0,0} index] && $index != ""} {
$win.bottom.cmdline delete 0 end
$win.bottom.cmdline insert end [string range $a 0 [expr {[string length $a] - [string length $word] - 1}]]
$win.bottom.cmdline insert end [lindex [split [$info(text,$win) get $index+1c "$index lineend"]] 0]
if {[llength [split [$win.bottom.cmdline get]]] == 1} {
$win.bottom.cmdline insert end " "
}
$win.bottom.cmdline icursor end
$win.bottom.cmdline insert end $b
}
}
proc UpdateAllTitles {} {
global me server away
wm title .0 "RoxIRC Status ${me}[expr {$away ? { (away)} : {}}] on $server"
wm iconname .0 "$me Status \[RoxIRC\]"
foreach x [channelwindows] {UpdateTitle $x}
}
proc UpdateTitle {win} {
global me server info away
if {[info exists info(channel,$win)]} {
if {[isop $info(channel,$win) $me]} {
set blah @$info(channel,$win)
} elseif {[isvoice $info(channel,$win) $me]} {
set blah +$info(channel,$win)
} else {
set blah $info(channel,$win)
}
} else {
set blah -none-
}
wm title $win "RoxIRC ${blah}[expr {$away ? { (away)} : {}}] \[$me on $server\]"
wm iconname $win "$blah \[RoxIRC\]"
if {[winfo exists $win.n]} {
wm title $win.n "RoxIRC $blah nicklist"
wm iconname $win.n "$blah nicklist \[RoxIRC\]"
}
}
proc ListFill {window} {
global info names prefs
set chan [globescape $info(channel,$window)]
$window.middle.right.nicks delete 0 end
set char [expr {$prefs(showops) ? {@} : {}}]
foreach x [lsort [array names names $chan,*,o]] {
$window.middle.right.nicks insert end $char$names($x)
}
set end1 [$window.middle.right.nicks index end]
set char [expr {$prefs(showops) ? {+} : {}}]
foreach x [lsort [array names names $chan,*,v]] {
$window.middle.right.nicks insert end $char$names($x)
}
set end2 [$window.middle.right.nicks index end]
foreach x [lsort [array names names $chan,*,n]] {
$window.middle.right.nicks insert end $names($x)
}
itemconfigure $window @nicklist 0 $end1
itemconfigure $window +nicklist $end1 $end2
array unset names $chan,*,n
ListUpdateLabel $window
}
proc showops {window state} {
global info
if {$state} {
foreach win [channelwindows] {
set end [$win.middle.right.nicks index end]
for {set index 0} {$index < $end} {incr index} {
set name [$win.middle.right.nicks get $index]
set sel [$win.middle.right.nicks selection includes $index]
if {[isop $info(channel,$win) $name]} {
$win.middle.right.nicks delete $index
$win.middle.right.nicks insert $index @$name
itemconfigure $win @nicklist $index
} elseif {[isvoice $info(channel,$win) $name]} {
$win.middle.right.nicks delete $index
$win.middle.right.nicks insert $index +$name
itemconfigure $win +nicklist $index
} else {
break
}
if {$sel} {$win.middle.right.nicks selection set $index}
}
}
} else {
foreach win [channelwindows] {
set end [$win.middle.right.nicks index end]
for {set index 0} {$index < $end} {incr index} {
set name [$win.middle.right.nicks get $index]
set sel [$win.middle.right.nicks selection includes $index]
if {[string match {[+@]*} $name]} {
$win.middle.right.nicks delete $index
$win.middle.right.nicks insert $index [string range $name 1 end]
itemconfigure $win [string index $name 0]nicklist $index
} else {
break
}
if {$sel} {$win.middle.right.nicks selection set $index}
}
}
}
}
proc opsinchan {window state} {
global info
foreach win [channelwindows] {
$info(text,$win) tag configure @ -elide [expr {!$state}]
$info(text,$win) tag configure + -elide [expr {!$state}]
}
}
proc itemconfigure {win tag index args} {
global prefs
foreach {x color} [array get prefs color,$tag,*] {
lappend config -[lindex [split $x ,] 2] $color
}
if {![info exists config]} {return}
if {$args != ""} {
set stop [$win.middle.right.nicks index $args]
} else {
set stop [expr {[$win.middle.right.nicks index $index] + 1}]
}
for {} {$index < $stop} {incr index} {
eval $win.middle.right.nicks itemconfigure $index $config
}
}
proc colorconfigure {w name} {
global prefs
foreach {x color} [array get prefs color,$name,*] {
lappend config -[lindex [split $x ,] 2] $color
}
if {[info exists config]} {eval $w configure $config}
if {$name == "cmdline"} {$w configure -insertbackground [$w cget -fg] -highlightcolor [$w cget -fg]}
}
proc ListDelete {win nick} {
global names info
ListUpdateLabel $win
set list [$win.middle.right.nicks get 0 end]
if {[set index [lsearch -exact $list $nick]] != -1} {
$win.middle.right.nicks delete $index
} elseif {[set index [lsearch -exact $list @$nick]] != -1} {
$win.middle.right.nicks delete $index
} elseif {[set index [lsearch -exact $list +$nick]] != -1} {
$win.middle.right.nicks delete $index
}
}
proc ListAdd {win nick} {
global info names
ListUpdateLabel $win
set list [GetList $win n]
set num [ListSearch $list $nick]
set index [expr {$num + [$win.middle.right.nicks index end] - [llength $list]}]
$win.middle.right.nicks insert $index $nick
return $index
}
proc ListSearch {list nick} {
set lo -1
set hi [llength $list]
set test [expr {$hi / 2}]
while {$lo != $test} {
set res [string compare -nocase [lindex $list $test] $nick]
if {$res < 0} {
set lo $test
} elseif {$res > 0} {
set hi $test
} else {
return $test
}
set test [expr {($hi + $lo) / 2}]
}
return $hi
}
proc ListUpdateLabel {win} {
global info names
set chan [globescape $info(channel,$win)]
set tmp "@[llength [array names names $chan,*,o]] +[llength [array names names $chan,*,v]] [llength [array names names $chan,*,a]]"
$win.middle.right.label configure -text $tmp
}
proc GetList {win mode} {
global names
set list [$win.middle.right.nicks get 0 end]
switch -exact -- $mode {
o {
return [lrange $list 0 [expr {[llength [split [join $list] @]] - 2}]]
}
v {
set l [split [join $list] +]
set f [llength [split [lindex $l 0]]]
return [lrange $list [expr {$f - 1}] [expr {$f + [llength $l] - 2}]]
}
n {
return [lrange [split [lindex [split [join $list] @+] end]] 1 end]
}
}
}
proc ListChange {win old new} {
global info names prefs
ListUpdateLabel $win
set list [$win.middle.right.nicks get 0 end]
if {[set index [lsearch -exact $list $old]] != -1} {
set sel [$win.middle.right.nicks selection includes $index]
$win.middle.right.nicks delete $index
} elseif {[set index [lsearch -exact $list @$old]] != -1} {
set sel [$win.middle.right.nicks selection includes $index]
$win.middle.right.nicks delete $index
} elseif {[set index [lsearch -exact $list +$old]] != -1} {
set sel [$win.middle.right.nicks selection includes $index]
$win.middle.right.nicks delete $index
}
if {[isop $info(channel,$win) $new]} {
set c [expr {$prefs(showops) ? {@} : {}}]
set index [ListSearch [GetList $win o] $c$new]
$win.middle.right.nicks insert $index $c$new
itemconfigure $win @nicklist $index
} elseif {[isvoice $info(channel,$win) $new]} {
set c [expr {$prefs(showops) ? {+} : {}}]
set index [ListSearch [GetList $win v] $c$new]
incr index [llength [array names names [globescape $info(channel,$win)],*,o]]
$win.middle.right.nicks insert $index $c$new
itemconfigure $win +nicklist $index
} else {
set index [ListAdd $win $new]
}
if {$sel} {$win.middle.right.nicks selection set $index}
}
proc UpdateChat {who} {
global info prefs
set nick [string tolower [lindex [split $who !] 0]]
if {[info exists info(query,$nick)]} {
wm title $info(query,$nick) "RoxIRC Query $who"
return $info(query,$nick)
}
set oldfocus [focus]
set win [CreateChat $who]
if {$prefs(iconifyqueries)} {wm iconify $win}
update
focus -force $oldfocus
return $win
}
proc CreateChat {who} {
global info prefs history options
set nick [string tolower [lindex [split $who !] 0]]
if {[info exists info(query,$nick)]} {
wm deiconify $info(query,$nick)
raise $info(query,$nick)
return
}
set i 0
while {[winfo exists .q$i]} {incr i}
set i .q$i
toplevel $i -class Query
frame $i.menubar
frame $i.middle
frame $i.bottom
text $i.middle.text -state disabled -bd 1 -yscrollcommand "$i.middle.scroll set"
scrollbar $i.middle.scroll -orient v -command "$i.middle.text yview"
entry $i.bottom.cmdline -font $prefs(font,cmdline)
MakeMenu $i "window query personal misc"
$i.menubar.window.menu.2 delete 4 5
if {$prefs(menubar)} {pack $i.menubar -side top -fill x}
pack $i.bottom -side bottom -fill x
pack $i.middle -side top -expand 1 -fill both
pack $i.middle.scroll -side right -fill y
pack $i.middle.text -expand 1 -fill both
pack $i.bottom.cmdline -fill x
wm protocol $i WM_DELETE_WINDOW "CloseChat $i"
wm title $i "RoxIRC Query $who"
wm iconname $i "Query $nick \[RoxIRC\]"
wm geometry $i $prefs(geom,chat)
array set info [list query,$nick $i nick,$i $nick text,$i $i.middle.text]
array set options [list ts,$i $prefs(ts) menubar,$i $prefs(menubar)]
array set history "$i,list {} $i,cur -1"
fontconfigure $i $prefs(font,chat)
colorconfigure $i.middle.text query
colorconfigure $i.bottom.cmdline cmdline
ConfigureTags $i
bindtags $i.bottom.cmdline "cmdline $i.bottom.cmdline Entry $i all"
bind $i.middle.text <Double-Button-1> "Double $i query ; break"
bind $i.middle.text <Button-3> "OtherPopup $i.menubar.query.menu %X %Y"
bind $i.middle.text <ButtonRelease-1> "focus $i.bottom.cmdline; tk_textCopy $i.middle.text; break"
bind $i.middle.text <Configure> "$i.middle.text see end"
bind $i <<command>> {foreach x [rele [split $line "\n"]] {Send "PRIVMSG $info(nick,%W) :$x" ; Echo %W "<$me> $x" me}}
if {[info exists prefs(geom,$nick)]} {
set window $i
catch {eval [join $prefs(geom,$nick) \;]}
}
focus $i.bottom.cmdline
event generate $i <<querycreate>>
return $i
}
proc CreateNicklist {i} {
global prefs
toplevel $i.n -class Channel
label $i.n.label -bd 1 -relief raised -text "@- +- -" -font $prefs(font,chantopic)
scrollbar $i.n.scroll -orient v -command "$i.n.nicks yview"
listbox $i.n.nicks -bd 2 -relief flat -selectmode extended -width 12 -exportselection 0 -yscrollcommand "$i.n.scroll set" -font $prefs(font,nicklist)
colorconfigure $i.n.nicks nicklist
pack $i.n.label -side top -fill x
pack $i.n.scroll -side right -fill y
pack $i.n.nicks -fill both -expand 1
wm protocol $i.n WM_DELETE_WINDOW "reattachnick $i"
if {[string match 8.4* [info patchlevel]]} {
wm protocol $i WM_TAKE_FOCUS "catch \"lower $i.n $i\""
wm protocol $i.n WM_TAKE_FOCUS "lower $i $i.n"
}
bind $i.n <Escape> "wm iconify $i.n"
bind $i.n <Control-KeyPress> "focus $i.bottom.cmdline; event generate $i.bottom.cmdline <Control-%K>; catch {focus $i.n}"
bind $i.n <Alt-KeyPress> "focus $i.bottom.cmdline; event generate $i.bottom.cmdline <Alt-%K>; catch {focus $i.n}"
bind $i.n.nicks <Double-Button-1> "Double $i nick"
bind $i.n.nicks <Button-3> "NickPopup $i.menubar.user $i.n.nicks %X %Y %y"
}
proc CreateChannel {chan} {
global info server prefs history options
foreach x [winfo children .] {
if {[string match {.[1-9]*} $x] && ![info exists info(channel,$x)]} {set i $x}
}
if {![info exists i]} {
for {set i 1} {[winfo exists .$i]} {incr i} {}
set i .$i
}
if {$chan != ""} {array set info [list window,$chan $i channel,$i $chan]}
if {[set exists [winfo exists $i]]} {
wm deiconify $i
raise $i
} else {
toplevel $i -class Channel
frame $i.menubar
frame $i.middle
frame $i.middle.left
frame $i.middle.right
frame $i.middle.right.move -width 3 -cursor sb_h_double_arrow
frame $i.bottom
label $i.menubar.modes -relief sunken -bd 1 -text "-" -font $prefs(font,menu)
entry $i.middle.left.topic -bd 1 -state disabled -highlightthickness 0 -font $prefs(font,chantopic)
scrollbar $i.middle.left.scroll -orient v -command "$i.middle.left.text yview"
text $i.middle.left.text -state disabled -bd 1 -yscrollcommand "$i.middle.left.scroll set"
listbox $i.middle.right.nicks -bd 2 -relief flat -selectmode extended -width 12 -exportselection 0 -takefocus 0 -yscrollcommand "$i.middle.right.scroll set" -font $prefs(font,nicklist)
scrollbar $i.middle.right.scroll -orient v -command "$i.middle.right.nicks yview"
label $i.middle.right.label -bd 1 -relief flat -text "@- +- -" -font $prefs(font,chantopic) -cursor fleur
entry $i.bottom.cmdline -font $prefs(font,cmdline)
MakeMenu $i "window user channel personal server misc"
if {$prefs(menubar)} {pack $i.menubar -side top -fill x}
pack $i.bottom -side bottom -fill x
pack $i.middle -side top -expand 1 -fill both
if {$prefs(nicklist)} {
pack $i.middle.right -side right -fill y
} else {
catch {$i.menubar.user configure -state disabled}
}
pack $i.middle.left -side left -expand 1 -fill both
pack $i.menubar.modes -side right -padx 2 -pady 2 -ipadx 3 -fill y
if {$prefs(topic)} {pack $i.middle.left.topic -side top -fill x}
pack $i.middle.left.scroll -side right -fill y
pack $i.middle.left.text -expand 1 -fill both
pack $i.middle.right.label -side top -fill x
pack $i.middle.right.scroll -side right -fill y
pack $i.middle.right.move -side left -fill y -expand 1
pack $i.middle.right.nicks -side bottom -fill y -expand 1
pack $i.bottom.cmdline -fill x
if {[string match "*8.4*" [info patchlevel]]} {
$i.middle.left.topic configure -state readonly -disabledbackground "" -disabledforeground "" -readonlybackground ""
}
wm protocol $i WM_DELETE_WINDOW "CloseChannel $i"
wm geometry $i $prefs(geom,channel)
array set options [list nicklist,$i $prefs(nicklist) ts,$i $prefs(ts) menubar,$i $prefs(menubar) topic,$i $prefs(topic)]
array set history [list $i,list {} $i,cur -1]
set info(text,$i) $i.middle.left.text
fontconfigure $i $prefs(font,chan)
colorconfigure $i.middle.left.topic chantopic
colorconfigure $i.middle.left.text chan
colorconfigure $i.middle.right.nicks nicklist
colorconfigure $i.bottom.cmdline cmdline
ConfigureTags $i
bind $i.menubar.modes <Double-Button-1> "ModeWindow $i"
bind $i.middle.right.nicks <Double-Button-1> "Double $i nick"
bind $i.middle.right.label <ButtonRelease-1> "NicksMove %W %X %Y"
bind $i.middle.right.move <ButtonPress-1> "NicksResize press $i %X"
bind $i.middle.right.nicks <Button-3> "NickPopup $i.menubar.user $i.middle.right.nicks %X %Y %y"
bind $i.middle.left.topic <Double-Button-1> "if \{[info exists info(channel,$i)]\} \{Send \"TOPIC \$info(channel,$i)\"\}; break"
bind $i.middle.left.text <Button-3> "ChanPopup $i %X %Y"
bind $i.middle.left.text <Double-Button-1> "Double $i channel ; break"
bind $i.middle.left.text <ButtonRelease-1> "tk_textCopy $i.middle.left.text; focus $i.bottom.cmdline; break"
bind $i.middle.left.topic <ButtonRelease-1> "event generate $i.middle.left.topic <<Copy>>; focus $i.bottom.cmdline; break"
bind $i.middle.left.text <Configure> "$i.middle.left.text see end"
bindtags $i.bottom.cmdline "cmdline $i.bottom.cmdline Entry $i all"
bind $i <<command>> {Echo %W "\[ info \] You have no channel joined in this window" {info default}}
}
if {$chan != ""} {
bind $i <<command>> {foreach x [rele [split $line "\n"]] {Send "PRIVMSG $info(channel,%W) :$x" ; Echo %W < "<> my<> me" $me "nicks mynick me" > "<> my<> me" " $x" "margin mytext me"}}
if {[info exists prefs(geom,$chan)]} {
set window $i
catch {eval [join $prefs(geom,$chan) \;]}
}
}
focus $i.bottom.cmdline
UpdateTitle $i
update idletasks
if {!$exists} {event generate $i <<channelcreate>>}
return $i
}
proc CreateDccChat {id} {
global info server prefs away history dcc
set i .$id
if {[winfo exists $i]} {
wm deiconify $i
raise $i
return $i
}
toplevel $i -class Chat
frame $i.menubar
frame $i.middle
frame $i.bottom
scrollbar $i.middle.scroll -orient v -command "$i.middle.text yview"
text $i.middle.text -state disabled -bd 1 -yscrollcommand "$i.middle.scroll set"
entry $i.bottom.cmdline -font $prefs(font,cmdline)
checkbutton $i.menubar.close -font $prefs(font,menu) -highlightthickness 0 -text Autoclose -variable dcc($id,close)
MakeMenu $i "window dcc personal misc"
$i.menubar.window.menu.2 delete 4 5
wm protocol $i WM_DELETE_WINDOW "CloseDccChatWindow $id"
wm title $i "RoxIRC DCC Chat $dcc($id,nick)"
wm iconname $i "DCC Chat $dcc($id,nick) \[RoxIRC\]"
wm geometry $i $prefs(geom,chat)
if {$prefs(menubar)} {pack $i.menubar -side top -fill x}
pack $i.bottom -side bottom -fill x
pack $i.middle -side top -expand 1 -fill both
pack $i.middle.scroll -side right -fill y
pack $i.middle.text -expand 1 -fill both
pack $i.bottom.cmdline -fill x
pack $i.menubar.close -side right
array set options [list ts,$i $prefs(ts) menubar,$i $prefs(menubar)]
set info(text,$i) $i.middle.text
set dcc($id,close) $prefs(dccchatautoclose)
array set history [list $i,list {} $i,cur -1]
fontconfigure $i $prefs(font,chat)
colorconfigure $i.middle.text dccchat
colorconfigure $i.bottom.cmdline cmdline
ConfigureTags $i
bindtags $i.bottom.cmdline "cmdline $i.bottom.cmdline Entry $i all"
bind $i.middle.text <Double-Button-1> "Double $i dcc ; break"
bind $i.middle.text <ButtonRelease-1> "tk_textCopy $i.middle.text; focus $i.bottom.cmdline; break"
bind $i.middle.text <Button-3> "OtherPopup $i.menubar.dcc.menu %X %Y"
bind $i.middle.text <Configure> "$i.middle.text see end"
bind $i <<command>> {Echo %W {[ info ] This dcc is not connected} {info default}}
if {[info exists prefs(geom,=$dcc($id,nick)]} {
set window $i
catch {eval [join $prefs(geom,=$dcc($id,nick) \;]}
}
focus $i.bottom.cmdline
update idletasks
event generate $i <<dccchatcreate>>
return $i
}
proc CreateDccFile {type id} {
global dcc prefs
set w .$id
if {[winfo exists $w]} {
wm deiconify $w
raise $w
return $w
}
if {[set bd [option get . Toplevel.borderWidth Toplevel]] == ""} {set bd 0}
toplevel $w -class File -relief raised -bd $bd
wm protocol $w WM_DELETE_WINDOW "CloseDccFileWindow $id"
wm title $w "RoxIRC DCC [string map {get "Get from" send "Send to"} $type] $dcc($id,nick) ([file tail $dcc($id,file)])"
wm iconname $w "DCC [string totitle $type] $dcc($id,nick) ([file tail $dcc($id,file)]) \[RoxIRC\]"
wm resizable $w 1 0
frame $w.bottom
frame $w.1 -bd 1 -relief sunken
frame $w.2 -bd 1 -relief sunken
label $w.1.file -font $prefs(font,menu) -anchor w
label $w.1.host -font $prefs(font,menu) -anchor e -text "ip: ?.?.?.?"
label $w.1.size -font $prefs(font,menu) -anchor e -text "size: 0"
label $w.2.elapsed -font $prefs(font,menu) -anchor e -text "elapsed: 0"
label $w.2.kbps -font $prefs(font,menu) -anchor e -text "kbps: 0.00"
label $w.2.r -font $prefs(font,menu) -anchor e -text "[string map {send sent get received} $type]: 0"
label $w.bottom.status -font $prefs(font,menu) -bd 1 -relief sunken -padx 3 -pady 2 -anchor e -text [string map {get "Connecting..." send "Waiting for connection"} $type] -anchor w
checkbutton $w.bottom.close -highlightthickness 0 -font $prefs(font,menu) -text "Autoclose" -variable dcc($id,close)
scale $w.graph -width 20 -highlightthickness 0 -from 0 -to 100 -resolution 1 -variable dcc($id,scale) -state disabled -orient h -tickinterval 25 -sliderlength 10 -label "Time remaining: "
pack $w.1 -side top -fill x -padx 5 -pady 5
pack $w.2 -side top -fill x -padx 5 -pady 5
pack $w.graph -padx 5 -fill x
pack $w.bottom -side bottom -fill x
pack $w.bottom.close -side right -pady 3 -padx 3
pack $w.bottom.status -side left -fill x -expand 1 -pady 3 -padx 3
grid $w.1.host $w.1.size $w.1.file -sticky w -pady 2 -padx 2 -ipady 1
grid $w.2.elapsed $w.2.r $w.2.kbps -sticky w -pady 2 -padx 2 -ipady 1
grid columnconfigure $w.1 {0 1} -uniform 1 -weight 1
grid columnconfigure $w.2 {0 1} -uniform 1 -weight 1
grid columnconfigure $w.1 2 -uniform 1 -weight 2
grid columnconfigure $w.2 2 -uniform 1 -weight 2
array set dcc [list $id,close $prefs(dccfileautoclose) $id,scale 0]
if {$type == "send"} {
$w.1.file configure -text "file: [string range $dcc($id,file) end-24 end]"
$w.1.size configure -text "size: [kb [file size $dcc($id,file)]]"
} elseif {$type == "get"} {
$w.1.file configure -text "file: [string range [file tail $dcc($id,file)] end-24 end]"
$w.1.size configure -text "size: [kb $dcc($id,size)]"
}
return $w
}
proc CreateStatus {} {
global info prefs history options
frame .0.menubar
frame .0.bottom
entry .0.bottom.cmdline -font $prefs(font,cmdline)
scrollbar .0.middle.scroll -orient v -command ".0.middle.text yview"
label .0.menubar.modes -text "-" -relief sunken -bd 1 -font $prefs(font,menu)
MakeMenu .0 "window personal server misc"
.0.middle.text configure -bd 1 -yscrollcommand ".0.middle.scroll set" -state disabled
.0.menubar.window.menu delete 10
.0.menubar.window.menu.1 delete 0 1
.0.menubar.window.menu.2 delete 4 5
wm geometry .0 $prefs(geom,status)
wm protocol .0 WM_DELETE_WINDOW {CloseClient ""}
if {$prefs(menubar)} {pack .0.menubar -side top -fill x}
pack .0.bottom -side bottom -fill x
pack .0.middle -side top -expand 1 -fill both
pack .0.menubar.modes -side right -padx 2 -ipadx 3
pack .0.middle.scroll -side right -fill y
pack .0.bottom.cmdline -fill x
pack .0.middle.text -side left -fill both -expand 1
set info(text,.0) .0.middle.text
array set history {.0,list "" .0,cur -1}
array set options [list menubar,.0 $prefs(menubar) ts,.0 $prefs(ts)]
fontconfigure .0 $prefs(font,status)
colorconfigure .0.middle.text status
colorconfigure .0.bottom.cmdline cmdline
bindtags .0.bottom.cmdline "cmdline .0.bottom.cmdline Entry .0 all"
bind .0.middle.text <Button-3> "OtherPopup .0.menubar.server.menu %X %Y"
bind .0.middle.text <Double-Button-1> "Double .0 status ; break"
bind .0.middle.text <ButtonRelease-1> "tk_textCopy .0.middle.text; focus .0.bottom.cmdline; break"
bind .0.middle.text <Configure> ".0.middle.text see end"
bind .0 <<command>> {Echo .0 {[ info ] You have no channel joined in this window} {info default}}
focus .0.bottom.cmdline
ConfigureTags .0
UpdateAllTitles
}
proc fontconfigure {win font} {
global prefs info option
set f f[string trimleft $win .]
catch {font create $f}
catch {font create ${f}b}
lappend font 14
font configure $f -family [lindex $font 0] -size [lindex $font 1] -weight normal -slant roman
font configure ${f}b -family [lindex $font 0] -size [lindex $font 1] -weight [expr {$prefs(bold) ? {bold} : {normal}}] -slant roman
$info(text,$win) configure -font $f
$info(text,$win) tag configure bold -font ${f}b
}
proc ConfigureTags {win} {
global prefs info options
# for backwards compatibility
foreach {name color} [array get prefs color,*] {
$info(text,$win) tag configure [lindex [split $name ,] 1] -foreground $color
}
foreach {name color} [array get prefs color,*,foreground] {
$info(text,$win) tag configure [lindex [split $name ,] 1] -foreground $color
}
foreach {name color} [array get prefs color,*,background] {
$info(text,$win) tag configure [lindex [split $name ,] 1] -background $color
}
foreach tag {<> @<> +<> me my<> mynick mytext hilight ts search sel} {
$info(text,$win) tag configure $tag -lmargin1 {}
$info(text,$win) tag raise $tag
}
foreach tag {nicks @nicks +nicks default} {
$info(text,$win) tag configure $tag -lmargin1 {}
$info(text,$win) tag lower $tag
}
$info(text,$win) tag lower nicks
$info(text,$win) tag lower default
$info(text,$win) tag configure ts -elide [expr {($options(ts,$win) || $prefs(ts)) ? 0 : 1}]
$info(text,$win) tag configure underline -underline $prefs(underline)
$info(text,$win) tag configure @ -elide [expr {!$prefs(opsinchan)}]
$info(text,$win) tag configure + -elide [expr {!$prefs(opsinchan)}]
$info(text,$win) tag configure margin -lmargin2 $prefs(margin)
$info(text,$win) tag bind url <Enter> "$info(text,$win) configure -cursor hand2"
$info(text,$win) tag bind url <Leave> "$info(text,$win) configure -cursor {}"
$info(text,$win) tag bind url <Double-Button-1> "UrlEvent double %W %X %Y %x %y"
$info(text,$win) tag bind url <Button-3> "UrlEvent menu %W %X %Y %x %y"
$info(text,$win) tag bind nicks <Button-3> {NickPopup2 %W %X %Y %x %y}
}
proc circulate {dir} {
set wins [winfo children .]
set p [lsearch $wins [winfo toplevel [focus]]]
set wins [concat [lrange $wins [expr {$p + 1}] end] [lrange $wins 0 [expr {$p - 1}]]]
if {[string match "back*" $dir]} {
set tmp $wins
set wins {}
foreach x $tmp {set wins [linsert $wins 0 $x]}
}
foreach i $wins {
if {[wm state $i] == "normal" && [winfo exists $i.bottom.cmdline]} {
set next $i
break
}
}
if {[info exists next] && $next != ""} {
wm deiconify $next
raise $next
focus $next.bottom.cmdline
}
}
proc margin {window line} {
global info
foreach x [textwindows] {
$info(text,$x) tag configure margin -lmargin2 $line
}
}
proc ts {win} {
global options info
set view [lindex [$info(text,$win) yview] 1]
$info(text,$win) tag configure ts -elide [expr {!$options(ts,$win)}]
if {$view == 1} {$info(text,$win) see end}
}
proc ial {window line} {
global ial
if {!$line} {
catch {unset ial}
}
}
proc bold {window line} {
set line [string map {0 normal 1 bold} $line]
foreach x [textwindows] {
font configure f[string trimleft $x .]b -weight $line
}
}
proc underline {window line} {
global info
foreach x [textwindows] {
$info(text,$x) tag configure underline -underline $line
}
}
proc MakeMenu {i types} {
global prefs menu
foreach type $types {
if {[info exists menu($type)]} {
menubutton $i.menubar.$type -text [string totitle $type] -menu $i.menubar.$type.menu -underline 0 -font $prefs(font,menu)
menu $i.menubar.$type.menu -tearoff 0 -font $prefs(font,menu)
menuparse $type $i.menubar.$type.menu $menu($type)
pack $i.menubar.$type -side left
}
}
}
proc menuparse {type menu list} {
global prefs options
set sub -1
set num -1
set window .[lindex [split $menu .] 1]
while {[set list [lreplace $list 0 $num]] != ""} {
set num 0
switch -exact -- [lindex $list 0] {
command {
$menu add command -label [lindex $list 1] -command [list DoMenu $window [lindex $list 2]]
incr num 2
}
separator {
$menu add separator
}
menu {
incr sub
$menu add cascade -label [subst [lindex $list 1]] -menu [append menu .$sub]
menu $menu -tearoff 0 -font $prefs(font,menu)
$menu delete 0 end
incr num
}
end {
set menu [string range $menu 0 [expr {[string last . $menu] - 1}]]
}
checkbutton {
$menu add checkbutton -label [lindex $list 1] -variable [subst [lindex $list 2]] -command [list DoMenu $window [lindex $list 3]]
incr num 3
}
radiobutton {
$menu add radiobutton -label [lindex $list 1] -variable [subst [lindex $list 2]] -value [subst [lindex $list 3]] -command [list DoMenu $window [lindex $list 4]]
incr num 4
}
tcl {
menuparse $type $menu [menutcl $window $type [lindex $list 1]]
incr num
}
default {
Echo .0 "\[ error \] Unknown menu option \"[lindex $list 0]\" in $type menu" {error default}
return
}
}
}
}
proc menutcl {window type tcl} {
global prefs menu options
if {[catch {eval $tcl} err] == 1} {
Echo .0 "\[ error \] Error in $type menu tcl command: $err" {error default}
return {}
}
return $err
}
proc DoMenu {window command} {
global info server away me prefs names dcc options
switch -exact [string index $window 1] {
0 {}
q {
if {![info exists info(nick,$window)]} {return}
set nick $info(nick,$window)
}
c {set nick $dcc([string trimleft $window .],nick)}
default {
set channel ""
if {[info exists info(channel,$window)]} {set channel $info(channel,$window)}
set nicks [selected $window]
set nick [lindex $nicks 0]
}
}
if {[catch {eval $command} msg]} {
Echo .0 "\[ error \] Error in menu command $command: $msg" {error default}
}
}
proc DefaultKeyBindings {} {
bind cmdline <Escape> {wm iconify [winfo toplevel %W]}
bind cmdline <Tab> {Complete %W}
bind cmdline <Return> {Command %W}
bind cmdline <Up> {HistoryUp %W}
bind cmdline <Down> {HistoryDown %W}
bind cmdline <Prior> {$info(text,[winfo toplevel %W]) yview scroll -1 pages}
bind cmdline <Next> {$info(text,[winfo toplevel %W]) yview scroll 1 pages}
bind cmdline <Control-Home> {$info(text,[winfo toplevel %W]) yview moveto 0}
bind cmdline <Control-End> {$info(text,[winfo toplevel %W]) yview moveto 1}
bind cmdline <MouseWheel> {$info(text,[winfo toplevel %W]) yview scroll [expr {%D / -24}] units}
catch {bind cmdline <KP_Prior> {$info(text,[winfo toplevel %W]) yview scroll -1 pages}}
catch {bind cmdline <KP_Next> {$info(text,[winfo toplevel %W]) yview scroll 1 pages}}
catch {bind cmdline <Control-KP_End> {$info(text,[winfo toplevel %W]) yview moveto 1; break}}
#bind cmdline <KeyPress> "puts %K"
bind Text <Button-5> {%W yview scroll 5 units}
bind Text <Button-4> {%W yview scroll -5 units}
bind all <Alt-Key> {catch {::tk::TraverseToMenu %W %A}}
bind all <Alt-Key> {+catch {tkTraverseToMenu %W %A}}
bind all <<PrevWindow>> {}
bind all <Tab> {}
}
proc nicklistselection {win dir} {
set win [winfo toplevel $win]
if {[winfo exists $win.middle.right.nicks]} {
# catch for compatability with both 8.3 and 8.4
switch -exact $dir {
up {
catch {tk::ListboxUpDown $win.middle.right.nicks -1}
catch {tkListboxUpDown $win.middle.right.nicks -1}
}
down {
catch {tk::ListboxUpDown $win.middle.right.nicks 1}
catch {tkListboxUpDown $win.middle.right.nicks 1}
}
}
}
}
proc reattachnick {i} {
catch {destroy $i.n}
pack forget $i.middle.left
pack $i.middle.right -side right -fill y
pack $i.middle.left -side left -expand 1 -fill both
if {[lindex [$i.middle.left.text yview] 1] == 1} {
update idletasks
$i.middle.left.text see end
}
}
proc detachnick {win X Y x y} {
global prefs
if {[winfo exists $win.n]} {return}
pack forget $win.middle.right
CreateNicklist $win
UpdateTitle $win
wm geometry $win.n [winfo width $win.middle.right]x[winfo height $win.middle.right]+[expr {$x - $X}]+[expr {$y - $Y}]
update idletasks
set nicks [$win.middle.right.nicks get 0 end]
eval "$win.n.nicks insert 0 $nicks"
set @nicklist ""
set +nicklist ""
foreach {x color} [array get prefs color,?nicklist,*] {
lappend [lindex [split $x ,] 1] -[lindex [split $x ,] 2] $color
}
set index 0
foreach x $nicks {
if {[string match @* $x]} {
eval $win.n.nicks itemconfigure $index ${@nicklist}
} elseif {[string match +* $x]} {
eval $win.n.nicks itemconfigure $index ${+nicklist}
} else {
break
}
incr index
}
$win.n.label configure -text [$win.middle.right.label cget -text]
rename $win.middle.right.nicks _$win.middle.right.nicks
rename $win.middle.right.label _$win.middle.right.label
proc $win.middle.right.nicks {args} "eval _$win.middle.right.nicks \$args; return \[eval $win.n.nicks \$args\]"
proc $win.middle.right.label {args} "eval _$win.middle.right.label \$args; return \[eval $win.n.label \$args\]"
bind $win.n.nicks <Destroy> [list catch "rename $win.middle.right.nicks {}; rename _$win.middle.right.nicks $win.middle.right.nicks"]
bind $win.n.label <Destroy> [list catch "rename $win.middle.right.label {}; rename _$win.middle.right.label $win.middle.right.label"]
}
proc NicksMove {win x y} {
set rx1 [winfo rootx $win]
set ry1 [winfo rooty $win]
set rx2 [expr {$rx1 + [winfo width $win]}]
set ry2 [expr {$ry1 + [winfo height $win]}]
if {$x < ($rx1 - 10) || $x > ($rx2 + 10) || $y < ($ry1 - 10) || $y > ($ry2 + 10)} {
eval detachnick [winfo toplevel $win] 0 0 $x $y
}
}
proc NicksResize {type win args} {
global info
switch $type {
press {
bind $win.middle.right.move <ButtonRelease-1> "NicksResize release $win [lindex [$info(text,$win) yview] 1]"
bind $win.middle.right.move <Motion> "NicksResize motion $win [$win.middle.right.nicks cget -width] [expr {[winfo width $win.middle.right.nicks] / [$win.middle.right.nicks cget -width]}] $args %X"
}
motion {
set new [expr {(([lindex $args 2] - [lindex $args 3]) / [lindex $args 1]) + [lindex $args 0]}]
if {$new == 0} {
command_option $win {nicklist 0}
NicksResize release $win
after idle [list $win.middle.left.scroll configure -activerelief [lindex [$win.middle.left.scroll configure -activerelief] 3]]
set new 12
}
if {$new > 0 && [$win.middle.right.nicks cget -width]} {
$win.middle.right.nicks configure -width $new
$win.middle.right.label configure -width $new
update idletasks
}
}
release {
bind $win.middle.right.move <Motion> ""
bind $win.middle.right.move <ButtonRelease-1> ""
if {$args == 1} {
update idletasks
$info(text,$win) see end
}
}
}
}
proc Double {window type} {
global info prefs server me away dcc event
if {[info exists event]} {
unset event
return
}
if {[info exists prefs(click,$type)]} {
switch -exact $type {
nick {
if {![info exists info(channel,$window)]} {return}
set channel $info(channel,$window)
set nick [string trimleft [$window.middle.right.nicks get [lindex [$window.middle.right.nicks curselection] 0]] "@+"]
}
channel {
if {![info exists info(channel,$window)]} {return}
set nicks [selected $window]
set nick [lindex $nicks 0]
set channel $info(channel,$window)
}
query {set nick $info(nick,$window)}
dcc {set nick $dcc([string trimleft $window .],nick)}
}
eval $prefs(click,$type)
return
}
}
proc TextWindowCleanup {w} {
array unset ::options *,$w
array unset ::history $w,*
unset ::info(text,$w)
font delete f[string trimleft $w .] f[string trimleft $w .]b
}
proc EndLogging {w} {
global options
if {$options(log,$w)} {
puts $options(lfh,$name) "Logging stopped on [clock format [clock seconds] -format "%D at %R %Z" -gmt $prefs(gmt)]"
close $options(lfh,$name)
}
}
proc CloseChat {name} {
global info options history prefs
destroy $name
unset info(query,$info(nick,$name)) info(nick,$name)
EndLogging $name
TextWindowCleanup $name
foreach x [textwindows] {
if {[wm state $x] != "withdrawn" && $x != $name} {return}
}
wm deiconify .0
}
proc CloseChannel {name} {
global info history options prefs
destroy $name
if {[info exists info(channel,$name)]} {Send "PART $info(channel,$name)"}
EndLogging $name
TextWindowCleanup $name
foreach x [textwindows] {
if {[wm state $x] != "withdrawn" && $x != $name} {return}
}
wm deiconify .0
}
proc DeleteChannel {chan win} {
global info names ial server
unset info(channel,$win) info(window,$chan)
set chan [globescape $chan]
array unset names $chan,*
array unset ial $chan,*
if {[winfo exists $win]} {
bind $win <<command>> {Echo %W {[ info ] You have no channel joined in this window} {info default}}
$win.middle.right.label configure -text "@- +- -"
$win.middle.right.nicks delete 0 end
InsertDisabled $win.middle.left.topic {}
$win.menubar.modes configure -text "-"
UpdateTitle $win
}
}
proc CloseDccFileWindow {id} {
DccFileDone $id
catch {destroy .$id}
}
proc CloseDccChatWindow {id} {
global dcc info history options prefs
destroy .$id
catch {close $dcc($id,sock)}
if {$dcc($id,state) == 1 || $dcc($id,state) > 2 || [info level] == 0} {ClearDcc $id}
EndLogging .$id
TextWindowCleanup .$id
foreach x [textwindows] {
if {[wm state $x] != "withdrawn"} {return}
}
wm deiconify .0
}
proc CloseClient {line} {
global options prefs irc
if {$line == ""} {set line "<insert witty, contrived message here>"}
Send "QUIT :$line"
foreach x [array names options lfh,*] {EndLogging [lindex [split $x ,] 1]}
exit
}
proc NickPopup {win path x y y2} {
global info event
if {[info exists event]} {
unset event
return
}
if {![winfo exists $win.menu]} {return}
if {[info exists info(channel,[winfo toplevel $win])]} {
if {![$path selection includes [$path nearest $y2]]} {
$path selection clear 0 end
$path selection set [$path nearest $y2]
}
tk_popup $win.menu $x $y
}
}
proc NickPopup2 {win x y x2 y2} {
global info event
set event 1
set twin [winfo toplevel $win]
if {[info exists info(channel,$twin)]} {
$win tag remove sel 1.0 end
eval $win tag add sel [$win tag prevrange nicks [$win index @[expr {$x2 + 15}],$y2]]
set nick [eval $win get [$win tag prevrange nicks [$win index @[expr {$x2 + 15}],$y2]]]
set list [$twin.middle.right.nicks get 0 end]
foreach c {{} @ +} {
if {[set i [lsearch -exact $list $c$nick]] > -1} {break}
}
if {$i < 0} {return}
$twin.middle.right.nicks selection clear 0 end
$twin.middle.right.nicks selection set $i
$twin.middle.right.nicks yview $i
if {[winfo exists $twin.menubar.user.menu]} {
tk_popup $twin.menubar.user.menu $x $y
}
}
}
proc ChanPopup {win x y} {
global info event
if {[info exists event]} {
unset event
return
}
if {[info exists info(channel,$win)] && [winfo exists $win.menubar.channel.menu]} {
tk_popup $win.menubar.channel.menu $x $y
}
}
proc OtherPopup {menu x y} {
global info event
if {[info exists event]} {
unset event
return
}
if {[winfo exists $menu]} {
tk_popup $menu $x $y
}
}
proc UrlEvent {type win x y x2 y2} {
global event prefs
set event 1
switch $type {
double {
set blah [$win tag prevrange url [$win index @$x2,$y2]]
set url [$win get [lindex $blah 0] [lindex $blah 1]]
eval exec [string map {"\$url" $url} $prefs(urlcommand)] &
}
menu {
$win tag remove sel 1.0 end
eval $win tag add sel [$win tag prevrange url [$win index @[expr {$x2 + 15}],$y2]]
#tk_popup $win.url $x $y
}
}
}
proc Echo {window line {tags 0} args} {
global info options prefs
if {![winfo exists $window]} {return}
set view [lindex [$info(text,$window) yview] 1]
set ts [clock format [clock seconds] -format $prefs(tsformat) -gmt $prefs(gmt)]
$info(text,$window) configure -state normal
if {$tags == "0"} {
set tags {}
if {[string match {\[ *} $line]} {
set tags "default [string range $line 2 [expr {[string first \] $line] - 2}]]"
} elseif {[set me2 [string map {\\ \\\\ \[ \\\[ \] \\\] ^ \\^} $::me]] != "" && [regexp -- "^(-> |<$me2>|\\\* $me2 |\\\+$me2\\\+|-$me2-)" $line]} {
set tags me
} elseif {[string match "(*" $line]} {
set tags numeric
} elseif {[regexp {^(\*|\+)\[^ \]+(\*|\+)} $line]} {
set tags privmsg
} elseif {[string match {\* *} $line]} {
set tags action
}
}
if {$args == ""} {
$info(text,$window) insert end \n {} "$ts " "ts $tags" $line "margin $tags"
} else {
$info(text,$window) insert end \n {} "$ts " "[lindex $args end] ts"
eval $info(text,$window) insert end {$line $tags} $args
}
$info(text,$window) delete 1.0 end-$prefs(scrollback)l
set line [$info(text,$window) get end-1l end]
if {[lsearch -exact $tags "me"] == -1 && [string match -nocase *[string map {\\ \\\\ \[ \\\[ \] \\\]} $::me]* $line]} {$info(text,$window) tag add hilight end-1l end}
event generate $info(text,$window) <<echo>>
if {$options(log,$window)} {puts -nonewline $options(lfh,$window) $line}
styleparse $info(text,$window) "\x02" bold
styleparse $info(text,$window) "\x1f" underline
$info(text,$window) configure -state disabled
if {$prefs(urls)} {urls $window}
set num [llength [split $line "\a"]]
incr num -1
if {$num > $prefs(maxbeeps)} {set num $prefs(maxbeeps)}
if {$num > 0} {command_beep .0 "$num 300"}
if {$options(popup,$window)} {
wm geometry $window [winfo geometry $window]
wm deiconify $window
raise $window
}
if {$view == 1} {$info(text,$window) yview moveto 1}
}
proc urls {window} {
global info urls prefs
set pos [$info(text,$window) index end-1l]
while {[set blah [$info(text,$window) search -elide -regexp -count len {http://[^ \"]+|www\.[^ \"]+} $pos end]] != ""} {
$info(text,$window) tag add url $blah $blah+${len}c
set url [$info(text,$window) get $blah $blah+${len}c]
set pos $blah+${len}c
set chan -
if {[info exists info(channel,$window)]} {
set chan $info(channel,$window)
} elseif {[info exists info(nick,$window)]} {
set chan $info(nick,$window)
}
lappend urls [format " %s %-15s %s" [clock format [clock seconds] -format "%D %R" -gmt $prefs(gmt)] $chan $url]
}
}
proc styleparse {text char tag} {
set line [$text get end-1l end]
set pos 0
set add {}
set del {}
while {[set pos [string first $char $line $pos]] > -1} {
lappend add end-1l+${pos}c
set del [linsert $del 0 $pos]
incr pos
}
if {$add != ""} {
eval $text tag add $tag $add end
foreach x $del {$text delete end-1l+${x}c}
}
}
proc HistoryUp {window} {
global history
set window [winfo toplevel $window]
if {[lindex $history($window,list) [expr {$history($window,cur) + 1}]] != ""} {
if {$history($window,cur) == -1} {
set history($window,tmp) [$window.bottom.cmdline get]
}
$window.bottom.cmdline delete 0 end
incr history($window,cur)
$window.bottom.cmdline insert end [lindex $history($window,list) $history($window,cur)]
} else {
bell
}
}
proc HistoryDown {window} {
global history
set window [winfo toplevel $window]
if {$history($window,cur) != -1} {
$window.bottom.cmdline delete 0 end
if {$history($window,cur) == 0} {
$window.bottom.cmdline insert end $history($window,tmp)
set history($window,cur) -1
} else {
incr history($window,cur) -1
$window.bottom.cmdline insert end [lindex $history($window,list) $history($window,cur)]
}
} else {
bell
}
}
proc autoaway {} {
global prefs away autoaway irc
if {[info exists irc] && !$away && $prefs(autoaway) > 0} {
Send "AWAY :$prefs(awayreason)"
}
set autoaway 1
}
proc AddToHistory {window line} {
global history prefs
if {$history($window,cur) > -1 && [lindex $history($window,list) $history($window,cur)] == $line} {
set history($window,list) [lreplace $history($window,list) $history($window,cur) $history($window,cur)]
}
set history($window,list) [linsert $history($window,list) 0 $line]
set history($window,list) [lrange $history($window,list) 0 $prefs(history)]
set history($window,cur) -1
}
proc Command {window} {
global away prefs autoaway line
after cancel autoaway
if {!$away && $prefs(autoaway) > 0} {after [expr {$prefs(autoaway) * 60000}] autoaway}
if {$away && ($prefs(autounaway) == 1 || ($prefs(autounaway) == 2 && [info exists autoaway]))} {Send "AWAY"}
if {[set line [$window get]] == ""} {
unset line
return
}
$window delete 0 end
set window [winfo toplevel $window]
AddToHistory $window $line
set command [trim [lindex [split $line] 0] /]
if {[string index $line 0] == "/"} {
set line [string range $line [expr {[string length $command] + 2}] end]
if {[info commands command_$command] != ""} {
command_$command $window $line
} else {
set tmp [info commands command_$command*]
switch [llength $tmp] {
1 {$tmp $window $line}
0 {Echo $window "\[ error \] Unknown command /$command $line" {error default}}
default {Echo $window "\[ info \] Ambigous command /$command $line" {info default}}
}
}
} else {
event generate $window <<command>>
}
catch {unset line}
}
proc sendq {} {
global prefs sendq flood irc ignore
if {[llength $sendq] > 0} {
set line [lindex $sendq 0]
#puts "Out: $line"
if {[info exists irc]} {
if {[catch {puts $irc $line} err] && ![info exists connecting]} {
Echo .0 "\[ error \] Error sending to server: [geterror $err]" {error default}
set sendq {}
}
} else {
foreach x [textwindows] {Echo $x {[ server ] You are not connected to a server} {server default}}
set sendq {}
}
set sendq [lreplace $sendq 0 0]
after $prefs(flooddelay) sendq
} else {
unset flood sendq
Echo .0 {[ info ] Flood protection deactivated} {info default}
}
}
proc Send {line} {
global info prefs
if {[info exists ::flood]} {
if {[llength $::sendq] < $prefs(floodmaxq)} {lappend ::sendq $line}
return
}
if {([clock clicks -milliseconds] - $info(send,last)) < $prefs(floodtime)} {
incr info(send,num)
} else {
set info(send,last) [clock clicks -milliseconds]
set info(send,num) 0
}
if {$info(send,num) >= $prefs(floodlines) && $prefs(flood)} {
set ::flood 1
set ::sendq {}
Echo .0 {[ info ] Flood protection activated} {info default}
Send $line
sendq
return
}
#puts "Out: $line"
if {[info exists ::irc]} {
if {[catch {puts $::irc $line} err]} {
Echo .0 "\[ error \] Error sending to server: [geterror $err]" {error default}
}
} elseif {[info level] > 1 && [string equal [upvar #1 fh fh] ""] && [info exists fh] && $fh != ""} {
catch {puts $fh $line}
} else {
set found ""
foreach x [file channels s*] {
if {![catch {fileevent $x readable} out] && [string match "Connected *" $out]} {lappend found $x}
}
if {[llength $found] == 1} {
catch {puts $found $line}
} elseif {![info exists ::connecting]} {
foreach x [textwindows] {Echo $x {[ server ] You are not connected to a server} {server default}}
}
}
}
proc unbind {tag event script} {
set bind ""
foreach x [split [bind $tag $event] "\n"] {
if {$x != $script} {lappend bind $x}
}
bind $tag $event {}
foreach x $bind {bind $tag $event $x}
}
proc bgerror {error} {
global errorInfo errorCode
set tmp [split $errorInfo "\n"]
puts stderr "$errorInfo"
Echo .0 "\[ error \] Error: $error [string trim [lindex $tmp 1]] [lindex $tmp 2] [string trim [lindex $tmp 3]]" {error default}
}
proc unknown {args} {
global unknown_pending errorCode errorInfo
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
set name [lindex $args 0]
if {[info exists unknown_pending($name)]} {
return -code error "self-referential recursion in command \"$name\""
}
set unknown_pending($name) pending
if {[string match /* $name]} {
if {[set cmd [info commands command_[string trim $name /]]] == ""} {
unset unknown_pending($name)
return -code error "invalid command name \"$name\""
}
if {[info level] > 1} {upvar window win}
if {![info exists win] || $win == ""} {set win .0}
set args [list $cmd $win [join [lrange $args 1 end]]]
} else {
set code [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
if {$code != 0} {
unset unknown_pending($name)
return -code $code -errorcode $errorCode "error while autoloading \"$name\": $msg"
}
if {!$msg} {
unset unknown_pending($name)
return -code error "invalid command name \"$name\""
}
}
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set code [catch {uplevel 1 $args} msg]
unset unknown_pending($name)
if {![array size unknown_pending]} {unset unknown_pending}
if {$code == 1} {
set new [split $errorInfo \n]
set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
return -code error -errorcode $errorCode -errorinfo $new $msg
}
return -code $code $msg
}
proc dialog {w title text cmd default args} {
global prefs
catch {destroy $w}
set oldfocus [focus]
if {[set bd [option get . Toplevel.borderWidth Toplevel]] == ""} {set bd 0}
toplevel $w -class Dialog -relief raised -bd $bd
wm title $w $title
wm iconname $w $title
wm transient $w [winfo toplevel [winfo parent $w]]
wm protocol $w WM_DELETE_WINDOW {# nothing}
wm resizable $w 0 0
pack [frame $w.bot] -side bottom -fill both -ipady 2
pack [frame $w.top] -side top -fill both -expand 1
label $w.top.msg -justify center -text $text -font $prefs(font,menu) -wraplength 4i
pack $w.top.msg -expand 1 -fill both -padx 3m -pady 3m
set i 0
foreach but $args {
button $w.bot.button$i -text [lindex $but 0] -command [list dialogcallback $w $cmd [lrange $but 1 end]] -font $prefs(font,menu)
if {$i == $default} {
$w.bot.button$i configure -default active
bind $w <Return> [list $w.bot.button$i invoke]
}
grid $w.bot.button$i -column $i -row 0 -sticky ew -padx 10
grid columnconfigure $w.bot $i -uniform 1
incr i
}
bind $w <Escape> [list destroy $w]
bindtags $w $w
wm withdraw $w
update idletasks
set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 - [winfo vrootx [winfo parent $w]]}]
set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 - [winfo vrooty [winfo parent $w]]}]
wm geometry $w +$x+$y
wm deiconify $w
update idletasks
focus -force $oldfocus
}
proc dialogcallback {win cmd a} {
destroy $win
eval [list $cmd] $a
}
proc current {} {
if {[set cur [focus]] != ""} {return [winfo toplevel $cur]}
return .0
}
proc trim {line char} {
if {[string index $line 0] == $char} {return [string range $line 1 end]}
return $line
}
proc escape {line} {
return [string map {\\ \\\\ \" \\\" \$ \\\$ \{ \\\{ \} \\\} \[ \\\[} $line]
}
proc unescape {line} {
return [subst -nocommands -novariables $line]
}
proc Parse {line} {
#puts "In: $line"
set line [string trimleft $line :]
if {[set pos [string first " :" $line]] > -1} {
set header [split [string range $line 0 [expr {$pos - 1}]]]
set line [string range $line [expr {$pos + 2}] end]
} else {
set line [string trim $line]
set pos [string last " " $line]
set header [split [string range $line 0 [expr {$pos - 1}]]]
set line [string range $line [expr {$pos + 1}] end]
}
set numeric [lindex $header 1]
if {$header == "PING"} {
catch {puts $::irc "PONG :$line"}
return
}
if {[info commands raw_$numeric] != ""} {
raw_$numeric $header $line
set ::last $numeric
} elseif {[string equal -nocase $::me $numeric]} {
regsub {^\*\*\* Notice -- |^\*\*\* } $line {} line
Echo .0 "\[ server \] $line" {server default}
} else {
Echo .0 "( $numeric ) [string trim "[join [lrange $header 3 end]] $line"]" numeric
}
foreach ns [namespace children ::scripts] {
if {[info commands ${ns}::event_$numeric] != ""} {
if {[catch {${ns}::event_$numeric $header $line} err]} {
Echo .0 "\[ error \] Error in event_$numeric in script [namespace tail $ns]: $err" {error default}
}
}
}
}
proc Connected {serv fh} {
global irc connecting info server prefs
if {[set line [fconfigure $fh -error]] != ""} {
close $fh
Echo .0 "\[ server \] Could not connect to $serv: [geterror $line]" {server default}
if {![info exists irc]} {
if {![string equal $serv [lindex $info(connect) 0]] && $server != "-"} {
after [expr {$prefs(reconnect) * 1000}] [list command_server .0 [join $info(connect)]]
} else {
foreach x [textwindows] {Echo $x {[ server ] You are not connected to a server} {server default}}
}
}
return
}
set name [string tolower [lindex [fconfigure $fh -peername] 1]]
Echo .0 "\[ server \] Connected to $name" {server default}
if {[info exists irc]} {
catch {puts $irc "QUIT :changing servers"}
after 100 [list catch "close $irc"]
unset irc
}
#if {[string equal [lindex $info(connect) 0] $serv]} {
# set info(connect) [lreplace $info(connect) 0 0 $name]
#}
fileevent $fh readable [list Connecting $name $fh]
}
proc Connecting {serv fh} {
global irc connecting info prefs server
set line {connection closed}
if {[eof $fh] || [catch {gets $fh} line]} {
close $fh
foreach x [textwindows] {Echo $x "\[ server \] Disconnected from $serv: [geterror $line]" {server default}}
if {![info exists irc]} {
if {$server != "-"} {
after [expr {$prefs(reconnect) * 1000}] [list command_server .0 [join $info(connect)]]
} else {
foreach x [textwindows] {Echo $x {[ server ] You are not connected to a server} {server default}}
}
}
return
}
set irc $fh
if {$line != ""} {Parse $line}
if {[info exists connecting]} {unset irc}
}
proc Registered {} {
global irc server connecting prefs info
upvar #1 fh fh serv serv
upvar header header
set irc $fh
set server [string tolower [lindex $header 0]]
fileevent $fh readable [list GetLine $server $fh]
unset info(connect)
foreach x [split $prefs(server) "\n"] {
set x [split [string tolower [string trim $x]] :]
if {[lindex $x 0] == $server && [lindex $x 1] != ""} {
set info(connect) [lrange $x 1 1]
break
}
}
if {![info exists info(connect)]} {set info(connect) [list $server]}
foreach x [file channels sock*] {
if {![catch {fileevent $x readable} out] && [string match "Connect*" $out]} {catch {close $x}}
}
unset connecting
foreach x [after info] {
if {[string match "command_server *" [lindex [after info $x] 0]]} {after cancel $x}
}
}
proc GetLine {serv fh} {
set line {connection closed}
if {[eof $fh] || [catch {gets $fh} line]} {
global info
foreach x [textwindows] {Echo $x "\[ server \] Disconnected from $serv: [geterror $line]" {server default}}
close $fh
if {$::irc == $fh} {unset ::irc}
if {[info exists info(time,server)]} {
Echo .0 "\[ info \] Connected to server for: [dur [expr {[clock seconds] - $info(time,server)}]]" {info default}
unset info(time,server)
}
after [expr {$::prefs(reconnect) * 1000}] [list command_server .0 [join $info(connect)]]
Event disconnect {}
return
}
if {$line != ""} {Parse $line}
}
proc getport {num} {
global prefs
if {$num == ""} {return $prefs(port)}
set ports [split $num ,]
for {set i 0} {$i < [llength $ports]} {incr i} {
set x [lindex $ports $i]
if {[string match ?*-?* $x]} {
set ports [lreplace $ports $i $i]
set to [lindex [split $x -] 1]
for {set a [lindex [split $x -] 0]} {$a <= $to} {incr a} {
lappend ports $a
}
}
}
return [lindex $ports [expr {round(rand() * ([llength $ports] - 1))}]]
}
proc OpenSock {serv port pass} {
global irc prefs info
set tmp ""
if {$pass != ""} {set tmp ", pass ****"}
Echo .0 "\[ server \] Connecting to $serv on port ${port}${tmp}" {server default}
set host ""
if {$prefs(host) != ""} {set host "-myaddr $prefs(host)"}
if {[catch {eval socket -async $host $serv $port} sock]} {
Echo .0 "\[ server \] Could not connect to $serv: [geterror $sock]" {server default}
if {$::server != "-" && ![info exists irc] && ![string equal [lindex $info(connect) 0] $serv]} {
after [expr {$prefs(reconnect) * 1000}] [list command_server .0 [join $info(connect)]]
} elseif {![info exists irc]} {
foreach x [textwindows] {Echo $x {[ server ] You are not connected to a server} {server default}}
}
return
}
fconfigure $sock -blocking 0 -buffering none
fileevent $sock readable [list Connected $serv $sock]
fileevent $sock writable [list auth $sock $pass]
global connecting
set connecting $serv
}
proc Start {} {
global info options prefs
SetVars
ParseCommandline
DefaultKeyBindings
toplevel .0 -class Status
wm withdraw .0
frame .0.middle
text .0.middle.text
.0.middle.text insert end {[ info ] RoxIRC 2.0b by RockShox} {default info}
set info(text,.0) .0.middle.text
array set options "popup,.0 0 log,.0 0 ts,.0 0"
SourceFiles
set info(time,client) [clock seconds]
CreateStatus
wm deiconify .0
update idletasks
after 60000 {periodic}
bind .0 <<periodic>> checkison
}
Start
syntax highlighted by Code2HTML, v. 0.9.1