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

Last change on this file since 3636 was 3636, checked in by mmc, 9 years ago

Fixed the drawing widget to handle notifications from outside widgets, so
that canvas items react to value changes. Also added tooltips for drawing
items.

Nudged the next/back buttons for the pager in a bit, so they're a little
easier to press in the iPad app.

Fixed the Ruby template for the builder to include the overwrite/append flag.

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