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

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

Updated all copyright notices.

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