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

Last change on this file since 13 was 13, checked in by mmc, 16 years ago

Many improvements, including a new energy level viewer
for Huckel-IV. Added support for a new <boolean> type.
Fixed the cloud/field stuff so that when a cloud is 1D,
it reverts to BLT vectors so it will plot correctly.
Fixed the install script to work better on Windows.

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