Context Navigation

source: trunk/tcl/scripts/library.tcl @ 829

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

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

Download in other formats: