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

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