Context Navigation

controlOwner.tcl @ 6372

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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

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

Download in other formats: