| 1 | # irc.tcl -- |
|---|
| 2 | # |
|---|
| 3 | # irc implementation for Tcl. |
|---|
| 4 | # |
|---|
| 5 | # Copyright (c) 2001-2003 by David N. Welton <davidw@dedasys.com>. |
|---|
| 6 | # This code may be distributed under the same terms as Tcl. |
|---|
| 7 | # |
|---|
| 8 | # $Id: irc.tcl,v 1.26 2006/04/23 22:35:57 patthoyts Exp $ |
|---|
| 9 | |
|---|
| 10 | package require Tcl 8.3 |
|---|
| 11 | |
|---|
| 12 | namespace eval ::irc { |
|---|
| 13 | variable version 0.6 |
|---|
| 14 | |
|---|
| 15 | # counter used to differentiate connections |
|---|
| 16 | variable conn 0 |
|---|
| 17 | variable config |
|---|
| 18 | variable irctclfile [info script] |
|---|
| 19 | array set config { |
|---|
| 20 | debug 0 |
|---|
| 21 | logger 0 |
|---|
| 22 | } |
|---|
| 23 | } |
|---|
| 24 | |
|---|
| 25 | # ::irc::config -- |
|---|
| 26 | # |
|---|
| 27 | # Set global configuration options. |
|---|
| 28 | # |
|---|
| 29 | # Arguments: |
|---|
| 30 | # |
|---|
| 31 | # key name of the configuration option to change. |
|---|
| 32 | # |
|---|
| 33 | # value value of the configuration option. |
|---|
| 34 | |
|---|
| 35 | proc ::irc::config { args } { |
|---|
| 36 | variable config |
|---|
| 37 | if { [llength $args] == 0 } { |
|---|
| 38 | return [array get config] |
|---|
| 39 | } elseif { [llength $args] == 1 } { |
|---|
| 40 | return $config($key) |
|---|
| 41 | } elseif { [llength $args] > 2 } { |
|---|
| 42 | error "wrong # args: should be \"config key ?val?\"" |
|---|
| 43 | } |
|---|
| 44 | set key [lindex $args 0] |
|---|
| 45 | set value [lindex $args 1] |
|---|
| 46 | foreach ns [namespace children] { |
|---|
| 47 | if { [info exists config($key)] && [info exists ${ns}::config($key)] \ |
|---|
| 48 | && [set ${ns}::config($key)] == $config($key)} { |
|---|
| 49 | ${ns}::cmd-config $key $value |
|---|
| 50 | } |
|---|
| 51 | } |
|---|
| 52 | set config($key) $value |
|---|
| 53 | } |
|---|
| 54 | |
|---|
| 55 | |
|---|
| 56 | # ::irc::connections -- |
|---|
| 57 | # |
|---|
| 58 | # Return a list of handles to all existing connections |
|---|
| 59 | |
|---|
| 60 | proc ::irc::connections { } { |
|---|
| 61 | set r {} |
|---|
| 62 | foreach ns [namespace children] { |
|---|
| 63 | lappend r ${ns}::network |
|---|
| 64 | } |
|---|
| 65 | return $r |
|---|
| 66 | } |
|---|
| 67 | |
|---|
| 68 | # ::irc::reload -- |
|---|
| 69 | # |
|---|
| 70 | # Reload this file, and merge the current connections into |
|---|
| 71 | # the new one. |
|---|
| 72 | |
|---|
| 73 | proc ::irc::reload { } { |
|---|
| 74 | variable conn |
|---|
| 75 | set oldconn $conn |
|---|
| 76 | namespace eval :: { |
|---|
| 77 | source [set ::irc::irctclfile] |
|---|
| 78 | } |
|---|
| 79 | foreach ns [namespace children] { |
|---|
| 80 | foreach var {sock logger host port} { |
|---|
| 81 | set $var [set ${ns}::$var] |
|---|
| 82 | } |
|---|
| 83 | array set dispatch [array get ${ns}::dispatch] |
|---|
| 84 | array set config [array get ${ns}::config] |
|---|
| 85 | # make sure our new connection uses the same namespace |
|---|
| 86 | set conn [string range $ns 10 end] |
|---|
| 87 | ::irc::connection |
|---|
| 88 | foreach var {sock logger host port} { |
|---|
| 89 | set ${ns}::$var [set $var] |
|---|
| 90 | } |
|---|
| 91 | array set ${ns}::dispatch [array get dispatch] |
|---|
| 92 | array set ${ns}::config [array get config] |
|---|
| 93 | } |
|---|
| 94 | set conn $oldconn |
|---|
| 95 | } |
|---|
| 96 | |
|---|
| 97 | # ::irc::connection -- |
|---|
| 98 | # |
|---|
| 99 | # Create an IRC connection namespace and associated commands. |
|---|
| 100 | |
|---|
| 101 | proc ::irc::connection { args } { |
|---|
| 102 | variable conn |
|---|
| 103 | variable config |
|---|
| 104 | |
|---|
| 105 | # Create a unique namespace of the form irc$conn::$host |
|---|
| 106 | |
|---|
| 107 | set name [format "%s::irc%s" [namespace current] $conn] |
|---|
| 108 | |
|---|
| 109 | namespace eval $name { |
|---|
| 110 | set sock {} |
|---|
| 111 | array set dispatch {} |
|---|
| 112 | array set linedata {} |
|---|
| 113 | array set config [array get ::irc::config] |
|---|
| 114 | if { $config(logger) || $config(debug)} { |
|---|
| 115 | package require logger |
|---|
| 116 | set logger [logger::init [namespace tail [namespace current]]] |
|---|
| 117 | if { !$config(debug) } { ${logger}::disable debug } |
|---|
| 118 | } |
|---|
| 119 | |
|---|
| 120 | |
|---|
| 121 | # ircsend -- |
|---|
| 122 | # send text to the IRC server |
|---|
| 123 | |
|---|
| 124 | proc ircsend { msg } { |
|---|
| 125 | variable sock |
|---|
| 126 | variable dispatch |
|---|
| 127 | if { $sock == "" } { return } |
|---|
| 128 | cmd-log debug "ircsend: '$msg'" |
|---|
| 129 | if { [catch {puts $sock $msg} err] } { |
|---|
| 130 | catch { close $sock } |
|---|
| 131 | set sock {} |
|---|
| 132 | if { [info exists dispatch(EOF)] } { |
|---|
| 133 | eval $dispatch(EOF) |
|---|
| 134 | } |
|---|
| 135 | cmd-log error "Error in ircsend: $err" |
|---|
| 136 | } |
|---|
| 137 | } |
|---|
| 138 | |
|---|
| 139 | |
|---|
| 140 | ######################################################### |
|---|
| 141 | # Implemented user-side commands, meaning that these commands |
|---|
| 142 | # cause the calling user to perform the given action. |
|---|
| 143 | ######################################################### |
|---|
| 144 | |
|---|
| 145 | |
|---|
| 146 | # cmd-config -- |
|---|
| 147 | # |
|---|
| 148 | # Set or return per-connection configuration options. |
|---|
| 149 | # |
|---|
| 150 | # Arguments: |
|---|
| 151 | # |
|---|
| 152 | # key name of the configuration option to change. |
|---|
| 153 | # |
|---|
| 154 | # value value (optional) of the configuration option. |
|---|
| 155 | |
|---|
| 156 | proc cmd-config { args } { |
|---|
| 157 | variable config |
|---|
| 158 | variable logger |
|---|
| 159 | |
|---|
| 160 | if { [llength $args] == 0 } { |
|---|
| 161 | return [array get config] |
|---|
| 162 | } elseif { [llength $args] == 1 } { |
|---|
| 163 | return $config($key) |
|---|
| 164 | } elseif { [llength $args] > 2 } { |
|---|
| 165 | error "wrong # args: should be \"config key ?val?\"" |
|---|
| 166 | } |
|---|
| 167 | set key [lindex $args 0] |
|---|
| 168 | set value [lindex $args 1] |
|---|
| 169 | if { $key == "debug" } { |
|---|
| 170 | if {$value} { |
|---|
| 171 | if { !$config(logger) } { cmd-config logger 1 } |
|---|
| 172 | ${logger}::enable debug |
|---|
| 173 | } elseif { [info exists logger] } { |
|---|
| 174 | ${logger}::disable debug |
|---|
| 175 | } |
|---|
| 176 | } |
|---|
| 177 | if { $key == "logger" } { |
|---|
| 178 | if { $value && !$config(logger)} { |
|---|
| 179 | package require logger |
|---|
| 180 | set logger [logger::init [namespace tail [namespace current]]] |
|---|
| 181 | } elseif { [info exists logger] } { |
|---|
| 182 | ${logger}::delete |
|---|
| 183 | unset logger |
|---|
| 184 | } |
|---|
| 185 | } |
|---|
| 186 | set config($key) $value |
|---|
| 187 | } |
|---|
| 188 | |
|---|
| 189 | proc cmd-log {level text} { |
|---|
| 190 | variable logger |
|---|
| 191 | if { ![info exists logger] } return |
|---|
| 192 | ${logger}::$level $text |
|---|
| 193 | } |
|---|
| 194 | |
|---|
| 195 | proc cmd-logname { } { |
|---|
| 196 | variable logger |
|---|
| 197 | if { ![info exists logger] } return |
|---|
| 198 | return $logger |
|---|
| 199 | } |
|---|
| 200 | |
|---|
| 201 | # cmd-destroy -- |
|---|
| 202 | # |
|---|
| 203 | # destroys the current connection and its namespace |
|---|
| 204 | |
|---|
| 205 | proc cmd-destroy { } { |
|---|
| 206 | variable logger |
|---|
| 207 | variable sock |
|---|
| 208 | if { [info exists logger] } { ${logger}::delete } |
|---|
| 209 | catch {close $sock} |
|---|
| 210 | namespace delete [namespace current] |
|---|
| 211 | } |
|---|
| 212 | |
|---|
| 213 | proc cmd-connected { } { |
|---|
| 214 | variable sock |
|---|
| 215 | if { $sock == "" } { return 0 } |
|---|
| 216 | return 1 |
|---|
| 217 | } |
|---|
| 218 | |
|---|
| 219 | proc cmd-user { username hostname servername {userinfo ""} } { |
|---|
| 220 | if { $userinfo == "" } { |
|---|
| 221 | ircsend "USER $username $hostname server :$servername" |
|---|
| 222 | } else { |
|---|
| 223 | ircsend "USER $username $hostname $servername :$userinfo" |
|---|
| 224 | } |
|---|
| 225 | } |
|---|
| 226 | |
|---|
| 227 | proc cmd-nick { nk } { |
|---|
| 228 | ircsend "NICK $nk" |
|---|
| 229 | } |
|---|
| 230 | |
|---|
| 231 | proc cmd-ping { target } { |
|---|
| 232 | ircsend "PRIVMSG $target :\001PING [clock seconds]\001" |
|---|
| 233 | } |
|---|
| 234 | |
|---|
| 235 | proc cmd-serverping { } { |
|---|
| 236 | ircsend "PING [clock seconds]" |
|---|
| 237 | } |
|---|
| 238 | |
|---|
| 239 | proc cmd-ctcp { target line } { |
|---|
| 240 | ircsend "PRIVMSG $target :\001$line\001" |
|---|
| 241 | } |
|---|
| 242 | |
|---|
| 243 | proc cmd-join { chan {key {}} } { |
|---|
| 244 | ircsend "JOIN $chan $key" |
|---|
| 245 | } |
|---|
| 246 | |
|---|
| 247 | proc cmd-part { chan {msg ""} } { |
|---|
| 248 | if { $msg == "" } { |
|---|
| 249 | ircsend "PART $chan" |
|---|
| 250 | } else { |
|---|
| 251 | ircsend "PART $chan :$msg" |
|---|
| 252 | } |
|---|
| 253 | } |
|---|
| 254 | |
|---|
| 255 | proc cmd-quit { {msg {tcllib irc module - http://tcllib.sourceforge.net/}} } { |
|---|
| 256 | ircsend "QUIT :$msg" |
|---|
| 257 | } |
|---|
| 258 | |
|---|
| 259 | proc cmd-privmsg { target msg } { |
|---|
| 260 | ircsend "PRIVMSG $target :$msg" |
|---|
| 261 | } |
|---|
| 262 | |
|---|
| 263 | proc cmd-notice { target msg } { |
|---|
| 264 | ircsend "NOTICE $target :$msg" |
|---|
| 265 | } |
|---|
| 266 | |
|---|
| 267 | proc cmd-kick { chan target {msg {}} } { |
|---|
| 268 | ircsend "KICK $chan $target :$msg" |
|---|
| 269 | } |
|---|
| 270 | |
|---|
| 271 | proc cmd-mode { target args } { |
|---|
| 272 | ircsend "MODE $target [join $args]" |
|---|
| 273 | } |
|---|
| 274 | |
|---|
| 275 | proc cmd-topic { chan msg } { |
|---|
| 276 | ircsend "TOPIC $chan :$msg" |
|---|
| 277 | } |
|---|
| 278 | |
|---|
| 279 | proc cmd-invite { chan target } { |
|---|
| 280 | ircsend "INVITE $target $chan" |
|---|
| 281 | } |
|---|
| 282 | |
|---|
| 283 | proc cmd-send { line } { |
|---|
| 284 | ircsend $line |
|---|
| 285 | } |
|---|
| 286 | |
|---|
| 287 | proc cmd-peername { } { |
|---|
| 288 | variable sock |
|---|
| 289 | if { $sock == "" } { return {} } |
|---|
| 290 | return [fconfigure $sock -peername] |
|---|
| 291 | } |
|---|
| 292 | |
|---|
| 293 | proc cmd-sockname { } { |
|---|
| 294 | variable sock |
|---|
| 295 | if { $sock == "" } { return {} } |
|---|
| 296 | return [fconfigure $sock -sockname] |
|---|
| 297 | } |
|---|
| 298 | |
|---|
| 299 | proc cmd-socket { } { |
|---|
| 300 | variable sock |
|---|
| 301 | return $sock |
|---|
| 302 | } |
|---|
| 303 | |
|---|
| 304 | proc cmd-disconnect { } { |
|---|
| 305 | variable sock |
|---|
| 306 | if { $sock == "" } { return -1 } |
|---|
| 307 | catch { close $sock } |
|---|
| 308 | set sock {} |
|---|
| 309 | return 0 |
|---|
| 310 | } |
|---|
| 311 | |
|---|
| 312 | # Connect -- |
|---|
| 313 | # Create the actual tcp connection. |
|---|
| 314 | |
|---|
| 315 | proc cmd-connect { h {p 6667} } { |
|---|
| 316 | variable sock |
|---|
| 317 | variable host |
|---|
| 318 | variable port |
|---|
| 319 | |
|---|
| 320 | set host $h |
|---|
| 321 | set port $p |
|---|
| 322 | |
|---|
| 323 | if { $sock == "" } { |
|---|
| 324 | set sock [socket $host $port] |
|---|
| 325 | fconfigure $sock -translation crlf -buffering line |
|---|
| 326 | fileevent $sock readable [namespace current]::GetEvent |
|---|
| 327 | } |
|---|
| 328 | return 0 |
|---|
| 329 | } |
|---|
| 330 | |
|---|
| 331 | # Callback API: |
|---|
| 332 | |
|---|
| 333 | # These are all available from within callbacks, so as to |
|---|
| 334 | # provide an interface to provide some information on what is |
|---|
| 335 | # coming out of the server. |
|---|
| 336 | |
|---|
| 337 | # action -- |
|---|
| 338 | |
|---|
| 339 | # Action returns the action performed, such as KICK, PRIVMSG, |
|---|
| 340 | # MODE etc, including numeric actions such as 001, 252, 353, |
|---|
| 341 | # and so forth. |
|---|
| 342 | |
|---|
| 343 | proc action { } { |
|---|
| 344 | variable linedata |
|---|
| 345 | return $linedata(action) |
|---|
| 346 | } |
|---|
| 347 | |
|---|
| 348 | # msg -- |
|---|
| 349 | |
|---|
| 350 | # The last argument of the line, after the last ':'. |
|---|
| 351 | |
|---|
| 352 | proc msg { } { |
|---|
| 353 | variable linedata |
|---|
| 354 | return $linedata(msg) |
|---|
| 355 | } |
|---|
| 356 | |
|---|
| 357 | # who -- |
|---|
| 358 | |
|---|
| 359 | # Who performed the action. If the command is called as [who address], |
|---|
| 360 | # it returns the information in the form |
|---|
| 361 | # nick!ident@host.domain.net |
|---|
| 362 | |
|---|
| 363 | proc who { {address 0} } { |
|---|
| 364 | variable linedata |
|---|
| 365 | if { $address == 0 } { |
|---|
| 366 | return [lindex [split $linedata(who) !] 0] |
|---|
| 367 | } else { |
|---|
| 368 | return $linedata(who) |
|---|
| 369 | } |
|---|
| 370 | } |
|---|
| 371 | |
|---|
| 372 | # target -- |
|---|
| 373 | |
|---|
| 374 | # To whom was this action done. |
|---|
| 375 | |
|---|
| 376 | proc target { } { |
|---|
| 377 | variable linedata |
|---|
| 378 | return $linedata(target) |
|---|
| 379 | } |
|---|
| 380 | |
|---|
| 381 | # additional -- |
|---|
| 382 | |
|---|
| 383 | # Returns any additional header elements beyond the target as a list. |
|---|
| 384 | |
|---|
| 385 | proc additional { } { |
|---|
| 386 | variable linedata |
|---|
| 387 | return $linedata(additional) |
|---|
| 388 | } |
|---|
| 389 | |
|---|
| 390 | # header -- |
|---|
| 391 | |
|---|
| 392 | # Returns the entire header in list format. |
|---|
| 393 | |
|---|
| 394 | proc header { } { |
|---|
| 395 | variable linedata |
|---|
| 396 | return [concat [list $linedata(who) $linedata(action) \ |
|---|
| 397 | $linedata(target)] $linedata(additional)] |
|---|
| 398 | } |
|---|
| 399 | |
|---|
| 400 | # GetEvent -- |
|---|
| 401 | |
|---|
| 402 | # Get a line from the server and dispatch it. |
|---|
| 403 | |
|---|
| 404 | proc GetEvent { } { |
|---|
| 405 | variable linedata |
|---|
| 406 | variable sock |
|---|
| 407 | variable dispatch |
|---|
| 408 | array set linedata {} |
|---|
| 409 | set line "eof" |
|---|
| 410 | if { [eof $sock] || [catch {gets $sock} line] } { |
|---|
| 411 | close $sock |
|---|
| 412 | set sock {} |
|---|
| 413 | cmd-log error "Error receiving from network: $line" |
|---|
| 414 | if { [info exists dispatch(EOF)] } { |
|---|
| 415 | eval $dispatch(EOF) |
|---|
| 416 | } |
|---|
| 417 | return |
|---|
| 418 | } |
|---|
| 419 | cmd-log debug "Recieved: $line" |
|---|
| 420 | if { [set pos [string first " :" $line]] > -1 } { |
|---|
| 421 | set header [string range $line 0 [expr {$pos - 1}]] |
|---|
| 422 | set linedata(msg) [string range $line [expr {$pos + 2}] end] |
|---|
| 423 | } else { |
|---|
| 424 | set header [string trim $line] |
|---|
| 425 | set linedata(msg) {} |
|---|
| 426 | } |
|---|
| 427 | |
|---|
| 428 | if { [string match :* $header] } { |
|---|
| 429 | set header [split [string trimleft $header :]] |
|---|
| 430 | } else { |
|---|
| 431 | set header [linsert [split $header] 0 {}] |
|---|
| 432 | } |
|---|
| 433 | set linedata(who) [lindex $header 0] |
|---|
| 434 | set linedata(action) [lindex $header 1] |
|---|
| 435 | set linedata(target) [lindex $header 2] |
|---|
| 436 | set linedata(additional) [lrange $header 3 end] |
|---|
| 437 | if { [info exists dispatch($linedata(action))] } { |
|---|
| 438 | eval $dispatch($linedata(action)) |
|---|
| 439 | } elseif { [string match {[0-9]??} $linedata(action)] } { |
|---|
| 440 | eval $dispatch(defaultnumeric) |
|---|
| 441 | } elseif { $linedata(who) == "" } { |
|---|
| 442 | eval $dispatch(defaultcmd) |
|---|
| 443 | } else { |
|---|
| 444 | eval $dispatch(defaultevent) |
|---|
| 445 | } |
|---|
| 446 | } |
|---|
| 447 | |
|---|
| 448 | # registerevent -- |
|---|
| 449 | |
|---|
| 450 | # Register an event in the dispatch table. |
|---|
| 451 | |
|---|
| 452 | # Arguments: |
|---|
| 453 | # evnt: name of event as sent by IRC server. |
|---|
| 454 | # cmd: proc to register as the event handler |
|---|
| 455 | |
|---|
| 456 | proc cmd-registerevent { evnt cmd } { |
|---|
| 457 | variable dispatch |
|---|
| 458 | set dispatch($evnt) $cmd |
|---|
| 459 | if { $cmd == "" } { |
|---|
| 460 | unset dispatch($evnt) |
|---|
| 461 | } |
|---|
| 462 | } |
|---|
| 463 | |
|---|
| 464 | # getevent -- |
|---|
| 465 | |
|---|
| 466 | # Return the currently registered handler for the event. |
|---|
| 467 | |
|---|
| 468 | # Arguments: |
|---|
| 469 | # evnt: name of event as sent by IRC server. |
|---|
| 470 | |
|---|
| 471 | proc cmd-getevent { evnt } { |
|---|
| 472 | variable dispatch |
|---|
| 473 | if { [info exists dispatch($evnt)] } { |
|---|
| 474 | return $dispatch($evnt) |
|---|
| 475 | } |
|---|
| 476 | return {} |
|---|
| 477 | } |
|---|
| 478 | |
|---|
| 479 | # eventexists -- |
|---|
| 480 | |
|---|
| 481 | # Return a boolean value indicating if there is a handler |
|---|
| 482 | # registered for the event. |
|---|
| 483 | |
|---|
| 484 | # Arguments: |
|---|
| 485 | # evnt: name of event as sent by IRC server. |
|---|
| 486 | |
|---|
| 487 | proc cmd-eventexists { evnt } { |
|---|
| 488 | variable dispatch |
|---|
| 489 | return [info exists dispatch($evnt)] |
|---|
| 490 | } |
|---|
| 491 | |
|---|
| 492 | # network -- |
|---|
| 493 | |
|---|
| 494 | # Accepts user commands and dispatches them. |
|---|
| 495 | |
|---|
| 496 | # Arguments: |
|---|
| 497 | # cmd: command to invoke |
|---|
| 498 | # args: arguments to the command |
|---|
| 499 | |
|---|
| 500 | proc network { cmd args } { |
|---|
| 501 | eval [linsert $args 0 [namespace current]::cmd-$cmd] |
|---|
| 502 | } |
|---|
| 503 | |
|---|
| 504 | # Create default handlers. |
|---|
| 505 | |
|---|
| 506 | set dispatch(PING) {network send "PONG :[msg]"} |
|---|
| 507 | set dispatch(defaultevent) # |
|---|
| 508 | set dispatch(defaultcmd) # |
|---|
| 509 | set dispatch(defaultnumeric) # |
|---|
| 510 | } |
|---|
| 511 | |
|---|
| 512 | set returncommand [format "%s::irc%s::network" [namespace current] $conn] |
|---|
| 513 | incr conn |
|---|
| 514 | return $returncommand |
|---|
| 515 | } |
|---|
| 516 | |
|---|
| 517 | # ------------------------------------------------------------------------- |
|---|
| 518 | |
|---|
| 519 | package provide irc $::irc::version |
|---|
| 520 | |
|---|
| 521 | # ------------------------------------------------------------------------- |
|---|
