source: trunk/gui/scripts/controlOwner.tcl @ 781

Last change on this file since 781 was 781, checked in by mmc, 17 years ago

Rough version of a drawing element that can be used for diagrams.

File size: 17.2 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: owner - manages Rappture controls
3#
4#  This object represents an entity managing Rappture controls.
5#  It is typically a Tool, a DeviceEditor, or some other large entity
6#  that manages a Rappture XML tree.  All controlling widgets are
7#  registered with an owner, and the owner propagates notifications
8#  out to clients who have an interest in a particular control.
9# ======================================================================
10#  AUTHOR:  Michael McLennan, Purdue University
11#  Copyright (c) 2004-2005  Purdue Research Foundation
12#
13#  See the file "license.terms" for information on usage and
14#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15# ======================================================================
16package require Itcl
17
18itcl::class Rappture::ControlOwner {
19    constructor {owner} { # defined below }
20
21    public method xml {args}
22
23    public method load {newobj}
24    public method widgetfor {path args}
25    public method valuefor {path args}
26    public method dependenciesfor {path args}
27    public method ownerfor {path {skip ""}}
28    public method changed {path}
29    public method regularize {path}
30    public method notify {option owner args}
31    public method sync {}
32    public method tool {}
33
34    protected method _slave {option args}
35
36    protected variable _owner ""     ;# ControlOwner containing this one
37    protected variable _path ""      ;# paths within are relative to this
38    protected variable _slaves ""    ;# this owner has these slaves
39    protected variable _xmlobj ""    ;# Rappture XML description
40    private variable _path2widget    ;# maps path => widget on this page
41    private variable _owner2paths    ;# for notify: maps owner => interests
42    private variable _callbacks      ;# for notify: maps owner/path => callback
43    private variable _dependencies   ;# maps path => other paths dep on this
44}
45                                                                               
46# ----------------------------------------------------------------------
47# CONSTRUCTOR
48# ----------------------------------------------------------------------
49itcl::body Rappture::ControlOwner::constructor {owner} {
50    if {"" != $owner} {
51        set parts [split $owner @]
52        set _owner [lindex $parts 0]
53        set _path [lindex $parts 1]
54        $_owner _slave add $this
55    }
56}
57
58# ----------------------------------------------------------------------
59# USAGE: xml <subcommand> ?<arg> <arg> ...?
60# USAGE: xml object
61#
62# Used by clients to manipulate the underlying XML data for this
63# tool.  The <subcommand> can be any operation supported by a
64# Rappture::library object.  Clients can also request the XML object
65# directly by using the "object" subcommand.
66# ----------------------------------------------------------------------
67itcl::body Rappture::ControlOwner::xml {args} {
68    if {"object" == $args} {
69        return $_xmlobj
70    }
71    return [eval $_xmlobj $args]
72}
73
74# ----------------------------------------------------------------------
75# USAGE: widgetfor <path> ?<widget>?
76#
77# Used by embedded widgets such as a Controls panel to register the
78# various controls associated with this page.  That way, this
79# ControlOwner knows what widgets to look at when syncing itself
80# to the underlying XML data.
81# ----------------------------------------------------------------------
82itcl::body Rappture::ControlOwner::widgetfor {path args} {
83    # if this is a query operation, then look for the path
84    if {[llength $args] == 0} {
85        set owner [ownerfor $path]
86        if {$owner != $this && $owner != ""} {
87            return [$owner widgetfor $path]
88        }
89        if {[info exists _path2widget($path)]} {
90            return $_path2widget($path)
91        }
92        return ""
93    }
94
95    # otherwise, associate the path with the given widget
96    set widget [lindex $args 0]
97    if {"" != $widget} {
98        if {[info exists _path2widget($path)]} {
99            error "$path already associated with widget $_path2widget($path)"
100        }
101        set _path2widget($path) $widget
102    } else {
103        catch {unset _path2widget($path)}
104    }
105}
106
107# ----------------------------------------------------------------------
108# USAGE: valuefor <path> ?<newValue>?
109#
110# Used by embedded widgets such as a Loader to query or set the
111# value of another control.  With no extra args, it returns the
112# value of the widget at the <path> in the XML.  Otherwise, it
113# sets the value of the widget to <newValue>.
114# ----------------------------------------------------------------------
115itcl::body Rappture::ControlOwner::valuefor {path args} {
116    set owner [ownerfor $path]
117
118    # if this is a query operation, then look for the path
119    if {[llength $args] == 0} {
120        if {$owner != $this && $owner != ""} {
121            return [$owner valuefor $path]
122        }
123        if {[info exists _path2widget($path)]} {
124            return [$_path2widget($path) value]
125        }
126        # can't find the path? try removing the prefix for this owner
127        set plen [string length $_path]
128        if {[string equal -length $plen $_path $path]} {
129            set relpath [string range $path [expr {$plen+1}] end]
130            if {[info exists _path2widget($relpath)]} {
131                return [$_path2widget($relpath) value]
132            }
133        }
134        return ""
135    }
136
137    # otherwise, set the value
138    if {$owner != $this && $owner != ""} {
139        return [eval $owner valuefor $path $args]
140    }
141    if {[llength $args] > 1} {
142        error "wrong # args: should be \"valuefor path ?newValue?\""
143    }
144
145    if {[info exists _path2widget($path)]} {
146        $_path2widget($path) value [lindex $args 0]
147    } else {
148        error "bad path \"$path\": should be one of [join [lsort [array names _path2widget]] {, }]"
149    }
150}
151
152# ----------------------------------------------------------------------
153# USAGE: dependenciesfor <path> ?<path>...?
154#
155# Used by embedded widgets such as a Controls panel to register the
156# various controls that are dependent on another one.  If only one
157# path is specified, then this method returns all known dependencies
158# for the specified <path>.  Otherwise, the additional <path>'s are
159# noted as being dependent on the first <path>.
160# ----------------------------------------------------------------------
161itcl::body Rappture::ControlOwner::dependenciesfor {path args} {
162    if {"" != $_owner} {
163        #
164        # Keep all dependencies at the highest level.
165        # That way, a structure can come and go, but the
166        # dependencies remain fixed in the topmost tool.
167        #
168        set plen [string length $_path]
169        if {"" != $_path && ![string equal -length $plen $_path $path]} {
170            set path $_path.$path
171        }
172        return [eval $_owner dependenciesfor $path $args]
173    }
174
175    # if this is a query operation, then look for the path
176    if {[llength $args] == 0} {
177        if {[info exists _dependencies($path)]} {
178            return $_dependencies($path)
179        }
180        return ""
181    }
182
183    # add new dependencies
184    if {![info exists _dependencies($path)]} {
185        set _dependencies($path) ""
186    }
187    foreach dpath $args {
188        set i [lsearch -exact $_dependencies($path) $dpath]
189        if {$i < 0} {
190            lappend _dependencies($path) $dpath
191        }
192    }
193}
194
195# ----------------------------------------------------------------------
196# USAGE: ownerfor <path> ?<skip>?
197#
198# Returns the ControlOwner that directly controls the specified <path>.
199# ----------------------------------------------------------------------
200itcl::body Rappture::ControlOwner::ownerfor {path {skip ""}} {
201    if {[info exists _path2widget($path)]} {
202        return $this
203    }
204
205    # can't find the path? try removing the prefix for this owner
206    set plen [string length $_path]
207    if {[string equal -length $plen $_path $path]} {
208        set relpath [string range $path [expr {$plen+1}] end]
209        if {[info exists _path2widget($relpath)]} {
210            return $this
211        }
212    }
213
214    # couldn't find this path?  then check all subordinates
215    foreach slave $_slaves {
216        if {$slave == $skip} {
217            continue  ;# skip this slave if it's already been searched
218        }
219        set rval [$slave ownerfor $path $this]
220        if {"" != $rval} {
221            return $rval
222        }
223    }
224
225    # check the owner as a last resort
226    if {"" != $_owner && $_owner != $skip} {
227        set rval [$_owner ownerfor $path $this]
228        if {"" != $rval} {
229            return $rval
230        }
231    }
232
233    return ""
234}
235
236# ----------------------------------------------------------------------
237# USAGE: load <xmlobj>
238#
239# Loads the contents of a Rappture <xmlobj> into the controls
240# associated with this tool.
241# ----------------------------------------------------------------------
242itcl::body Rappture::ControlOwner::load {newobj} {
243    if {![Rappture::library isvalid $newobj]} {
244        error "\"$newobj\" is not a Rappture::library"
245    }
246
247    foreach path [array names _path2widget] {
248        # copy new value to the XML tree
249        [tool] xml copy $path.current from $newobj $path.current
250
251        # also copy to the widget associated with the tree
252        if {"" != [$newobj element -as type $path.current]} {
253            set val [$newobj get $path.current]
254            if {[string length $val] > 0
255                  || [llength [$newobj children $path.current]] == 0} {
256                $_path2widget($path) value $val
257            } else {
258                set obj [$newobj element -as object $path.current]
259                $_path2widget($path) value $obj
260            }
261        }
262    }
263}
264
265# ----------------------------------------------------------------------
266# USAGE: changed <path>
267#
268# Invoked automatically by the various widgets associated with this
269# tool whenever their value changes.  Sends notifications to any
270# client that has registered an interest via "notify add".
271# ----------------------------------------------------------------------
272itcl::body Rappture::ControlOwner::changed {path} {
273    if {"" != $_owner} {
274        set plen [string length $_path]
275        if {"" != $_path && ![string equal -length $plen $_path $path]} {
276            set path $_path.$path
277        }
278        $_owner changed $path
279    } else {
280        # send out any callback notifications
281        foreach owner [array names _owner2paths] {
282            foreach pattern $_owner2paths($owner) {
283                if {[string match $pattern $path]} {
284                    uplevel #0 $_callbacks($owner/$pattern)
285                    break
286                }
287            }
288        }
289
290        # find the control panel for each dependency, and tell it
291        # to update its layout.
292        foreach cpath [dependenciesfor $path] {
293            set wv [widgetfor $cpath]
294            while {"" != $wv} {
295                set wv [winfo parent $wv]
296                if {[winfo class $wv] == "Controls"} {
297                    $wv refresh
298                    break
299                }
300            }
301        }
302    }
303}
304
305# ----------------------------------------------------------------------
306# USAGE: regularize <path>
307#
308# Clients use this to get a full, regularized path for the specified
309# <path>, which may be relative to the current owner.
310# ----------------------------------------------------------------------
311itcl::body Rappture::ControlOwner::regularize {path} {
312    set owner [ownerfor $path]
313    if {$owner != $this && $owner != ""} {
314        return [$owner regularize $path]
315    }
316    set rpath ""
317    if {"" != $_xmlobj} {
318        set rpath [$_xmlobj element -as path $path]
319
320        # can't find the path? try removing the prefix for this owner
321        if {"" == $rpath} {
322            set plen [string length $_path]
323            if {[string equal -length $plen $_path $path]} {
324                set relpath [string range $path [expr {$plen+2}] end]
325                set rpath [$_xmlobj element -as path $relpath]
326            }
327        }
328
329        if {"" != $rpath && "" != $_path} {
330            # return a full name for the path
331            set rpath "$_path.$rpath"
332        }
333    }
334    return $rpath
335}
336
337# ----------------------------------------------------------------------
338# USAGE: notify add <owner> <path> <callback>
339# USAGE: notify info ?<owner>? ?<path>?
340# USAGE: notify remove <owner> ?<path> ...?
341#
342# Clients use this to request notifications about changes to a
343# particular <path> for a control under this tool.  Whenever the
344# value associated with <path> changes, the client identified by
345# <owner> is sent a message by invoking its <callback> routine.
346#
347# Notifications can be silenced by calling the "notify remove"
348# function.
349# ----------------------------------------------------------------------
350itcl::body Rappture::ControlOwner::notify {option args} {
351    switch -- $option {
352        add {
353            if {[llength $args] != 3} {
354                error "wrong # args: should be \"notify add owner path callback\""
355            }
356            set owner [lindex $args 0]
357            set path [lindex $args 1]
358            set cb [lindex $args 2]
359
360            if {[info exists _owner2paths($owner)]} {
361                set plist $_owner2paths($owner)
362            } else {
363                set plist ""
364            }
365
366            set i [lsearch -exact $plist $path]
367            if {$i < 0} { lappend _owner2paths($owner) $path }
368            set _callbacks($owner/$path) $cb
369        }
370        info {
371            if {[llength $args] == 0} {
372                # no args? then return all owners
373                return [array names _owner2paths]
374            } else {
375                set owner [lindex $args 0]
376                if {[info exists _owner2paths($owner)]} {
377                    set plist $_owner2paths($owner)
378                } else {
379                    set plist ""
380                }
381                if {[llength $args] == 1} {
382                    # 1 arg? then return paths for this owner
383                    return $plist
384                } elseif {[llength $args] == 2} {
385                    # 2 args? then return callback for this path
386                    set path [lindex $args 1]
387                    if {[info exists _callbacks($owner/$path)]} {
388                        return $_callbacks($owner/$path)
389                    }
390                    return ""
391                } else {
392                    error "wrong # args: should be \"notify info ?owner? ?path?\""
393                }
394            }
395        }
396        remove {
397            if {[llength $args] < 1} {
398                error "wrong # args: should be \"notify remove owner ?path ...?\""
399            }
400            set owner [lindex $args 0]
401
402            if {[llength $args] == 1} {
403                # no args? then delete all paths for this owner
404                if {[info exists _owner2paths($owner)]} {
405                    set plist $_owner2paths($owner)
406                } else {
407                    set plist ""
408                }
409            } else {
410                set plist [lrange $args 1 end]
411            }
412
413            # forget about the callback for each path
414            foreach path $plist {
415                catch {unset _callbacks($owner/$path)}
416
417                if {[info exists _owner2paths($owner)]} {
418                    set i [lsearch -exact $_owner2paths($owner) $path]
419                    if {$i >= 0} {
420                        set _owner2paths($owner) \
421                            [lreplace $_owner2paths($owner) $i $i]
422                    }
423                }
424            }
425        }
426    }
427}
428
429# ----------------------------------------------------------------------
430# USAGE: sync
431#
432# Used by descendents such as a Controls panel to register the
433# various controls associated with this page.  That way, this
434# ControlOwner knows what widgets to look at when syncing itself
435# to the underlying XML data.
436# ----------------------------------------------------------------------
437itcl::body Rappture::ControlOwner::sync {} {
438    # sync all of the widgets under control of this owner
439    if {"" != $_xmlobj} {
440        foreach path [lsort [array names _path2widget]] {
441            set type [$_xmlobj element -as type $path]
442            if {[lsearch {group separator control note} $type] >= 0} {
443                continue
444            }
445            $_xmlobj put $path.current [$_path2widget($path) value]
446        }
447    }
448
449    # sync all subordinate slaves as well
450    foreach slave $_slaves {
451        $slave sync
452    }
453}
454
455# ----------------------------------------------------------------------
456# USAGE: tool
457#
458# Clients use this to figure out which tool is associated with
459# this object.  If there is no parent ControlOwner, then this
460# must be the top-level tool.
461# ----------------------------------------------------------------------
462itcl::body Rappture::ControlOwner::tool {} {
463    if {"" != $_owner} {
464        return [$_owner tool]
465    }
466    return $this
467}
468
469# ----------------------------------------------------------------------
470# USAGE: _slave add <newobj>...
471#
472# Used internally to register the parent-child relationship whenever
473# one ControlOwner is registered to another.  When the parent syncs,
474# it causes all of its children to sync.  When a name is being
475# resolved, it is resolved locally first, then up to the parent for
476# further resolution.
477# ----------------------------------------------------------------------
478itcl::body Rappture::ControlOwner::_slave {option args} {
479    switch -- $option {
480        add {
481            eval lappend _slaves $args
482        }
483        default {
484            error "bad option \"$option\": should be add"
485        }
486    }
487}
Note: See TracBrowser for help on using the repository browser.