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

Last change on this file since 22 was 22, checked in by mmc, 17 years ago

Lots of changes to support Huckel-IV:

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