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