Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: code/archive/mac_HS16/data/tcl/irk/lib/irkcommand.tcl @ 12337

Last change on this file since 12337 was 5781, checked in by rgrieder, 15 years ago

Reverted trunk again. We might want to find a way to delete these revisions again (x3n's changes are still available as diff in the commit mails).

  • Property svn:eol-style set to native
File size: 8.9 KB
Line 
1# irkcommand.tcl:
2#
3# Various commands that can be invoked by the user of the IRK library:
4
5namespace eval irk {
6
7    # Say something to a user or to a channel
8
9    proc say {token chan saying} {
10        variable state
11
12        if {[catch {set sock $state($token,socket)}]} {
13            error "$token: not a valid irc connection"
14        }
15        if {![string compare "" $saying]} {
16            return
17        }
18        sendit $sock "PRIVMSG $chan :[string trim $saying]"
19    }
20
21    # Send a NOTICE to a user or a channel
22
23    proc notice {token chan args} {
24        variable state
25
26        if {[catch {set sock $state($token,socket)}]} {
27            error "$token: not a valid irc connection"
28        }
29        sendit $sock "NOTICE $chan :$args"
30    }
31
32    # Send a raw command to the server:
33
34    proc send {token args} {
35        variable state
36
37        if {[catch {set sock $state($token,socket)}]} {
38            error "$token: not a valid irc connection"
39        }
40        puts $sock $args
41    }
42
43    # Change your NICK
44
45    proc nick {token {newnick ""}} {
46        variable state
47
48        if {![string compare "" $newnick]} {
49            return $state($token,nick)
50        }
51        if {[catch {set sock $state($token,socket)}]} {
52            error "$token: not a valid irc connection"
53        }
54        puts $sock "NICK $newnick"
55    }
56
57    # Join a channel
58
59    proc join {token chans {keys ""}} {
60        variable state
61
62        if {[catch {set sock $state($token,socket)}]} {
63            error "$token: not a valid irc connection"
64        }
65        puts $sock "JOIN $chans $keys"
66    }
67
68    # Leave a channel
69
70    proc leave {token chans {partmsg ""}} {
71        variable state
72
73        if {![string compare $partmsg ""]} {
74            if {[info exists state(partmsg)]} {
75                set partmsg $state(partmsg)
76            }
77        }
78        if {[catch {set sock $state($token,socket)}]} {
79            error "$token: not a valid irc connection"
80        }
81        puts $sock "PART $chans $partmsg"
82    }
83
84    # Return a list of all connections that are open:
85
86    proc connections {} {
87        variable state
88
89        if {![info exists state(connections)]} {
90            return {}
91        }
92        return $state(connections)
93    }
94
95    # Return a list of channels we're on in a give connection:
96
97    proc onchannels {token} {
98        variable state
99
100        if {![info exists state($token,channels)]} {
101            return {}
102        }
103        return $state($token,channels)
104    }
105
106    # Returns 1 if we are on the given channel.
107
108    proc onchannel {token channel} {
109        variable state
110
111        if {![info exists state($token,channels)]} {
112            return 0
113        }
114
115        set idx [lsearch $state($token,channels) $channel]
116        if {$idx == -1} {
117            return 0
118        }
119        return 1
120    }
121
122    # Return a list of users on a given channel (we must be on that channel).
123
124    proc whoison {token chan} {
125        variable state
126
127        if {![info exists state($token,$chan,NAMES)]} {
128            return {}
129        }
130        return $state($token,$chan,NAMES)
131    }
132
133    # Ping a server
134
135    proc ping {token} {
136        variable state
137
138        if {[catch {set sock $state($token,socket)}]} {
139            error "$token: not a valid irc connection"
140        }
141        set state($token,PINGSTART) [clock clicks -millis]
142        puts $sock "PING $state($token,host)"
143    }
144
145    # Quit this connection
146
147    proc quit {token} {
148        disconnect $token
149    }
150
151    # Query information about someone
152
153    proc whois {token nick} {
154        variable state
155
156        if {[catch {set sock $state($token,socket)}]} {
157            error "$token: not a valid irc connection"
158        }
159        puts $sock "WHOIS $nick"
160    }
161
162    # Set an away message
163
164    proc away {token args} {
165        variable state
166
167        if {[catch {set sock $state($token,socket)}]} {
168            error "$token: not a valid irc connection"
169        }
170        puts $sock "AWAY :$args"
171    }
172
173    # This procedure lets the client do CTCP actions:
174
175    proc ctcp {token target action args} {
176        variable state
177
178        if {[catch {set sock $state($token,socket)}]} {
179            error "$token: not a valid irc connection"
180        }
181        sendit $sock "PRIVMSG $target :\001$action $args\001"
182    }
183
184    # This command implements the TCL CTCP protocol:
185
186    proc tcl {token target args} {
187        variable state
188
189        # Send it to the channel:
190
191        if {[catch {set sock $state($token,socket)}]} {
192            error "$token: not a valid irc connection"
193        }
194        sendit $sock "PRIVMSG $target :\001TCL $args\001"
195
196        # Apply it locally:
197
198        if {[info exists state($token,channel,ctcp,TCL,LOCAL)]} {
199            $state($token,channel,ctcp,TCL,LOCAL) \
200                    $token $state($token,nick) $state($token,user) \
201                    PRIVMSG $target TCL $args
202        }
203    }
204
205    # These procedures add and remove action handlers:
206
207    # These procedures add actions that will be called when the user
208    # with the given nick causes the supplied comm(and) to be executed
209    # on the given dest(ination). This is the most specific form of action.
210
211    proc addaction3 {token nick comm dest cmd} {
212        variable state
213
214        if {![info exists state($token,$nick,$comm,$dest)]} {
215            set state($token,$nick,$comm,$dest) [list $cmd]
216        } else {
217            lappend state($token,$nick,$comm,$dest) $cmd
218        }
219    }
220
221    proc setaction3 {token nick comm dest cmd} {
222        variable state
223
224        set state($token,$nick,$comm,$dest) [list $cmd]
225    }
226
227    # This procedure removes an action set by either of the above two
228    # procedures.
229
230    proc remaction3 {token nick comm dest cmd} {
231        variable state
232
233        if {![info exists state($token,$nick,$comm,$dest)]} {
234            return
235        }
236        set cmds $state($token,$nick,$comm,$dest)
237        set idx [lsearch $cmds $cmd]
238        if {$idx == -1} {
239            return
240        }
241        set state($token,$nick,$comm,$dest) [lreplace $cmds $idx $idx]
242        if {![string compare "" $state($token,$nick,$comm,$dest)]} {
243            unset state($token,$nick,$comm,$dest)
244        }
245    }
246
247    # These procedures add actions that will be called when the
248    # specific comm(and) is caused for the given dest(ination).
249
250    proc addaction2 {token comm dest cmd} {
251        variable state
252
253        if {![info exists state($token,$comm,$dest)]} {
254            set state($token,$comm,$dest) [list $cmd]
255        } else {
256            lappend state($token,$comm,$dest) $cmd
257        }
258    }
259
260    proc setaction2 {token comm dest cmd} {
261        variable state
262
263        set state($token,$comm,$dest) [list $cmd]
264    }
265
266    # This procedure removes an action set by either of the above two
267    # procedures.
268
269    proc remaction2 {token comm dest cmd} {
270        variable state
271
272        if {![info exists state($token,$comm,$dest)]} {
273            return
274        }
275        set cmds $state($token,$comm,$dest)
276        set idx [lsearch $cmds $cmd]
277        if {$idx == -1} {
278            return
279        }
280        set state($token,$comm,$dest) [lreplace $cmds $idx $idx]
281        if {![string compare "" $state($token,$comm,$dest)]} {
282            unset state($token,$comm,$dest)
283        }
284    }
285
286    # These procedures add actions that will be called when the
287    # specific comm(and) is caused any dest(ination).
288
289    proc addaction1 {token comm cmd} {
290        variable state
291
292        if {![info exists state($token,$comm)]} {
293            set state($token,$comm) [list $cmd]
294        } else {
295            lappend state($token,$comm) $cmd
296        }
297    }
298
299    proc setaction1 {token comm cmd} {
300        variable state
301
302        set state($token,$comm) [list $cmd]
303    }
304
305    # This procedure removes an action set by either of the above two
306    # procedures.
307
308    proc remaction1 {token comm cmd} {
309        variable state
310
311        if {![info exists state($token,$comm)]} {
312            return
313        }
314        set cmds $state($token,$comm)
315        set idx [lsearch $cmds $cmd]
316        if {$idx == -1} {
317            return
318        }
319        set state($token,$comm) [lreplace $cmds $idx $idx]
320        if {![string compare "" $state($token,$comm)]} {
321            unset state($token,$comm)
322        }
323    }
324
325    # These procedures add global actions that will be called
326    # when the specific comm(and) is caused on any dest(ination) and
327    # any irc connection. These are the lowest priority commands.
328
329    proc addactionglobal {comm cmd} {
330        variable state
331
332        if {![info exists state(cmd,$comm)]} {
333            set state(cmd,$comm) [list $cmd]
334        } else {
335            lappend state(cmd,$comm) $cmd
336        }
337    }
338
339    proc setactionglobal {comm cmd} {
340        variable state
341
342        set state(cmd,$comm) [list $cmd]
343    }
344
345    # This procedure removes an action set by either of the above two
346    # procedures.
347
348    proc remactionglobal {comm cmd} {
349        variable state
350
351        if {![info exists state(cmd,$comm)]} {
352            return
353        }
354        set cmds $state(cmd,$comm)
355        set idx [lsearch $cmds $cmd]
356        if {$idx == -1} {
357            return
358        }
359        set state(cmd,$comm) [lreplace $cmds $idx $idx]
360        if {![string compare "" $state(cmd,$comm)]} {
361            unset state(cmd,$comm)
362        }
363    }
364
365    # This procedure manages configuration information for IRC:
366
367    proc config {args} {
368        if {$args == {}} {
369            return [collectConfig]
370        }
371
372        if {[llength $args] == 1} {
373            return [queryConfig [lindex $args 0]]
374        }
375
376        if {[expr [llength $args] % 2] != 0} {
377            error "incorrect number of argument, must be multiple of 2"
378        }
379
380        setConfig $args
381    }
382
383    # Helper procedure to return a list with all important user settable
384    # configuration information.
385
386    proc collectConfig {} {
387        variable state
388
389        set config {}
390
391        foreach name [array names state "-*"] {
392            lappend config [list $name $state($name)]
393        }
394        return $config
395    }
396
397    # Helper procedure to return the value of one option.
398
399    proc queryConfig {option} {
400        variable state
401
402        if {![info exists state($option)]} {
403            return {}
404        }
405        return $state($option)
406    }
407
408    # Helper procedure to modify the configuration of a set of options.
409
410    proc setConfig {theargs} {
411        variable state
412
413        foreach {opt val} $theargs {
414            if {![string match "-*" $opt]} {
415                continue
416            }
417            set state($opt) $val
418        }
419    }
420}
Note: See TracBrowser for help on using the repository browser.