1 # coordbus.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1998-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 #
31 # @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/net/coordbus.tcl,v 1.8 2003/03/18 03:16:31 peterp Exp $
32
33
34 # -- for otcldoc
35 #Class CoordinationBus
36
37 #FIXME
38 CoordinationBus set protocolId_ ""
39
40
41 CoordinationBus proc.invoke { } {
42 $self set protocolId_ cbus/1.0
43 if { [info commands mtrace]=="" } {
44 proc ::mtrace { args } { }
45 }
46 }
47
48
49 #
50 # Create a new CoordinationBus channel and open the appropriate multicast
51 # sockets.
52 # <pre>
53 # new CoordinationBus ?-channel <channel-number>?<BR>
54 # ?-mediatype <mediatype>?<BR>
55 # ?-moduletype <mediatype>?<BR>
56 # ?-appname <appname>?<BR>
57 # ?-appinstance <appinstance>?<BR>
58 # ?-srcid <mediatype>/<mediatype>/<appname>/<appinstance>?<BR>
59 # ?-mode readwrite|readonly|writeonly?<BR>
60 # ?-ttl <ttl>?<BR>
61 # </pre>
62 # <channel> defaults to 0. <srcid> may contain wildcards and
63 # it defaults to "*/*/*/<ip-addr*gt;:<pid>.
64 #
65 CoordinationBus public init { args } {
66 eval [list $self] next
67 $self set seqno_ 0
68
69 # now check if all of the individual variables have been defined or
70 # not; if not, use some default values
71
72 $self instvar ttl_ srcid_ mediatype_ moduletype_ appname_ appinstance_\
73 channel_ mode_
74
75 foreach {key value} $args {
76 if { [string index $key 0] != "-" } {
77 error "invalid argument '$key'"
78 }
79 $self set [string range $key 1 end]_ $value
80 }
81
82 if { ![info exists ttl_] } { set ttl_ 0 }
83 if { ![info exists mediatype_] } { set mediatype_ "*" }
84 if { ![info exists moduletype_] } { set moduletype_ "*" }
85 if { ![info exists appname_] } { set appname_ "*" }
86 if { ![info exists appinstance_]} { set appinstance_ [localaddr]:[pid]}
87 if { ![info exists channel_] } { set channel_ 0 }
88 if { ![info exists mode_] } { set mode_ "readwrite" }
89 if { ![info exists srcid_] } {
90 set srcid_ "$mediatype_/$moduletype_/$appname_/$appinstance_"
91 } else {
92 set tmp [split $srcid_ /]
93 if { [llength $tmp] != 4 } {
94 error "invalid srcid '$srcid_'"
95 }
96 }
97
98 $self open $channel_ $ttl_ $mode_
99 }
100
101
102 #
103 # Deallocate all the resources associated with
104 # the CoordinationBus object. Close all associated sockets.
105 #
106 CoordinationBus public destroy { } {
107 $self close
108 $self next
109 }
110
111
112 #
113 # Register an event to listen for on the coordination bus.
114 # <method> can either be the name of a method defined
115 # on the coordination bus object, or it may be of the form
116 # "<object> <method>". When <event> is heard
117 # on the coordination bus, the associated <method> is
118 # invoked. <method> may accept arguments, in which case
119 # the corrsponding arguments that are received as part of the
120 # event are passed on to <method>
121 # <p>
122 # The first argument to <method> is always a list describing
123 # the event: key-vaue pairs -- srcid (the source id),
124 # destid (the destination id), event (the actual event),
125 # cb (the coordination bus object)
126 #
127 CoordinationBus public register { event method } {
128 $self instvar dispatch_
129 if { [llength $method] > 1 } {
130 set dispatch_($event,object) [lindex $method 0]
131 set dispatch_($event,method) [lindex $method 1]
132 } else {
133 set dispatch_($event,object) $self
134 set dispatch_($event,method) [lindex $method 0]
135 }
136
137 set dispatch_($event,argcnt) [$self get_argcnt \
138 $dispatch_($event,object) $dispatch_($event,method)]
139 if { $dispatch_($event,argcnt) < 0 } {
140 set object $dispatch_($event,object)
141 unset dispatch_($event,object)
142 unset dispatch_($event,method)
143 unset dispatch_($event,argcnt)
144 error "trying to register undefined method '$method' on object\
145 $object"
146 }
147 }
148
149
150 #
151 # Unregister a previously registered event
152 #
153 CoordinationBus public unregister { event } {
154 $self instvar dispatch_
155 if [info exists dispatch_($event,object)] {
156 unset dispatch_($event,object)
157 unset dispatch_($event,method)
158 unset dispatch_($event,argcnt)
159 }
160 }
161
162
163 #
164 # Send an event on the coordination bus
165 # <pre>
166 # $cb send ?-dstid <mediatype>/<mediatype>/<appname>/<appinstance>? <event> ?args ...?
167 # </pre>
168 # -dstid identifies a specific target or a group of targets. Any of the
169 # individual elements of -dstid may be substituted by a * wildcard.
170 #
171 CoordinationBus public send { args } {
172 if { [string compare [lindex $args 0] "-dstid"] == 0 } {
173 set dst [lindex $args 1]
174 set tmp [split $dst /]
175 if { [llength $tmp] != 4 } {
176 error "Invalid destination: must be of the form\
177 <media-type>/<module-type>/<app-name>/<app-instance>"
178 }
179
180 set args [lrange $args 2 end]
181 } else {
182 set dst "*/*/*/*"
183 }
184
185 $self instvar seqno_ srcid_
186
187 if { [llength $args]==0 } {
188 error "Must specify event type: \$cb send\
189 [-dstid <destination>] $event_type [args...]"
190 }
191
192 #
193 # packet header consists of
194 # ProtocolID (cbus/1.0)
195 # SeqNo
196 # MessageType (R=reliable U=unreliable)
197 # SrcAddr
198 # DstAddr
199 # AckList (for now, empty)
200 #
201 set headers [list [CoordinationBus set protocolId_] $seqno_ \
202 "U" $srcid_ $dst ""]
203 $self transmit [concat $headers $args]
204 }
205
206
207 CoordinationBus private match_wildcards { d s } {
208 if { [string compare $d $s]==0 || $d=="*" || $s=="*" } {
209 return 1
210 } else {
211 return 0
212 }
213 }
214
215
216 CoordinationBus private filter { destid } {
217 $self instvar srcid_
218
219 set s [split $srcid_ /]
220 set d [split $destid /]
221
222 if { [$self match_wildcards [lindex $d 0] [lindex $s 0]] && \
223 [$self match_wildcards [lindex $d 1] [lindex $s 1]] &&\
224 [$self match_wildcards [lindex $d 2] [lindex $s 2]] &&\
225 [$self match_wildcards [lindex $d 3] [lindex $s 3]] } {
226 return 1
227 } else {
228 return 0
229 }
230 }
231
232
233 CoordinationBus private dispatch { packet } {
234 set packet [split $packet]
235
236 # ensure that you at least have the header + event type
237 if { [llength $packet] < 7 } {
238 # ignore this packet
239 mtrace trcCB "CB: Invalid packet: only [llength $packet]\
240 elements"
241 return
242 }
243
244 set protocolId [lindex $packet 0]
245 set seqNo [lindex $packet 1]
246 set messageType [lindex $packet 2]
247 set srcId [lindex $packet 3]
248 set destId [lindex $packet 4]
249 set ackList [lindex $packet 5]
250
251 set event [lindex $packet 6]
252 set args [lrange $packet 7 end]
253
254 if { $protocolId != [CoordinationBus set protocolId_] } {
255 mtrace trcCB "CB: Invalid protocol id '$protocolId': must be\
256 [CoordinationBus set protocolId_]"
257 return
258 }
259
260 # first check if it is our packet
261 $self instvar srcid_
262 if { [string compare $srcId $srcid_]==0 } {
263 # filter out our own packets
264 return
265 }
266
267 # now check if the packet is destined for us
268 if { ![$self filter $destId] } {
269 # this packet was not meant for us
270 mtrace trcCB|trcVerbose "CB: filtering out packet meant for\
271 '$destId'"
272 return
273 }
274
275 # the packet seems sane. try to dispatch it
276 $self instvar dispatch_
277 if { ![info exists dispatch_($event,object)] } {
278 mtrace trcCB|trcVerbose "CB: unknown event '$event'"
279 return
280 }
281
282 if { [llength $args] != $dispatch_($event,argcnt) } {
283 mtrace trcCB "CB: argument mismatch: expected\
284 $dispatch_($event,argcnt) arguments,\
285 got [llength $args]"
286 puts "argument mismatch: expected $dispatch_($event,argcnt) arguments, got [llength $args]"
287 puts "args were $args"
288 return
289 }
290
291 #
292 # FIXME SECURITY ALERT: bracketed commands from external agents
293 # can be executed here as a side-effect of this eval.
294 # FIX THIS.
295 #
296
297 set info [list cb $self srcid $srcId dstid $destId event $event]
298 eval [list $dispatch_($event,object)] \
299 [list $dispatch_($event,method)] [list $info] $args
300 }
301
302
303 CoordinationBus private get_argcnt { object method } {
304 if { [$object info procs $method] != "" } {
305 return [llength [$object info args $method]]
306 }
307
308 set cls [$object info class]
309 if { [$cls info instprocs $method] != "" } {
310 return [llength [$cls info instargs $method]]
311 }
312
313 foreach c [$cls info heritage] {
314 if { [$c info instprocs $method] != "" } {
315 return [llength [$c info instargs $method]]
316 }
317 }
318
319 return -1
320 }
321
322
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.