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

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

Added support for experimental <drawing> object.

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