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