1# Based upon the picoirc code by Salvatore Sanfillipo and Richard Suchenwirth 2# See http://wiki.tcl.tk/13134 for the original standalone version. 3# 4# This package provides a general purpose minimal IRC client suitable for 5# embedding in other applications. All communication with the parent 6# application is done via an application provided callback procedure. 7# 8# Copyright (c) 2004 Salvatore Sanfillipo 9# Copyright (c) 2004 Richard Suchenwirth 10# Copyright (c) 2007 Patrick Thoyts 11# 12# ------------------------------------------------------------------------- 13# See the file "license.terms" for information on usage and redistribution 14# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 15# ------------------------------------------------------------------------- 16# 17# $Id: picoirc.tcl,v 1.4 2008/06/24 22:06:56 patthoyts Exp $ 18 19namespace eval ::picoirc { 20 variable version 0.5.1 21 variable uid; if {![info exists uid]} { set uid 0 } 22 variable defaults { 23 server "irc.freenode.net" 24 port 6667 25 channel "" 26 callback "" 27 motd {} 28 users {} 29 } 30 namespace export connect send post splituri 31} 32 33proc ::picoirc::splituri {uri} { 34 foreach {server port channel} {{} {} {}} break 35 if {![regexp {^irc://([^:/]+)(?::([^/]+))?(?:/([^,]+))?} $uri -> server port channel]} { 36 regexp {^(?:([^@]+)@)?([^:]+)(?::(\d+))?} $uri -> channel server port 37 } 38 if {$port eq {}} { set port 6667 } 39 return [list $server $port $channel] 40} 41 42proc ::picoirc::connect {callback nick args} { 43 if {[llength $args] > 2} { 44 return -code error "wrong # args: must be \"callback nick ?passwd? url\"" 45 } elseif {[llength $args] == 1} { 46 set url [lindex $args 0] 47 } else { 48 foreach {passwd url} $args break 49 } 50 variable defaults 51 variable uid 52 set context [namespace current]::irc[incr uid] 53 upvar #0 $context irc 54 array set irc $defaults 55 foreach {server port channel} [splituri $url] break 56 if {[info exists channel] && $channel ne ""} {set irc(channel) $channel} 57 if {[info exists server] && $server ne ""} {set irc(server) $server} 58 if {[info exists port] && $port ne ""} {set irc(port) $port} 59 if {[info exists passwd] && $passwd ne ""} {set irc(passwd) $passwd} 60 set irc(callback) $callback 61 set irc(nick) $nick 62 Callback $context init 63 set irc(socket) [socket -async $irc(server) $irc(port)] 64 fileevent $irc(socket) readable [list [namespace origin Read] $context] 65 fileevent $irc(socket) writable [list [namespace origin Write] $context] 66 return $context 67} 68 69proc ::picoirc::Callback {context state args} { 70 upvar #0 $context irc 71 if {[llength $irc(callback)] > 0 72 && [llength [info commands [lindex $irc(callback) 0]]] == 1} { 73 if {[catch {eval $irc(callback) [list $context $state] $args} err]} { 74 puts stderr "callback error: $err" 75 } 76 } 77} 78 79proc ::picoirc::Version {context} { 80 if {[catch {Callback $context version} ver]} { set ver {} } 81 if {$ver eq {}} { 82 set ver "PicoIRC:[package provide picoirc]:Tcl [info patchlevel]" 83 } 84 return $ver 85} 86 87proc ::picoirc::Write {context} { 88 upvar #0 $context irc 89 fileevent $irc(socket) writable {} 90 if {[set err [fconfigure $irc(socket) -error]] ne ""} { 91 Callback $context close $err 92 close $irc(socket) 93 unset irc 94 return 95 } 96 fconfigure $irc(socket) -blocking 0 -buffering line -translation crlf -encoding utf-8 97 Callback $context connect 98 if {[info exists irc(passwd)]} { 99 send $context "PASS $irc(passwd)" 100 } 101 set ver [join [lrange [split [Version $context] :] 0 1] " "] 102 send $context "NICK $irc(nick)" 103 send $context "USER $::tcl_platform(user) 0 * :$ver user" 104 if {$irc(channel) ne {}} { 105 after idle [list [namespace origin send] $context "JOIN $irc(channel)"] 106 } 107 return 108} 109 110proc ::picoirc::Splitirc {s} { 111 foreach v {nick flags user host} {set $v {}} 112 regexp {^([^!]*)!([^=]*)=([^@]+)@(.*)} $s -> nick flags user host 113 return [list $nick $flags $user $host] 114} 115 116proc ::picoirc::Read {context} { 117 upvar #0 $context irc 118 if {[eof $irc(socket)]} { 119 fileevent $irc(socket) readable {} 120 Callback $context close 121 close $irc(socket) 122 unset irc 123 return 124 } 125 if {[gets $irc(socket) line] != -1} { 126 if {[string match "PING*" $line]} { 127 send $context "PONG [info hostname] [lindex [split $line] 1]" 128 return 129 } 130 # the callback can return -code break to prevent processing the read 131 if {[catch {Callback $context debug read $line}] == 3} { 132 return 133 } 134 if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +:(.*)} $line -> \ 135 nick target msg]} { 136 set type "" 137 if {[regexp {\001(\S+)(.*)?\001} $msg -> ctcp data]} { 138 switch -- $ctcp { 139 ACTION { set type ACTION ; set msg $data } 140 VERSION { 141 send $context "NOTICE $nick :\001VERSION [Version $context]\001" 142 return 143 } 144 PING { 145 send $context "NOTICE $nick :\001PING [lindex $data 0]\001" 146 return 147 } 148 TIME { 149 set time [clock format [clock seconds] \ 150 -format {%a %b %d %H:%M:%S %Y %Z}] 151 send $context "NOTICE $nick :\001TIME $time\001" 152 return 153 } 154 default { 155 set err [string map [list \001 ""] $msg] 156 send $context "NOTICE $nick :\001ERRMSG $err : unknown query\001" 157 return 158 } 159 } 160 } 161 if {[lsearch -exact {ijchain wubchain} $nick] != -1} { 162 if {$type eq "ACTION"} { 163 regexp {(\S+) (.+)} $msg -> nick msg 164 } else { 165 regexp {<([^>]+)> (.+)} $msg -> nick msg 166 } 167 } 168 Callback $context chat $target $nick $msg $type 169 } elseif {[regexp {^:((?:([^ ]+) +){1,}?):(.*)$} $line -> parts junk rest]} { 170 foreach {server code target fourth fifth} [split $parts] break 171 switch -- $code { 172 001 - 002 - 003 - 004 - 005 - 250 - 251 - 252 - 173 254 - 255 - 265 - 266 { return } 174 433 { 175 variable nickid ; if {![info exists nickid]} {set nickid 0} 176 set seqlen [string length [incr nickid]] 177 set irc(nick) [string range $irc(nick) 0 [expr 8-$seqlen]]$nickid 178 send $context "NICK $irc(nick)" 179 } 180 353 { set irc(users) [concat $irc(users) $rest]; return } 181 366 { 182 Callback $context userlist $fourth $irc(users) 183 set irc(users) {} 184 return 185 } 186 332 { Callback $context topic $fourth $rest; return } 187 333 { return } 188 375 { set irc(motd) {} ; return } 189 372 { append irc(motd) $rest ; return} 190 376 { return } 191 311 { 192 foreach {server code target nick name host x} [split $parts] break 193 set irc(whois,$fourth) [list name $name host $host userinfo $rest] 194 return 195 } 196 301 - 312 - 317 - 320 { return } 197 319 { lappend irc(whois,$fourth) channels $rest; return } 198 318 { 199 if {[info exists irc(whois,$fourth)]} { 200 Callback $context userinfo $fourth $irc(whois,$fourth) 201 unset irc(whois,$fourth) 202 } 203 return 204 } 205 JOIN { 206 foreach {n f u h} [Splitirc $server] break 207 Callback $context traffic entered $rest $n 208 return 209 } 210 NICK { 211 foreach {n f u h} [Splitirc $server] break 212 Callback $context traffic nickchange {} $n $rest 213 return 214 } 215 QUIT - PART { 216 foreach {n f u h} [Splitirc $server] break 217 Callback $context traffic left $target $n 218 return 219 } 220 } 221 Callback $context system "" "[lrange [split $parts] 1 end] $rest" 222 } else { 223 Callback $context system "" $line 224 } 225 } 226} 227 228proc ::picoirc::post {context channel msg} { 229 upvar #0 $context irc 230 set type "" 231 if [regexp {^/([^ ]+) *(.*)} $msg -> cmd msg] { 232 regexp {^([^ ]+)?(?: +(.*))?} $msg -> first rest 233 switch -- $cmd { 234 me {set msg "\001ACTION $msg\001";set type ACTION} 235 nick {send $context "NICK $msg"; set $irc(nick) $msg} 236 quit {send $context "QUIT" } 237 part {send $context "PART $channel" } 238 names {send $context "NAMES $channel"} 239 whois {send $context "WHOIS $channel $msg"} 240 kick {send $context "KICK $channel $first :$rest"} 241 mode {send $context "MODE $msg"} 242 topic {send $context "TOPIC $channel :$msg" } 243 quote {send $context $msg} 244 join {send $context "JOIN $msg" } 245 version {send $context "PRIVMSG $first :\001VERSION\001"} 246 msg { 247 if {[regexp {([^ ]+) +(.*)} $msg -> target querymsg]} { 248 send $context "PRIVMSG $target :$msg" 249 Callback $context chat $target $target $querymsg "" 250 } 251 } 252 default {Callback $context system $channel "unknown command /$cmd"} 253 } 254 if {$cmd ne {me} || $cmd eq {msg}} return 255 } 256 foreach line [split $msg \n] {send $context "PRIVMSG $channel :$line"} 257 Callback $context chat $channel $irc(nick) $msg $type 258} 259 260proc ::picoirc::send {context line} { 261 upvar #0 $context irc 262 # the callback can return -code break to prevent writing to socket 263 if {[catch {Callback $context debug write $line}] != 3} { 264 puts $irc(socket) $line 265 } 266} 267 268# ------------------------------------------------------------------------- 269 270package provide picoirc $::picoirc::version 271 272# ------------------------------------------------------------------------- 273