source: trunk/lang/tcl/scripts/library.tcl @ 4668

Last change on this file since 4668 was 4181, checked in by gah, 10 years ago

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