source: branches/uq/lang/tcl/scripts/library.tcl @ 5169

Last change on this file since 5169 was 5169, checked in by mmh, 9 years ago

fix multiple simulations

File size: 36.0 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        set fid [::open $fname r]
73        set info [read $fid]
74        close $fid
75
76        set stdlib [Rappture::LibraryObj ::#auto $info]
77        return $stdlib
78    }
79
80    if {[regexp {^<\?[Xx][Mm][Ll]} $fname]} {
81        set info $fname
82    } else {
83        # otherwise, try to open the file and create its LibraryObj
84        set fid [::open $fname r]
85        set info [read $fid]
86        close $fid
87    }
88
89    set obj [Rappture::LibraryObj ::#auto $info]
90    return $obj
91}
92
93# ----------------------------------------------------------------------
94# USAGE: entities ?-as <fval>? <object> <path>
95#
96# Used to sift through an XML <object> for "entities" within the
97# Rappture description.  Entities are things like strings, numbers,
98# etc., which show up in the GUI as controls.
99#
100# Returns a list of all entities found beneath <path>.
101#
102# By default, this method returns the component name "type(id)".
103# This is changed by setting the -as argument to "id" (for name
104# of the tail element), to "type" (for the type of the tail element),
105# to "object" (for an object representing the DOM node referenced by
106# the path.
107# ----------------------------------------------------------------------
108proc Rappture::entities {args} {
109    array set params {
110        -as component
111    }
112    while {[llength $args] > 1} {
113        set first [lindex $args 0]
114        if {[string index $first 0] == "-"} {
115            set choices [array names params]
116            if {[lsearch $choices $first] < 0} {
117                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
118            }
119            set params($first) [lindex $args 1]
120            set args [lrange $args 2 end]
121        } else {
122            break
123        }
124    }
125    if {[llength $args] > 2} {
126        error "wrong # args: should be \"entities ?-as fval? obj ?path?\""
127    }
128    set xmlobj [lindex $args 0]
129    set path [lindex $args 1]
130
131    set rlist ""
132    lappend queue $path
133    while {[llength $queue] > 0} {
134        set path [lindex $queue 0]
135        set queue [lrange $queue 1 end]
136
137        foreach cpath [$xmlobj children -as path $path] {
138            set type [$xmlobj element -as type $cpath]
139            switch -- $type {
140                group - phase {
141                    lappend queue $cpath
142                }
143                structure {
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 {[$xmlobj element $cpath.current.parameters] != ""} {
152                        lappend queue $cpath.current.parameters
153                    }
154                }
155                drawing {
156                    # add this to the return list with the right flavor
157                    if {$params(-as) == "component"} {
158                        lappend rlist $cpath
159                    } else {
160                        lappend rlist [$xmlobj element -as $params(-as) $cpath]
161                    }
162
163                    foreach child [$xmlobj children $cpath.current] {
164                        if {[string match about* $child]} {
165                            continue
166                        }
167                        if {[$xmlobj element $cpath.current.$child.parameters] != ""} {
168                            lappend queue $cpath.current.$child.parameters
169                        }
170                    }
171                }
172                loader {
173                    if {$params(-as) == "component"} {
174                        lappend rlist $cpath
175                    } else {
176                        lappend rlist [$xmlobj element -as $params(-as) $cpath]
177                    }
178                }
179                default {
180                    if {[catch {Rappture::objects::get $type}] == 0} {
181                        # add this to the return list with the right flavor
182                        if {$params(-as) == "component"} {
183                            lappend rlist $cpath
184                        } else {
185                            lappend rlist [$xmlobj element -as $params(-as) $cpath]
186                        }
187                    }
188
189                    # if this element has embedded groups, add them to the queue
190                    foreach ccpath [$xmlobj children -as path $cpath] {
191                        set cctype [$xmlobj element -as type $ccpath]
192                        if {$cctype == "group" || $cctype == "phase"} {
193                            lappend queue $ccpath
194                        }
195                    }
196                }
197            }
198        }
199    }
200    return $rlist
201}
202
203# ----------------------------------------------------------------------
204itcl::class Rappture::LibraryObj {
205    constructor {info} { # defined below }
206    destructor { # defined below }
207
208    public method element {args}
209    public method parent {args}
210    public method children {args}
211    public method get {args}
212    public method put {args}
213    public method copy {path from args}
214    public method remove {{path ""}}
215    public method xml {{path ""}}
216    public method uq_get_vars {{tfile ""}}
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
693    puts "Library DIFF $libobj"
694    set rlist ""
695
696    # query the values for all entities in both objects
697    set thisv [Rappture::entities $this input]
698    set otherv [Rappture::entities $libobj input]
699
700    puts "thisv=$thisv\n"
701    puts "otherv=$otherv\n"
702
703    # scan through values for this object, and compare against other one
704    foreach path $thisv {
705      puts "path=$path"
706        set i [lsearch -exact $otherv $path]
707        if {$i < 0} {
708            foreach {raw norm} [value $this $path] break
709            lappend rlist - $path $raw ""
710        } else {
711          puts "tvalue=[value $this $path]"
712          puts "ovalue=[value $libobj $path]"
713            foreach {traw tnorm} [value $this $path] break
714            foreach {oraw onorm} [value $libobj $path] break
715            puts "tnorm=$tnorm onorm=$onorm traw=$traw oraw=$oraw"
716            if {![string equal $tnorm $onorm]} {
717                lappend rlist c $path $traw $oraw
718            }
719            set otherv [lreplace $otherv $i $i]
720        }
721    }
722
723    # add any values left over in the other object
724    foreach path $otherv {
725        foreach {oraw onorm} [value $libobj $path] break
726        lappend rlist + $path "" $oraw
727    }
728    puts "LDIFF returning $rlist"
729    return $rlist
730}
731
732# ----------------------------------------------------------------------
733# USAGE: value <object> <path>
734#
735# Used to query the "value" associated with the <path> in an XML
736# <object>.  This is a little more complicated than the object's
737# "get" method.  It handles things like structures and values
738# with normalized units.
739#
740# Returns a list of two items:  {raw norm} where "raw" is the raw
741# value from the "get" method and "norm" is the normalized value
742# produced by this routine.  Example:  {300K 300}
743#
744# Right now, it is a handy little utility used by the "diff" method.
745# Eventually, it should be moved to a better object-oriented
746# implementation, where each Rappture type could overload the
747# various bits of processing below.  So we leave it as a "proc"
748# now instead of a method, since it should be deprecated soon.
749# ----------------------------------------------------------------------
750itcl::body Rappture::LibraryObj::value {libobj path} {
751  puts "VALUE $path [$libobj element -as type $path]"
752    switch -- [$libobj element -as type $path] {
753        structure {
754            set raw $path
755            # try to find a label to represent the structure
756            set val [$libobj get $path.about.label]
757            if {"" == $val} {
758                set val [$libobj get $path.current.about.label]
759            }
760            if {"" == $val} {
761                if {[$libobj element $path.current] != ""} {
762                    set comps [$libobj children $path.current.components]
763                    set val "<structure> with [llength $comps] components"
764                } else {
765                    set val "<structure>"
766                }
767            }
768            return [list $raw $val]
769        }
770        number {
771            # get the usual value...
772            set raw ""
773            set val ""
774            if {"" != [$libobj element $path.current]} {
775                set raw [$libobj get $path.current]
776            } elseif {"" != [$libobj element $path.default]} {
777                set raw [$libobj get $path.default]
778            }
779            if {"" != $raw} {
780                set val $raw
781                # then normalize to default units
782                set units [$libobj get $path.units]
783                puts "val=$val units=$units"
784                if {"" != $units} {
785                    set val [Rappture::Units::mconvert $val \
786                        -context $units -to $units -units off]
787                }
788            }
789            return [list $raw $val]
790        }
791    }
792
793    # for all other types, get the value (current, or maybe default)
794    set raw ""
795    if {"" != [$libobj element $path.current]} {
796        set raw [$libobj get $path.current]
797    } elseif {"" != [$libobj element $path.default]} {
798        set raw [$libobj get $path.default]
799    }
800    return [list $raw $raw]
801}
802
803# ----------------------------------------------------------------------
804# USAGE: find ?-create? <path>
805#
806# Used internally to find a particular element within the root node
807# according to the path, which is a string of the form
808# "typeNN(id).typeNN(id). ...", where each "type" is a tag <type>;
809# if the optional NN is specified, it indicates an index for the
810# <type> tag within its parent; if the optional (id) part is included,
811# it indicates a tag of the form <type id="id">.
812#
813# By default, it looks for an element along the path and returns None
814# if not found.  If the create flag is set, it creates various elements
815# along the path as it goes.  This is useful for "put" operations.
816#
817# If you include "#" instead of a specific number, a node will be
818# created automatically with a new number.  For example, the path
819# "foo.bar#" called the first time will create "foo.bar", the second
820# time "foo.bar1", the third time "foo.bar2" and so forth.
821#
822# Returns an object representing the element indicated by the path,
823# or "" if the path is not found.
824# ----------------------------------------------------------------------
825itcl::body Rappture::LibraryObj::find {args} {
826    set create 0
827    while {[llength $args] > 1} {
828        set first [lindex $args 0]
829        set args [lrange $args 1 end]
830        if {$first == "-create"} {
831            set create 1
832        } else {
833            error "bad option \"$first\": should be -create"
834        }
835    }
836    if {[llength $args] != 1} {
837        error "wrong # args: should be \"find ?-create? path\""
838    }
839    set path [lindex $args 0]
840
841    if {$path == ""} {
842        return $_node
843    }
844    set path [path2list $path]
845
846    #
847    # Follow the given path and look for all of the parts.
848    #
849    set lastnode $_node
850    set node $lastnode
851    foreach part $path {
852        if {![regexp {^(([a-zA-Z0-9_]*[a-zA-Z_]+#?)([0-9]*))?(\((.*)\))?$} $part \
853               match dummy type index dummy name]} {
854            error "bad path component \"$part\""
855        }
856        #
857        # If the name is like "type2", then look for elements with
858        # the type name and return the one with the given index.
859        # If the name is like "type", then assume the index is 0.
860        #
861        if {$name == ""} {
862            if {$index == ""} {
863                set index 0
864            }
865            set nlist [childnodes $node $type]
866            set node [lindex $nlist $index]
867        } else {
868            #
869            # If the name is like "type(id)", then look for elements
870            # that match the type and see if one has the requested name.
871            # if the name is like "(id)", then look for any elements
872            # with the requested name.
873            #
874            if {$type != ""} {
875                set nlist [childnodes $node $type]
876            } else {
877                set nlist [$node childNodes]
878            }
879            set found 0
880            foreach n $nlist {
881                if {[catch {$n getAttribute id} tag]} { set tag "" }
882                if {$tag == $name} {
883                    set found 1
884                    break
885                }
886            }
887            set node [expr {($found) ? $n : ""}]
888        }
889
890        if {$node == ""} {
891            if {!$create} {
892                return ""
893            }
894
895            #
896            # If the "create" flag is set, then create a node
897            # with the specified "type(id)" and continue on.
898            # If the type is "type#", then create a node with
899            # an automatic number.
900            #
901            if {![regexp {^([^\(]+)\(([^\)]+)\)$} $part match type name]} {
902                set type $part
903                set name ""
904            }
905
906            if {[string match *# $type]} {
907                set type [string trimright $type #]
908                set node [$_document createElement $type]
909
910                # find the last node of same type and append there
911                set pos ""
912                foreach n [$lastnode childNodes] {
913                    if {[$n nodeName] == $type} {
914                        set pos $n
915                    }
916                }
917                if {$pos != ""} {
918                    set pos [$pos nextSibling]
919                }
920                if {$pos != ""} {
921                    $lastnode insertBefore $node $pos
922                } else {
923                    $lastnode appendChild $node
924                }
925            } else {
926                set node [$_document createElement $type]
927                $lastnode appendChild $node
928            }
929            if {"" != $name} {
930                $node setAttribute id $name
931            }
932        }
933        set lastnode $node
934    }
935    return $node
936}
937
938# ----------------------------------------------------------------------
939# USAGE: path2list <path>
940#
941# Converts a path of the form "foo(a).bar.baz" into a list of the
942# form "foo(a) bar baz".  This is a little more complicated than
943# splitting on the .'s, since the stuff in ()'s might have embedded
944# .'s.  Returns a proper Tcl list for all elements of the path.
945# ----------------------------------------------------------------------
946itcl::body Rappture::LibraryObj::path2list {path} {
947    #
948    # Normally, we just split on .'s within the path.  But there
949    # might be some .'s embedded within ()'s in the path.  Change
950    # any embedded .'s to an out-of-band character, then split on
951    # the .'s, and change the embedded .'s back.
952    #
953    if {[regexp {(\([^\)]*)\.([^\)]*\))} $path]} {
954        while {[regsub -all {(\([^\)]*)\.([^\)]*\))} $path "\\1\007\\2" path]} {
955            # keep fixing...
956        }
957    }
958    set path [split $path .]
959    regsub -all {\007} $path {.} path
960
961    return $path
962}
963
964# ----------------------------------------------------------------------
965# USAGE: node2name <node>
966#
967# Used internally to create a name for the specified node.  If the
968# node doesn't have a specific name ("id" attribute) then a name of
969# the form "type123" is constructed.
970# ----------------------------------------------------------------------
971itcl::body Rappture::LibraryObj::node2name {node} {
972    if {[catch {$node getAttribute id} name]} { set name "" }
973    if {$name == ""} {
974        set pnode [$node parentNode]
975        if {$pnode == ""} {
976            return ""
977        }
978        set type [$node nodeName]
979        set siblings [childnodes $pnode $type]
980        set index [lsearch $siblings $node]
981        if {$index == 0} {
982            set name $type
983        } else {
984            set name "$type$index"
985        }
986    }
987    return $name
988}
989
990# ----------------------------------------------------------------------
991# USAGE: node2comp <node>
992#
993# Used internally to create a path component name for the specified
994# node.  A path component name has the form "type(id)" or just
995# "type##" if the node doesn't have a name.  This name can be used
996# in a path to uniquely address the component.
997# ----------------------------------------------------------------------
998itcl::body Rappture::LibraryObj::node2comp {node} {
999    set type [$node nodeName]
1000    if {[catch {$node getAttribute id} name]} { set name "" }
1001    if {$name == ""} {
1002        set pnode [$node parentNode]
1003        if {$pnode == ""} {
1004            return ""
1005        }
1006        set siblings [childnodes $pnode $type]
1007        set index [lsearch $siblings $node]
1008        if {$index == 0} {
1009            set name $type
1010        } else {
1011            set name "$type$index"
1012        }
1013    } else {
1014        set name "${type}($name)"
1015    }
1016    return $name
1017}
1018
1019# ----------------------------------------------------------------------
1020# USAGE: node2path <node>
1021#
1022# Used internally to create a full path name for the specified node.
1023# The path is relative to the current object, so it stops when the
1024# parent is the root node for this object.
1025# ----------------------------------------------------------------------
1026itcl::body Rappture::LibraryObj::node2path {node} {
1027    set path [node2comp $node]
1028    set node [$node parentNode]
1029    while {$node != "" && $node != $_node} {
1030        set path "[node2comp $node].$path"
1031        set node [$node parentNode]
1032    }
1033    return $path
1034}
1035
1036# ----------------------------------------------------------------------
1037# USAGE: childnodes <node> <type>
1038#
1039# Used internally to return a list of children for the given <node>
1040# that match a specified <type>.  Similar to XML getElementsByTagName,
1041# but returns only direct children of the <node>.
1042# ----------------------------------------------------------------------
1043itcl::body Rappture::LibraryObj::childnodes {node type} {
1044    set rlist ""
1045    foreach cnode [$node childNodes] {
1046        if {[$cnode nodeName] == $type} {
1047            lappend rlist $cnode
1048        }
1049    }
1050    return $rlist
1051}
1052
1053itcl::body Rappture::LibraryObj::uq_get_vars {{tfile ""}} {
1054    set varlist ""
1055
1056    if {$tfile == ""} {
1057        set node $_node
1058    } else {
1059        set fid [::open $tfile r]
1060        set doc [dom parse [read $fid]]
1061        set node [$doc documentElement]
1062        close $fid
1063    }
1064
1065    set n [$node selectNodes /run/input//number]
1066    foreach _n $n {
1067        set x [$_n selectNodes current/text()]
1068        set val [$x nodeValue]
1069        if {[string equal -length 8 $val "uniform "] ||
1070            [string equal -length 9 $val "gaussian "]} {
1071            set unode [$_n selectNodes units/text()]
1072            if {"" != $unode} {
1073                set units [$unode nodeValue]
1074                set val [Rappture::Units::mconvert $val \
1075                -context $units -to $units -units off]
1076            }
1077            if {$tfile != ""} {
1078              $x nodeValue @@[$_n getAttribute id]
1079            }
1080            lappend varlist [list [$_n getAttribute id] $val]
1081        }
1082    }
1083
1084    if {$tfile != ""} {
1085        set fid [open $tfile w]
1086        puts $fid "<?xml version=\"1.0\"?>"
1087        puts $fid [$node asXML]
1088        close $fid
1089        $doc delete
1090    }
1091    return $varlist
1092}
Note: See TracBrowser for help on using the repository browser.