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