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

Last change on this file since 763 was 763, checked in by mmc, 14 years ago

Fix for support ticket #2273 (can't read "val": no such variable).

File size: 32.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-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 {args}
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 ?-decode yes? ?<path>?
438#
439# Clients use this to query the value of a node. Clients can specify
440# if they want the data to be automatically decoded or no using the
441# -decode flag. This is useful for situations where you want to keep
442# the data encoded to pass to another system, like dx data in fields
443# sending data to nanovis. If the path is not
444# specified, it returns the value associated with the root node.
445# Otherwise, it returns the value for the element specified by the
446# path.
447# ----------------------------------------------------------------------
448itcl::body Rappture::LibraryObj::get {args} {
449    array set params {
450        -decode yes
451    }
452    while {[llength $args] > 0} {
453        set first [lindex $args 0]
454        if {[string index $first 0] == "-"} {
455            set choices [array names params]
456            if {[lsearch $choices $first] < 0} {
457                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
458            }
459            set params($first) [lindex $args 1]
460            set args [lrange $args 2 end]
461        } else {
462            break
463        }
464    }
465    if {[llength $args] > 1} {
466        error "wrong # args: should be \"get ?-decode yes? ?path?\""
467    }
468    if {[llength $args] == 1} {
469        set path [lindex $args 0]
470    } else {
471        set path ""
472    }
473
474    set node [find $path]
475    if {$node == ""} {
476        return ""
477    }
478    if {$params(-decode) == "yes"} {
479        return [Rappture::encoding::decode [string trim [$node text]]]
480    } else {
481        return [string trim [$node text]]
482    }
483}
484
485# ----------------------------------------------------------------------
486# USAGE: put ?-append yes? ?-id num? ?-type string|file? ?-compress no? ?<path>? <string>
487#
488# Clients use this to set the value of a node.  If the path is not
489# specified, it sets the value for the root node.  Otherwise, it sets
490# the value for the element specified by the path.  If the value is a
491# string, then it is treated as the text within the tag at the tail
492# of the path.  If it is a DOM node or a library, then it is inserted
493# into the tree at the specified path.
494#
495# If the optional id is specified, then it sets the identifier for
496# the tag at the tail of the path.  If the optional append flag is
497# specified, then the value is appended to the current value.
498# Otherwise, the value replaces the current value.
499# ----------------------------------------------------------------------
500itcl::body Rappture::LibraryObj::put {args} {
501    array set params {
502        -id ""
503        -append no
504        -type string
505        -compress no
506    }
507    while {[llength $args] > 1} {
508        set first [lindex $args 0]
509        if {[string index $first 0] == "-"} {
510            set choices [array names params]
511            if {[lsearch $choices $first] < 0} {
512                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
513            }
514            set params($first) [lindex $args 1]
515            set args [lrange $args 2 end]
516        } else {
517            break
518        }
519    }
520    if {[llength $args] > 2} {
521        error "wrong # args: should be \"put ?-append bval? ?-id num? ?-type string|file? ?-compress bval? ?path? string\""
522    }
523    if {[llength $args] == 2} {
524        set path [lindex $args 0]
525        set str [lindex $args 1]
526    } else {
527        set path ""
528        set str [lindex $args 0]
529    }
530
531    if {$params(-type) == "file"} {
532        set fileName $str
533        set fid [open $fileName r]
534        fconfigure $fid -translation binary -encoding binary
535        set str [read $fid]
536        close $fid
537    }
538
539    if {$params(-compress) || [Rappture::encoding::is binary $str]} {
540        set str [Rappture::encoding::encode $str]
541    }
542
543    set node [find -create $path]
544
545    #
546    # Clean up any nodes that don't belong.  If we're appending
547    # the value, then clean up only child <tag> nodes.  Otherwise,
548    # clean up all nodes.
549    #
550    set nlist ""
551    if {$params(-append)} {
552        foreach n [$node childNodes] {
553            if {[$n nodeType] != "TEXT_NODE"} {
554                lappend nlist $n
555            }
556        }
557    } else {
558        set nlist [$node childNodes]
559    }
560    foreach n $nlist {
561        $n delete
562    }
563
564    if {[Rappture::library isvalid $str]} {
565        foreach n [[$str info variable _node -value] childNodes] {
566            $node appendXML [$n asXML]
567        }
568    } else {
569        set n [$_document createText $str]
570        $node appendChild $n
571        if {"" != $params(-id)} {
572            $node setAttribute id $params(-id)
573        }
574    }
575    return ""
576}
577
578# ----------------------------------------------------------------------
579# USAGE: copy <path> from ?<xmlobj>? <path>
580#
581# Clients use this to copy the value from one xmlobj/path to another.
582# If the <xmlobj> is not specified, it is assumed to be the same as
583# the current object.
584# ----------------------------------------------------------------------
585itcl::body Rappture::LibraryObj::copy {path from args} {
586    if {[llength $args] == 1} {
587        set xmlobj $this
588        set fpath [lindex $args 0]
589    } elseif {[llength $args] == 2} {
590        set xmlobj [lindex $args 0]
591        set fpath [lindex $args 1]
592    } else {
593        error "wrong # args: should be \"copy path from ?xmlobj? path\""
594    }
595    if {$from != "from"} {
596        error "bad syntax: should be \"copy path from ?xmlobj? path\""
597    }
598
599    if {[llength [$xmlobj children $fpath]] == 0} {
600        set val [$xmlobj get $fpath]
601        put $path $val
602    } else {
603        set obj [$xmlobj element -as object $fpath]
604        put $path $obj
605        itcl::delete object $obj
606    }
607}
608
609# ----------------------------------------------------------------------
610# USAGE: remove ?<path>?
611#
612# Clients use this to remove the specified node.  Removes the node
613# from the tree.
614# ----------------------------------------------------------------------
615itcl::body Rappture::LibraryObj::remove {{path ""}} {
616    set node [find $path]
617    if {$node != ""} {
618        $node delete
619    }
620}
621
622# ----------------------------------------------------------------------
623# USAGE: xml
624#
625# Returns a string representing the XML information for the information
626# in this library.
627# ----------------------------------------------------------------------
628itcl::body Rappture::LibraryObj::xml {} {
629    return [$_node asXML]
630}
631
632# ----------------------------------------------------------------------
633# USAGE: diff <libobj>
634#
635# Compares the entities in this object to those in another and
636# returns a list of differences.  The result is a list of the form:
637# {op1 path1 oldval1 newval1 ...} where each "op" is +/-/c for
638# added/subtracted/changed, "path" is the path within the library
639# that is different, and "oldval"/"newval" give the values for the
640# object at the path.
641# ----------------------------------------------------------------------
642itcl::body Rappture::LibraryObj::diff {libobj} {
643    set rlist ""
644
645    # query the values for all entities in both objects
646    set thisv [Rappture::entities $this input]
647    set otherv [Rappture::entities $libobj input]
648
649    # scan through values for this object, and compare against other one
650    foreach path $thisv {
651        set i [lsearch -exact $otherv $path]
652        if {$i < 0} {
653            foreach {raw norm} [value $this $path] break
654            lappend rlist - $path $raw ""
655        } else {
656            foreach {traw tnorm} [value $this $path] break
657            foreach {oraw onorm} [value $libobj $path] break
658            if {![string equal $tnorm $onorm]} {
659                lappend rlist c $path $traw $oraw
660            }
661            set otherv [lreplace $otherv $i $i]
662        }
663    }
664
665    # add any values left over in the other object
666    foreach path $otherv {
667        foreach {oraw onorm} [value $libobj $path] break
668        lappend rlist + $path "" $oraw
669    }
670    return $rlist
671}
672
673# ----------------------------------------------------------------------
674# USAGE: value <object> <path>
675#
676# Used to query the "value" associated with the <path> in an XML
677# <object>.  This is a little more complicated than the object's
678# "get" method.  It handles things like structures and values
679# with normalized units.
680#
681# Returns a list of two items:  {raw norm} where "raw" is the raw
682# value from the "get" method and "norm" is the normalized value
683# produced by this routine.  Example:  {300K 300}
684#
685# Right now, it is a handy little utility used by the "diff" method.
686# Eventually, it should be moved to a better object-oriented
687# implementation, where each Rappture type could overload the
688# various bits of processing below.  So we leave it as a "proc"
689# now instead of a method, since it should be deprecated soon.
690# ----------------------------------------------------------------------
691itcl::body Rappture::LibraryObj::value {libobj path} {
692    switch -- [$libobj element -as type $path] {
693        structure {
694            set raw $path
695            # try to find a label to represent the structure
696            set val [$libobj get $path.about.label]
697            if {"" == $val} {
698                set val [$libobj get $path.current.about.label]
699            }
700            if {"" == $val} {
701                if {[$libobj element $path.current] != ""} {
702                    set comps [$libobj children $path.current.components]
703                    set val "<structure> with [llength $comps] components"
704                } else {
705                    set val "<structure>"
706                }
707            }
708            return [list $raw $val]
709        }
710        number {
711            # get the usual value...
712            set raw ""
713            set val ""
714            if {"" != [$libobj element $path.current]} {
715                set raw [$libobj get $path.current]
716            } elseif {"" != [$libobj element $path.default]} {
717                set raw [$libobj get $path.default]
718            }
719            if {"" != $raw} {
720                set val $raw
721                # then normalize to default units
722                set units [$libobj get $path.units]
723                if {"" != $units} {
724                    set val [Rappture::Units::convert $val \
725                        -context $units -to $units -units off]
726                }
727            }
728            return [list $raw $val]
729        }
730    }
731
732    # for all other types, get the value (current, or maybe default)
733    set raw ""
734    if {"" != [$libobj element $path.current]} {
735        set raw [$libobj get $path.current]
736    } elseif {"" != [$libobj element $path.default]} {
737        set raw [$libobj get $path.default]
738    }
739    return [list $raw $raw]
740}
741
742# ----------------------------------------------------------------------
743# USAGE: find ?-create? <path>
744#
745# Used internally to find a particular element within the root node
746# according to the path, which is a string of the form
747# "typeNN(id).typeNN(id). ...", where each "type" is a tag <type>;
748# if the optional NN is specified, it indicates an index for the
749# <type> tag within its parent; if the optional (id) part is included,
750# it indicates a tag of the form <type id="id">.
751#
752# By default, it looks for an element along the path and returns None
753# if not found.  If the create flag is set, it creates various elements
754# along the path as it goes.  This is useful for "put" operations.
755#
756# If you include "#" instead of a specific number, a node will be
757# created automatically with a new number.  For example, the path
758# "foo.bar#" called the first time will create "foo.bar", the second
759# time "foo.bar1", the third time "foo.bar2" and so forth.
760#
761# Returns an object representing the element indicated by the path,
762# or "" if the path is not found.
763# ----------------------------------------------------------------------
764itcl::body Rappture::LibraryObj::find {args} {
765    set create 0
766    while {[llength $args] > 1} {
767        set first [lindex $args 0]
768        set args [lrange $args 1 end]
769        if {$first == "-create"} {
770            set create 1
771        } else {
772            error "bad option \"$first\": should be -create"
773        }
774    }
775    if {[llength $args] != 1} {
776        error "wrong # args: should be \"find ?-create? path\""
777    }
778    set path [lindex $args 0]
779
780    if {$path == ""} {
781        return $_node
782    }
783    set path [path2list $path]
784
785    #
786    # Follow the given path and look for all of the parts.
787    #
788    set lastnode $_node
789    set node $lastnode
790    foreach part $path {
791        if {![regexp {^(([a-zA-Z_]+#?)([0-9]*))?(\((.*)\))?$} $part \
792               match dummy type index dummy name]} {
793            error "bad path component \"$part\""
794        }
795        #
796        # If the name is like "type2", then look for elements with
797        # the type name and return the one with the given index.
798        # If the name is like "type", then assume the index is 0.
799        #
800        if {$name == ""} {
801            if {$index == ""} {
802                set index 0
803            }
804            set nlist [childnodes $node $type]
805            set node [lindex $nlist $index]
806        } else {
807            #
808            # If the name is like "type(id)", then look for elements
809            # that match the type and see if one has the requested name.
810            # if the name is like "(id)", then look for any elements
811            # with the requested name.
812            #
813            if {$type != ""} {
814                set nlist [childnodes $node $type]
815            } else {
816                set nlist [$node childNodes]
817            }
818            set found 0
819            foreach n $nlist {
820                if {[catch {$n getAttribute id} tag]} { set tag "" }
821                if {$tag == $name} {
822                    set found 1
823                    break
824                }
825            }
826            set node [expr {($found) ? $n : ""}]
827        }
828
829        if {$node == ""} {
830            if {!$create} {
831                return ""
832            }
833
834            #
835            # If the "create" flag is set, then create a node
836            # with the specified "type(id)" and continue on.
837            # If the type is "type#", then create a node with
838            # an automatic number.
839            #
840            if {![regexp {^([^\(]+)\(([^\)]+)\)$} $part match type name]} {
841                set type $part
842                set name ""
843            }
844
845            if {[string match *# $type]} {
846                set type [string trimright $type #]
847                set node [$_document createElement $type]
848
849                # find the last node of same type and append there
850                set pos ""
851                foreach n [$lastnode childNodes] {
852                    if {[$n nodeName] == $type} {
853                        set pos $n
854                    }
855                }
856                if {$pos != ""} {
857                    set pos [$pos nextSibling]
858                }
859                if {$pos != ""} {
860                    $lastnode insertBefore $node $pos
861                } else {
862                    $lastnode appendChild $node
863                }
864            } else {
865                set node [$_document createElement $type]
866                $lastnode appendChild $node
867            }
868            if {"" != $name} {
869                $node setAttribute id $name
870            }
871        }
872        set lastnode $node
873    }
874    return $node
875}
876
877# ----------------------------------------------------------------------
878# USAGE: path2list <path>
879#
880# Converts a path of the form "foo(a).bar.baz" into a list of the
881# form "foo(a) bar baz".  This is a little more complicated than
882# splitting on the .'s, since the stuff in ()'s might have embedded
883# .'s.  Returns a proper Tcl list for all elements of the path.
884# ----------------------------------------------------------------------
885itcl::body Rappture::LibraryObj::path2list {path} {
886    #
887    # Normally, we just split on .'s within the path.  But there
888    # might be some .'s embedded within ()'s in the path.  Change
889    # any embedded .'s to an out-of-band character, then split on
890    # the .'s, and change the embedded .'s back.
891    #
892    if {[regexp {(\([^\)]*)\.([^\)]*\))} $path]} {
893        while {[regsub -all {(\([^\)]*)\.([^\)]*\))} $path "\\1\007\\2" path]} {
894            # keep fixing...
895        }
896    }
897    set path [split $path .]
898    regsub -all {\007} $path {.} path
899
900    return $path
901}
902
903# ----------------------------------------------------------------------
904# USAGE: node2name <node>
905#
906# Used internally to create a name for the specified node.  If the
907# node doesn't have a specific name ("id" attribute) then a name of
908# the form "type123" is constructed.
909# ----------------------------------------------------------------------
910itcl::body Rappture::LibraryObj::node2name {node} {
911    if {[catch {$node getAttribute id} name]} { set name "" }
912    if {$name == ""} {
913        set pnode [$node parentNode]
914        if {$pnode == ""} {
915            return ""
916        }
917        set type [$node nodeName]
918        set siblings [childnodes $pnode $type]
919        set index [lsearch $siblings $node]
920        if {$index == 0} {
921            set name $type
922        } else {
923            set name "$type$index"
924        }
925    }
926    return $name
927}
928
929# ----------------------------------------------------------------------
930# USAGE: node2comp <node>
931#
932# Used internally to create a path component name for the specified
933# node.  A path component name has the form "type(id)" or just
934# "type##" if the node doesn't have a name.  This name can be used
935# in a path to uniquely address the component.
936# ----------------------------------------------------------------------
937itcl::body Rappture::LibraryObj::node2comp {node} {
938    set type [$node nodeName]
939    if {[catch {$node getAttribute id} name]} { set name "" }
940    if {$name == ""} {
941        set pnode [$node parentNode]
942        if {$pnode == ""} {
943            return ""
944        }
945        set siblings [childnodes $pnode $type]
946        set index [lsearch $siblings $node]
947        if {$index == 0} {
948            set name $type
949        } else {
950            set name "$type$index"
951        }
952    } else {
953        set name "${type}($name)"
954    }
955    return $name
956}
957
958# ----------------------------------------------------------------------
959# USAGE: node2path <node>
960#
961# Used internally to create a full path name for the specified node.
962# The path is relative to the current object, so it stops when the
963# parent is the root node for this object.
964# ----------------------------------------------------------------------
965itcl::body Rappture::LibraryObj::node2path {node} {
966    set path [node2comp $node]
967    set node [$node parentNode]
968    while {$node != "" && $node != $_node} {
969        set path "[node2comp $node].$path"
970        set node [$node parentNode]
971    }
972    return $path
973}
974
975# ----------------------------------------------------------------------
976# USAGE: childnodes <node> <type>
977#
978# Used internally to return a list of children for the given <node>
979# that match a specified <type>.  Similar to XML getElementsByTagName,
980# but returns only direct children of the <node>.
981# ----------------------------------------------------------------------
982itcl::body Rappture::LibraryObj::childnodes {node type} {
983    set rlist ""
984    foreach cnode [$node childNodes] {
985        if {[$cnode nodeName] == $type} {
986            lappend rlist $cnode
987        }
988    }
989    return $rlist
990}
Note: See TracBrowser for help on using the repository browser.