[Orxonox-commit 824] r2209 - in media: . tcl tcl/irk tcl/irk/docs tcl/irk/examples tcl/irk/lib tcl/irk/socks
landauf at orxonox.net
landauf at orxonox.net
Fri Jul 24 17:56:48 CEST 2009
Author: landauf
Date: 2009-07-24 17:56:47 +0200 (Fri, 24 Jul 2009)
New Revision: 2209
Added:
media/tcl/
media/tcl/init.tcl
media/tcl/irc.tcl
media/tcl/irk/
media/tcl/irk/README
media/tcl/irk/docs/
media/tcl/irk/docs/changes.txt
media/tcl/irk/docs/todo.txt
media/tcl/irk/docs/usage.txt
media/tcl/irk/examples/
media/tcl/irk/examples/fortunebot.tcl
media/tcl/irk/examples/mysaint.tcl
media/tcl/irk/irk.tcl
media/tcl/irk/lib/
media/tcl/irk/lib/irkauth.tcl
media/tcl/irk/lib/irkcommand.tcl
media/tcl/irk/lib/irkconnect.tcl
media/tcl/irk/lib/irkctcptcl.tcl
media/tcl/irk/lib/irkdispatch.tcl
media/tcl/irk/lib/irkflow.tcl
media/tcl/irk/lib/irkqueue.tcl
media/tcl/irk/lib/irkreceive.tcl
media/tcl/irk/lib/irkservers.tcl
media/tcl/irk/lib/irkstate.tcl
media/tcl/irk/lib/irkutil.tcl
media/tcl/irk/pkgIndex.tcl
media/tcl/irk/socks/
media/tcl/irk/socks/socks.tcl
media/tcl/remote.tcl
media/tcl/telnet_server.tcl
Log:
added our custom tcl files
Added: media/tcl/init.tcl
===================================================================
--- media/tcl/init.tcl (rev 0)
+++ media/tcl/init.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,234 @@
+namespace eval orxonox {}
+
+# query --
+# Sends a query to the CommandExecutor of Orxonox and waits for the response.
+# This dummy procedure will be changed to it's real implementation by Orxonox itself.
+#
+# Arguments:
+# args - The command to send to Orxonox
+
+proc query args {
+ return -code error "Can't query Orxonox now"
+}
+
+
+# crossquery --
+# Sends a query to another Tcl-interpreter in Orxonox and waits for the response.
+# This dummy procedure will be changed to it's real implementation by Orxonox itself.
+#
+# Arguments:
+# id - The ID of the other interpreter
+# args - The command to send to Orxonox
+
+proc crossquery {id args} {
+ return -code error "Can't query interpreter with ID $id now"
+}
+
+
+# execute --
+# Sends a command to the queue of Orxonox where it will be executed by the CommandExecutor after some time
+# This dummy procedure will be changed to it's real implementation by Orxonox itself.
+#
+# Arguments:
+# args - The command
+
+proc execute args {
+ return -code error "Can't execute a command now"
+}
+
+
+# crossexecute --
+# Sends a command to the queue of another Tcl-interpreter where it will be executed by after some time
+# This dummy procedure will be changed to it's real implementation by Orxonox itself.
+#
+# Arguments:
+# id - The ID of the other interpreter
+# args - The command
+
+proc crossexecute {id args} {
+ return -code error "Can't execute a command now"
+}
+
+
+# add the path to this file to the auto path
+
+set filepath [info script]
+set ::orxonox::mediapath [string range $filepath 0 [string last "/" $filepath]]
+if {[lsearch $auto_path $::orxonox::mediapath] == -1} {
+ lappend auto_path $::orxonox::mediapath
+}
+unset filepath
+
+
+# change the working directory to the media path
+
+cd $::orxonox::mediapath
+
+
+# change the source command to use files from the media path
+
+#if {[llength [info command ::tcl::source]] == 0} {
+# rename source ::tcl::source
+#}
+#proc source args {
+# global ::orxonox::mediapath
+#
+# set argc [llength $args]
+# if {$argc != 1 && $argc != 3} {
+# error "wrong # args: should be \"source ?-encoding name? fileName\""
+# }
+# if {$argc == 3} {
+# if {[lindex $args 0] != "-encoding"} {
+# error "bad option \"[lindex $args 0]\": must be -encoding"
+# } else {
+# set file [lindex $args 2]
+# }
+# } else {
+# set file [lindex $args 0]
+# }
+# set orxonoxfile [file join $::orxonox::mediapath $file]
+# if {[file readable $orxonoxfile]} {
+# if {$argc == 1} {
+# return [::tcl::source $orxonoxfile]
+# } else {
+# return [::tcl::source [lindex $args 0] [lindex $args 1] $orxonoxfile]
+# }
+# } else {
+# return [::tcl::source $args]
+# }
+#}
+
+
+# Redefines puts to write directly into the Orxonox console if the channel is stdout or stderr.
+
+if {[llength [info command ::tcl::puts]] == 0} {
+ rename puts ::tcl::puts
+}
+proc puts args {
+ set argc [llength $args]
+ if {$argc < 1 || $argc > 3} {
+ error "wrong # args: should be \"puts ?-nonewline? ?channelId? string\""
+ }
+
+ set newline 1
+ set input $args
+
+ if {$argc > 1 && [lindex $input 0] == "-nonewline"} {
+ set newline 0
+ set input [lrange $input 1 end]
+ } elseif {$argc == 3} {
+ if {[lindex $input 2] == "nonewline"} {
+ set newline 0
+ set input [lrange $input 0 1]
+ } else {
+ error "bad argument \"[lindex $input 2]\": should be \"nonewline\""
+ }
+ }
+
+ if {[llength $input] == 1} {
+ set input [list stdout [join $input]]
+ }
+
+ foreach {channel s} $input break
+
+ if {$channel == "stdout" || $channel == "stderr"} {
+ execute puts $newline $s
+ } else {
+ ::tcl::puts $args
+ }
+}
+
+
+# Redefines unknown to send unknown commands back to orxonox
+
+if {[llength [info commands unknown]] != 0} {
+ # check if a command named "undefined_proc" exists, if yes rename it temporarily
+ set undefined_was_defined 0
+ if {[llength [info commands undefined_proc]] != 0} {
+ set undefined_was_defined 0
+ rename undefined_proc _undefined
+ }
+
+ # get the returned errormessage if an undefined_proc command is called
+ if {[llength [info commands ::tcl::unknown]] == 0} {
+ set errorcode [catch {unknown undefined_proc} result options]
+ } else {
+ set errorcode [catch {::tcl::unknown undefined_proc} result options]
+ }
+
+ if {$errorcode} {
+ set result_list [split $result]
+ set ::orxonox::errormessage_unknown [list]
+
+ # parse the error message (the original message was something like "invalid command name "undefined_proc"" but we just want "invalid command name")
+ foreach token $result_list {
+ if {![string match "*undefined_proc*" $token]} {
+ lappend ::orxonox::errormessage_unknown $token
+ }
+ }
+
+ unset result_list
+ unset token
+
+ set ::orxonox::errormessage_unknown_length [llength $::orxonox::errormessage_unknown]
+
+ # rename the original unknown procedure
+ if {[llength [info commands ::tcl::unknown]] == 0} {
+ rename unknown ::tcl::unknown
+ }
+
+ # define the modified version of unknown
+ proc unknown args {
+ global ::orxonox::errormessage_unknown ::orxonox::errormessage_unknown_length
+
+ set errorcode [catch {::tcl::unknown $args} result options]
+ set resultlist [split $result]
+ set success 1
+
+ if {$errorcode && [llength $resultlist] >= $::orxonox::errormessage_unknown_length} {
+ for {set i 0} {$i < $::orxonox::errormessage_unknown_length} {incr i} {
+ if {[lindex $::orxonox::errormessage_unknown $i] != [lindex $resultlist $i]} {
+ set success 0
+ tcl::puts "not equal"
+ break
+ }
+ }
+ }
+
+ if {!$success} {
+ return -code $errorcode -options $options $result
+ } else {
+ return [query $args]
+ }
+ }
+
+ set success 1
+ } else {
+ set success 0
+ }
+
+ unset errorcode
+ unset result
+ unset options
+
+ # if the "undefined_proc" command was renamed previously, undo this
+ if {$undefined_was_defined} {
+ rename _undefined undefined_proc
+ }
+
+ unset undefined_was_defined
+
+ if {!$success} {
+ unset success
+ # something went wrong, use the default method
+ proc unknown args {
+ return [query $args]
+ }
+ }
+ unset success
+} else {
+ # no original unknown procedure defined, use the default method
+ proc unknown args {
+ return [query $args]
+ }
+}
Added: media/tcl/irc.tcl
===================================================================
--- media/tcl/irc.tcl (rev 0)
+++ media/tcl/irc.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,6 @@
+proc every {ms body} { eval $body; after $ms [list every $ms $body] }
+package require irk
+set conn [irk::connect orxonox $nickname]
+irk::join $conn #orxonox
+every 25 {}
+vwait termination
Added: media/tcl/irk/README
===================================================================
--- media/tcl/irk/README (rev 0)
+++ media/tcl/irk/README 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,76 @@
+IRK README
+==========
+
+Welcome to IRK, a Tcl IRC client library. IRK is intended for Tcl
+programmers that want to use the IRC protocol for communication. It
+can be used to ease the creation of IRC "bots", as shown by the
+examples in the examples directory, and it can also serve as the basis
+for graphical chat clients. Finally, it can be used to allow IRKs to
+find each other without centralized coordination, by meeting on a
+designated IRC server and channel. It is therefore ideal for setting
+up the initial contact for P2P programs without requiring a central
+registry or server.
+
+LICENSE
+=======
+
+IRK is distributed under the BSD license, the same license as Tcl.
+
+INSTALLATION
+============
+
+IRK is written in pure Tcl, which means it requires no extensions. It
+works with Tcl 8.0 and all later releases of Tcl.
+
+IRK has been tested on Solaris 7, Red Hat Linux 7.2, Windows 98,
+Windows 2000 and FreeBSD 4.2. It should work on any platform that is
+able to support Tcl 8.0 or later.
+
+Just drop this directory into one of the directories in Tcl's auto
+path. In your Tcl scripts, add the line:
+
+ package require irk
+
+and the IRK package should load into your Tcl interpreter.
+
+USAGE
+=====
+
+Read docs/usage.txt for a short overview of the commands provided by
+IRK.
+
+RECENT CHANGES AND CURRENT VERSION
+==================================
+
+Please read docs/changes.txt to see a list of all changes, ordered
+chronologically by release.
+
+REQUIREMENTS
+============
+
+IRK is event driven, and it requires the event loop to be active. If
+you want to use IRK from tclsh or other programs embedding a Tcl
+interpreter where the event loop is inactive, enter the event loop by
+adding the following line somewhere in your program:
+
+ vwait infinitely
+
+If you are using IRK in Wish, you do not need to take any action.
+
+TODO
+====
+
+Please docs/todo.txt for a list of planned enhancements.
+
+CREDITS AND CONTACT
+===================
+
+IRK benefited from examination of the Zircon and savIRC code written
+by Lindsay Marshall and Saverio Castellano, respectively. The future
+OO wrapper API is based on an idea suggested by Dave N. Welton.
+
+You can contact Jacob Levy, the author of IRK, at jyl at best.com. Please
+do drop a note if you use IRK, or if you have suggestions for
+enhancements, or if you run into problems.
+
+
Added: media/tcl/irk/docs/changes.txt
===================================================================
--- media/tcl/irk/docs/changes.txt (rev 0)
+++ media/tcl/irk/docs/changes.txt 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,22 @@
+IRK 0.01, 02/07/2002
+ This is the first release of IRK.
+
+ What's implemented:
+
+ * Connection management.
+ * Integrated support for SOCKS5 to get through firewalls.
+ * Rudimentary flow control and queueing. Needs more work.
+ * Ping, MOTD, and informational messages management.
+ * Channel and nick management.
+ * Users on channels tracking.
+ * CTCP and all its subcommands.
+ * Special CTCP TCL protocol for communication between IRKs. All Tcl code
+ received from remote IRKs is run in a safe interpreter.
+ * Generalized persistent authorization and password management mechanism.
+ * Two usage examples:
+ + tontalou.tcl: a "bot" modelled after SmallSaints on DalNet. This
+ bot is unfinished.
+ + fortunebot.tcl: a "bot" that demonstrates grabbing a page from
+ the web and presenting its information in IRC.
+ Unfortunately no documentation is provided for these bots but they do
+ provide excellent examples on how you can use IRK to write Tcl "bots".
Added: media/tcl/irk/docs/todo.txt
===================================================================
--- media/tcl/irk/docs/todo.txt (rev 0)
+++ media/tcl/irk/docs/todo.txt 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,10 @@
+TODO LIST FOR IRK
+=================
+
+* Implement DCC.
+* Implement object based command structure.
+* Implement event bindings modelled after the Tk Text widget.
+* Improve flow control.
+* Implement the last remaining RFC1439 protocol elements.
+* Implement proxy IRK commands for CTCP TCL safe interpreters.
+* Implement /mode commands.
Added: media/tcl/irk/docs/usage.txt
===================================================================
--- media/tcl/irk/docs/usage.txt (rev 0)
+++ media/tcl/irk/docs/usage.txt 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,59 @@
+A VERY ABBREVIATED INTRO TO IRK
+===============================
+
+All IRK commands are found within the ::irk namespace.
+
+To open a connection with an IRC server, use:
+
+ set conn [irk::connect twisted panda1]
+
+This opens a connection to the server named 'twisted' (This is
+actually the server twisted.ma.us.dal.net) with the nickname
+'panda1'. It also saves the connection token in the variable 'conn'
+for later use.
+
+If you're behind a SOCKS5 firewall, you can configure IRK to use a
+SOCKS5 proxy:
+
+ irk::config -sockproxy <proxyhost> -sockport <port>
+
+Do this before attempting to open connections to servers outside the
+firewall. After this step all communication with remote IRC servers
+goes through the SOCKS5 proxy. At present it is not possible to have
+connections simultaneously to IRC servers inside and outside the firewall.
+
+You can open any number of connections to different servers at the
+same time, limited only by the resources available on the host
+machine. Most IRC servers disallow opening two or more connections
+from the same user to a single server.
+
+Next, to join a channel, type:
+
+ irk::join $conn #mycoolchannel
+
+You can join any number of channels (no limits except those imposed by
+the server).
+
+To talk to a channel, do:
+
+ irk::say $conn #mycoolchannel {Wow, I'm on IRC!}
+
+The message "Wow, I'm on IRC!" (without the quotes) is sent to the
+channel #mycoolchannel.
+
+You can also send a private message to a specific nickname, via:
+
+ irk::say $conn somenick {Hey, I'm talking to you}
+
+To leave a channel use irk::leave. To close a connection with a server
+use irk::close. Read lib/irkcommand.tcl for all the commands
+provided. Full documentation will be provided eventually.
+
+The above API is likely to be subsumed by a more OO API that will look
+something like this:
+
+ set conn [irk::connect twisted panda1]
+ set mychan [$conn join #mycoolchannel]
+ $mychan say {Wow, I'm on IRC!}
+ set somenick [$conn user somenick]
+ $somenick say {Hey, I'm taling to you}
Added: media/tcl/irk/examples/fortunebot.tcl
===================================================================
--- media/tcl/irk/examples/fortunebot.tcl (rev 0)
+++ media/tcl/irk/examples/fortunebot.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,151 @@
+# fortunebot.tcl --
+#
+# Demo bot using the irc TCL client library. This is a VERY simple bot that
+# demonstrates some simple uses of the irc TCL library.
+#
+# The bot sits on any number of channels and networks. It periodically grabs
+# a fortune from a web site and sends the fortune with appropriate delays
+# between each line to all channels on all networks it is on.
+
+# Example use in Tcl:
+#
+# % source fortunebot.tcl
+# % set token [irc::connect ....]
+# % fortune::join $token #mychannel
+# % fortune::start 120
+#
+# What this does:
+# * Loads the bot, which in turn will load the IRC library and HTTP.
+# * Connect to IRC
+# * Send the bot to join #mychannel
+# * Start the bot, with 120 seconds delay. Now it'll do its actions every
+# 120 seconds.
+#
+# To stop the bot:
+#
+# % fortune::stop
+#
+# Make him leave a channel:
+#
+# % fortune::leave $token #mychannel
+
+package require irk
+package require http
+
+namespace eval fortune {
+ variable state
+
+ array set state {
+ linedelay 2000
+ fortuneurl http://www.earth.com/fortune
+ }
+}
+
+# Bot control:
+
+proc ::fortune::start {{delay 60}} {
+ variable state
+
+ # Compute the delay in milliseconds:
+
+ set state(delay) [expr $delay * 1000]
+
+ # Schedule the bot to run each $delay milliseconds:
+
+ set state(after) [after $state(delay) [list ::fortune::doquote]]
+}
+
+proc ::fortune::stop {} {
+ variable state
+
+ # Stop the bot if its running:
+
+ if {[info exists state(after)]} {
+ after cancel $state(after)
+ unset state(after)
+ }
+}
+
+
+# This is the actual body of the bot:
+#
+# Grab a quote from a web page and post it to all channels we're on:
+
+proc ::fortune::doquote {} {
+ variable state
+
+ # Grab the quote. The command callback does all the work:
+
+ http::geturl $state(fortuneurl) -command ::fortune::httpdone
+
+ # Finally reschedule ourselves, after events are one-shots
+
+ set state(after) [after $state(delay) [list ::fortune::doquote]]
+}
+
+proc ::fortune::httpdone {http} {
+ variable state
+ upvar #0 $http response
+
+ # Scrape the fortune off of the page:
+
+ set fortune [grabfortune $response(body)]
+
+ # Discard the HTTP array:
+
+ unset response
+
+ # Check if the quote is too long. If it is then punt.
+
+ if {[llength $fortune] > 3} {
+ return
+ }
+
+ # Say this quote on all channels on all connections we're on:
+
+ foreach conn [irk::connections] {
+ tell $fortune $conn
+ }
+}
+
+# This procedure scrapes the quote off of an HTML page:
+
+proc ::fortune::grabfortune {body} {
+ set body [split $body "\n"]
+ set beg [lsearch $body <PRE>]
+ set end [lsearch $body </PRE>]
+ return [lrange $body [expr $beg+1] [expr $end-1]]
+}
+
+# This procedure sends the quote to all channels we want the bot to be on:
+
+proc ::fortune::tell {fort conn} {
+ variable state
+
+ # Send the fortune to each channel we're on:
+
+ foreach chan [irk::onchannels $conn] {
+ tellchan $fort $conn $chan
+ }
+}
+
+# Asynchronously send lines to the channel:
+
+proc ::fortune::tellchan {fort conn channel} {
+ variable state
+
+ # Check if we are still on the channel:
+
+ if {![irk::onchannel $conn $channel]} {
+ return
+ }
+
+ # OK we're still on this channel, so say the current line and schedule
+ # the next line for later:
+
+ if {[llength $fort] > 0} {
+ irk::say $conn $channel [lindex $fort 0]
+ after $state(linedelay) \
+ [list ::fortune::tellchan [lrange $fort 1 end] $conn $channel]
+ }
+}
Added: media/tcl/irk/examples/mysaint.tcl
===================================================================
--- media/tcl/irk/examples/mysaint.tcl (rev 0)
+++ media/tcl/irk/examples/mysaint.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,277 @@
+# mysaint.tcl
+#
+# I got the inspiration to write this bot from the SmallSaints
+# bot on DalNet and the request of some Malay friends to create a clone.
+#
+# The bot sits on a channel and simply counts words that each user says.
+
+package require irk
+
+namespace eval ::mysaint {
+
+ variable state
+
+ set state(thisdir) [file dir [info script]]
+ set state(words,save) [file join $state(thisdir) savedwords.dat]
+ set state(save,interval) 30000
+
+ # For each identified user, there are several entries in the state array:
+ #
+ # state($user,words) How many words they have total.
+ # state($user,session) How many words they said this time.
+ # state($user,password) What's their password
+ # state($user,ident) What's their ident
+ #
+ # We also keep a mapping from nicknames to users:
+ #
+ # state($nick,user) What's the user mask associated with this
+ # nick name
+
+ proc initialize {} {
+ variable state
+ variable thisdir
+
+ # Set up a timer to save words:
+
+ set state(saver) [after $state(save,interval) ::mysaint::save]
+
+ # See if we have a saved words file. If so, read it in.
+
+ if {[file exists $state(words,save)]} {
+ uplevel #0 source $state(words,save)
+ }
+ }
+
+ proc userSays {token nick user comm dest rest} {
+ if {[string match "!*" [lindex $rest 0]]} {
+ userSaysCommand $token $dest $nick $user \
+ [lindex $rest 0] [lrange $rest 1 end]
+ } else {
+ userSaysWords $nick $user [llength $rest]
+ }
+ }
+
+ proc userSaysWords {nick user n} {
+ variable state
+
+ set seconds [clock seconds]
+ if {![info exists state($user,session,time)]} {
+ set state($user,session,time) [clock seconds]
+ }
+ set state($user,time) $seconds
+
+ if {![info exists state($user,session)]} {
+ set state($user,session) $n
+ } else {
+ incr state($user,session) $n
+ }
+ if {![info exists state($user,words)]} {
+ set state($user,words) $n
+ } else {
+ incr state($user,words) $n
+ }
+
+ set state($nick,user) $user
+ }
+
+ proc userSaysCommand {token dest nick user cmd rest} {
+ variable state
+
+ # Determine destination of any reply we're going to send:
+
+ if {![string compare $dest $state(nick)]} {
+ set dest $nick
+ }
+
+ switch -exact $cmd {
+ "!help" {userAsksHelp $token $nick}
+ "!time" {userAsksTime $token $nick $user $rest $dest}
+ "!heard" {userAsksHeard $token $nick $user $rest $dest}
+ "!words" {userAsksWords $token $nick $user $rest $dest}
+ "!donate" {userDonates $token $nick $user $rest $dest}
+ "!pass" {::irk::pass $token mysaint $nick $user $rest}
+ "!ident" {::irk::id $token mysaint $nick $user $rest}
+ "!newpass" {::irk::np $token mysaint $nick $user $rest}
+ }
+ }
+
+ proc userAsksHelp {token nick} {
+ ::irk::say $token $nick \
+ [list Hello $nick, the following commands are supported: ]
+ ::irk::say $token $nick "!help ---- prints this message"
+ ::irk::say $token $nick "!words --- how many words you have"
+ ::irk::say $token $nick "!donate -- to donate words to someone"
+ after 2000 [list ::irk::say $token $nick \
+ "!heard --- when did some speak last time"]
+ after 2500 [list ::irk::say $token $nick \
+ "!time ---- when someone connected"]
+ after 5000 [list ::irk::say $token $nick \
+ "Note: To donate you have to have a password"]
+ after 7500 [list ::irk::say $token $nick \
+ "Note: You can get a password with !pass"]
+ }
+
+ proc userAsksWords {token nick user rest dest} {
+ variable state
+
+ set target [lindex $rest 0]
+ if {[string compare $target ""]} {
+ if {[catch {set user $state($target,user)}]} {
+ set who "The unknown user $target"
+ set target "The unknown user $target"
+ } else {
+ set who $user
+ }
+ } else {
+ set who ""
+ }
+ if {[string compare $who ""]} {
+ if {[catch {set words $state($who,words)}]} {
+ set words 0
+ }
+ if {[catch {set session $state($who,session)}]} {
+ set session 0
+ }
+ set reply \
+ "$nick, $target has $session words now, total $words words"
+ } else {
+ if {[catch {set words $state($user,words)}]} {
+ set words 0
+ }
+ if {[catch {set session $state($user,session)}]} {
+ set session 0
+ }
+ set reply \
+ "$nick, you have $session words now, $words total words"
+ }
+ ::irk::say $token $dest $reply
+ }
+
+ proc userAsksHeard {token nick user rest dest} {
+ variable state
+
+ set target [lindex $rest 0]
+ if {[string compare $target ""]} {
+ if {[catch {set user $state($target,user)}]} {
+ set answer "I haven't heard $target speak recently."
+ } else {
+ set time $state($user,time)
+ set time [clock format $time]
+ set answer "I heard $target speak last at $time"
+ }
+ } else {
+ set answer "I'm talking to you just now, $nick"
+ }
+
+ ::irk::say $token $dest $answer
+ }
+
+ proc userAsksTime {token nick user rest dest} {
+ variable state
+
+ set target [lindex $rest 0]
+ if {[string compare $target ""]} {
+ if {[catch {set user $state($target,user)}]} {
+ set answer "I don't know when $target connected"
+ } else {
+ if {[catch {set time $state($user,session,time)}]} {
+ set answer "I don't know when $target connected"
+ } else {
+ set time [clock format $time]
+ set answer \
+ "I first noticed $target at $time"
+ }
+ }
+ } else {
+ if {[catch {set user $state($nick,user)}]} {
+ set answer "$nick, I don't know when you connected"
+ } else {
+ if {[catch {set time $state($user,session,time)}]} {
+ set answer "$nick, I don't know when you connected"
+ } else {
+ set time [clock format $time]
+ set answer \
+ "$nick, I first noticed you at $time"
+ }
+ }
+ }
+
+ ::irk::say $token $dest $answer
+ }
+
+ # Start the bot:
+
+ proc start {token} {
+ variable state
+
+ set state($token,token) $token
+
+ set symsrv $::irk::state($token,symsrv)
+ set state(nick) $::irk::state(-$symsrv,nick)
+ set nick $state(nick)
+
+ foreach chan [::irk::onchannels $token] {
+ ::irk::setaction2 $token PRIVMSG $chan ::mysaint::userSays
+ }
+ ::irk::setaction2 $token PRIVMSG $nick ::mysaint::userSays
+
+ # Set up a timer to save the words info.
+
+ if {![info exists state(saver)]} {
+ initialize
+ }
+
+ return ""
+ }
+
+ # Stop the bot:
+
+ proc stop {} {
+ variable state
+
+ foreach conn [array names state *,token] {
+ stopcon $state($conn)
+ }
+
+ after cancel $state(saver)
+ catch {unset state(saver)}
+
+ return ""
+ }
+ proc stopcon {token} {
+ variable state
+
+ if {[catch {set symsrv $::irk::state($token,symsrv)}]} {
+ return
+ }
+ set nick $state(nick)
+
+ foreach chan [::irk::onchannels $token] {
+ ::irk::remaction2 $token PRIVMSG $chan ::mysaint::userSays
+ }
+ ::irk::remaction2 $token PRIVMSG $nick ::mysaint::userSays
+
+ return ""
+ }
+
+ # Save words to a disk file:
+
+ proc save {} {
+ variable state
+
+ puts "Saving words in $state(words,save)"
+
+ # First of all reschedule ourselves:
+
+ set state(saver) [after $state(save,interval) ::mysaint::save]
+
+ # Save the words:
+
+ set pt "*,words"
+ if {![catch {set fd [open $state(words,save) w]}]} {
+ puts $fd "array set ::mysaint::state [list [array get state $pt]]"
+
+ catch {close $fd}
+ }
+ }
+}
Added: media/tcl/irk/irk.tcl
===================================================================
--- media/tcl/irk/irk.tcl (rev 0)
+++ media/tcl/irk/irk.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,24 @@
+# IRK: A client library for IRC programming written in Tcl.
+
+# We need the socks package to get through firewalls:
+
+package require socks
+
+# We provide the IRK package:
+
+package provide irk 0.1
+
+set thisdir [file dir [info script]]
+
+# Source the rest of the package:
+
+source [file join $thisdir lib irkstate.tcl]
+source [file join $thisdir lib irkconnect.tcl]
+source [file join $thisdir lib irkdispatch.tcl]
+source [file join $thisdir lib irkreceive.tcl]
+source [file join $thisdir lib irkcommand.tcl]
+source [file join $thisdir lib irkflow.tcl]
+source [file join $thisdir lib irkutil.tcl]
+source [file join $thisdir lib irkctcptcl.tcl]
+source [file join $thisdir lib irkauth.tcl]
+source [file join $thisdir lib irkservers.tcl]
Added: media/tcl/irk/lib/irkauth.tcl
===================================================================
--- media/tcl/irk/lib/irkauth.tcl (rev 0)
+++ media/tcl/irk/lib/irkauth.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,303 @@
+# irkauth.tcl:
+#
+# Various procedures that deal with user authentication:
+
+namespace eval ::irk {
+
+ # The AUTH module keeps information about each user and facility ($fac)
+ # in the state array:
+ #
+ # auth(auth,$fac,$user) If set, then $user has authenticated
+ # successfully for the facility $fac.
+ # auth(user,$fac,$user,pass) The password for this $user and $fac.
+ # auth(user,$fac,$user,ident) The ident token for this $user & $fac.
+ #
+ # auth(ident,$fac,$ident,pass) The password for this $ident and $fac.
+ # auth(ident,$fac,$ident,user) The user for this $ident and $fac.
+ #
+ # auth(identcounter,$fac) The ident token counter for $fac. This
+ # is incremented each time a new user
+ # establishes themselves with $fac.
+
+ # This procedure can be called by programs using the IRK library
+ # when a user sends a password.
+
+ proc pass {token fac nick user rest} {
+ variable auth
+
+ if {[llength $rest] != 1} {
+ # Incorrect syntax:
+
+ set reply "$nick, syntax is !pass <yourpass> (one word, no spaces)"
+ } elseif {[info exists auth(user,$fac,$user,pass)]} {
+
+ # If this user has already established a password,
+ # check that they're giving the right password.
+
+ if {[string compare $auth(user,$fac,$user,pass) \
+ [lindex $rest 0]]} {
+ set reply "$nick, sorry, wrong password!"
+ } else {
+ set reply "$nick, thanks for entering your password!"
+ set auth(auth,$fac,$user) 1
+ }
+ } else {
+
+ # This is the first time we're seeing this user. Accept
+ # their password and send them an ident token. They can
+ # use the ident token to reestablish themselves when their
+ # user mask changes significantly.
+
+ if {![info exists auth(identcounter,$fac)]} {
+ set auth(identcounter,$fac) 0
+ }
+ set ident $auth(identcounter,$fac)
+ incr auth(identcounter,$fac)
+
+ set auth(ident,$fac,$ident,user) $user
+ set auth(ident,$fac,$ident,pass) [lindex $rest 0]
+
+ set auth(user,$fac,$user,ident) $ident
+ set auth(user,$fac,$user,pass) [lindex $rest 0]
+
+ # Save the changes
+
+ saveauth
+
+ # Save them a step and also authorize them:
+
+ set auth(ident,$fac,$user) 1
+
+ set reply [list \
+ $nick, your password is [lindex $rest 0]. Your ident is \
+ $ident, write it down, you will need it later to \
+ reidentify yourself if your user mask changes. \
+ You user mask is currently $user. You are now authorised \
+ to use $fac.]
+ }
+
+ # Tell them what happened:
+
+ ::irk::say $token $nick $reply
+
+ return ""
+ }
+
+ # This procedure can be called by programs when the user attempts to
+ # reestablish themselves with the existing ident and password.
+
+ proc id {token fac nick user rest} {
+ variable auth
+
+ set len [llength $rest]
+ set reply "Wrong syntax. Call !ident or !ident <ident> <pass>"
+
+ if {$len == 0} {
+
+ # Calling ident with zero arguments. The user is trying to
+ # retrieve their ident. Give it to them only if they did
+ # identify successfully with the correct password.
+
+ if {![info exists auth(user,$fac,$user,pass)]} {
+ set reply "$nick, first set a password"
+ } elseif {[info exists auth(auth,$fac,$user)]} {
+ set reply \
+ "$nick, your ident is $auth(user,$fac,$user,ident)"
+ } else {
+ set reply \
+ "$nick, identify with password before getting your ident!"
+ }
+ } elseif {$len == 2} {
+
+ # Calling ident with two arguments. The user is trying to
+ # establish a new value for $user to associate with this
+ # ident and password. If $auth($ident,pass) is the password
+ # she gave, then they're the rightfull owner of the ident and
+ # so we now recognize the new $user mask.
+
+ set ident [lindex $rest 0]
+ set pass [lindex $rest 1]
+
+ if {[info exists auth(ident,$fac,$ident,pass)]} {
+ if {![string compare $auth(ident,$fac,$ident,pass) $pass]} {
+
+ # Identify the old user mask they were using:
+
+ set olduser $auth(ident,$fac,$ident,user)
+
+ # Clean up the state associated with the old mask:
+
+ array unset auth user,$fac,$olduser,*
+ catch {unset auth(ident,$face,$olduser)}
+
+ # Link up the new state:
+
+ set auth(ident,$fac,$ident,user) $user
+
+ set auth(user,$fac,$user,ident) $ident
+ set auth(user,$fac,$user,pass) $pass
+
+ # Save the changes
+
+ saveauth
+
+ # Save them a step and also treat them as authenticated:
+
+ set auth(ident,$fac,$user) 1
+
+ set reply \
+ "OK, $nick, I'm now recognising you as $user.\
+ You are now authorised to use $fac."
+ } else {
+ set reply "$nick, sorry, wrong ident or password"
+ }
+ } else {
+ set reply "$nick, sorry, wrong ident or password"
+ }
+ }
+
+ # Tell them what happened:
+
+ ::irk::say $token $nick $reply
+
+ return ""
+ }
+
+ # This procedure can be invoked by a program when a user tries to
+ # change her password.
+
+ proc np {token fac nick user rest} {
+ variable auth
+
+ set reply "Wrong syntax. Call !newpass <oldpass> <newpass>"
+
+ if {[llength $rest] == 2} {
+ set opw [lindex $rest 0]
+ set npw [lindex $rest 1]
+
+ if {![info exists auth(user,$fac,$user,pass)]} {
+ # Unknown $user, probably their user mask changed. Help
+ # them reestablish the connection.
+
+ set reply \
+ [list $nick, I don't have you in my database. Perhaps \
+ your user mask changed drastically. If so, please \
+ reestablish your user mask by using !ident <ident> \
+ <oldpass>.]
+ } elseif {[string compare $auth(user,$fac,$user,pass) $opw]} {
+ # Wrong old password!
+
+ set reply "$nick, sorry, wrong old password!"
+ } else {
+ # Their user mask matches and they gave the correct old
+ # password, so we accept their new password:
+
+ set ident $auth(user,$fac,$user,ident)
+
+ set auth(ident,$fac,$ident,pass) $npw
+ set auth(user,$fac,$user,pass) $npw
+
+ # Save the changes:
+
+ saveauth
+
+ # Save them a step by also recording that they
+ # authenticated:
+
+ set auth(auth,$fac,$user) 1
+
+ set reply "OK, $nick, your new password is now $npw"
+ }
+ }
+
+ # Tell them what happened:
+
+ ::irk::say $token $nick $reply
+
+ return ""
+ }
+
+ # This procedure can be called by programs when the user wants to
+ # "log out" or lose her authentication with a given facility:
+
+ proc logout {token fac nick user rest} {
+ variable auth
+
+ set reply "You were not logged into $fac. Now you certainly aren't."
+
+ if {[info exists auth(auth,$fac,$user)]} {
+ unset auth(auth,$fac,$user)
+
+ set reply \
+ [list $nick, you logged out successfully from $fac. Thank you \
+ for using $fac.]
+ }
+
+ # Tell them what happened:
+
+ ::irk::say $token $nick $reply
+
+ return ""
+ }
+
+ # Is the user authenticated with the given facility?
+
+ proc userauthenticated {fac user} {
+ variable auth
+
+ # If auth(auth,$fac,$user) exists, then she is authenticated.
+
+ if {[info exists auth(auth,$fac,$user)]} {
+ return 1
+ }
+ return 0
+ }
+
+ # This procedure automatically saves the authorization database:
+
+ proc saveauth {} {
+ variable state
+ variable auth
+
+ puts "Saving!"
+
+ # Define the patterns to save:
+
+ set p1 "identcounter,*"
+ set p2 "user,*"
+ set p3 "ident,*"
+
+ # Try to open the save file:
+
+ if {[info exists state(auth,save,file)]} {
+ if {![catch {set fd [open $state(auth,save,file) w]}]} {
+ puts $fd "array set ::irk::auth [list [array get auth $p1]]"
+ puts $fd "array set ::irk::auth [list [array get auth $p2]]"
+ puts $fd "array set ::irk::auth [list [array get auth $p3]]"
+
+ catch {close $fd}
+ }
+ }
+ }
+
+ # This procedure restores the authorization database:
+
+ proc restoreauth {} {
+ variable state
+
+ if {[info exists state(auth,save,file)]} {
+ catch {uplevel #0 source $state(auth,save,file)}
+ }
+ set state(auth,restored) 1
+ }
+
+ # If this is the first time we're loading the IRK package, then
+ # restore the authorization database. Otherwise we'd be overwriting
+ # a potentially unsaved state.
+
+ variable state
+
+ if {![info exists state(auth,restored)]} {
+ restoreauth
+ }
+}
Added: media/tcl/irk/lib/irkcommand.tcl
===================================================================
--- media/tcl/irk/lib/irkcommand.tcl (rev 0)
+++ media/tcl/irk/lib/irkcommand.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,420 @@
+# irkcommand.tcl:
+#
+# Various commands that can be invoked by the user of the IRK library:
+
+namespace eval irk {
+
+ # Say something to a user or to a channel
+
+ proc say {token chan saying} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid irc connection"
+ }
+ if {![string compare "" $saying]} {
+ return
+ }
+ sendit $sock "PRIVMSG $chan :[string trim $saying]"
+ }
+
+ # Send a NOTICE to a user or a channel
+
+ proc notice {token chan args} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid irc connection"
+ }
+ sendit $sock "NOTICE $chan :$args"
+ }
+
+ # Send a raw command to the server:
+
+ proc send {token args} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid irc connection"
+ }
+ puts $sock $args
+ }
+
+ # Change your NICK
+
+ proc nick {token {newnick ""}} {
+ variable state
+
+ if {![string compare "" $newnick]} {
+ return $state($token,nick)
+ }
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid irc connection"
+ }
+ puts $sock "NICK $newnick"
+ }
+
+ # Join a channel
+
+ proc join {token chans {keys ""}} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid irc connection"
+ }
+ puts $sock "JOIN $chans $keys"
+ }
+
+ # Leave a channel
+
+ proc leave {token chans {partmsg ""}} {
+ variable state
+
+ if {![string compare $partmsg ""]} {
+ if {[info exists state(partmsg)]} {
+ set partmsg $state(partmsg)
+ }
+ }
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid irc connection"
+ }
+ puts $sock "PART $chans $partmsg"
+ }
+
+ # Return a list of all connections that are open:
+
+ proc connections {} {
+ variable state
+
+ if {![info exists state(connections)]} {
+ return {}
+ }
+ return $state(connections)
+ }
+
+ # Return a list of channels we're on in a give connection:
+
+ proc onchannels {token} {
+ variable state
+
+ if {![info exists state($token,channels)]} {
+ return {}
+ }
+ return $state($token,channels)
+ }
+
+ # Returns 1 if we are on the given channel.
+
+ proc onchannel {token channel} {
+ variable state
+
+ if {![info exists state($token,channels)]} {
+ return 0
+ }
+
+ set idx [lsearch $state($token,channels) $channel]
+ if {$idx == -1} {
+ return 0
+ }
+ return 1
+ }
+
+ # Return a list of users on a given channel (we must be on that channel).
+
+ proc whoison {token chan} {
+ variable state
+
+ if {![info exists state($token,$chan,NAMES)]} {
+ return {}
+ }
+ return $state($token,$chan,NAMES)
+ }
+
+ # Ping a server
+
+ proc ping {token} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid irc connection"
+ }
+ set state($token,PINGSTART) [clock clicks -millis]
+ puts $sock "PING $state($token,host)"
+ }
+
+ # Quit this connection
+
+ proc quit {token} {
+ disconnect $token
+ }
+
+ # Query information about someone
+
+ proc whois {token nick} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid irc connection"
+ }
+ puts $sock "WHOIS $nick"
+ }
+
+ # Set an away message
+
+ proc away {token args} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid irc connection"
+ }
+ puts $sock "AWAY :$args"
+ }
+
+ # This procedure lets the client do CTCP actions:
+
+ proc ctcp {token target action args} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid irc connection"
+ }
+ sendit $sock "PRIVMSG $target :\001$action $args\001"
+ }
+
+ # This command implements the TCL CTCP protocol:
+
+ proc tcl {token target args} {
+ variable state
+
+ # Send it to the channel:
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid irc connection"
+ }
+ sendit $sock "PRIVMSG $target :\001TCL $args\001"
+
+ # Apply it locally:
+
+ if {[info exists state($token,channel,ctcp,TCL,LOCAL)]} {
+ $state($token,channel,ctcp,TCL,LOCAL) \
+ $token $state($token,nick) $state($token,user) \
+ PRIVMSG $target TCL $args
+ }
+ }
+
+ # These procedures add and remove action handlers:
+
+ # These procedures add actions that will be called when the user
+ # with the given nick causes the supplied comm(and) to be executed
+ # on the given dest(ination). This is the most specific form of action.
+
+ proc addaction3 {token nick comm dest cmd} {
+ variable state
+
+ if {![info exists state($token,$nick,$comm,$dest)]} {
+ set state($token,$nick,$comm,$dest) [list $cmd]
+ } else {
+ lappend state($token,$nick,$comm,$dest) $cmd
+ }
+ }
+
+ proc setaction3 {token nick comm dest cmd} {
+ variable state
+
+ set state($token,$nick,$comm,$dest) [list $cmd]
+ }
+
+ # This procedure removes an action set by either of the above two
+ # procedures.
+
+ proc remaction3 {token nick comm dest cmd} {
+ variable state
+
+ if {![info exists state($token,$nick,$comm,$dest)]} {
+ return
+ }
+ set cmds $state($token,$nick,$comm,$dest)
+ set idx [lsearch $cmds $cmd]
+ if {$idx == -1} {
+ return
+ }
+ set state($token,$nick,$comm,$dest) [lreplace $cmds $idx $idx]
+ if {![string compare "" $state($token,$nick,$comm,$dest)]} {
+ unset state($token,$nick,$comm,$dest)
+ }
+ }
+
+ # These procedures add actions that will be called when the
+ # specific comm(and) is caused for the given dest(ination).
+
+ proc addaction2 {token comm dest cmd} {
+ variable state
+
+ if {![info exists state($token,$comm,$dest)]} {
+ set state($token,$comm,$dest) [list $cmd]
+ } else {
+ lappend state($token,$comm,$dest) $cmd
+ }
+ }
+
+ proc setaction2 {token comm dest cmd} {
+ variable state
+
+ set state($token,$comm,$dest) [list $cmd]
+ }
+
+ # This procedure removes an action set by either of the above two
+ # procedures.
+
+ proc remaction2 {token comm dest cmd} {
+ variable state
+
+ if {![info exists state($token,$comm,$dest)]} {
+ return
+ }
+ set cmds $state($token,$comm,$dest)
+ set idx [lsearch $cmds $cmd]
+ if {$idx == -1} {
+ return
+ }
+ set state($token,$comm,$dest) [lreplace $cmds $idx $idx]
+ if {![string compare "" $state($token,$comm,$dest)]} {
+ unset state($token,$comm,$dest)
+ }
+ }
+
+ # These procedures add actions that will be called when the
+ # specific comm(and) is caused any dest(ination).
+
+ proc addaction1 {token comm cmd} {
+ variable state
+
+ if {![info exists state($token,$comm)]} {
+ set state($token,$comm) [list $cmd]
+ } else {
+ lappend state($token,$comm) $cmd
+ }
+ }
+
+ proc setaction1 {token comm cmd} {
+ variable state
+
+ set state($token,$comm) [list $cmd]
+ }
+
+ # This procedure removes an action set by either of the above two
+ # procedures.
+
+ proc remaction1 {token comm cmd} {
+ variable state
+
+ if {![info exists state($token,$comm)]} {
+ return
+ }
+ set cmds $state($token,$comm)
+ set idx [lsearch $cmds $cmd]
+ if {$idx == -1} {
+ return
+ }
+ set state($token,$comm) [lreplace $cmds $idx $idx]
+ if {![string compare "" $state($token,$comm)]} {
+ unset state($token,$comm)
+ }
+ }
+
+ # These procedures add global actions that will be called
+ # when the specific comm(and) is caused on any dest(ination) and
+ # any irc connection. These are the lowest priority commands.
+
+ proc addactionglobal {comm cmd} {
+ variable state
+
+ if {![info exists state(cmd,$comm)]} {
+ set state(cmd,$comm) [list $cmd]
+ } else {
+ lappend state(cmd,$comm) $cmd
+ }
+ }
+
+ proc setactionglobal {comm cmd} {
+ variable state
+
+ set state(cmd,$comm) [list $cmd]
+ }
+
+ # This procedure removes an action set by either of the above two
+ # procedures.
+
+ proc remactionglobal {comm cmd} {
+ variable state
+
+ if {![info exists state(cmd,$comm)]} {
+ return
+ }
+ set cmds $state(cmd,$comm)
+ set idx [lsearch $cmds $cmd]
+ if {$idx == -1} {
+ return
+ }
+ set state(cmd,$comm) [lreplace $cmds $idx $idx]
+ if {![string compare "" $state(cmd,$comm)]} {
+ unset state(cmd,$comm)
+ }
+ }
+
+ # This procedure manages configuration information for IRC:
+
+ proc config {args} {
+ if {$args == {}} {
+ return [collectConfig]
+ }
+
+ if {[llength $args] == 1} {
+ return [queryConfig [lindex $args 0]]
+ }
+
+ if {[expr [llength $args] % 2] != 0} {
+ error "incorrect number of argument, must be multiple of 2"
+ }
+
+ setConfig $args
+ }
+
+ # Helper procedure to return a list with all important user settable
+ # configuration information.
+
+ proc collectConfig {} {
+ variable state
+
+ set config {}
+
+ foreach name [array names state "-*"] {
+ lappend config [list $name $state($name)]
+ }
+ return $config
+ }
+
+ # Helper procedure to return the value of one option.
+
+ proc queryConfig {option} {
+ variable state
+
+ if {![info exists state($option)]} {
+ return {}
+ }
+ return $state($option)
+ }
+
+ # Helper procedure to modify the configuration of a set of options.
+
+ proc setConfig {theargs} {
+ variable state
+
+ foreach {opt val} $theargs {
+ if {![string match "-*" $opt]} {
+ continue
+ }
+ set state($opt) $val
+ }
+ }
+}
Added: media/tcl/irk/lib/irkconnect.tcl
===================================================================
--- media/tcl/irk/lib/irkconnect.tcl (rev 0)
+++ media/tcl/irk/lib/irkconnect.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,239 @@
+# irkconnect.tcl:
+#
+# This file provides the IRK commands to connect to remote servers
+# as well as some attendant utility procedures:
+
+namespace eval ::irk {
+
+ # The "connect" procedure returns a token
+ # for the connection to this server.
+ #
+ # symsrv The symbolic name of the server to connect to.
+ # nick The nick name to use.
+ # user The user name to use.
+ # pass The password to use.
+ # disp The command dispatcher expression to use.
+
+ proc connect {{symsrv ""} {nick ""} {user ""} {pass ""} {disp ""}} {
+ variable state
+
+ # Auto initialize the list of connections. We do this so that
+ # the list is not reset each time the irk.tcl file is sourced.
+
+ if {![info exists state(connections)]} {
+ set state(connections) {}
+ }
+
+ # Try to convert the symbolic server name to a
+ # server description. This may throw an error,
+ # we propagate it.
+
+ set servdesc [locate $symsrv]
+
+ # If the nickname is not specified, there must be
+ # a nick setting in the state array; use that
+
+ if {![string compare $nick ""]} {
+ if {![info exists state(-$symsrv,nick)]} {
+ error "No nick given or set in global state"
+ }
+ set nick $state(-$symsrv,nick)
+ }
+
+ # If a global nick is not set, save this nick for use
+ # as a global nick.
+
+ if {![info exists state(-$symsrv,nick)]} {
+ set state(-$symsrv,nick) $nick
+ }
+
+ # If user is not supplied, see if there is a global
+ # user registered in the IRK package state. If not,
+ # invent a user.
+
+ if {![string compare $user ""]} {
+ if {[info exists state(-$symsrv,user)]} {
+ set user $state(-$symsrv,user)
+ } else {
+ set user $nick
+ set state(-$symsrv,user) $user
+ }
+ }
+
+ # If a password is not supplied, see if there is a global
+ # one registered. If so, use that. Otherwise, do not
+ # use a password.
+
+ if {![string compare $pass ""]} {
+ if {[info exists state(-$symsrv,pass)]} {
+ set pass $state(-$symsrv,pass)
+ }
+ }
+
+ # If a dispatcher expression is not supplied, there must be a
+ # global dispatcher expression in the state array, and use that.
+
+ if {![string compare $disp ""]} {
+ if {![info exists state(dispatcher)]} {
+ error "ERROR: o dispatch given or found in global state"
+ }
+ set disp $state(dispatcher)
+ }
+
+ # Try to connect to the given server.
+
+ set h [lindex $servdesc 0]
+ set p [randselect [lindex $servdesc 1]]
+
+ set s [opensocket $h $p]
+
+ # The socket is line buffered and consumed by the
+ # supplied consumer
+
+ fconfigure $s -translation auto -buffering line
+ fileevent $s readable [list ::irk::consumer $s]
+
+
+ # Identify ourselves to the IRK server: If a password is given
+ # send that first. Then send the nick name and user name.
+
+ if {[string compare $pass ""]} {
+ puts $s "PASS $pass"
+ }
+
+ puts $s "NICK $nick"
+ puts $s "USER $user $h $h :$user"
+
+ # Make a connection token:
+
+ set contok [contok $s $symsrv]
+
+ # Save the state for this new connection
+
+ lappend state(connections) $contok
+
+ set state($contok,port) $p
+ set state($contok,host) $h
+ set state($contok,symsrv) $symsrv
+ set state($contok,nick) $nick
+ set state($contok,user) $user
+ set state($contok,pass) $pass
+ set state($contok,disp) $disp
+
+ # Set up some default behavior for the connection:
+
+ setupDefaultActions $contok $nick
+
+ # Collect information about who the server thinks we are
+
+ puts $s "WHOIS $nick"
+
+ # Finally return the token for this connection:
+
+ return $contok
+ }
+
+ # This procedure makes an easy to remember connection token. It takes
+ # the symbolic server's name and appends _<n> to it, where n is an
+ # integer starting at 0 and monotonically increasing for every new
+ # connection to that server.
+ #
+ # Once it figures out what the connection token is going to be,
+ # it associates it with the given socket so it can be used.
+
+ proc contok {sock symsrv} {
+ variable state
+
+ # Compute the symbolic name for this connection:
+
+ if {![info exists state($symsrv,counter)]} {
+ set state($symsrv,counter) 0
+ }
+ set contok ${symsrv}_$state($symsrv,counter)
+ incr state($symsrv,counter)
+
+ # Associate the symbolic name with the socket:
+
+ set state($contok,socket) $sock
+ set state($sock,contok) $contok
+
+ return $contok
+ }
+
+ # The locate procedure tries to convert the symbolic name for
+ # a connection to a server/port specification.
+
+ proc locate {s} {
+ variable symsrv
+ variable state
+
+ # If the caller specified "" as the name of the server, select
+ # a random one from the list of known servers.
+
+ if {![string compare $s ""]} {
+ set s [randselect $state(servers)]
+ }
+
+ # Now see if the requested server exists:
+
+ if {![info exists symsrv($s)]} {
+ error \
+ "Could not find a match for symbolic IRK server name \"$s\""
+ }
+
+ # It does, return the server specification:
+
+ return $symsrv($s)
+ }
+
+ # opensocket connects to the requested server and port, either
+ # directly or through a SOCKS5 proxy.
+
+ proc opensocket {server port} {
+ variable state
+
+ if {[info exists state(-socksproxy)] \
+ && [info exists state(-socksport)]} {
+ set sock [socket $state(-socksproxy) $state(-socksport)]
+ return [::socks::init $sock $server $port]
+ }
+
+ return [socket $server $port]
+ }
+
+ # The disconnect procedure disconnects from a given connection
+ # identified by its symbolic name, and cleans up state associated
+ # with the connection.
+
+ proc disconnect {contok} {
+ variable state
+
+ if {[catch {set s $state($contok,socket)} err]} {
+ error "ERROR: $contok: No such IRC connection"
+ }
+
+ # Send a QUIT message.
+
+ if {[info exists state(quitmsg)]} {
+ set q ":$state($contok,nick) $state(quitmsg)"
+ } else {
+ set q ":$state($contok,nick) quit"
+ }
+ puts $s "QUIT $q"
+
+ # Try to close the connection with the server.
+
+ catch {close $s}
+
+ # And clean up all state associated with this connection:
+
+ array unset state $contok,*
+
+ # Remove this connection from the list of active connections:
+
+ set i [lsearch $state(connections) $s]
+ set state(connections) [lreplace $state(connections) $i $i]
+
+ return ""
+ }
+}
Added: media/tcl/irk/lib/irkctcptcl.tcl
===================================================================
--- media/tcl/irk/lib/irkctcptcl.tcl (rev 0)
+++ media/tcl/irk/lib/irkctcptcl.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,45 @@
+# irkctcptcl.tcl:
+#
+# This file implements the IRK CTCP TCL protocol:
+
+namespace eval ::irk {
+
+ # This procedure sets up a safe interpreter for the channel in which
+ # the CTCP TCL action occurs:
+
+ proc setupInterp {token chan} {
+ variable state
+
+ if {![info exists state($token,$chan,interp)]} {
+ catch {interp delete ${token}${chan}}
+ set state($token,$chan,interp) [safe::interpCreate ${token}${chan}]
+ safe::loadTk $state($token,$chan,interp)
+ }
+ if {![interp exists ${token}${chan}]} {
+ set state($token,$chan,interp) [safe::interpCreate ${token}${chan}]
+ safe::loadTk $state($token,$chan,interp)
+ }
+ }
+
+ # This procedure dispatches the Tcl command embedded within the
+ # CTCP TCL action to the associated interpreter:
+
+ proc RECV,CTCP,TCL {token nick user comm dest action rest} {
+ variable state
+
+ puts stderr "Tcl command is: $rest [llength $rest]"
+ setupInterp $token $dest
+ interp eval $state($token,$dest,interp) [::join $rest]
+ }
+
+ # This procedure dispatches the Tcl command embedded within the
+ # CTCP TCL action for local execution on the issuer's side:
+
+ proc RECV,CTCP,TCL,LOCAL {token nick user comm dest action rest} {
+ variable state
+
+ puts stderr "Tcl command is: $rest [llength $rest]"
+ setupInterp $token $dest
+ interp eval $state($token,$dest,interp) $rest
+ }
+}
Added: media/tcl/irk/lib/irkdispatch.tcl
===================================================================
--- media/tcl/irk/lib/irkdispatch.tcl (rev 0)
+++ media/tcl/irk/lib/irkdispatch.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,248 @@
+# irkdispatch.tcl:
+#
+# Based on the input received from the server, dispatch control to various
+# command procedures.
+
+namespace eval ::irk {
+
+ # This procedure sets up the default actions for a connection:
+
+ proc setupDefaultActions {s nick} {
+ variable state
+
+ # Catch any unexpected PRIVMSG actions:
+
+ set state($s,PRIVMSG,$nick) $state(PRIVMSG,unsolicited)
+
+ # Set up CTCP global actions:
+
+ set state($s,cmd,ctcp,PING) ::irk::RECV,CTCP,PING
+ set state($s,cmd,ctcp,TIME) ::irk::RECV,CTCP,TIME
+ set state($s,cmd,ctcp,VERSION) ::irk::RECV,CTCP,VERSION
+ set state($s,cmd,ctcp,USERINFO) \
+ ::irk::RECV,CTCP,USERINFO
+
+ # Set up CTCP channel specific actions:
+
+ set state($s,channel,ctcp,ACTION) \
+ ::irk::RECV,CTCP,ACTION
+
+ # Set up the CTCP TCL protocol:
+
+ set state($s,channel,ctcp,TCL) ::irk::RECV,CTCP,TCL
+ set state($s,channel,ctcp,TCL,LOCAL) \
+ ::irk::RECV,CTCP,TCL,LOCAL
+
+ # Deal with CTCP commands we do not understand:
+
+ set state($s,cmd,ctcp,error) ::irk::RECV,CTCP,ERROR
+ set state($s,channel,ctcp,error) \
+ ::irk::RECV,CTCP,ERROR
+ }
+
+ # The consumer procedure consumes input received from
+ # a connection. It calls the dispatcher for the given connection
+ # with each input line.
+
+ proc consumer {s} {
+ variable state
+
+ if {[eof $s]} {
+ disconnect $s
+ } else {
+ set l [gets $s]
+ if {[info exists state($s,trace)]} {
+ $state($s,trace) $l
+ }
+ if {[string compare $l ""]} {
+ dissect $state($s,contok) $l
+ }
+ }
+ }
+
+ # This procedure dissects the input into its parts:
+
+ proc dissect {token line} {
+ variable state
+
+ # Make a list out of the line:
+
+ set line [split $line " "]
+
+ # Split first token into nickname and user mask:
+
+ set nandu [split [lindex $line 0] \!]
+
+ # Call dispatcher for this connection:
+
+ $state($token,disp) \
+ $token \
+ [lindex $nandu 0] \
+ [lindex $nandu 1] \
+ [lindex $line 1] \
+ [lindex $line 2] \
+ [lrange $line 3 end]
+ }
+
+ # This procedure is the default command dispatcher:
+
+ proc defaultDispatcher {token nick user comm dest rest} {
+ variable state
+
+ # Check if the nick starts with ':'. If not then this is
+ # a special action, handled by the built in actions.
+
+ if {![string match ":*" $nick]} {
+ return [specialAction $token $nick $user $comm $dest $rest]
+ }
+
+ # Trim off the leading ':' on the $nick, if present.
+
+ if {[string match ":*" $nick]} {
+ set nick [string range $nick 1 end]
+ }
+
+ # If a ':' is present in the $dest, trim that off too.
+
+ if {[string match ":*" $dest]} {
+ set dest [string range $dest 1 end]
+ }
+
+ # If a ':' is present in the $rest, trim that off too.
+
+ set firstrest [lindex $rest 0]
+ if {[string match ":*" $firstrest]} {
+ set firstrest [string range $firstrest 1 end]
+ set rest [lreplace $rest 0 0 $firstrest]
+ }
+
+ # Clean up the payload:
+
+ set rest [split [string trim [eval concat $rest]] " "]
+
+ # Now try to dispatch to specific handlers.
+ #
+ # First see if there is a handler for the specific combination
+ # of $token, $nick, $comm and $dest. This is used for PRIVMSG.
+
+ if {[info exists state($token,$nick,$comm,$dest)]} {
+ foreach cmd $state($token,$nick,$comm,$dest) {
+ if {[catch {set res [$cmd $token $nick $user \
+ $comm $dest $rest]} err]} {
+ if {[info exists state(errorhandler)]} {
+ $state(errorhandler) $err $token $comm $dest
+ }
+ return
+ }
+
+ # If this handler said to go on to a more general handler,
+ # then don't return. Otherwise return.
+
+ if {[string compare $res pass]} {
+ return
+ }
+ }
+ }
+
+ # If there's a handler for $token, $comm and $dest, use that.
+
+ if {[info exists state($token,$comm,$dest)]} {
+ foreach cmd $state($token,$comm,$dest) {
+ if {[catch {set res [$cmd $token $nick $user \
+ $comm $dest $rest]} err]} {
+ if {[info exists state(errorhandler)]} {
+ $state(errorhandler) $err $token $comm $dest
+ }
+ return
+ }
+
+ # If this handler said to go on to a more general handler,
+ # then don't return. Otherwise return.
+
+ if {[string compare $res pass]} {
+ return
+ }
+ }
+ }
+
+ # See if there's a handler for $token and $comm. If so use that.
+
+ if {[info exists state($token,$comm)]} {
+ foreach cmd $state($token,$comm) {
+ if {[catch {set res [$cmd $token $nick $user \
+ $comm $dest $rest]} err]} {
+ if {[info exists state(errorhandler)]} {
+ $state(errorhandler) $err $token $comm $dest
+ }
+ return
+ }
+
+ # If this handler said to go on to a more general handler,
+ # then don't return. Otherwise return.
+
+ if {[string compare $res pass]} {
+ return
+ }
+ }
+ }
+
+ # See if there's a global handler for the command. All the
+ # default handlers are defined here.
+
+ if {[info exists state(cmd,$comm)]} {
+ foreach cmd $state(cmd,$comm) {
+ if {[catch {set res [$cmd $token $nick $user \
+ $comm $dest $rest]} err]} {
+ if {[info exists state(errorhandler)]} {
+ $state(errorhandler) $err $token $comm $dest
+ }
+ return
+ }
+
+ # If this handler said to go on to a more general handler,
+ # then don't return. Otherwise return.
+
+ if {[string compare $res pass]} {
+ return
+ }
+ }
+ }
+
+ # If all of the above fail, send this input to the default
+ # action handler:
+
+ if {[catch {set res [$state(action) \
+ $token $nick $user \
+ $comm $dest $rest]} err]} {
+ if {[info exists state(errorhandler)]} {
+ $state(errorhandler) $err $token $comm $dest
+ }
+ return
+ }
+ }
+
+ # This procedure deals with special actions (built in, cannot
+ # easily be modified by users). I use this to e.g deal with
+ # PING, NOTICE, ERROR etc., automatically.
+
+ proc specialAction {token nick user comm dest rest} {
+ variable state
+
+ # The nick is the special action selector:
+
+ $state(special,$nick) $token $nick $user $comm $dest $rest
+ }
+
+ # This is the default error handler:
+
+ proc echoerror {args} {
+ puts stderr $args
+ }
+
+ # This procedure provides a default tracing facility (it just prints
+ # the lines received to stderr):
+
+ proc trace {args} {
+ puts stderr "Received: $args"
+ }
+}
Added: media/tcl/irk/lib/irkflow.tcl
===================================================================
--- media/tcl/irk/lib/irkflow.tcl (rev 0)
+++ media/tcl/irk/lib/irkflow.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,102 @@
+# irkflow.tcl
+#
+# Simple flow control management so as to avoid flooding.
+
+namespace eval ::irk {
+
+ # For each combination of destination+connection, we keep three items:
+ #
+ # flowctl($dest,$conn,after) The "after" token for the next time
+ # we send anything to this destination.
+ # flowctl($dest,$conn,queue) A list of items to send to this
+ # destination on this connection.
+ # flowctl($dest,$conn,lastsend) The time we last sent to this
+ # destination on this connection.
+ #
+ # NOTE: We do not limit the length of each item to send. This
+ # would lead to extremely hard to diagnose bugs due to commands
+ # (e.g. ctcp's) getting cut up into chunks.
+
+ variable flowctl
+
+ # The following setting controls how often (in msecs) we can send
+ # to a given connection. It should not be modified by user code or
+ # flooding may occur.
+
+ set flowctl(floodlimit) 1500
+
+ # This procedure sends an item to a specific destination+connection.
+ # If possible, the item is sent right away. Otherwise it is enqueued
+ # for later sending.
+
+ proc sendit {conn item} {
+ variable flowctl
+
+ # If this connection has a backlog, append the new
+ # items. Otherwise, check if the previous send was
+ # less than flowctl(floodlimit) msecs ago. If so, enqueue
+ # it for later sending. Otherwise send it now and record
+ # the time we sent this item.
+
+ if {[info exists flowctl($conn,after)]} {
+ lappend flowctl($conn,queue) $item
+ } else {
+ if {[catch {set lastsend $flowctl($conn,lastsend)}]} {
+ set lastsend 0
+ }
+ set now [clock clicks -milliseconds]
+ set lim $flowctl(floodlimit)
+ if {[expr $now - $lastsend] < $lim} {
+ lappend flowctl($conn,queue) $item
+ set wait [expr ($lim - ($now - $lastsend))]
+ set flowctl($conn,after) \
+ [after $wait [list ::irk::sendlater $conn]]
+ } else {
+ set flowctl($conn,lastsend) $now
+ puts $conn $item
+ }
+ }
+
+ return ""
+ }
+
+ # This procedure does the sending when flow control for a connection
+ # is activated.
+
+ proc sendlater {conn} {
+ variable flowctl
+
+ # First of all clear the after entry.
+
+ unset flowctl($conn,after)
+
+ # Grab the first item on the queue:
+
+ if {[info exists flowctl($conn,queue)]} {
+ set items $flowctl($conn,queue)
+ if {[string compare $items ""]} {
+ set item [lindex $items 0]
+ set rest [lrange $items 1 end]
+ if {[string compare $rest ""]} {
+ set flowctl($conn,queue) $rest
+ set flowctl($conn,after) \
+ [after $flowctl(floodlimit) \
+ [list ::irk::sendlater $conn]]
+ } else {
+ unset flowctl($conn,queue)
+ }
+
+ # Record time we last sent to this destination.
+
+ set flowctl($conn,lastsend) [clock clicks -milliseconds]
+
+ # Send this item:
+
+ puts $conn $item
+ } else {
+ unset flowctl($conn,queue)
+ }
+ }
+ }
+}
+
Added: media/tcl/irk/lib/irkqueue.tcl
===================================================================
--- media/tcl/irk/lib/irkqueue.tcl (rev 0)
+++ media/tcl/irk/lib/irkqueue.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,103 @@
+# irkenqueue.tcl
+#
+# Simple flow control management so as to avoid flooding.
+
+namespace eval ::irk {
+
+ # For each combination of destination+connection, we keep three items:
+ #
+ # flowctl($dest,$conn,after) The "after" token for the next time
+ # we send anything to this destination.
+ # flowctl($dest,$conn,queue) A list of items to send to this
+ # destination on this connection.
+ # flowctl($dest,$conn,lastsend) The time we last sent to this
+ # destination on this connection.
+ #
+ # NOTE: We do not limit the length of each item to send. This
+ # would lead to extremely hard to diagnose bugs due to commands
+ # (e.g. ctcp's) getting cut up into chunks.
+
+ variable flowctl
+
+ # The following setting determines the number of seconds that must
+ # pass between sends to any one destination+connection. If fewer
+ # seconds have passed since the last send, then flow control is
+ # activated for this destination+connection.
+
+ set flowctl(sendlimit) 2
+
+ # This procedure sends an item to a specific destination+connection.
+ # If possible, the item is sent right away. Otherwise it is enqueued
+ # for later sending.
+
+ proc enqueue {dest conn item} {
+ variable flowctl
+
+ # If this destination has a backlog, append the new
+ # items. Otherwise, check if the previous send was
+ # less than 2 seconds ago. If so, enqueue it for
+ # later sending. Otherwise send it now and record
+ # the time we sent this item.
+
+ if {[info exists flowctl($dest,$conn,after)]} {
+ lappend flowctl($dest,$conn,queue) $item
+ } else {
+ if {[catch {set lastsend $flowctl($dest,$conn,lastsend)}]} {
+ set lastsend 0
+ }
+ set now [clock seconds]
+ set lim $flowctl(sendlimit)
+ if {[expr $now - $lastsend] < $lim} {
+ lappend flowctl($dest,$conn,queue) $item
+ set wait [expr ($lim - ($now - $lastsend)) * 1000]
+ set flowctl($dest,$conn,after) \
+ [after $wait [list ::irk::sender $dest $conn]]
+ } else {
+ set flowctl($dest,$conn,lastsend) $now
+ puts $conn $item
+ }
+ }
+
+ return ""
+ }
+
+ # This procedure does the sending when flow control for a connection
+ # is activated.
+
+ proc sender {dest conn} {
+ variable flowctl
+
+ # First of all clear the after entry.
+
+ unset flowctl($dest,$conn,after)
+
+ # Grab the first item on the queue:
+
+ if {[info exists flowctl($dest,$conn,queue)]} {
+ set items $flowctl($dest,$conn,queue)
+ if {[string compare $items ""]} {
+ set item [lindex $items 0]
+ set rest [lrange $items 1 end]
+ if {[string compare $rest ""]} {
+ set lim [expr $flowctl(sendlimit) * 1000]
+ set flowctl($dest,$conn,queue) $rest
+ set flowctl($dest,$conn,after) \
+ [after $lim [list ::irk::sender $dest $conn]]
+ } else {
+ unset flowctl($dest,$conn,queue)
+ }
+
+ # Record time we last sent to this destination.
+
+ set flowctl($dest,$conn,lastsend) [clock seconds]
+
+ # Send this item:
+
+ puts $conn $item
+ } else {
+ unset flowctl($dest,$conn,queue)
+ }
+ }
+ }
+}
+
Added: media/tcl/irk/lib/irkreceive.tcl
===================================================================
--- media/tcl/irk/lib/irkreceive.tcl (rev 0)
+++ media/tcl/irk/lib/irkreceive.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,618 @@
+# irkreceive.tcl:
+#
+# Various commands invoked in response to input received from the server:
+
+namespace eval irk {
+
+ # This procedure deals with the PING special action:
+
+ proc RECV,PING {token nick user comm dest rest} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid IRK connection"
+ }
+ puts $sock "PONG :$comm $rest"
+
+ return ""
+ }
+
+ # This procedure deals with the NOTICE special action:
+
+ proc RECV,NOTICE {token nick user comm dest rest} {
+ variable state
+
+ append state($token,GLOBALNOTICES) "$rest\n"
+
+ return ""
+ }
+
+
+ # This procedure deals with the ERROR special action:
+
+ proc RECV,ERROR {token nick user comm dest rest} {
+ variable state
+
+ set rest [eval concat $rest]
+ append state($token,ERRORS) "$nick $dest $rest\n"
+# puts "Got ERROR: $token $nick ---> $dest: $rest"
+ orxonox::execute error "Got ERROR: $token $nick ---> $dest: $rest"
+
+ return ""
+ }
+
+ # This procedure deals with the AWAY response:
+
+ proc RECV,AWAY {token nick user comm dest rest} {
+ set id [lindex $rest 0]
+ set rest [lrange $rest 1 end]
+ set rest [lreplace $rest 0 0 [string range [lindex $rest 0] 1 end]]
+ set rest [eval concat $rest]
+ puts "$id is away: $rest"
+
+ return ""
+ }
+
+ # This procedure deals with the WHOIS USER message:
+
+ proc RECV,WHOIS,NICK,USER {token nick user comm dest rest} {
+ variable state
+
+ # Split the rest of the line on space:
+
+ foreach {unick uuser uhost ustar urnm} [split $rest " "] break
+
+ # If the WHOIS information is about this user, save it specially:
+
+ if {[isus $token $unick]} {
+ set state($token,uuser) $uuser
+ set state($token,uhost) $uhost
+ set state($token,urnm) $urnm
+ }
+
+ # Save the information for a regular user:
+
+ set state($token,ident,$unick,uuser) $uuser
+ set state($token,ident,$unick,uhost) $uhost
+ set state($token,ident,$unick,urnm) $urnm
+ }
+
+ # This procedure deals with the WHOIS SERVER message:
+
+ proc RECV,WHOIS,NICK,SERVER {token nick user comm dest rest} {
+ variable state
+
+ # Split the rest of the line on space:
+
+ foreach {unick userv} [split $rest " "] break
+
+ # If the WHOIS information is about this user, save it specially:
+
+ if {[isus $token $unick]} {
+ set state($token,userv) $userv
+ }
+
+ # Save the information for a regular user:
+
+ set state($token,ident,$unick,userv) $userv
+ }
+
+ # This procedure deals with the WHOIS IDENT message
+
+ proc RECV,WHOIS,NICK,IDENT {token nick user comm dest rest} {
+ variable state
+
+ # Extract the nick of the user who has identified
+
+ set unick [lindex [split $rest " "] 0]
+
+ # If the WHOIS information is about this user, save it specially:
+
+ if {[isus $token $unick]} {
+ set state($token,ident) 1
+ }
+
+ # Save the information for a regular user:
+
+ set state($token,ident,$unick,ident) 1
+ }
+
+ # This procedure deals with the WHOIS CONNECTTIME message:
+
+ proc RECV,WHOIS,NICK,CONNECTTIME {token nick user comm dest rest} {
+ variable state
+
+ # Split the rest of the input on space:
+
+ foreach {unick idle connecttime} [split $rest " "] break
+
+ # Format the connect time for this user:
+
+ set connecttime [clock format $connecttime]
+
+ # If the WHOIS information is about this user, save it specially:
+
+ if {[isus $token $unick]} {
+ set state($token,connecttime) $connecttime
+ }
+
+ # Save the information for a regular user:
+
+ set state($token,ident,$unick,connecttime) $connecttime
+ }
+
+ # Handle the WHOIS CHANNELS message:
+
+ proc RECV,WHOIS,NICK,CHANNELS {token nick user comm dest rest} {
+ variable state
+
+ # Split the rest on space.
+
+ set rest [split $rest " "]
+
+ # Get the nick for which this is the channel list:
+
+ set unick [lindex $rest 0]
+ set rest [lrange $rest 1 end]
+
+ # The first channel may have an extra ":", if it does get rid of it.
+
+ set firstchan [lindex $rest 0]
+ if {[string match ":*" $firstchan]} {
+ set rest [lreplace $rest 0 0 [string range $firstchan 1 end]]
+ }
+
+ # If the WHOIS information is about this user, save it specially:
+
+ if {[isus $token $unick]} {
+ set state($token,channels) $channels
+ }
+
+ # Save the information for a regular user:
+
+ set state($token,ident,$unick,channels) $rest
+ }
+
+ # This procedure deals with the WHOIS END message:
+
+ proc RECV,WHOIS,NICK,END {token nick user comm dest rest} {
+ variable state
+
+ set state($token,whois,done) 1
+ }
+
+ # This procedure deals with various MOTD actions:
+
+ proc RECV,MOTD {token nick user comm dest rest} {
+ variable state
+
+ append state($token,MOTD) "${rest}\n"
+
+ return ""
+ }
+
+ # This procedure deals with PONG actions:
+
+ proc RECV,PONG {token nick user comm dest rest} {
+ variable state
+
+ if {[info exists state($token,PINGSTART)]} {
+ set elapsed \
+ [expr [clock clicks -millis] - $state($token,PINGSTART)]
+ puts "$nick: $elapsed msecs"
+ unset state($token,PINGSTART)
+ }
+
+ return ""
+ }
+
+ # This procedure deals with NOTICE received from a regular user:
+
+ proc RECV,NOTICE,USER {token nick user comm dest rest} {
+ if {[string match "\001*" [lindex $rest 0]]} {
+ set rest [ctcpcleanup $rest]
+ RECV,NOTICE,CTCP,USER $token $nick $user $comm $dest \
+ [lindex $rest 0] [lrange $rest 1 end]
+ } else {
+ set rest [eval concat $rest]
+ puts "$nick sends $dest a notice: $rest"
+ }
+
+ return ""
+ }
+
+ # This procedure helps with CTCP notice actions:
+
+ proc RECV,NOTICE,CTCP,USER {token nick user comm dest action rest} {
+ variable state
+
+ if {[info exists state($token,response,ctcp,$action)]} {
+ $state($token,response,ctcp,$action) \
+ $token $nick $user $comm $dest \
+ $action $rest
+ } else {
+ $state($token,response,ctcp,error) \
+ $token $nick $user $comm $dest \
+ $action $rest
+ }
+
+ return ""
+ }
+
+ # This procedure deals with JOIN actions:
+
+ proc RECV,JOIN {token nick user comm dest rest} {
+ variable state
+
+ # Check if it's us that joined the channel or someone else.
+
+ if {[isus $token $nick]} {
+# puts "You joined $dest"
+ orxonox::irc::info $token "You joined $dest"
+
+ addChannel $token $dest
+ } else {
+# puts "$nick joined $dest"
+ orxonox::irc::info $token "$nick joined $dest"
+
+ addToChannel $token $nick $dest
+ }
+
+ return ""
+ }
+
+ # This procedure deals with PART actions:
+
+ proc RECV,PART {token nick user comm dest rest} {
+ variable state
+
+ set chan [string tolower $dest]
+
+ if {[isus $token $nick]} {
+# puts "You left channel $chan"
+ orxonox::irc::info $token "You left channel $chan"
+ } else {
+# puts "$nick left [string tolower $dest]"
+ orxonox::irc::info $token "$nick left [string tolower $dest]"
+ }
+ removeFromChannel $token $nick $chan
+ removeFromChannel $token @$nick $chan
+
+ return ""
+ }
+
+ # This procedure deals with MODE actions:
+
+ proc RECV,MODE {token nick user comm dest rest} {
+ set rest [eval concat $rest]
+# puts "$nick sets mode $dest $rest"
+ orxonox::irc::info "$nick $token sets mode $dest $rest"
+
+ return ""
+ }
+
+ # This procedure deals with NICK actions:
+
+ proc RECV,NICK {token nick user comm dest rest} {
+ variable state
+
+ set newnick [string range $dest 0 end]
+
+ # If our nick changed, remember it as the nick associated with
+ # this connection:
+
+ if {[isus $token $nick]} {
+ set state($token,nick) $newnick
+ set state($token,$newnick,PRIVMSG) $state(PRIVMSG,unsolicited)
+ catch {unset state($token,$nick,PRIVMSG)}
+ }
+
+ # Replace the old nick with the new in all channels that we're on:
+
+ replaceAllChannels $token $nick $newnick
+
+# puts "$nick ${user} ($token) changes his/her nickname to $newnick"
+ orxonox::irc::info $token "$nick changes his/her nickname to $newnick"
+
+ return ""
+ }
+
+ # This procedure deals with QUIT actions:
+
+ proc RECV,QUIT {token nick user comm dest rest} {
+ variable state
+
+ set rest [eval concat $rest]
+# puts "Received QUIT $token $nick $rest"
+ orxonox::irc::info $token "Received QUIT $token $nick $rest"
+
+ if {[string match ":*" $dest]} {
+ set dest [string range $dest 1 end]
+ }
+ if {[isus $token $nick]} {
+# puts "You left the server $state($token,host) ($dest $rest)"
+ orxonox::irc::info $token "You left the server $state($token,host) ($dest $rest)"
+ forgetConnection $token
+ } else {
+ puts "$nick quits IRK ($dest $rest)"
+ removeFromAllChannels $token $nick
+ removeFromAllChannels $token @$nick
+ }
+
+ return ""
+ }
+
+ # This procedure deals with expected PRIVMSG actions:
+
+ proc RECV,PRIVMSG {token nick user comm dest rest} {
+ if {[string match "\001*" [lindex $rest 0]]} {
+ set rest [ctcpcleanup $rest]
+ RECV,PRIVMSG,CTCP,CHANNEL $token $nick $user $comm $dest \
+ [lindex $rest 0] [lrange $rest 1 end]
+ } else {
+# puts "$nick$dest: [eval concat $rest]"
+ orxonox::irc::say $token $nick [eval concat $rest]
+ }
+
+ return ""
+ }
+
+ # This procedure handles CTCP actions on the channel:
+
+ proc RECV,PRIVMSG,CTCP,CHANNEL {token nick user comm dest action rest} {
+ variable state
+
+ if {[info exists state($token,channel,ctcp,$action)]} {
+ $state($token,channel,ctcp,$action) \
+ $token $nick $user $comm $dest \
+ $action $rest
+ } else {
+ $state($token,channel,ctcp,error) \
+ $token $nick $user $comm $dest \
+ $action $rest
+ }
+
+ return ""
+ }
+
+ # This procedure stores the result of USERHOST actions:
+
+ proc RECV,USERHOST {token nick user comm dest rest} {
+ return ""
+ }
+
+ # This procedure stores the channel topic:
+
+ proc RECV,CHANNEL,TOPIC {token nick user comm dest rest} {
+ variable state
+
+ set chan [lindex $rest 0]
+ set rest [lrange $rest 1 end]
+ if {[string match ":*" [lindex $rest 0]]} {
+ set rest [lreplace $rest 0 0 \
+ [string range [lindex $rest 0] 1 end]]
+ }
+ set state($token,$chan,TOPIC) $rest
+ set state($token,$chan,TOPIC,SETBY) $nick
+ set state($token,$chan,TOPIC,SETAT) [clock format [clock seconds]]
+
+ return ""
+ }
+
+ # This procedure stores the channel byline:
+
+ proc RECV,CHANNEL,SETBY {token nick user comm dest rest} {
+ variable state
+
+ set chan [lindex $rest 0]
+ set rest [lrange $rest 1 end]
+ if {[string match ":*" [lindex $rest 0]]} {
+ set rest [lreplace $rest 0 0 \
+ [string range [lindex $rest 0] 1 end]]
+ }
+ set state($token,$chan,TOPIC,SETBY) [lindex $rest 0]
+ set state($token,$chan,TOPIC,SETAT) [clock format [lindex $rest 1]]
+
+ return ""
+ }
+
+ # This procedure deals with unsolicited PRIVMSG actions:
+
+ proc RECV,PRIVMSG,unsolicited {token nick user comm dest rest} {
+ if {[string match "\001*" [lindex $rest 0]]} {
+ set rest [ctcpcleanup $rest]
+ RECV,PRIVMSG,CTCP,USER $token $nick $user $comm $dest \
+ [lindex $rest 0] [lrange $rest 1 end]
+ } else {
+# puts "$nick: [eval concat $rest]"
+ orxonox::irc::privmsg $nick $nick [eval concat $rest]
+ }
+
+ return ""
+ }
+
+ # This procedure helps with CTCP private messages:
+
+ proc RECV,PRIVMSG,CTCP,USER {token nick user comm dest action rest} {
+ variable state
+
+ if {[info exists state($token,cmd,ctcp,$action)]} {
+ $state($token,cmd,ctcp,$action) \
+ $token $nick $user $comm $dest \
+ $action $rest
+ } else {
+ $state($token,cmd,ctcp,error) \
+ $token $nick $user $comm $dest \
+ $action $rest
+ }
+
+ return ""
+ }
+
+ # This procedure deals with a KICK action:
+
+ proc RECV,KICK {token nick user comm dest rest} {
+ set kicked [lindex $rest 0]
+ if {[string match ":*" $kicked]} {
+ set kicked [string range $kicked 1 end]
+ }
+ set reason [eval concat [lrange $rest 1 end]]
+ if {[string match ":*" $reason]} {
+ set reason [string range $reason 1 end]
+ }
+
+ if {[isus $token $kicked]} {
+# puts "$nick kicked you from $dest because $reason"
+ orxonox::irc::info $token "$nick kicked you from $dest because $reason"
+
+ removeChannel $token $dest
+ } else {
+# puts "$nick kicks $kicked from $dest because $reason"
+ orxonox::irc::info $token "$nick kicks $kicked from $dest because $reason"
+
+ removeFromChannel $token $kicked $dest
+ removeFromChannel $token @$kicked $dest
+ }
+
+ return ""
+ }
+
+ # These procedures collect the name list for a channel:
+
+ proc RECV,CHANNEL,NAMELIST {token nick user comm dest rest} {
+ variable state
+
+ # Scan forward in $rest for the channel name:
+
+ for {set i 0; set l [llength $rest]} {$i < $l} {incr i} {
+ if {[string match "#*" [lindex $rest $i]]} {
+ break
+ }
+ }
+
+ # Didn't find it?
+
+ if {$i == $l} {
+ return
+ }
+
+ # Extract the channel name and the rest of the input:
+
+ set chan [lindex $rest $i]
+ set rest [lrange $rest [expr $i + 1] end]
+ set rest [lreplace $rest 0 0 [string range [lindex $rest 0] 1 end]]
+ set rest [eval concat $rest]
+
+ if {![info exists state($token,$chan,NAMES)]} {
+ set state($token,$chan,NAMES) ""
+ }
+ set state($token,$chan,NAMES) [concat $state($token,$chan,NAMES) $rest]
+
+ return ""
+ }
+
+ proc RECV,CHANNEL,NAMELIST,END {token nick user comm dest rest} {
+ variable state
+
+ set chan [lindex $rest 0]
+ set $state($token,$chan,NAMES) [split $state($token,$chan,NAMES) " "]
+ }
+
+ # This procedure deals with a request from the server to send a PONG
+ # with a given code.
+
+ proc RECV,PONG,REQUEST {token nick user comm dest rest} {
+ set pongcode [lindex $rest [expr [llength $rest] - 1]]
+ puts $token "PONG $pongcode"
+
+ return ""
+ }
+
+ # This procedure deals with a CTCP PING request:
+
+ proc RECV,CTCP,PING {token nick user comm dest action rest} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid IRK connection"
+ }
+ puts $sock "NOTICE $nick :\001PING ${rest}\001"
+
+ return ""
+ }
+
+ # This procedure deals with a CTCP TIME request:
+
+ proc RECV,CTCP,TIME {token nick user comm dest action rest} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid IRK connection"
+ }
+ puts $sock \
+ "NOTICE $nick :\001TIME :[clock format [clock seconds]]\001"
+
+ return ""
+ }
+
+ # This procedure deals with a CTCP VERSION request:
+
+ proc RECV,CTCP,VERSION {token nick user comm dest action rest} {
+ variable state
+ global tcl_platform
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid IRK connection"
+ }
+ set version "$state(-useragent):$state(-version):$tcl_platform(os)"
+ puts $sock "NOTICE $nick :\001VERSION ${version}\001"
+ }
+
+ # This procedure deals with a CTCP USERINFO request:
+
+ proc RECV,CTCP,USERINFO {token nick user comm dest action rest} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid IRK connection"
+ }
+ puts $sock "NOTICE $nick :\001USERINFO $state(-$token,user)\001"
+ }
+
+ # This procedure deals with CTCP ACTION messages:
+
+ proc RECV,CTCP,ACTION {token nick user comm dest action rest} {
+# puts "$nick $rest"
+ orxonox::irc::action $token $nick $rest
+
+ return ""
+ }
+
+ # This procedure is a catch all for CTCP actions that we do not
+ # understand:
+
+ proc RECV,CTCP,ERROR {token nick user comm dest action rest} {
+ variable state
+
+ if {[catch {set sock $state($token,socket)}]} {
+ error "$token: not a valid IRC connection"
+ }
+ if {[llength $rest] > 0} {
+ puts $sock \
+ "NOTICE $nick :\001ERRMSG $action $rest: unknown CTCP\001"
+ } else {
+ puts $sock "NOTICE $nick :\001ERRMSG $action: unknown CTCP\001"
+ }
+ }
+
+ # This is the default action, used by the default dispatcher
+ # when no action can be found for the given $token, $nick, $user,
+ # $comm, and $dest.
+
+ proc defaultAction {token nick user comm dest rest} {
+# puts "$token: $nick $user: $comm -> $dest ... [eval concat $rest]"
+ orxonox::execute log "$token: $nick $user: $comm -> $dest ... [eval concat $rest]"
+
+ return ""
+ }
+}
Added: media/tcl/irk/lib/irkservers.tcl
===================================================================
--- media/tcl/irk/lib/irkservers.tcl (rev 0)
+++ media/tcl/irk/lib/irkservers.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,57 @@
+# irkservers.tcl:
+#
+# This file defines the servers that are known to the Tcl IRK library.
+# It is actually a Tcl script and is source'd by the irk.tcl file.
+
+namespace eval ::irk {
+
+ # This procedure helps define a new server:
+
+ proc defineserver {symname host ports} {
+ variable state
+ variable symsrv
+
+ # Auto initialize the list of known (symbolic names for) servers:
+
+ if {![info exists state(servers)]} {
+ set state(servers) {}
+ }
+
+ # Add an entry in the list of (symbolic names for) servers:
+
+ lappend state(servers) $symname
+
+ # Add an entry for the contact information of this symbolic server:
+
+ set symsrv($symname) [list $host $ports]
+ }
+
+ # OK, now define a bunch of servers. This is where you can add your
+ # own, or edit if things change:
+
+ defineserver twisted twisted.ma.us.dal.net {6660 6661 6662 6663}
+ defineserver dalnet irc.dal.net 6667
+ defineserver undernet McLean.VA.us.undernet.org {6667 6668}
+ defineserver efnet irc.Prison.NET 6666
+ defineserver ircnet irc.stealth.net {6663 6664}
+ defineserver powersurf irc.powersurfr.com 6667
+ defineserver coins coins.dal.net {6667 6668 6669 7000}
+ defineserver sodre sodre.on.ca.dal.net {6667 6668 6669 7000}
+ defineserver austnet au.austnet.org 6667
+ defineserver nznet nz.austnet.org 6667
+ defineserver sgnet sg.austnet.org 6667
+ defineserver us.efnet us.rr.efnet.net 6667
+ defineserver eu.efnet eu.rr.efnet.net 6667
+ defineserver ca.efnet ca.rr.efnet.net 6667
+ defineserver au.efnet au.rr.efnet.net 6667
+ defineserver us.ircnet us.ircnet.org {6665 6666 6667 6668}
+ defineserver eu.ircnet eu.ircnet.org {6665 6666 6667 6668}
+ defineserver ca.ircnet ca.ircnet.org {6665 6666 6667 6668}
+ defineserver au.ircnet au.ircnet.org {6665 6666 6667 6668}
+ defineserver us.undernet us.undernet.org 6667
+ defineserver eu.undernet eu.undernet.org 6667
+ defineserver othernet irc.othernet.org 6667
+ defineserver de.quakenet de.quakenet.org 6667
+ defineserver datacore irc.datacore.ch 6667
+ defineserver orxonox irc.orxonox.net 6667
+}
Added: media/tcl/irk/lib/irkstate.tcl
===================================================================
--- media/tcl/irk/lib/irkstate.tcl (rev 0)
+++ media/tcl/irk/lib/irkstate.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,134 @@
+# irkstate.tcl:
+#
+# This file defines the contents of the ::irk::state array
+
+namespace eval ::irk {
+
+ # The state array contains all the state for the IRK package:
+ #
+ # These options can be configured with irk::config:
+ #
+ # state(-useragent) Name of this IRK user agent.
+ # state(-version) Version of this IRK user agent.
+ #
+ # state(-sockproxy) Name of SOCKS5 proxy to use (optional).
+ # state(-socksport) Port on which SOCKS5 server accepts
+ # connections (optional).
+ #
+ # state(-$symsrv,nick) If set and connect is called without giving
+ # a nick, use this as the nickname.
+ # state(-$symsrv,user) If set and connect is called without giving
+ # a user, this is used. Otherwise, if it's not
+ # set when connect is called without a user,
+ # it is set to the given nickname (and used).
+ # state(-$symsrv,pass) If set, and connect is called without giving
+ # a password, this is used.
+ #
+ # state(-quitmessage) If set, the message is sent when a connection
+ # is closed, as part of a QUIT command.
+ #
+ # These options cannot be configured with irk::config:
+ #
+ # state(connections) A list of all active connections.
+ # state(dispatcher) The default command dispatcher (must be set).
+ # state(action) The default action (must be set).
+ # state(servers) List of known servers (further described in
+ # the symsrv array below).
+ #
+ # The following state is kept per connection (identified by $contok):
+ #
+ # state($contok,socket) The socket for a given connection
+ # state($contok,port) The port of a given connection
+ # state($contok,host) The host of a given connection
+ # state($contok,symsrv) The symbolic name of the server for
+ # this connection.
+ # state($contok,nick) The nick name used on a given connection
+ # state($contok,user) The real user used on a given connection
+ # state($contok,pass) The password used on a given connection
+ # state($contok,disp) The command dispatcher for the connection
+ #
+ # Depending on the dispatcher associated with each connection, there
+ # may be many more settings of the general form:
+ #
+ # state($contok,action,...)
+ #
+ # System wide responses to common commands are handled by
+ # special actions, stored in the state array:
+ #
+ # state(PRIVMSG,unsolicited)
+ # Action that responds to unsolicited private
+ # messages directed at this user's nickname.
+ # state(special,PING) Responds to PING messages.
+ # state(special,NOTICE) Responds to NOTICE messages.
+ # state(special,ERROR) Responds to ERROR messages.
+ #
+ # The IRK library provides a unified authorization mechanism, implemented
+ # in irkauth.tcl. The state array contains two settings that affect the
+ # behavior of the authorization mechanism:
+ #
+ # state(auth,save,file) Name of a file to save the authorization
+ # information in. Defaults to auth.dat in the
+ # directory containing the IRK package.
+ # state(auth,save,interval) The number of milliseconds that pass between
+ # autosaves of the authorization data.
+
+ variable state
+ array set state {
+ -useragent "Tcl IRK Library"
+ -version 0.1
+ -quitmessage "gives up the ghost"
+
+ dispatcher ::irk::defaultDispatcher
+ action ::irk::defaultAction
+
+ cmd,QUIT ::irk::RECV,QUIT
+ cmd,JOIN ::irk::RECV,JOIN
+ cmd,PART ::irk::RECV,PART
+ cmd,MODE ::irk::RECV,MODE
+ cmd,NICK ::irk::RECV,NICK
+ cmd,PONG ::irk::RECV,PONG
+ cmd,PRIVMSG ::irk::RECV,PRIVMSG
+ cmd,NOTICE ::irk::RECV,NOTICE,USER
+ cmd,KICK ::irk::RECV,KICK
+ cmd,001 ::irk::RECV,MOTD
+ cmd,002 ::irk::RECV,MOTD
+ cmd,003 ::irk::RECV,MOTD
+ cmd,004 ::irk::RECV,MOTD
+ cmd,005 ::irk::RECV,MOTD
+ cmd,250 ::irk::RECV,MOTD
+ cmd,251 ::irk::RECV,MOTD
+ cmd,252 ::irk::RECV,MOTD
+ cmd,253 ::irk::RECV,MOTD
+ cmd,254 ::irk::RECV,MOTD
+ cmd,255 ::irk::RECV,MOTD
+ cmd,265 ::irk::RECV,MOTD
+ cmd,266 ::irk::RECV,MOTD
+ cmd,301 ::irk::RECV,AWAY
+ cmd,307 ::irk::RECV,WHOIS,NICK,IDENT
+ cmd,311 ::irk::RECV,WHOIS,NICK,USER
+ cmd,312 ::irk::RECV,WHOIS,NICK,SERVER
+ cmd,317 ::irk::RECV,WHOIS,NICK,CONNECTTIME
+ cmd,318 ::irk::RECV,WHOIS,NICK,END
+ cmd,319 ::irk::RECV,WHOIS,NICK,CHANNELS
+ cmd,372 ::irk::RECV,MOTD
+ cmd,375 ::irk::RECV,MOTD
+ cmd,376 ::irk::RECV,MOTD
+ cmd,332 ::irk::RECV,CHANNEL,TOPIC
+ cmd,333 ::irk::RECV,CHANNEL,SETBY
+ cmd,353 ::irk::RECV,CHANNEL,NAMELIST
+ cmd,366 ::irk::RECV,CHANNEL,NAMELIST,END
+
+ cmd,513 ::irk::RECV,PONG,REQUEST
+
+ special,PING ::irk::RECV,PING
+ special,NOTICE ::irk::RECV,NOTICE
+ special,ERROR ::irk::RECV,ERROR
+
+ PRIVMSG,unsolicited ::irk::RECV,PRIVMSG,unsolicited
+
+ errorhandler ::irk::echoerror
+
+ auth,save,file [file join [file dir [info script]] auth.dat]
+ auth,save,interval 300000
+ }
+}
Added: media/tcl/irk/lib/irkutil.tcl
===================================================================
--- media/tcl/irk/lib/irkutil.tcl (rev 0)
+++ media/tcl/irk/lib/irkutil.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,144 @@
+# irkutil.tcl:
+#
+# Utility procedures used throughout the IRK package.
+
+namespace eval ::irk {
+
+ # The randselect randomly selects an element of a given list.
+
+ proc randselect {l} {
+ lindex $l [expr int(floor(rand() * [llength $l]))]
+ }
+
+ # Remove a user from the list of users on a channel
+
+ proc removeFromChannel {token user chan} {
+ variable state
+
+ # If it's us that left the channel, forget the channel:
+
+ if {![string compare $state($token,nick) $user]} {
+ removeChannel $token $chan
+ return
+ }
+
+ # Try to retrieve the channel's user list:
+
+ if {[catch {set users $state($token,$chan,NAMES)}]} {
+ return
+ }
+ set idx [lsearch $users $user]
+ if {$idx == -1} {
+ return
+ }
+
+ # Remove the user:
+
+ set state($token,$chan,NAMES) [lreplace $users $idx $idx]
+ }
+
+ # Remove a user from all the channels I am on (for QUIT etc.)
+
+ proc removeFromAllChannels {token user} {
+ variable state
+
+ foreach chan $state($token,channels) {
+ removeFromChannel $token $user $chan
+ }
+ }
+
+ # Add a user to a channel I am on.
+
+ proc addToChannel {token user chan} {
+ variable state
+
+ lappend state($token,$chan,NAMES) $user
+ }
+
+ # Add a channel to the list of channels we're on:
+
+ proc addChannel {token chan} {
+ variable state
+
+ lappend state($token,channels) $chan
+ }
+
+ # Remove a channel from the list of channels we're on:
+
+ proc removeChannel {token chan} {
+ variable state
+
+ if {[catch {set channels $state($token,channels)}]} {
+ return
+ }
+ set idx [lsearch $channels $chan]
+ if {$idx == -1} {
+ return
+ }
+
+ # Remove this channel from the list of channels we're on:
+
+ set state($token,channels) [lreplace $channels $idx $idx]
+
+ # Forget all state for this channel:
+
+ array unset state $token,$chan,*
+ }
+
+ # This procedure cleans up all state associated with a connection:
+
+ proc forgetConnection {token} {
+ variable state
+
+ array unset state $token,*
+ }
+
+ # This procedure updates the channel names for all channels we're on
+ # due to a nick change.
+
+ proc replaceAllChannels {token nick newnick} {
+ variable state
+
+ # If we're not on any channels, then no need to replace.
+
+ if {![info exists state($token,channels)]} {
+ return
+ }
+
+ # Replace the old nick with the new nick in all the channels I'm on.
+
+ foreach chan $state($token,channels) {
+ if {[catch {set names $state($token,$chan,NAMES)}]} {
+ continue
+ }
+ set idx [lsearch $names $nick]
+ if {$idx != -1} {
+ set state($token,$chan,NAMES) \
+ [lreplace $names $idx $idx $newnick]
+ }
+ }
+ }
+
+ # This procedure determines whether a nick is our nick.
+
+ proc isus {token nick} {
+ variable state
+
+ if {![string compare $nick $state($token,nick)]} {
+ return 1
+ }
+ return 0
+ }
+
+ # This procedure cleans up input received as part of a CTCP action.
+
+ proc ctcpcleanup {l} {
+ if {[llength $l] > 1} {
+ set h [string range [lindex $l 0] 1 end]
+ set t [string range [lindex $l end] 0 end-1]
+ return [lreplace [lreplace $l 0 0 $h] end end $t]
+ }
+ return [string range $l 1 end-1]
+ }
+
+}
Added: media/tcl/irk/pkgIndex.tcl
===================================================================
--- media/tcl/irk/pkgIndex.tcl (rev 0)
+++ media/tcl/irk/pkgIndex.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,12 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script. It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands. When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded socks 1.2 [list source [file join $dir socks socks.tcl]]
+package ifneeded irk 0.1 [list source [file join $dir irk.tcl]]
\ No newline at end of file
Added: media/tcl/irk/socks/socks.tcl
===================================================================
--- media/tcl/irk/socks/socks.tcl (rev 0)
+++ media/tcl/irk/socks/socks.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,347 @@
+# Socks5 Client Library v1.2
+#
+# Original author: (C)2000 Kerem 'Waster_' HADIMLI
+#
+# Author contact information:
+# E-mail : waster at iname.com
+# ICQ# : 27216346
+# Jabber : waster at jabber.org (New IM System - http://www.jabber.org)
+#
+# Cleaned up a little by Jacob Levy, jyl at best.com (01/07/2001)
+#
+# * Moved everything into the ::socks:: namespace.
+# * Parameterized so that constants do not get reset for every connection.
+# * Uniform error handling and cleanup.
+# * Incremented the version number to 1.2.
+#
+# How to use:
+#
+# Step 1: Create your client socket connected to the SOCKS5 server.
+#
+# Step 2: Call socks::init sock host port ?auth? ?user? ?pass?
+# where:
+#
+# sock The socket from step #1.
+# host The remote host to connect to through the proxy.
+# port The remote port to connect to through the proxy.
+# auth Optional. If 1, it means that we do an
+# authentication with the proxy server.
+# user Optional. If present, the user name to use for
+# authentication with the proxy server.
+# pass Optional. If present, the password for the user
+# name to use for authentication with the
+# proxy server.
+#
+# If auth == 1, user and pass are not present, and socks::state(username)
+# and socks::state(pass) are set, then socks::init uses the values from
+# socks::state(username) and socks::state(password) for user name and
+# password, respectively.
+#
+# If anything goes wrong during the attempt to connect through the
+# proxy server, socks::init throws an appropriate error and closes
+# the socket. If the operation succeeds, socks::init returns $sock.
+#
+# You can set up your socket with fconfigure before calling socks::init,
+# the socks::init procedure is careful to restore the state to what it
+# was before the call upon successful completion. Likewise, you can
+# have fileevent handlers installed for handling socket readable and
+# socket writable events. These will also be preserved.
+
+# This file provides the "socks" package:
+
+package provide socks 1.2
+
+# Global settings:
+
+namespace eval ::socks {
+ variable state
+
+ array set state {
+ protocolversion "\x05"
+ cmdconnect "\x01"
+ addresstype "\x03"
+ reserved "\x00"
+
+ noauthmethod "\x00"
+ noauthlengthstr "\x01"
+
+ authmethod "\x00\x02"
+ authlengthstr "\x02"
+
+ nomatchingmethod "\xFF"
+ nomatchlengthstr "\x01"
+
+ authenticationversion "\x01"
+
+ errorheader "Error: "
+ error1 "General SOCKS server failure"
+ error2 "Connection not allowed by ruleset"
+ error3 "Network unreachable"
+ error4 "Host unreachable"
+ error5 "Connection refused"
+ error6 "TTL expired"
+ error7 "Command not supported"
+ error8 "Address type not supported"
+ errorUnknown "Unknown error"
+
+ errorDisconnect "SOCKS server disconnected"
+ errorNotSOCKS5 "SOCKS server does not support SOCKS 5"
+ errorMustAuthenticate "SOCKS server demands user/pass authentication"
+ errorAuthMethodNotSup "SOCKS server doesn't support user/pass auth"
+ errorWrongUserPass "Wrong user name or password"
+ errorIncorrectAuthVal "Incorrect value for $auth, expecting 1 or 0"
+ errorMissingUserAndPass "Missing user and pass, required for auth == 1"
+ }
+}
+
+# Error handling and cleanup:
+
+proc ::socks::Error {sock errorMsg} {
+ variable state
+
+ # Attempt to close the socket. This also cancels any installed
+ # fileevent handlers, so no need to do that explicitly.
+
+ catch {close $sock}
+
+ # Clean up the state we keep about this socket:
+
+ catch {array unset state $sock,*}
+
+ # Report the requested error:
+
+ error "$state(errorheader)$state($errorMsg)"
+}
+
+# Main entry point: socks::init
+#
+# See comment at head of file for how to use.
+
+proc ::socks::init {sock addr port {auth 0} {user {}} {pass {}}} {
+ variable state
+
+ # Save current configuration state for $sock
+
+ set currentConfiguration [fconfigure $sock]
+
+ # We cannot configure -peername so if its present (it should be)
+ # then remove it from the list of options.
+
+ set idx [lsearch $currentConfiguration -peername]
+ if {$idx != -1} {
+ set currentConfiguration \
+ [lreplace $currentConfiguration $idx [expr $idx + 1]]
+ }
+
+ # Same for -sockname.
+
+ set idx [lsearch $currentConfiguration -sockname]
+ if {$idx != -1} {
+ set currentConfiguration \
+ [lreplace $currentConfiguration $idx [expr $idx + 1]]
+ }
+
+ # Save any currently installed handler for fileevent readable:
+
+ set currentReadableHandler [fileevent $sock readable]
+
+ # If the user has "set and forget" user name and password, and
+ # indicates that she wants to use them, use them now:
+
+ if {($auth == 1) && (![string compare {} $user]) \
+ && (![string compare {} $pass])} {
+ if {[info exists state(username)] && [info exists state(password)]} {
+ set auth 1
+ set user $state(username)
+ set pass $state(password)
+ } else {
+ Error $sock errorMissingUserAndPass
+ }
+ }
+
+ # Figure out the authentication method to use:
+
+ if {$auth == 0} {
+ set nmethods $state(noauthlengthstr)
+ set method $state(noauthmethod)
+ } elseif {$auth == 1} {
+ set nmethods $state(authlengthstr)
+ set method $state(authmethod)
+ } else {
+ Error $sock errorIncorrectAuthVal
+ }
+
+ # Encode the length of the address given (binary 1 byte):
+
+ set domainlen "[binary format c [string length $addr]]"
+
+ # Encode the port (network byte order, 2 bytes):
+
+ set port [binary format S $port]
+
+ if {$auth == 1} {
+ # Encode the length of the user given (binary 1 byte):
+
+ set userlen "[binary format c [string length $user]]"
+
+ # Encode the length of the password given (binary 1 byte):
+
+ set passlen "[binary format c [string length $pass]]"
+ }
+
+ # Set up initial state for the given socket:
+
+ set state($sock,state) $sock
+ set state($sock,data) ""
+
+ # Prepare the socket:
+
+ fconfigure $sock -translation {binary binary} -blocking 0
+ fileevent $sock readable "::socks::readable $sock"
+
+ # Tell the server what version and authentication method we're using:
+
+ puts -nonewline $sock "$state(protocolversion)$nmethods$method"
+ flush $sock
+
+ # Wait for server response and retrieve the information sent by the
+ # server:
+
+ vwait ::socks::state($sock,state)
+ set serverReply $state($sock,data)
+
+ if {[eof $sock]} {
+ Error $sock errorDisconnect
+ }
+
+ # Analyze the server's reply:
+
+ set serverVersion ""
+ set serverMethod $state(nomatchingmethod)
+
+ binary scan $serverReply "cc" serverVersion serverMethod
+
+ # Check for various error conditions:
+
+ if {$serverVersion != 5} {
+
+ # Server does not support SOCKS5 protocol
+
+ Error $sock errorNotSOCKS5
+ }
+
+ # If server demands authentication, do that step now:
+
+ if {$serverMethod == 2} {
+
+ if {$auth == 0} {
+
+ # We didn't supply user/pass but server wants us to authenticate:
+
+ Error $sock errorMustAuthenticate
+ }
+
+ puts -nonewline $sock \
+ "$state(authenticationversion)$userlen$user$passlen$pass"
+ flush $sock
+
+ # Wait again for server reply:
+
+ vwait ::socks::state($sock,state)
+ set serverReply $state($sock,data)
+
+ # Analyze the server reply:
+
+ set authenticationVersion ""
+ set serverStatus "\x00"
+
+ binary scan $serverReply "cc" authenticationVersion serverStatus
+
+ # Deal with errors:
+
+ if {$authenticationVersion != 1} {
+
+ # Server does not support our user/pass authentication method:
+
+ Error $sock errorAuthMethodNotSup
+ }
+
+ if {$serverStatus != 0} {
+
+ # We supplied wrong user/pass combination:
+
+ Error $Sock errorWrongUserPass
+ }
+ } elseif {$serverMethod != 0} {
+
+ # Unknown method. Clean up:
+
+ Error $sock errorUnsupportedMethod
+ }
+
+ # Finally tell the server to connect us to the requested host and port:
+
+ puts -nonewline $sock \
+ "$state(protocolversion)$state(cmdconnect)$state(reserved)"
+ puts -nonewline $sock "$state(addresstype)$domainlen$addr$port"
+ flush $sock
+
+ # Wait again for server response:
+
+ vwait ::socks::state($sock,state)
+ set serverReply $state($sock,data)
+
+ if {[eof $sock]} {
+ Error $sock errorDisconnect
+ }
+
+ # Analyze server reply:
+
+ set serverVersion ""
+ set serverReplyCode ""
+
+ binary scan $serverReply "cc" serverVersion serverReplyCode
+
+ # Deal with errors:
+
+ if {$serverVersion != 5} {
+ Error $sock errorNotSOCKS5
+ }
+
+ if {$serverReplyCode != 0} {
+ if {($serverReplyCode > 0) && ($serverReplyCode < 9)} {
+ Error $sock error$serverReplyCode
+ }
+ Error $sock errorUnknown
+ }
+
+ # All done, clean up state, reconfigure $sock to its original state,
+ # remove our fileevent handler and potentially restore the original
+ # one if one was present.
+
+ fileevent $sock readable {}
+ if {[string compare $currentReadableHandler ""]} {
+ fileevent $sock readable $currentReadableHandler
+ }
+ catch {eval fconfigure $sock $currentConfiguration}
+ catch {array unset state $sock,*}
+
+ # For good measure return the socket:
+
+ return $sock
+}
+
+# This procedure reads input available from the server socket and then
+# changes a state variable so that the main program will be woken up.
+
+proc ::socks::readable {sock} {
+ variable state
+
+ # Wake up the vwait:
+
+ set state($sock,state) $sock
+
+ # Read the data:
+
+ set state($sock,data) [read $sock]
+}
Added: media/tcl/remote.tcl
===================================================================
--- media/tcl/remote.tcl (rev 0)
+++ media/tcl/remote.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,2 @@
+set telnetserverthreadid [TclThreadManager create]
+TclThreadManager execute $telnetserverthreadid source telnet_server.tcl
Added: media/tcl/telnet_server.tcl
===================================================================
--- media/tcl/telnet_server.tcl (rev 0)
+++ media/tcl/telnet_server.tcl 2009-07-24 15:56:47 UTC (rev 2209)
@@ -0,0 +1,213 @@
+ #!/usr/bin/env tclsh
+ # Pseudo-telnet server. Includes basic auth, but no separate identities
+ # or proper multi-threaded operation, so whoever runs this had better
+ # trust those he gives identities/passwords to and they had better trust
+ # each other too. Note this script does not support command-line arguments.
+
+ ## The names of this array are IP addresses of hosts that are not permitted
+ ## to connect to any of our services. Admin account(s) can change this
+ ## at run-time, though this info is not maintained across whole-server shutdowns.
+ array set denyHosts {}
+
+ ## Keep the Tcl-thread busy
+ proc every {ms body} { eval $body; after $ms [list every $ms $body] }
+ every 200 {}
+
+ ## Create a server on the given port with the given name/password map
+ ## and the given core interaction handler.
+ proc telnetServer {port {passmap} {handlerCmd remoteCommand}} {
+ if {$port == 0} {
+ return -code error "Only non-zero port numbers are supported"
+ }
+ set server [socket -server [list connect $port $handlerCmd] $port]
+ global passwords services
+ foreach {id pass} $passmap {set passwords($port,$id) $pass}
+ set services($server) $handlerCmd
+ return $server
+ }
+
+ ## Removes the server on the given port, cleaning up the extra state too.
+ proc closedownServer {server} {
+ global services passwords connections auth
+ set port [lindex [fconfigure $server -sockname] 2]
+ catch {close $server}
+ unset services($server)
+ foreach passmap [array names passwords $port,*] {
+ unset passwords($passmap)
+ }
+ # Hmph! Have to remove unauthorized connections too, though any
+ # connection which has been authorized can continue safely.
+ foreach {client data} [array get connections] {
+ if {$port == [lindex $data 0] && !$auth($client)} {
+ disconnect $client
+ }
+ }
+ }
+
+ ## Handle an incoming connection to the given server
+ proc connect {serverport handlerCmd client clienthost clientport} {
+ global auth cmd denyHosts connections
+ if {[info exist denyHosts($clienthost)]} {
+ puts stdout "${clienthost}:${clientport} attempted connection"
+ catch {puts $client "Connection denied"}
+ catch {close $client}
+ return
+ }
+ puts stdout "${clienthost}:${clientport} connected on $client"
+ fileevent $client readable "handle $serverport $client"
+ set auth($client) 0
+ set cmd($client) $handlerCmd
+ set connections($client) [list $serverport $clienthost $clientport]
+ fconfigure $client -buffering none
+ catch {puts -nonewline $client "Login: "}
+ }
+
+ ## Disconnect the given client, cleaning up any connection-specific data
+ proc disconnect {client} {
+ catch {close $client}
+ global auth cmd connections
+ unset auth($client)
+ unset cmd($client)
+ unset connections($client)
+ puts stdout "$client disconnected"
+ }
+
+ ## Handle data sent from the client. Log-in is handled directly by this
+ ## procedure, and requires the name and password on the same line
+ proc handle {serverport client} {
+ global passwords auth cmd
+ if {[gets $client line] < 0} {
+ disconnect $client
+ return
+ }
+ if {[string equal $line "logout"] || [string equal $line "quit"]} {
+ disconnect $client
+ return
+ }
+ if {[string equal $line "exit"]} {
+ set ::termination 1
+ return
+ }
+ if {$auth($client)} {
+ eval $cmd($client) [list $client $line 0]
+ eval $cmd($client) [list $client $line 1]
+ return
+ }
+ foreach {id pass} [split $line] {break}
+ if {![info exist pass]} {
+ catch {puts -nonewline $client "Login: "}
+ return
+ }
+ if {
+ [info exist passwords($serverport,$id)] &&
+ [string equal $passwords($serverport,$id) $pass]
+ } then {
+ set auth($client) 1
+ puts stdout "$id logged in on $client"
+ catch {puts $client "Welcome, $id!"}
+ eval $cmd($client) [list $client $line 1]
+ return
+ }
+ puts stdout "AUTH FAILURE ON $client"
+ catch {puts $client "Unknown name or password"}
+ disconnect $client
+ }
+
+ ## Standard handler for logged-in conversations and prompt-generation.
+ proc execCommand {client line prompt} {
+ global tcl_platform
+ if {$prompt} {
+ catch {puts -nonewline $client "\$ "}
+ return
+ }
+ switch $tcl_platform(platform) {
+ unix {
+ catch {exec sh -c $line <@$client >@$client 2>@$client}
+ }
+ default {
+ catch {exec $line} data
+ puts $client $data
+ }
+ }
+ }
+
+ ## Administration service handler. Chains to the normal handler for
+ ## everything it doesn't recognise itself.
+ proc admin {client line prompt} {
+ if {$prompt} {
+ catch {puts -nonewline $client "# "}
+ return
+ }
+ set cmd [split $line]
+ global denyHosts connections services
+ if {[string equal $line "shutdown"]} {
+ set ::termination 1
+ puts stdout "Shutdown requested on $client"
+ catch {puts $client "System will shut down as soon as possible"}
+ return -code return "SHUTTING DOWN"
+ } elseif {[string equal [lindex $cmd 0] "deny"]} {
+ set denyHosts([lindex $cmd 1]) 1
+ } elseif {[string equal [lindex $cmd 0] "allow"]} {
+ catch {unset denyHosts([lindex $cmd 1])}
+ } elseif {[string equal $line "denied"]} {
+ foreach host [array names denyHosts] {
+ catch {puts $client $host}
+ }
+ } elseif {[string equal $line "connections"]} {
+ set len 0
+ foreach conn [array names connections] {
+ if {$len < [string length $conn]} {
+ set len [string length $conn]
+ }
+ }
+ foreach {conn details} [array get connections] {
+ catch {puts $client [format "%-*s = %s" $len $conn $details]}
+ }
+ } elseif {[string equal [lindex $cmd 0] "close"]} {
+ set sock [lindex $cmd 1]
+ if {[info exist connections($sock)]} {
+ disconnect $sock
+ }
+ } elseif {[string equal $line "services"]} {
+ set len 0
+ foreach serv [array names services] {
+ if {$len < [string length $serv]} {
+ set len [string length $serv]
+ }
+ }
+ foreach {serv handler} [array get services] {
+ set port [lindex [fconfigure $serv -sockname] 2]
+ catch {puts $client [format "%-*s (port %d) = handler %s" $len $serv $port $handler]}
+ }
+ } elseif {[string equal [lindex $cmd 0] "addService"]} {
+ set service [eval telnetServer [lrange $cmd 1 end]]
+ catch {puts $client "Created service as $service"}
+ } elseif {[string equal [lindex $cmd 0] "removeService"]} {
+ set service [lindex $cmd 1]
+ if {[info exist services($service)]} {
+ closedownServer $service
+ }
+ } else {
+ # CHAIN TO DEFAULT
+ execCommand $client $line 0
+ }
+ }
+
+ ## Executes a given command
+ proc remoteCommand {client line prompt} {
+ global tcl_platform
+ if {$prompt} {
+ catch {puts -nonewline $client "\$ "}
+ return
+ }
+ catch {eval $line} data
+ puts $client $data
+ }
+
+ telnetServer 2560 {orxonox rocks} remoteCommand
+ telnetServer 2561 {orxadmin *****} admin
+
+ puts stdout "Ready for service"
+
+ vwait termination
+ execute exit
More information about the Orxonox-commit
mailing list