source: branches/1.7/lang/tcl/scripts/library.tcl @ 6283

Last change on this file since 6283 was 6283, checked in by gah, 8 years ago

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