Context Navigation

← Previous Revision
Next Revision →
Blame
Revision Log

library.tcl

Last change on this file was 6692, checked in by clarksm, 7 years ago
More trouble with file(execute):driver.xml having structure elements changed - reset to tool.xml defaults. This changes the signature computed for caching.
File size: 39.0 KB

Line
1	# ----------------------------------------------------------------------
2	# COMPONENT: library - provides access to the XML library
3	#
4	# These routines make it easy to load the XML description for a
5	# series of tool parameters and browse through the results.
6	# ======================================================================
7	# AUTHOR: Michael McLennan, Purdue University
8	# Copyright (c) 2004-2012 HUBzero Foundation, LLC
9	#
10	# See the file "license.terms" for information on usage and
11	# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12	# ======================================================================
13	package require tdom
14	package require Itcl
15
16	namespace eval Rappture {
17	variable stdlib ""
18	}
19
20	# load the object system along with the XML library code
21	Rappture::objects::init
22	encoding system utf-8
23
24	# ----------------------------------------------------------------------
25	# USAGE: library <file>
26	# USAGE: library standard
27	# USAGE: library isvalid <object>
28	#
29	# Used to open a <file> containing an XML description of tool
30	# parameters. Loads the file and returns the name of the LibraryObj
31	# file that represents it.
32	#
33	# If you use the word "standard" in place of the file name, this
34	# function returns the standard Rappture library object, which
35	# contains material definitions.
36	#
37	# The isvalid operation checks an <object> to see if it is a valid
38	# library object. Returns 1 if so, and 0 otherwise.
39	# ----------------------------------------------------------------------
40	proc Rappture::library {args} {
41	# handle the isvalid operation...
42	if {[llength $args] > 1 && [lindex $args 0] == "isvalid"} {
43	if {[llength $args] != 2} {
44	error "wrong # args: should be \"library isvalid object\""
45	}
46	set obj [lindex $args 1]
47	#
48	# BE CAREFUL with the object test:
49	# The command should look like a LibraryObj formed by #auto.
50	# We want to avoid things like "split" or "set", which are
51	# valid Tcl commands but won't respond well to isa.
52	#
53	if {[regexp {libraryObj[0-9]+$} $obj]
54	&& [catch {$obj isa ::Rappture::LibraryObj} valid] == 0
55	&& $valid} {
56	return 1
57	}
58	return 0
59	}
60
61	if {[llength $args] != 1} {
62	error "wrong # args: should be \"library file\" or \"library isvalid object\""
63	}
64	set fname [lindex $args 0]
65
66	if {$fname == "standard"} {
67	variable stdlib
68	if {$stdlib != ""} {
69	return $stdlib
70	}
71	set fname [file join $Rappture::installdir lib library.xml]
72	if { [catch {
73	set fid [::open $fname r]
74	set info [read $fid]
75	close $fid
76	} errs] != 0 } {
77	global errorInfo
78	puts stderr "can't open \"$fname\": errs=$errs errorInfo=$errorInfo"
79	}
80	set stdlib [Rappture::LibraryObj ::#auto $info]
81	return $stdlib
82	}
83
84	if {[regexp {^<\?[Xx][Mm][Ll]} $fname]} {
85	set info $fname
86	} else {
87	# otherwise, try to open the file and create its LibraryObj
88	if { [catch {
89	set fid [::open $fname r]
90	set info [read $fid]
91	close $fid
92	} errs] != 0 } {
93	global errorInfo
94	puts stderr "can't open \"$fname\": errs=$errs errorInfo=$errorInfo"
95	}
96	}
97
98	set obj [Rappture::LibraryObj ::#auto $info]
99	return $obj
100	}
101
102	# ----------------------------------------------------------------------
103	# USAGE: entities ?-as <fval>? <object> <path>
104	#
105	# Used to sift through an XML <object> for "entities" within the
106	# Rappture description. Entities are things like strings, numbers,
107	# etc., which show up in the GUI as controls.
108	#
109	# Returns a list of all entities found beneath <path>.
110	#
111	# By default, this method returns the component name "type(id)".
112	# This is changed by setting the -as argument to "id" (for name
113	# of the tail element), to "type" (for the type of the tail element),
114	# to "object" (for an object representing the DOM node referenced by
115	# the path.
116	# ----------------------------------------------------------------------
117	proc Rappture::entities {args} {
118	array set params {
119	-as component
120	}
121	while {[llength $args] > 1} {
122	set first [lindex $args 0]
123	if {[string index $first 0] == "-"} {
124	set choices [array names params]
125	if {[lsearch $choices $first] < 0} {
126	error "bad option \"$first\": should be [join [lsort $choices] {, }]"
127	}
128	set params($first) [lindex $args 1]
129	set args [lrange $args 2 end]
130	} else {
131	break
132	}
133	}
134	if {[llength $args] > 2} {
135	error "wrong # args: should be \"entities ?-as fval? obj ?path?\""
136	}
137	set xmlobj [lindex $args 0]
138	set path [lindex $args 1]
139
140	set rlist ""
141	lappend queue $path
142	while {[llength $queue] > 0} {
143	set path [lindex $queue 0]
144	set queue [lrange $queue 1 end]
145
146	foreach cpath [$xmlobj children -as path $path] {
147	set type [$xmlobj element -as type $cpath]
148	switch -- $type {
149	group - phase {
150	lappend queue $cpath
151	}
152	structure {
153	# add this to the return list with the right flavor
154	if {$params(-as) == "component"} {
155	lappend rlist $cpath
156	} else {
157	lappend rlist [$xmlobj element -as $params(-as) $cpath]
158	}
159
160	if {[$xmlobj element $cpath.default.parameters] != ""} {
161	lappend queue $cpath.default.parameters
162	}
163	if {[$xmlobj element $cpath.current.parameters] != ""} {
164	lappend queue $cpath.current.parameters
165	}
166	if {[$xmlobj element $cpath.current.fields] != ""} {
167	lappend rlist $cpath.current.fields
168	}
169	if {[$xmlobj element $cpath.current.components] != ""} {
170	lappend rlist $cpath.current.components
171	}
172	}
173	drawing {
174	# add this to the return list with the right flavor
175	if {$params(-as) == "component"} {
176	lappend rlist $cpath
177	} else {
178	lappend rlist [$xmlobj element -as $params(-as) $cpath]
179	}
180
181	foreach child [$xmlobj children $cpath.current] {
182	if {[string match about* $child]} {
183	continue
184	}
185	if {[$xmlobj element $cpath.current.$child.parameters] != ""} {
186	lappend queue $cpath.current.$child.parameters
187	}
188	}
189	}
190	loader {
191	if {$params(-as) == "component"} {
192	lappend rlist $cpath
193	} else {
194	lappend rlist [$xmlobj element -as $params(-as) $cpath]
195	}
196	}
197	default {
198	if {[catch {Rappture::objects::get $type}] == 0} {
199	# add this to the return list with the right flavor
200	if {$params(-as) == "component"} {
201	lappend rlist $cpath
202	} else {
203	lappend rlist [$xmlobj element -as $params(-as) $cpath]
204	}
205	}
206
207	# if this element has embedded groups, add them to the queue
208	foreach ccpath [$xmlobj children -as path $cpath] {
209	set cctype [$xmlobj element -as type $ccpath]
210	if {$cctype == "group" \|\| $cctype == "phase"} {
211	lappend queue $ccpath
212	}
213	}
214	}
215	}
216	}
217	}
218	return $rlist
219	}
220
221	# ----------------------------------------------------------------------
222	itcl::class Rappture::LibraryObj {
223	constructor {info} { # defined below }
224	destructor { # defined below }
225
226	public method element {args}
227	public method parent {args}
228	public method children {args}
229	public method get {args}
230	public method put {args}
231	public method copy {path from args}
232	public method remove {{path ""}}
233	public method xml {{path ""}}
234	public method uq_get_vars {{tfile ""}}
235
236	public method diff {libobj}
237	public proc value {libobj path}
238
239	public proc path2list {path}
240	protected method find {path}
241	protected method node2name {node}
242	protected method node2comp {node}
243	protected method node2path {node}
244	protected method childnodes {node type}
245
246	private variable _root 0 ;# non-zero => this obj owns document
247	private variable _document "" ;# XML DOM tree
248	private variable _node "" ;# node within
249	}
250
251	# ----------------------------------------------------------------------
252	# CONSTRUCTOR
253	# ----------------------------------------------------------------------
254	itcl::body Rappture::LibraryObj::constructor {info} {
255	if {[regexp {<?[Xx][Mm][Ll]} $info]} {
256	set _root 1
257	set _document [dom parse $info]
258	set _node [$_document documentElement]
259	} elseif {[regexp {^domNode} $info]} {
260	set _root 0
261	set _document [$info ownerDocument]
262	set _node $info
263	} else {
264	error "bad info: should be XML text or DOM node"
265	}
266	}
267
268	# ----------------------------------------------------------------------
269	# DESTRUCTOR
270	# ----------------------------------------------------------------------
271	itcl::body Rappture::LibraryObj::destructor {} {
272	if {$_root && $_document != ""} {
273	$_document delete
274	}
275	}
276
277	# ----------------------------------------------------------------------
278	# USAGE: element ?-as <fval>? ?<path>?
279	#
280	# Clients use this to query a particular element within the entire
281	# data structure. The path is a string of the form
282	# "structure.box(source).corner". This example represents the tag
283	# <corner> within a tag <box id="source"> within a tag <structure>,
284	# which must be found at the top level within this document.
285	#
286	# By default, this method returns the component name "type(id)".
287	# This is changed by setting the -as argument to "id" (for name
288	# of the tail element), to "type" (for the type of the tail element),
289	# to "object" (for an object representing the DOM node referenced by
290	# the path).
291	# ----------------------------------------------------------------------
292	itcl::body Rappture::LibraryObj::element {args} {
293	array set params {
294	-as component
295	}
296	while {[llength $args] > 1} {
297	set first [lindex $args 0]
298	if {[string index $first 0] == "-"} {
299	set choices [array names params]
300	if {[lsearch $choices $first] < 0} {
301	error "bad option \"$first\": should be [join [lsort $choices] {, }]"
302	}
303	set params($first) [lindex $args 1]
304	set args [lrange $args 2 end]
305	} else {
306	break
307	}
308	}
309	if {[llength $args] > 1} {
310	error "wrong # args: should be \"element ?-as fval? ?path?\""
311	}
312	set path [lindex $args 0]
313
314	set node [find $path]
315	if {$node == ""} {
316	return ""
317	}
318
319	switch -- $params(-as) {
320	object {
321	return [::Rappture::LibraryObj ::#auto $node]
322	}
323	component {
324	return [node2comp $node]
325	}
326	id {
327	return [node2name $node]
328	}
329	path {
330	return [node2path $node]
331	}
332	type {
333	return [$node nodeName]
334	}
335	default {
336	error "bad flavor \"$params(-as)\": should be component, id, object, path, type"
337	}
338	}
339	}
340
341	# ----------------------------------------------------------------------
342	# USAGE: parent ?-as <fval>? ?<path>?
343	#
344	# Clients use this to query the parent of a particular element.
345	# This is just like the "element" method, but it returns the parent
346	# of the element instead of the element itself.
347	#
348	# By default, this method returns a list of component names "type(id)".
349	# This is changed by setting the -as argument to "id" (for tail
350	# names of all children), to "type" (for the types of all children),
351	# to "object" (for a list of objects representing the DOM nodes for
352	# all children).
353	# ----------------------------------------------------------------------
354	itcl::body Rappture::LibraryObj::parent {args} {
355	array set params {
356	-as component
357	}
358	while {[llength $args] > 1} {
359	set first [lindex $args 0]
360	if {[string index $first 0] == "-"} {
361	set choices [array names params]
362	if {[lsearch $choices $first] < 0} {
363	error "bad option \"$first\": should be [join [lsort $choices] {, }]"
364	}
365	set params($first) [lindex $args 1]
366	set args [lrange $args 2 end]
367	} else {
368	break
369	}
370	}
371	if {[llength $args] > 1} {
372	error "wrong # args: should be \"parent ?-as fval? ?path?\""
373	}
374	set path [lindex $args 0]
375
376	set node [find $path]
377	if {$node == ""} {
378	return ""
379	}
380	set node [$node parentNode]
381	if {$node == ""} {
382	return ""
383	}
384
385	switch -- $params(-as) {
386	object {
387	return [::Rappture::LibraryObj ::#auto $node]
388	}
389	component {
390	return [node2comp $node]
391	}
392	id {
393	return [node2name $node]
394	}
395	path {
396	return [node2path $node]
397	}
398	type {
399	return [$node nodeName]
400	}
401	default {
402	error "bad flavor \"$params(-as)\": should be component, id, object, path, type"
403	}
404	}
405	}
406
407	# ----------------------------------------------------------------------
408	# USAGE: children ?-as <fval>? ?-type <name>? ?<path>?
409	#
410	# Clients use this to query the children of a particular element
411	# within the entire data structure. This is just like the "element"
412	# method, but it returns the children of the element instead of the
413	# element itself. If the optional -type argument is specified, then
414	# the return list is restricted to children of the specified type.
415	#
416	# By default, this method returns a list of component names "type(id)".
417	# This is changed by setting the -as argument to "id" (for tail
418	# names of all children), to "type" (for the types of all children),
419	# to "object" (for a list of objects representing the DOM nodes for
420	# all children).
421	# ----------------------------------------------------------------------
422	itcl::body Rappture::LibraryObj::children {args} {
423	array set params {
424	-as component
425	-type ""
426	}
427	while {[llength $args] > 1} {
428	set first [lindex $args 0]
429	if {[string index $first 0] == "-"} {
430	set choices [array names params]
431	if {[lsearch $choices $first] < 0} {
432	error "bad option \"$first\": should be [join [lsort $choices] {, }]"
433	}
434	set params($first) [lindex $args 1]
435	set args [lrange $args 2 end]
436	} else {
437	break
438	}
439	}
440	if {[llength $args] > 1} {
441	error "wrong # args: should be \"children ?-as fval? ?-type name? ?path?\""
442	}
443	set path [lindex $args 0]
444	set node [find $path]
445	if {$node == ""} {
446	return ""
447	}
448
449	set nlist ""
450	foreach n [$node childNodes] {
451	set type [$n nodeName]
452	if {[regexp {^#} $type]} {
453	continue
454	}
455	if {$params(-type) != "" && $params(-type) != $type} {
456	continue
457	}
458	lappend nlist $n
459	}
460
461	set rlist ""
462	switch -- $params(-as) {
463	object {
464	foreach n $nlist {
465	lappend rlist [::Rappture::LibraryObj ::#auto $n]
466	}
467	}
468	component {
469	foreach n $nlist {
470	lappend rlist [node2comp $n]
471	}
472	}
473	id {
474	foreach n $nlist {
475	lappend rlist [node2name $n]
476	}
477	}
478	path {
479	foreach n $nlist {
480	lappend rlist [node2path $n]
481	}
482	}
483	type {
484	foreach n $nlist {
485	lappend rlist [$n nodeName]
486	}
487	}
488	default {
489	error "bad flavor \"$params(-as)\": should be component, id, object, path, type"
490	}
491	}
492	return $rlist
493	}
494
495	# ----------------------------------------------------------------------
496	# USAGE: get ?-decode yes? ?<path>?
497	#
498	# Clients use this to query the value of a node. Clients can specify
499	# if they want the data to be automatically decoded or no using the
500	# -decode flag. This is useful for situations where you want to keep
501	# the data encoded to pass to another system, like dx data in fields
502	# sending data to nanovis. If the path is not
503	# specified, it returns the value associated with the root node.
504	# Otherwise, it returns the value for the element specified by the
505	# path.
506	# ----------------------------------------------------------------------
507	itcl::body Rappture::LibraryObj::get {args} {
508	array set params {
509	-decode yes
510	}
511	while {[llength $args] > 0} {
512	set first [lindex $args 0]
513	if {[string index $first 0] == "-"} {
514	set choices [array names params]
515	if {[lsearch $choices $first] < 0} {
516	error "bad option \"$first\": should be [join [lsort $choices] {, }]"
517	}
518	set params($first) [lindex $args 1]
519	set args [lrange $args 2 end]
520	} else {
521	break
522	}
523	}
524	if {[llength $args] > 1} {
525	error "wrong # args: should be \"get ?-decode yes? ?path?\""
526	}
527	if {[llength $args] == 1} {
528	set path [lindex $args 0]
529	} else {
530	set path ""
531	}
532
533	set node [find $path]
534	if {$node == ""} {
535	return ""
536	}
537	set string [string trim [$node text]]
538	if {$params(-decode)} {
539	set string [Rappture::encoding::decode -- $string]
540	}
541	return $string
542	}
543
544	# ----------------------------------------------------------------------
545	# USAGE: put ?-append yes? ?-id num? ?-type string\|file? ?-compress no? ?<path>? <string>
546	#
547	# Clients use this to set the value of a node. If the path is not
548	# specified, it sets the value for the root node. Otherwise, it sets
549	# the value for the element specified by the path. If the value is a
550	# string, then it is treated as the text within the tag at the tail
551	# of the path. If it is a DOM node or a library, then it is inserted
552	# into the tree at the specified path.
553	#
554	# If the optional id is specified, then it sets the identifier for
555	# the tag at the tail of the path. If the optional append flag is
556	# specified, then the value is appended to the current value.
557	# Otherwise, the value replaces the current value.
558	# ----------------------------------------------------------------------
559	itcl::body Rappture::LibraryObj::put {args} {
560	array set params {
561	-id ""
562	-append no
563	-type string
564	-compress no
565	}
566	while {[llength $args] > 1} {
567	set first [lindex $args 0]
568	if {[string index $first 0] == "-"} {
569	set choices [array names params]
570	if {[lsearch $choices $first] < 0} {
571	error "bad option \"$first\": should be [join [lsort $choices] {, }]"
572	}
573	set params($first) [lindex $args 1]
574	set args [lrange $args 2 end]
575	} else {
576	break
577	}
578	}
579	if {[llength $args] < 1 \|\| [llength $args] > 2} {
580	error "wrong # args: should be \"put ?-append bval? ?-id num? ?-type string\|file? ?-compress bval? ?path? string\""
581	}
582	if {[llength $args] == 2} {
583	set path [lindex $args 0]
584	set str [lindex $args 1]
585	} else {
586	set path ""
587	set str [lindex $args 0]
588	}
589
590	if {$params(-type) == "file"} {
591	set fileName $str
592	set fid [open $fileName r]
593	fconfigure $fid -translation binary -encoding binary
594	set str [read $fid]
595	close $fid
596	}
597
598	if {$params(-compress) \|\| [Rappture::encoding::is binary $str]} {
599	set str [Rappture::encoding::encode -- $str]
600	}
601
602	set node [find -create $path]
603
604	#
605	# Clean up any nodes that don't belong. If we're appending
606	# the value, then clean up only child <tag> nodes. Otherwise,
607	# clean up all nodes.
608	#
609	set nlist ""
610	if {$params(-append)} {
611	foreach n [$node childNodes] {
612	if {[$n nodeType] != "TEXT_NODE"} {
613	lappend nlist $n
614	}
615	}
616	} else {
617	set nlist [$node childNodes]
618	}
619	foreach n $nlist {
620	$n delete
621	}
622
623	if {[Rappture::library isvalid $str]} {
624	foreach n [[$str info variable _node -value] childNodes] {
625	if { [$n nodeType] == "COMMENT_NODE" } {
626	continue
627	}
628	$node appendXML [$n asXML]
629	}
630	} else {
631	set n [$_document createText $str]
632	$node appendChild $n
633	if {"" != $params(-id)} {
634	$node setAttribute id $params(-id)
635	}
636	}
637	return ""
638	}
639
640	# ----------------------------------------------------------------------
641	# USAGE: copy <path> from ?<xmlobj>? <path>
642	#
643	# Clients use this to copy the value from one xmlobj/path to another.
644	# If the <xmlobj> is not specified, it is assumed to be the same as
645	# the current object.
646	# ----------------------------------------------------------------------
647	itcl::body Rappture::LibraryObj::copy {path from args} {
648	if {[llength $args] == 1} {
649	set xmlobj $this
650	set fpath [lindex $args 0]
651	} elseif {[llength $args] == 2} {
652	set xmlobj [lindex $args 0]
653	set fpath [lindex $args 1]
654	} else {
655	error "wrong # args: should be \"copy path from ?xmlobj? path\""
656	}
657	if {$from != "from"} {
658	error "bad syntax: should be \"copy path from ?xmlobj? path\""
659	}
660
661	if {[llength [$xmlobj children $fpath]] == 0} {
662	set val [$xmlobj get $fpath]
663	put $path $val
664	} else {
665	set obj [$xmlobj element -as object $fpath]
666	put $path $obj
667	itcl::delete object $obj
668	}
669	}
670
671	# ----------------------------------------------------------------------
672	# USAGE: remove ?<path>?
673	#
674	# Clients use this to remove the specified node. Removes the node
675	# from the tree.
676	# ----------------------------------------------------------------------
677	itcl::body Rappture::LibraryObj::remove {{path ""}} {
678	set node [find $path]
679	if {$node != ""} {
680	$node delete
681	}
682	}
683
684	# ----------------------------------------------------------------------
685	# USAGE: xml ?<path>?
686	#
687	# Returns a string representing the XML information for the information
688	# in this library.
689	# ----------------------------------------------------------------------
690	itcl::body Rappture::LibraryObj::xml {{path ""}} {
691	if {"" != $path} {
692	set n [find $path]
693	} else {
694	set n $_node
695	}
696	return [$n asXML]
697	}
698
699	# ----------------------------------------------------------------------
700	# USAGE: diff <libobj>
701	#
702	# Compares the entities in this object to those in another and
703	# returns a list of differences. The result is a list of the form:
704	# {op1 path1 oldval1 newval1 ...} where each "op" is +/-/c for
705	# added/subtracted/changed, "path" is the path within the library
706	# that is different, and "oldval"/"newval" give the values for the
707	# object at the path.
708	# ----------------------------------------------------------------------
709	itcl::body Rappture::LibraryObj::diff {libobj} {
710	set rlist ""
711
712	# query the values for all entities in both objects
713	set thisv [Rappture::entities $this input]
714	set otherv [Rappture::entities $libobj input]
715
716	# add UQ checking
717	lappend thisv uq.type uq.args
718	lappend otherv uq.type uq.args
719
720	# scan through values for this object, and compare against other one
721	foreach path $thisv {
722	set i [lsearch -exact $otherv $path]
723	if {$i < 0} {
724	foreach {raw norm} [value $this $path] break
725	lappend rlist - $path $raw ""
726	} else {
727	foreach {traw tnorm} [value $this $path] break
728	foreach {oraw onorm} [value $libobj $path] break
729	if {![string equal $tnorm $onorm]} {
730	lappend rlist c $path $traw $oraw
731	}
732	set otherv [lreplace $otherv $i $i]
733	}
734	}
735
736	# add any values left over in the other object
737	foreach path $otherv {
738	foreach {oraw onorm} [value $libobj $path] break
739	lappend rlist + $path "" $oraw
740	}
741
742	return $rlist
743	}
744
745	# ----------------------------------------------------------------------
746	# USAGE: value <object> <path>
747	#
748	# Used to query the "value" associated with the <path> in an XML
749	# <object>. This is a little more complicated than the object's
750	# "get" method. It handles things like structures and values
751	# with normalized units.
752	#
753	# Returns a list of two items: {raw norm} where "raw" is the raw
754	# value from the "get" method and "norm" is the normalized value
755	# produced by this routine. Example: {300K 300}
756	#
757	# Right now, it is a handy little utility used by the "diff" method.
758	# Eventually, it should be moved to a better object-oriented
759	# implementation, where each Rappture type could overload the
760	# various bits of processing below. So we leave it as a "proc"
761	# now instead of a method, since it should be deprecated soon.
762	# ----------------------------------------------------------------------
763	itcl::body Rappture::LibraryObj::value {libobj path} {
764	switch -- [$libobj element -as type $path] {
765	structure {
766	set raw $path
767	# try to find a label to represent the structure
768	set val [$libobj get $path.about.label]
769	if {"" == $val} {
770	set val [$libobj get $path.current.about.label]
771	}
772	if {"" == $val} {
773	if {[$libobj element $path.current] != ""} {
774	set comps [$libobj children $path.current.components]
775	set val "<structure> with [llength $comps] components"
776	} else {
777	set val "<structure>"
778	}
779	}
780	return [list $raw $val]
781	}
782	number {
783	# get the usual value...
784	set raw ""
785	set val ""
786	if {"" != [$libobj element $path.current]} {
787	set raw [$libobj get $path.current]
788	} elseif {"" != [$libobj element $path.default]} {
789	set raw [$libobj get $path.default]
790	}
791	if {"" != $raw} {
792	set val $raw
793	# then normalize to default units
794	set units [$libobj get $path.units]
795	if {"" != $units} {
796	set val [Rappture::Units::mconvert $val \
797	-context $units -to $units -units off]
798	}
799	}
800	return [list $raw $val]
801	}
802	}
803
804	# for all other types, get the value (current, or maybe default)
805	set raw ""
806	if {"" != [$libobj element $path.current]} {
807	set raw [$libobj get $path.current]
808	} elseif {"" != [$libobj element $path.default]} {
809	set raw [$libobj get $path.default]
810	}
811	return [list $raw $raw]
812	}
813
814	# ----------------------------------------------------------------------
815	# USAGE: find ?-create? <path>
816	#
817	# Used internally to find a particular element within the root node
818	# according to the path, which is a string of the form
819	# "typeNN(id).typeNN(id). ...", where each "type" is a tag <type>;
820	# if the optional NN is specified, it indicates an index for the
821	# <type> tag within its parent; if the optional (id) part is included,
822	# it indicates a tag of the form <type id="id">.
823	#
824	# By default, it looks for an element along the path and returns None
825	# if not found. If the create flag is set, it creates various elements
826	# along the path as it goes. This is useful for "put" operations.
827	#
828	# If you include "#" instead of a specific number, a node will be
829	# created automatically with a new number. For example, the path
830	# "foo.bar#" called the first time will create "foo.bar", the second
831	# time "foo.bar1", the third time "foo.bar2" and so forth.
832	#
833	# Returns an object representing the element indicated by the path,
834	# or "" if the path is not found.
835	# ----------------------------------------------------------------------
836	itcl::body Rappture::LibraryObj::find {args} {
837	set create 0
838	while {[llength $args] > 1} {
839	set first [lindex $args 0]
840	set args [lrange $args 1 end]
841	if {$first == "-create"} {
842	set create 1
843	} else {
844	error "bad option \"$first\": should be -create"
845	}
846	}
847	if {[llength $args] != 1} {
848	error "wrong # args: should be \"find ?-create? path\""
849	}
850	set path [lindex $args 0]
851
852	if {$path == ""} {
853	return $_node
854	}
855	set path [path2list $path]
856
857	#
858	# Follow the given path and look for all of the parts.
859	#
860	set lastnode $_node
861	set node $lastnode
862	foreach part $path {
863	if {![regexp {^(([a-zA-Z0-9_][a-zA-Z_]+#?)([0-9]))?($(.*)$)?$} $part \
864	match dummy type index dummy name]} {
865	error "bad path component \"$part\""
866	}
867	#
868	# If the name is like "type2", then look for elements with
869	# the type name and return the one with the given index.
870	# If the name is like "type", then assume the index is 0.
871	#
872	if {$name == ""} {
873	if {$index == ""} {
874	set index 0
875	}
876	set nlist [childnodes $node $type]
877	set node [lindex $nlist $index]
878	} else {
879	#
880	# If the name is like "type(id)", then look for elements
881	# that match the type and see if one has the requested name.
882	# if the name is like "(id)", then look for any elements
883	# with the requested name.
884	#
885	if {$type != ""} {
886	set nlist [childnodes $node $type]
887	} else {
888	set nlist [$node childNodes]
889	}
890	set found 0
891	foreach n $nlist {
892	if {[catch {$n getAttribute id} tag]} { set tag "" }
893	if {$tag == $name} {
894	set found 1
895	break
896	}
897	}
898	set node [expr {($found) ? $n : ""}]
899	}
900
901	if {$node == ""} {
902	if {!$create} {
903	return ""
904	}
905
906	#
907	# If the "create" flag is set, then create a node
908	# with the specified "type(id)" and continue on.
909	# If the type is "type#", then create a node with
910	# an automatic number.
911	#
912	if {![regexp {^([^$]+)\(([^$]+)\)$} $part match type name]} {
913	set type $part
914	set name ""
915	}
916
917	if {[string match *# $type]} {
918	set type [string trimright $type #]
919	set node [$_document createElement $type]
920
921	# find the last node of same type and append there
922	set pos ""
923	foreach n [$lastnode childNodes] {
924	if {[$n nodeName] == $type} {
925	set pos $n
926	}
927	}
928	if {$pos != ""} {
929	set pos [$pos nextSibling]
930	}
931	if {$pos != ""} {
932	$lastnode insertBefore $node $pos
933	} else {
934	$lastnode appendChild $node
935	}
936	} else {
937	set node [$_document createElement $type]
938	$lastnode appendChild $node
939	}
940	if {"" != $name} {
941	$node setAttribute id $name
942	}
943	}
944	set lastnode $node
945	}
946	return $node
947	}
948
949	# ----------------------------------------------------------------------
950	# USAGE: path2list <path>
951	#
952	# Converts a path of the form "foo(a).bar.baz" into a list of the
953	# form "foo(a) bar baz". This is a little more complicated than
954	# splitting on the .'s, since the stuff in ()'s might have embedded
955	# .'s. Returns a proper Tcl list for all elements of the path.
956	# ----------------------------------------------------------------------
957	itcl::body Rappture::LibraryObj::path2list {path} {
958	#
959	# Normally, we just split on .'s within the path. But there
960	# might be some .'s embedded within ()'s in the path. Change
961	# any embedded .'s to an out-of-band character, then split on
962	# the .'s, and change the embedded .'s back.
963	#
964	if {[regexp {($[^$])\.([^\)]\))} $path]} {
965	while {[regsub -all {($[^$])\.([^\)]\))} $path "\\1\007\\2" path]} {
966	# keep fixing...
967	}
968	}
969	set path [split $path .]
970	regsub -all {\007} $path {.} path
971
972	return $path
973	}
974
975	# ----------------------------------------------------------------------
976	# USAGE: node2name <node>
977	#
978	# Used internally to create a name for the specified node. If the
979	# node doesn't have a specific name ("id" attribute) then a name of
980	# the form "type123" is constructed.
981	# ----------------------------------------------------------------------
982	itcl::body Rappture::LibraryObj::node2name {node} {
983	if {[catch {$node getAttribute id} name]} { set name "" }
984	if {$name == ""} {
985	set pnode [$node parentNode]
986	if {$pnode == ""} {
987	return ""
988	}
989	set type [$node nodeName]
990	set siblings [childnodes $pnode $type]
991	set index [lsearch $siblings $node]
992	if {$index == 0} {
993	set name $type
994	} else {
995	set name "$type$index"
996	}
997	}
998	return $name
999	}
1000
1001	# ----------------------------------------------------------------------
1002	# USAGE: node2comp <node>
1003	#
1004	# Used internally to create a path component name for the specified
1005	# node. A path component name has the form "type(id)" or just
1006	# "type##" if the node doesn't have a name. This name can be used
1007	# in a path to uniquely address the component.
1008	# ----------------------------------------------------------------------
1009	itcl::body Rappture::LibraryObj::node2comp {node} {
1010	set type [$node nodeName]
1011	if {[catch {$node getAttribute id} name]} { set name "" }
1012	if {$name == ""} {
1013	set pnode [$node parentNode]
1014	if {$pnode == ""} {
1015	return ""
1016	}
1017	set siblings [childnodes $pnode $type]
1018	set index [lsearch $siblings $node]
1019	if {$index == 0} {
1020	set name $type
1021	} else {
1022	set name "$type$index"
1023	}
1024	} else {
1025	set name "${type}($name)"
1026	}
1027	return $name
1028	}
1029
1030	# ----------------------------------------------------------------------
1031	# USAGE: node2path <node>
1032	#
1033	# Used internally to create a full path name for the specified node.
1034	# The path is relative to the current object, so it stops when the
1035	# parent is the root node for this object.
1036	# ----------------------------------------------------------------------
1037	itcl::body Rappture::LibraryObj::node2path {node} {
1038	set path [node2comp $node]
1039	set node [$node parentNode]
1040	while {$node != "" && $node != $_node} {
1041	set path "[node2comp $node].$path"
1042	set node [$node parentNode]
1043	}
1044	return $path
1045	}
1046
1047	# ----------------------------------------------------------------------
1048	# USAGE: childnodes <node> <type>
1049	#
1050	# Used internally to return a list of children for the given <node>
1051	# that match a specified <type>. Similar to XML getElementsByTagName,
1052	# but returns only direct children of the <node>.
1053	# ----------------------------------------------------------------------
1054	itcl::body Rappture::LibraryObj::childnodes {node type} {
1055	set rlist ""
1056	foreach cnode [$node childNodes] {
1057	if {[$cnode nodeName] == $type} {
1058	lappend rlist $cnode
1059	}
1060	}
1061	return $rlist
1062	}
1063
1064	# ----------------------------------------------------------------------
1065	# USAGE: uq_get_vars [$tfile]
1066	#
1067	# Scans number nodes in the input section for UQ parameters.
1068	#
1069	# Returns a string in JSON so it can easily be passed to PUQ. Strips units
1070	# because PUQ does not need or recognize them.
1071	#
1072	# For example, 2 parameters, one gaussian and one uniform might return:
1073	# [["height","m",["gaussian",100,10,{"min":0}]],["velocity","m/s",["uniform",80,90]]]
1074	#
1075	# Returns "" if there are no UQ parameters.
1076	#
1077	# If tfile is specified, write a template file out.
1078	# ----------------------------------------------------------------------
1079	itcl::body Rappture::LibraryObj::uq_get_vars {{tfile ""}} {
1080	set varout "\["
1081	set varlist {}
1082
1083	if {$tfile == ""} {
1084	set node $_node
1085	} else {
1086	set fid [::open $tfile r]
1087	set doc [dom parse [read $fid]]
1088	set node [$doc documentElement]
1089	close $fid
1090	}
1091
1092	set count 0
1093	set n [$node selectNodes /run/input//number]
1094	foreach _n $n {
1095	set x [$_n selectNodes current/text()]
1096	set val [$x nodeValue]
1097	if {[string equal -length 8 $val "uniform "] \|\|
1098	[string equal -length 9 $val "gaussian "]} {
1099
1100	set vname [$_n getAttribute id]
1101	if {[lsearch $varlist $vname] >= 0} {
1102	continue
1103	} else {
1104	lappend varlist $vname
1105	}
1106
1107	if {$count > 0} {
1108	append varout ,
1109	}
1110	incr count
1111
1112	set units ""
1113	set unode [$_n selectNodes units/text()]
1114	if {"" != $unode} {
1115	set units [$unode nodeValue]
1116	set val [Rappture::Units::mconvert $val \
1117	-context $units -to $units -units off]
1118	}
1119
1120	set v \[\"$vname\",\"$units\",
1121	set fmt "\[\"%s\",%.16g,%.16g"
1122	set val [format $fmt [lindex $val 0] [lindex $val 1] [lindex $val 2]]
1123	append v $val
1124
1125	if {[string equal -length 9 [$x nodeValue] "gaussian "]} {
1126	set minv ""
1127	set min_node [$_n selectNodes min/text()]
1128	if {"" != $min_node} {
1129	set minv [$min_node nodeValue]
1130	if {$units != ""} {
1131	set minv [Rappture::Units::convert $minv -context $units -units off]
1132	}
1133	}
1134
1135	set maxv ""
1136	set max_node [$_n selectNodes max/text()]
1137	if {"" != $max_node} {
1138	set maxv [$max_node nodeValue]
1139	if {$units != ""} {
1140	set maxv [Rappture::Units::convert $maxv -context $units -units off]
1141	}
1142	}
1143
1144	if {$minv != "" \|\| $maxv != ""} {
1145	append v ",{"
1146	if {$minv != ""} {
1147	append v "\"min\":$minv"
1148	if {$maxv != ""} {append v ,}
1149	}
1150	if {$maxv != ""} {
1151	append v "\"max\":$maxv"
1152	}
1153	append v "}"
1154	}
1155	}
1156
1157	if {$tfile != ""} {
1158	$x nodeValue @@[$_n getAttribute id]
1159	}
1160	append varout $v\]\]
1161	}
1162	}
1163	append varout \]
1164
1165	if {$tfile != ""} {
1166	set fid [open $tfile w]
1167	puts $fid "<?xml version=\"1.0\"?>"
1168	puts $fid [$node asXML]
1169	close $fid
1170	$doc delete
1171	}
1172	if {$varout == "\[\]"} {set varout ""}
1173	#puts "uq_get_vars returning $varout"
1174	return [list $varout $count]
1175	}

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

Context Navigation

source: branches/1.7/lang/tcl/scripts/library.tcl

Download in other formats: