Context Navigation

controlOwner.tcl @ 6714

Last change on this file since 6714 was 6714, checked in by clarksm, 4 years ago
Make sure all phases/pages get initialized before processing loaders. There was a problem when new elements were introduced in loader files. The arbitrary sleep was not long enough.
File size: 20.4 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	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	# ----------------------------------------------------------------------
85	itcl::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	# ----------------------------------------------------------------------
107	itcl::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	# puts stderr "controlOwner::widgetfor register $path"
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	# puts stderr "controlOwner::load"
291	foreach path [array names _path2widget] {
292	# the following elements do not accept "current" tags, skip them
293	set type [[tool] xml element -as type $path]
294	# puts stderr "controlOwner::load path = $path, type = $type"
295	if {[lsearch {group separator control} $type] >= 0} {
296	continue
297	}
298
299	set type [[tool] xml element -as type $path]
300	if {[info exists _type2curpath($type)]} {
301	if { $_type2curpath($type) == "all" } {
302	set currentpath $path
303	} else {
304	set currentpath $path.$_type2curpath($type)
305	}
306	} else {
307	# default incase i forgot an input type in _type2curpath
308	set currentpath $path.current
309	}
310
311	# copy new value to the XML tree
312	# also copy to the widget associated with the tree
313	#
314	# we only copy the values if they existed in newobj
315	# so we don't overwrite values that were set in previous loads.
316	# this is needed for when the users specify copy.from and copy.to
317	# in a loader. in this case, _path2widget holds a list of all
318	# widgets. if there are two loaders loading two different widgets,
319	# and each loader uses the copy from/to functionality,
320	# the second load could wipe out the values set in the first load
321	# because on the second load, the copied paths from the first load no
322	# longer exist in newobj and blanks are copied to the paths
323	# in [tool] xml set by the first loader. the solution is to check
324	# newobj and see if the path exists. if the path exists, then we copy
325	# it over to [tool] xml, otherwise we ignore it.
326	if {"" != [$newobj element -as type $currentpath]} {
327	[tool] xml copy $currentpath from $newobj $currentpath
328	set val [$newobj get $currentpath]
329	if {[string length $val] > 0
330	\|\| [llength [$newobj children $currentpath]] == 0} {
331	$_path2widget($path) value $val
332	} else {
333	set obj [$newobj element -as object $currentpath]
334	$_path2widget($path) value $obj
335	}
336	}
337	}
338	# puts stderr "controlOwner::load done"
339	}
340
341	# ----------------------------------------------------------------------
342	# USAGE: changed <path>
343	#
344	# Invoked automatically by the various widgets associated with this
345	# tool whenever their value changes. Sends notifications to any
346	# client that has registered an interest via "notify add".
347	# ----------------------------------------------------------------------
348	itcl::body Rappture::ControlOwner::changed {path} {
349	if {"" != $_owner} {
350	set plen [string length $_path]
351	if {"" != $_path && ![string equal -length $plen $_path $path]} {
352	set path $_path.$path
353	}
354	$_owner changed $path
355	} else {
356	# send out any callback notifications
357	foreach owner [array names _owner2paths] {
358	foreach pattern $_owner2paths($owner) {
359	if {[string match $pattern $path]} {
360	uplevel #0 $_callbacks($owner/$pattern)
361	break
362	}
363	}
364	}
365
366	# find the control panel for each dependency, and tell it
367	# to update its layout.
368	foreach cpath [dependenciesfor $path] {
369	set wv [widgetfor $cpath]
370	while {"" != $wv} {
371	set wv [winfo parent $wv]
372	if {[winfo class $wv] == "Controls"} {
373	$wv refresh
374	break
375	}
376	}
377	}
378	}
379	}
380
381	# ----------------------------------------------------------------------
382	# USAGE: regularize <path>
383	#
384	# Clients use this to get a full, regularized path for the specified
385	# <path>, which may be relative to the current owner.
386	# ----------------------------------------------------------------------
387	itcl::body Rappture::ControlOwner::regularize {path} {
388	set owner [ownerfor $path]
389	if {$owner != $this && $owner != ""} {
390	return [$owner regularize $path]
391	}
392	set rpath ""
393	if {"" != $_xmlobj} {
394	set rpath [$_xmlobj element -as path $path]
395
396	# can't find the path? try removing the prefix for this owner
397	if {"" == $rpath} {
398	set plen [string length $_path]
399	if {[string equal -length $plen $_path $path]} {
400	set relpath [string range $path [expr {$plen+2}] end]
401	set rpath [$_xmlobj element -as path $relpath]
402	}
403	}
404
405	if {"" != $rpath && "" != $_path} {
406	# return a full name for the path
407	set rpath "$_path.$rpath"
408	}
409	}
410	return $rpath
411	}
412
413	# ----------------------------------------------------------------------
414	# USAGE: notify add <owner> <path> <callback>
415	# USAGE: notify info ?<owner>? ?<path>?
416	# USAGE: notify remove <owner> ?<path> ...?
417	#
418	# Clients use this to request notifications about changes to a
419	# particular <path> for a control under this tool. Whenever the
420	# value associated with <path> changes, the client identified by
421	# <owner> is sent a message by invoking its <callback> routine.
422	#
423	# Notifications can be silenced by calling the "notify remove"
424	# function.
425	# ----------------------------------------------------------------------
426	itcl::body Rappture::ControlOwner::notify {option args} {
427	switch -- $option {
428	add {
429	if {[llength $args] != 3} {
430	error "wrong # args: should be \"notify add owner path callback\""
431	}
432	set owner [lindex $args 0]
433	set path [lindex $args 1]
434	set cb [lindex $args 2]
435
436	if {[info exists _owner2paths($owner)]} {
437	set plist $_owner2paths($owner)
438	} else {
439	set plist ""
440	}
441
442	set i [lsearch -exact $plist $path]
443	if {$i < 0} { lappend _owner2paths($owner) $path }
444	set _callbacks($owner/$path) $cb
445	}
446	info {
447	if {[llength $args] == 0} {
448	# no args? then return all owners
449	return [array names _owner2paths]
450	} else {
451	set owner [lindex $args 0]
452	if {[info exists _owner2paths($owner)]} {
453	set plist $_owner2paths($owner)
454	} else {
455	set plist ""
456	}
457	if {[llength $args] == 1} {
458	# 1 arg? then return paths for this owner
459	return $plist
460	} elseif {[llength $args] == 2} {
461	# 2 args? then return callback for this path
462	set path [lindex $args 1]
463	if {[info exists _callbacks($owner/$path)]} {
464	return $_callbacks($owner/$path)
465	}
466	return ""
467	} else {
468	error "wrong # args: should be \"notify info ?owner? ?path?\""
469	}
470	}
471	}
472	remove {
473	if {[llength $args] < 1} {
474	error "wrong # args: should be \"notify remove owner ?path ...?\""
475	}
476	set owner [lindex $args 0]
477
478	if {[llength $args] == 1} {
479	# no args? then delete all paths for this owner
480	if {[info exists _owner2paths($owner)]} {
481	set plist $_owner2paths($owner)
482	} else {
483	set plist ""
484	}
485	} else {
486	set plist [lrange $args 1 end]
487	}
488
489	# forget about the callback for each path
490	foreach path $plist {
491	catch {unset _callbacks($owner/$path)}
492
493	if {[info exists _owner2paths($owner)]} {
494	set i [lsearch -exact $_owner2paths($owner) $path]
495	if {$i >= 0} {
496	set _owner2paths($owner) \
497	[lreplace $_owner2paths($owner) $i $i]
498	}
499	}
500	}
501	}
502	}
503	}
504
505	# ----------------------------------------------------------------------
506	# USAGE: sync
507	#
508	# Used by descendents such as a Controls panel to register the
509	# various controls associated with this page. That way, this
510	# ControlOwner knows what widgets to look at when syncing itself
511	# to the underlying XML data.
512	# ----------------------------------------------------------------------
513	itcl::body Rappture::ControlOwner::sync {} {
514	# sync all of the widgets under control of this owner
515	if {"" != $_xmlobj} {
516	foreach path [lsort [array names _path2widget]] {
517	set type [$_xmlobj element -as type $path]
518	if {[lsearch {group separator control note} $type] >= 0} {
519	continue
520	}
521	$_xmlobj put $path.current [$_path2widget($path) value]
522	}
523	}
524
525	# sync all subordinate slaves as well
526	foreach slave $_slaves {
527	$slave sync
528	}
529	}
530
531	# ----------------------------------------------------------------------
532	# USAGE: tool
533	#
534	# Clients use this to figure out which tool is associated with
535	# this object. If there is no parent ControlOwner, then this
536	# must be the top-level tool.
537	# ----------------------------------------------------------------------
538	itcl::body Rappture::ControlOwner::tool {} {
539	if {"" != $_owner} {
540	return [$_owner tool]
541	}
542	return $this
543	}
544
545	# ----------------------------------------------------------------------
546	# USAGE: _slave add <newobj>...
547	#
548	# Used internally to register the parent-child relationship whenever
549	# one ControlOwner is registered to another. When the parent syncs,
550	# it causes all of its children to sync. When a name is being
551	# resolved, it is resolved locally first, then up to the parent for
552	# further resolution.
553	# ----------------------------------------------------------------------
554	itcl::body Rappture::ControlOwner::_slave {option args} {
555	switch -- $option {
556	add {
557	eval lappend _slaves $args
558	}
559	default {
560	error "bad option \"$option\": should be add"
561	}
562	}
563	}

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

Context Navigation

source: branches/1.7/gui/scripts/controlOwner.tcl @ 6714

Download in other formats: