source: trunk/gui/scripts/dispatcher.tcl @ 1

Last change on this file since 1 was 1, checked in by mmc, 19 years ago

initial import

File size: 11.7 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: dispatcher - central notification mechanism
3#
4#  The DispatchObj is used within other objects to manage events that
5#  the object sends to itself or other clients.  Each event type
6#  must first be registered via the "register" method.  After that,
7#  an event can be dispatched by calling the "event" method.  Clients
8#  can bind to the various event types by registering a callback via
9#  the "dispatch" method.
10#
11#  The Dispatcher base class provides a foundation for objects that
12#  use the DispatchObj internally.
13# ======================================================================
14#  AUTHOR:  Michael McLennan, Purdue University
15#  Copyright (c) 2004  Purdue Research Foundation, West Lafayette, IN
16# ======================================================================
17package require Itcl
18
19namespace eval Rappture { # forward declaration }
20
21proc Rappture::dispatcher {varName} {
22    upvar $varName obj
23    set obj [Rappture::DispatchObj ::#auto]
24    trace variable obj u "[list rename $obj {}]; list"
25}
26
27itcl::class Rappture::DispatchObj {
28    constructor {} { # defined below }
29    destructor { # defined below }
30
31    public method register {args}
32    public method dispatch {option args}
33    public method event {name args}
34    public method cancel {args}
35    public method ispending {name}
36
37    protected method _send {event caller {arglist ""}}
38
39    private variable _event2clients  ;# maps !event => clients
40    private variable _event2datacb   ;# maps !event => data callback
41    private variable _dispatch       ;# maps !event/client => callback
42    private variable _extraargs      ;# extra args for dispatch calls
43}
44                                                                               
45# ----------------------------------------------------------------------
46# CONSTRUCTOR
47# ----------------------------------------------------------------------
48itcl::body Rappture::DispatchObj::constructor {} {
49    # nothing to do
50}
51                                                                               
52# ----------------------------------------------------------------------
53# DESTRUCTOR
54# ----------------------------------------------------------------------
55itcl::body Rappture::DispatchObj::destructor {} {
56    eval cancel [array names _event2clients]
57}
58
59# ----------------------------------------------------------------------
60# USAGE: register !event ?dataCallback?
61#
62# Clients use this to register new event types with this dispatcher.
63# Once registered, each !event name can be used in the "dispatch"
64# method to bind to the event, and in the "event" method to raise
65# the event.  If the optional dataCallback is supplied, then it is
66# invoked whenever the event is triggered to generate event data
67# that gets passed along to the various dispatch callbacks.
68# ----------------------------------------------------------------------
69itcl::body Rappture::DispatchObj::register {name {datacb ""}} {
70    if {![regexp {^![-_a-zA-Z0-9]} $name]} {
71        error "bad name \"$name\": should be !name"
72    }
73    if {[info exists _event2clients($name)]} {
74        error "event \"$name\" already exists"
75    }
76    set _event2clients($name) ""
77    set _event2datacb($name) $datacb
78}
79
80# ----------------------------------------------------------------------
81# USAGE: dispatch caller ?-now? ?!event ...? ?callback?
82#
83# Clients use this to query binding information, or to bind a callback
84# to one or more of the !events recognized by this object.
85#
86# With no args, this returns a list of all events that are currently
87# bound to the caller.
88#
89# With one argument, this returns the callback associated with the
90# specified !event for the given caller.
91#
92# Otherwise, it sets the callback for one or more events.  If the
93# -now flag is specified, then the callback is invoked immediately
94# to send data back to this caller.  This comes in handy when the
95# caller is set up to react to changes.  It provides a way of
96# initializing the client, as if an event had just occurred.
97# ----------------------------------------------------------------------
98itcl::body Rappture::DispatchObj::dispatch {caller args} {
99    if {[llength $args] == 0} {
100        # no args? then return a list of events for this caller
101        foreach key [array names _dispatch $caller-*] {
102            set name [lindex [split $key -] 1]
103            set events($name) 1
104        }
105        return [array names events]
106    } elseif {[llength $args] == 1} {
107        set name [lindex $args 0]
108        if {[info exists _dispatch($caller-$name)]} {
109            return $_dispatch($caller-$name)
110        }
111        return ""
112    }
113
114    # set a callback for one or more events
115    set now 0
116    set events ""
117    set callback [lindex $args end]
118    foreach str [lrange $args 0 end-1] {
119        if {$str == "-now"} {
120            set now 1
121        } elseif {[info exists _event2clients($str)]} {
122            lappend events $str
123        } else {
124            if {[string index $str 0] == "-"} {
125                error "bad option \"$str\": should be -now"
126            } else {
127                error "bad event \"$str\": should be [join [lsort [array names _event2clients]] {, }]"
128            }
129        }
130    }
131
132    #
133    # If the callback is "", then remove the callback for this
134    # caller.  Otherwise, set the callback for this caller.
135    #
136    foreach name $events {
137        cancel $name
138
139        if {"" == $callback} {
140            catch {unset _dispatch($caller-$name)}
141            if {"" == [array names _dispatch $caller-*]} {
142                set i [lsearch $_event2clients($name) $caller]
143                if {$i >= 0} {
144                    set _event2clients($name) [lreplace $_event2clients($name) $i $i]
145                }
146            }
147        } else {
148            set _dispatch($caller-$name) $callback
149            set i [lsearch $_event2clients($name) $caller]
150            if {$i < 0} { lappend _event2clients($name) $caller }
151
152            if {$now} {
153                _send $name $caller
154            }
155        }
156    }
157}
158
159# ----------------------------------------------------------------------
160# USAGE: event ?-now? ?-later? ?-idle? ?-after time? !event ?args...?
161#
162# Clients use this to dispatch an event to any callers who have
163# registered their interest.
164# ----------------------------------------------------------------------
165itcl::body Rappture::DispatchObj::event {args} {
166    set when "-now"
167    set first [lindex $args 0]
168    if {[string index $first 0] == "-"} {
169        switch -- $first {
170            -now   {
171                set when "-now"
172                set args [lrange $args 1 end]
173            }
174            -later {
175                set when 1
176                set args [lrange $args 1 end]
177            }
178            -idle  {
179                set when "-idle"
180                set args [lrange $args 1 end]
181            }
182            -after {
183                set when [lindex $args 1]
184                if {![string is int $when]} {
185                    error "bad value \"$when\": should be int (time in ms)"
186                }
187                set args [lrange $args 2 end]
188            }
189            default {
190                error "bad option \"$first\": should be -now, -later, -idle, or -after"
191            }
192        }
193    }
194
195    if {[llength $args] < 1} {
196        error "wrong # args: should be \"event ?switches? !event ?args...?\""
197    }
198    set event [lindex $args 0]
199    set args [lrange $args 1 end]
200    if {![info exists _event2clients($event)]} {
201        error "bad event \"$event\": should be [join [lsort [array names _event2clients]] {, }]"
202    }
203
204    switch -- $when {
205        -now {
206            _send $event all $args
207        }
208        -idle {
209            set _extraargs($event) $args
210            after cancel [itcl::code $this _send $event all @extra]
211            after idle [itcl::code $this _send $event all @extra]
212        }
213        default {
214            set _extraargs($event) $args
215            after cancel [itcl::code $this _send $event all @extra]
216            after $when [itcl::code $this _send $event all @extra]
217        }
218    }
219}
220
221# ----------------------------------------------------------------------
222# USAGE: cancel ?!event ...?
223#
224# Used to cancel any event notifications pending for the specified
225# list of events.  Notifications may be pending if a particular
226# event was raised with the -idle or -after flags.
227# ----------------------------------------------------------------------
228itcl::body Rappture::DispatchObj::cancel {args} {
229    foreach event $args {
230        if {![info exists _event2clients($event)]} {
231            error "bad event \"$str\": should be [join [lsort [array names _event2clients]] {, }]"
232        }
233        after cancel [itcl::code $this _send $event all @extra]
234    }
235}
236
237# ----------------------------------------------------------------------
238# USAGE: ispending !event
239#
240# Returns 1 if the specified !event is pending, and 0 otherwise.
241# Notifications may be pending if a particular event was raised
242# with the -idle or -after flags.
243# ----------------------------------------------------------------------
244itcl::body Rappture::DispatchObj::ispending {event} {
245    set cmd [itcl::code $this _send $event all @extra]
246    foreach id [after info] {
247        set cmd2 [lindex [after info $id] 0]
248        if {[string equal $cmd $cmd2]} {
249            return 1
250        }
251    }
252    return 0
253}
254
255# ----------------------------------------------------------------------
256# USAGE: _send !event caller ?arglist?
257#
258# Used internally to send an event to one or all callers.  The event
259# is sent by first invoking a callback to generate any data associated
260# with the event.  This data, along with any extra args passed in,
261# are added to the callback for the caller.
262# ----------------------------------------------------------------------
263itcl::body Rappture::DispatchObj::_send {event caller {arglist ""}} {
264    if {$caller == "all"} {
265        set caller $_event2clients($event)
266    }
267    if {$arglist == "@extra" && [info exists _extraargs($event)]} {
268        set arglist $_extraargs($event)
269    }
270
271    # if there are any clients for this event, get the arguments ready
272    set any 0
273    foreach cname $caller {
274        if {[info exists _dispatch($cname-$event)]} {
275            set any 1
276            break
277        }
278    }
279
280    set dargs ""
281    if {$any && [string length $_event2datacb($event)] > 0} {
282        # get the args from the data callback
283        set status [catch {
284            uplevel #0 $_event2datacb($event) $event
285        } dargs]
286
287        if {$status != 0} {
288            # anything go wrong? then throw a background error
289            bgerror "$dargs\n(while dispatching $event)"
290            set dargs ""
291        }
292    }
293    # add any arguments added from command line
294    eval lappend dargs $arglist
295
296    foreach cname $caller {
297        if {[info exists _dispatch($cname-$event)]} {
298            set status [catch {
299                uplevel #0 $_dispatch($cname-$event) event $event $dargs
300            } result]
301
302            if {$status != 0} {
303                # anything go wrong? then throw a background error
304                bgerror "$result\n(while dispatching $event to $cname)"
305            }
306        }
307    }
308}
309
310# ----------------------------------------------------------------------
311# BASE CLASS: Dispatcher
312# ----------------------------------------------------------------------
313itcl::class Rappture::Dispatcher {
314    constructor {args} {
315        Rappture::dispatcher _dispatcher
316        $_dispatcher register !destroy
317
318        eval configure $args
319    }
320
321    destructor {
322        event !destroy
323    }
324
325    public method dispatch {args} {
326        eval $_dispatcher dispatch $args
327    }
328
329    protected method register {args} {
330        eval $_dispatcher register $args
331    }
332    protected method event {args} {
333        eval $_dispatcher event $args object $this
334    }
335
336    private variable _dispatcher ""  ;# dispatcher for events
337}
Note: See TracBrowser for help on using the repository browser.