Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: code/branches/output/data/tcl/irk/lib/irkdispatch.tcl @ 8877

Last change on this file since 8877 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: 5.9 KB
Line 
1# irkdispatch.tcl:
2#
3# Based on the input received from the server, dispatch control to various
4# command procedures.
5
6namespace eval ::irk {
7
8    # This procedure sets up the default actions for a connection:
9
10    proc setupDefaultActions {s nick} {
11        variable state
12
13        # Catch any unexpected PRIVMSG actions:
14
15        set state($s,PRIVMSG,$nick)     $state(PRIVMSG,unsolicited)
16
17        # Set up CTCP global actions:
18
19        set state($s,cmd,ctcp,PING)     ::irk::RECV,CTCP,PING
20        set state($s,cmd,ctcp,TIME)     ::irk::RECV,CTCP,TIME
21        set state($s,cmd,ctcp,VERSION)  ::irk::RECV,CTCP,VERSION
22        set state($s,cmd,ctcp,USERINFO) \
23                                        ::irk::RECV,CTCP,USERINFO
24
25        # Set up CTCP channel specific actions:
26
27        set state($s,channel,ctcp,ACTION) \
28                                        ::irk::RECV,CTCP,ACTION
29
30        # Set up the CTCP TCL protocol:
31
32        set state($s,channel,ctcp,TCL)  ::irk::RECV,CTCP,TCL
33        set state($s,channel,ctcp,TCL,LOCAL) \
34                                        ::irk::RECV,CTCP,TCL,LOCAL
35
36        # Deal with CTCP commands we do not understand:
37
38        set state($s,cmd,ctcp,error)    ::irk::RECV,CTCP,ERROR
39        set state($s,channel,ctcp,error) \
40                                        ::irk::RECV,CTCP,ERROR
41    }
42
43    # The consumer procedure consumes input received from
44    # a connection. It calls the dispatcher for the given connection
45    # with each input line.
46
47    proc consumer {s} {
48        variable state
49
50        if {[eof $s]} {
51            disconnect $s
52        } else {
53            set l [gets $s]
54            if {[info exists state($s,trace)]} {
55                $state($s,trace) $l
56            }
57            if {[string compare $l ""]} {
58                dissect $state($s,contok) $l
59            }
60        }
61    }
62
63    # This procedure dissects the input into its parts:
64
65    proc dissect {token line} {
66        variable state
67
68        # Make a list out of the line:
69
70        set line [split $line " "]
71
72        # Split first token into nickname and user mask:
73
74        set nandu [split [lindex $line 0] \!]
75
76        # Call dispatcher for this connection:
77
78        $state($token,disp) \
79                $token \
80                [lindex $nandu 0] \
81                [lindex $nandu 1] \
82                [lindex $line 1] \
83                [lindex $line 2] \
84                [lrange $line 3 end]
85    }
86
87    # This procedure is the default command dispatcher:
88   
89    proc defaultDispatcher {token nick user comm dest rest} {
90        variable state
91
92        # Check if the nick starts with ':'. If not then this is
93        # a special action, handled by the built in actions.
94
95        if {![string match ":*" $nick]} {
96            return [specialAction $token $nick $user $comm $dest $rest]
97        }
98
99        # Trim off the leading ':' on the $nick, if present.
100
101        if {[string match ":*" $nick]} {
102            set nick [string range $nick 1 end]
103        }
104
105        # If a ':' is present in the $dest, trim that off too.
106
107        if {[string match ":*" $dest]} {
108            set dest [string range $dest 1 end]
109        }
110
111        # If a ':' is present in the $rest, trim that off too.
112
113        set firstrest [lindex $rest 0]
114        if {[string match ":*" $firstrest]} {
115            set firstrest [string range $firstrest 1 end]
116            set rest [lreplace $rest 0 0 $firstrest]
117        }
118
119        # Clean up the payload:
120
121        set rest [split [string trim [eval concat $rest]] " "]
122
123        # Now try to dispatch to specific handlers.
124        #
125        # First see if there is a handler for the specific combination
126        # of $token, $nick, $comm and $dest. This is used for PRIVMSG.
127
128        if {[info exists state($token,$nick,$comm,$dest)]} {
129            foreach cmd $state($token,$nick,$comm,$dest) {
130                if {[catch {set res [$cmd $token $nick $user \
131                                          $comm $dest $rest]} err]} {
132                    if {[info exists state(errorhandler)]} {
133                        $state(errorhandler) $err $token $comm $dest
134                    }
135                    return
136                }
137
138                # If this handler said to go on to a more general handler,
139                # then don't return. Otherwise return.
140
141                if {[string compare $res pass]} {
142                    return
143                }
144            }
145        }
146
147        # If there's a handler for $token, $comm and $dest, use that.
148
149        if {[info exists state($token,$comm,$dest)]} {
150            foreach cmd $state($token,$comm,$dest) {
151                if {[catch {set res [$cmd $token $nick $user \
152                                          $comm $dest $rest]} err]} {
153                    if {[info exists state(errorhandler)]} {
154                        $state(errorhandler) $err $token $comm $dest
155                    }
156                    return
157                }
158
159                # If this handler said to go on to a more general handler,
160                # then don't return. Otherwise return.
161
162                if {[string compare $res pass]} {
163                    return
164                }
165            }
166        }
167
168        # See if there's a handler for $token and $comm. If so use that.
169
170        if {[info exists state($token,$comm)]} {
171            foreach cmd $state($token,$comm) {
172                if {[catch {set res [$cmd $token $nick $user \
173                                          $comm $dest $rest]} err]} {
174                    if {[info exists state(errorhandler)]} {
175                        $state(errorhandler) $err $token $comm $dest
176                    }
177                    return
178                }
179
180                # If this handler said to go on to a more general handler,
181                # then don't return. Otherwise return.
182
183                if {[string compare $res pass]} {
184                    return
185                }
186            }
187        }
188
189        # See if there's a global handler for the command. All the
190        # default handlers are defined here.
191
192        if {[info exists state(cmd,$comm)]} {
193            foreach cmd $state(cmd,$comm) {
194                if {[catch {set res [$cmd $token $nick $user \
195                                          $comm $dest $rest]} err]} {
196                    if {[info exists state(errorhandler)]} {
197                        $state(errorhandler) $err $token $comm $dest
198                    }
199                    return
200                }
201
202                # If this handler said to go on to a more general handler,
203                # then don't return. Otherwise return.
204
205                if {[string compare $res pass]} {
206                    return
207                }
208            }
209        }
210
211        # If all of the above fail, send this input to the default
212        # action handler:
213
214        if {[catch {set res [$state(action) \
215                                $token $nick $user \
216                                $comm $dest $rest]} err]} {
217            if {[info exists state(errorhandler)]} {
218                $state(errorhandler) $err $token $comm $dest
219            }
220            return
221        }
222    }
223
224    # This procedure deals with special actions (built in, cannot
225    # easily be modified by users). I use this to e.g deal with
226    # PING, NOTICE, ERROR etc., automatically.
227
228    proc specialAction {token nick user comm dest rest} {
229        variable state
230
231        # The nick is the special action selector:
232
233        $state(special,$nick) $token $nick $user $comm $dest $rest
234    }
235
236    # This is the default error handler:
237
238    proc echoerror {args} {
239        puts stderr $args
240    }
241
242    # This procedure provides a default tracing facility (it just prints
243    # the lines received to stderr):
244
245    proc trace {args} {
246        puts stderr "Received: $args"
247    }
248}
Note: See TracBrowser for help on using the repository browser.