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

Last change on this file since 752 was 752, checked in by dkearney, 14 years ago

added use of RPENC_HDR flag in decode function so users can give the RPENC_Z and RPENC_B64 flags and tell the decode function to only use those flags
if the header does not say how to treat the data.

in library.tcl, added a -decode flag set to yes by default. this flag allows the user to tell if they want the data to be automatically decoded when
it is retrieved from the xmlobj. this is paricaularly useful for dx data held within a field where we do not want the data automatcially decoded.

added the -decode no flag to dx data being retrieved from fields

updated nanovis.cpp with capability to decode data with the new @@RP-ENC: style headers.

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            if {"" != [$libobj element $path.current]} {
714                set raw [$libobj get $path.current]
715            } elseif {"" != [$libobj element $path.default]} {
716                set raw [$libobj get $path.default]
717            }
718            if {"" != $raw} {
719                set val $raw
720                # then normalize to default units
721                set units [$libobj get $path.units]
722                if {"" != $units} {
723                    set val [Rappture::Units::convert $val \
724                        -context $units -to $units -units off]
725                }
726            }
727            return [list $raw $val]
728        }
729    }
730
731    # for all other types, get the value (current, or maybe default)
732    set raw ""
733    if {"" != [$libobj element $path.current]} {
734        set raw [$libobj get $path.current]
735    } elseif {"" != [$libobj element $path.default]} {
736        set raw [$libobj get $path.default]
737    }
738    return [list $raw $raw]
739}
740
741# ----------------------------------------------------------------------
742# USAGE: find ?-create? <path>
743#
744# Used internally to find a particular element within the root node
745# according to the path, which is a string of the form
746# "typeNN(id).typeNN(id). ...", where each "type" is a tag <type>;
747# if the optional NN is specified, it indicates an index for the
748# <type> tag within its parent; if the optional (id) part is included,
749# it indicates a tag of the form <type id="id">.
750#
751# By default, it looks for an element along the path and returns None
752# if not found.  If the create flag is set, it creates various elements
753# along the path as it goes.  This is useful for "put" operations.
754#
755# If you include "#" instead of a specific number, a node will be
756# created automatically with a new number.  For example, the path
757# "foo.bar#" called the first time will create "foo.bar", the second
758# time "foo.bar1", the third time "foo.bar2" and so forth.
759#
760# Returns an object representing the element indicated by the path,
761# or "" if the path is not found.
762# ----------------------------------------------------------------------
763itcl::body Rappture::LibraryObj::find {args} {
764    set create 0
765    while {[llength $args] > 1} {
766        set first [lindex $args 0]
767        set args [lrange $args 1 end]
768        if {$first == "-create"} {
769            set create 1
770        } else {
771            error "bad option \"$first\": should be -create"
772        }
773    }
774    if {[llength $args] != 1} {
775        error "wrong # args: should be \"find ?-create? path\""
776    }
777    set path [lindex $args 0]
778
779    if {$path == ""} {
780        return $_node
781    }
782    set path [path2list $path]
783
784    #
785    # Follow the given path and look for all of the parts.
786    #
787    set lastnode $_node
788    set node $lastnode
789    foreach part $path {
790        if {![regexp {^(([a-zA-Z_]+#?)([0-9]*))?(\((.*)\))?$} $part \
791               match dummy type index dummy name]} {
792            error "bad path component \"$part\""
793        }
794        #
795        # If the name is like "type2", then look for elements with
796        # the type name and return the one with the given index.
797        # If the name is like "type", then assume the index is 0.
798        #
799        if {$name == ""} {
800            if {$index == ""} {
801                set index 0
802            }
803            set nlist [childnodes $node $type]
804            set node [lindex $nlist $index]
805        } else {
806            #
807            # If the name is like "type(id)", then look for elements
808            # that match the type and see if one has the requested name.
809            # if the name is like "(id)", then look for any elements
810            # with the requested name.
811            #
812            if {$type != ""} {
813                set nlist [childnodes $node $type]
814            } else {
815                set nlist [$node childNodes]
816            }
817            set found 0
818            foreach n $nlist {
819                if {[catch {$n getAttribute id} tag]} { set tag "" }
820                if {$tag == $name} {
821                    set found 1
822                    break
823                }
824            }
825            set node [expr {($found) ? $n : ""}]
826        }
827
828        if {$node == ""} {
829            if {!$create} {
830                return ""
831            }
832
833            #
834            # If the "create" flag is set, then create a node
835            # with the specified "type(id)" and continue on.
836            # If the type is "type#", then create a node with
837            # an automatic number.
838            #
839            if {![regexp {^([^\(]+)\(([^\)]+)\)$} $part match type name]} {
840                set type $part
841                set name ""
842            }
843
844            if {[string match *# $type]} {
845                set type [string trimright $type #]
846                set node [$_document createElement $type]
847
848                # find the last node of same type and append there
849                set pos ""
850                foreach n [$lastnode childNodes] {
851                    if {[$n nodeName] == $type} {
852                        set pos $n
853                    }
854                }
855                if {$pos != ""} {
856                    set pos [$pos nextSibling]
857                }
858                if {$pos != ""} {
859                    $lastnode insertBefore $node $pos
860                } else {
861                    $lastnode appendChild $node
862                }
863            } else {
864                set node [$_document createElement $type]
865                $lastnode appendChild $node
866            }
867            if {"" != $name} {
868                $node setAttribute id $name
869            }
870        }
871        set lastnode $node
872    }
873    return $node
874}
875
876# ----------------------------------------------------------------------
877# USAGE: path2list <path>
878#
879# Converts a path of the form "foo(a).bar.baz" into a list of the
880# form "foo(a) bar baz".  This is a little more complicated than
881# splitting on the .'s, since the stuff in ()'s might have embedded
882# .'s.  Returns a proper Tcl list for all elements of the path.
883# ----------------------------------------------------------------------
884itcl::body Rappture::LibraryObj::path2list {path} {
885    #
886    # Normally, we just split on .'s within the path.  But there
887    # might be some .'s embedded within ()'s in the path.  Change
888    # any embedded .'s to an out-of-band character, then split on
889    # the .'s, and change the embedded .'s back.
890    #
891    if {[regexp {(\([^\)]*)\.([^\)]*\))} $path]} {
892        while {[regsub -all {(\([^\)]*)\.([^\)]*\))} $path "\\1\007\\2" path]} {
893            # keep fixing...
894        }
895    }
896    set path [split $path .]
897    regsub -all {\007} $path {.} path
898
899    return $path
900}
901
902# ----------------------------------------------------------------------
903# USAGE: node2name <node>
904#
905# Used internally to create a name for the specified node.  If the
906# node doesn't have a specific name ("id" attribute) then a name of
907# the form "type123" is constructed.
908# ----------------------------------------------------------------------
909itcl::body Rappture::LibraryObj::node2name {node} {
910    if {[catch {$node getAttribute id} name]} { set name "" }
911    if {$name == ""} {
912        set pnode [$node parentNode]
913        if {$pnode == ""} {
914            return ""
915        }
916        set type [$node nodeName]
917        set siblings [childnodes $pnode $type]
918        set index [lsearch $siblings $node]
919        if {$index == 0} {
920            set name $type
921        } else {
922            set name "$type$index"
923        }
924    }
925    return $name
926}
927
928# ----------------------------------------------------------------------
929# USAGE: node2comp <node>
930#
931# Used internally to create a path component name for the specified
932# node.  A path component name has the form "type(id)" or just
933# "type##" if the node doesn't have a name.  This name can be used
934# in a path to uniquely address the component.
935# ----------------------------------------------------------------------
936itcl::body Rappture::LibraryObj::node2comp {node} {
937    set type [$node nodeName]
938    if {[catch {$node getAttribute id} name]} { set name "" }
939    if {$name == ""} {
940        set pnode [$node parentNode]
941        if {$pnode == ""} {
942            return ""
943        }
944        set siblings [childnodes $pnode $type]
945        set index [lsearch $siblings $node]
946        if {$index == 0} {
947            set name $type
948        } else {
949            set name "$type$index"
950        }
951    } else {
952        set name "${type}($name)"
953    }
954    return $name
955}
956
957# ----------------------------------------------------------------------
958# USAGE: node2path <node>
959#
960# Used internally to create a full path name for the specified node.
961# The path is relative to the current object, so it stops when the
962# parent is the root node for this object.
963# ----------------------------------------------------------------------
964itcl::body Rappture::LibraryObj::node2path {node} {
965    set path [node2comp $node]
966    set node [$node parentNode]
967    while {$node != "" && $node != $_node} {
968        set path "[node2comp $node].$path"
969        set node [$node parentNode]
970    }
971    return $path
972}
973
974# ----------------------------------------------------------------------
975# USAGE: childnodes <node> <type>
976#
977# Used internally to return a list of children for the given <node>
978# that match a specified <type>.  Similar to XML getElementsByTagName,
979# but returns only direct children of the <node>.
980# ----------------------------------------------------------------------
981itcl::body Rappture::LibraryObj::childnodes {node type} {
982    set rlist ""
983    foreach cnode [$node childNodes] {
984        if {[$cnode nodeName] == $type} {
985            lappend rlist $cnode
986        }
987    }
988    return $rlist
989}
Note: See TracBrowser for help on using the repository browser.