source: branches/1.4/lang/tcl/scripts/library.tcl @ 5891

Last change on this file since 5891 was 5891, checked in by gah, 9 years ago

surround file opens with catches
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            puts stderr "can't open \"$fname\": errs=$errs errorInfo=$errorInfo"
78        }
79        set stdlib [Rappture::LibraryObj ::#auto $info]
80        return $stdlib
81    }
82
83    if {[regexp {^<\?[Xx][Mm][Ll]} $fname]} {
84        set info $fname
85    } else {
86        # otherwise, try to open the file and create its LibraryObj
87        if { [catch {
88            set fid [::open $fname r]
89            set info [read $fid]
90            close $fid
91        } errs] != 0 } {
92            puts stderr "can't open \"$fname\": errs=$errs errorInfo=$errorInfo"
93        }
94    }
95
96    set obj [Rappture::LibraryObj ::#auto $info]
97    return $obj
98}
99
100# ----------------------------------------------------------------------
101# USAGE: entities ?-as <fval>? <object> <path>
102#
103# Used to sift through an XML <object> for "entities" within the
104# Rappture description.  Entities are things like strings, numbers,
105# etc., which show up in the GUI as controls.
106#
107# Returns a list of all entities found beneath <path>.
108#
109# By default, this method returns the component name "type(id)".
110# This is changed by setting the -as argument to "id" (for name
111# of the tail element), to "type" (for the type of the tail element),
112# to "object" (for an object representing the DOM node referenced by
113# the path.
114# ----------------------------------------------------------------------
115proc Rappture::entities {args} {
116    array set params {
117        -as component
118    }
119    while {[llength $args] > 1} {
120        set first [lindex $args 0]
121        if {[string index $first 0] == "-"} {
122            set choices [array names params]
123            if {[lsearch $choices $first] < 0} {
124                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
125            }
126            set params($first) [lindex $args 1]
127            set args [lrange $args 2 end]
128        } else {
129            break
130        }
131    }
132    if {[llength $args] > 2} {
133        error "wrong # args: should be \"entities ?-as fval? obj ?path?\""
134    }
135    set xmlobj [lindex $args 0]
136    set path [lindex $args 1]
137
138    set rlist ""
139    lappend queue $path
140    while {[llength $queue] > 0} {
141        set path [lindex $queue 0]
142        set queue [lrange $queue 1 end]
143
144        foreach cpath [$xmlobj children -as path $path] {
145            set type [$xmlobj element -as type $cpath]
146            switch -- $type {
147                group - phase {
148                    lappend queue $cpath
149                }
150                structure {
151                    # add this to the return list with the right flavor
152                    if {$params(-as) == "component"} {
153                        lappend rlist $cpath
154                    } else {
155                        lappend rlist [$xmlobj element -as $params(-as) $cpath]
156                    }
157
158                    if {[$xmlobj element $cpath.current.parameters] != ""} {
159                        lappend queue $cpath.current.parameters
160                    }
161                }
162                drawing {
163                    # add this to the return list with the right flavor
164                    if {$params(-as) == "component"} {
165                        lappend rlist $cpath
166                    } else {
167                        lappend rlist [$xmlobj element -as $params(-as) $cpath]
168                    }
169
170                    foreach child [$xmlobj children $cpath.current] {
171                        if {[string match about* $child]} {
172                            continue
173                        }
174                        if {[$xmlobj element $cpath.current.$child.parameters] != ""} {
175                            lappend queue $cpath.current.$child.parameters
176                        }
177                    }
178                }
179                loader {
180                    if {$params(-as) == "component"} {
181                        lappend rlist $cpath
182                    } else {
183                        lappend rlist [$xmlobj element -as $params(-as) $cpath]
184                    }
185                }
186                default {
187                    if {[catch {Rappture::objects::get $type}] == 0} {
188                        # add this to the return list with the right flavor
189                        if {$params(-as) == "component"} {
190                            lappend rlist $cpath
191                        } else {
192                            lappend rlist [$xmlobj element -as $params(-as) $cpath]
193                        }
194                    }
195
196                    # if this element has embedded groups, add them to the queue
197                    foreach ccpath [$xmlobj children -as path $cpath] {
198                        set cctype [$xmlobj element -as type $ccpath]
199                        if {$cctype == "group" || $cctype == "phase"} {
200                            lappend queue $ccpath
201                        }
202                    }
203                }
204            }
205        }
206    }
207    return $rlist
208}
209
210# ----------------------------------------------------------------------
211itcl::class Rappture::LibraryObj {
212    constructor {info} { # defined below }
213    destructor { # defined below }
214
215    public method element {args}
216    public method parent {args}
217    public method children {args}
218    public method get {args}
219    public method put {args}
220    public method copy {path from args}
221    public method remove {{path ""}}
222    public method xml {{path ""}}
223    public method uq_get_vars {{tfile ""}}
224
225    public method diff {libobj}
226    public proc value {libobj path}
227
228    public proc path2list {path}
229    protected method find {path}
230    protected method node2name {node}
231    protected method node2comp {node}
232    protected method node2path {node}
233    protected method childnodes {node type}
234
235    private variable _root 0       ;# non-zero => this obj owns document
236    private variable _document ""  ;# XML DOM tree
237    private variable _node ""      ;# node within
238}
239
240# ----------------------------------------------------------------------
241# CONSTRUCTOR
242# ----------------------------------------------------------------------
243itcl::body Rappture::LibraryObj::constructor {info} {
244    if {[regexp {<?[Xx][Mm][Ll]} $info]} {
245        set _root 1
246        set _document [dom parse $info]
247        set _node [$_document documentElement]
248    } elseif {[regexp {^domNode} $info]} {
249        set _root 0
250        set _document [$info ownerDocument]
251        set _node $info
252    } else {
253        error "bad info: should be XML text or DOM node"
254    }
255}
256
257# ----------------------------------------------------------------------
258# DESTRUCTOR
259# ----------------------------------------------------------------------
260itcl::body Rappture::LibraryObj::destructor {} {
261    if {$_root && $_document != ""} {
262        $_document delete
263    }
264}
265
266# ----------------------------------------------------------------------
267# USAGE: element ?-as <fval>? ?<path>?
268#
269# Clients use this to query a particular element within the entire
270# data structure.  The path is a string of the form
271# "structure.box(source).corner".  This example represents the tag
272# <corner> within a tag <box id="source"> within a tag <structure>,
273# which must be found at the top level within this document.
274#
275# By default, this method returns the component name "type(id)".
276# This is changed by setting the -as argument to "id" (for name
277# of the tail element), to "type" (for the type of the tail element),
278# to "object" (for an object representing the DOM node referenced by
279# the path).
280# ----------------------------------------------------------------------
281itcl::body Rappture::LibraryObj::element {args} {
282    array set params {
283        -as component
284    }
285    while {[llength $args] > 1} {
286        set first [lindex $args 0]
287        if {[string index $first 0] == "-"} {
288            set choices [array names params]
289            if {[lsearch $choices $first] < 0} {
290                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
291            }
292            set params($first) [lindex $args 1]
293            set args [lrange $args 2 end]
294        } else {
295            break
296        }
297    }
298    if {[llength $args] > 1} {
299        error "wrong # args: should be \"element ?-as fval? ?path?\""
300    }
301    set path [lindex $args 0]
302
303    set node [find $path]
304    if {$node == ""} {
305        return ""
306    }
307
308    switch -- $params(-as) {
309      object {
310          return [::Rappture::LibraryObj ::#auto $node]
311      }
312      component {
313          return [node2comp $node]
314      }
315      id {
316          return [node2name $node]
317      }
318      path {
319          return [node2path $node]
320      }
321      type {
322          return [$node nodeName]
323      }
324      default {
325          error "bad flavor \"$params(-as)\": should be component, id, object, path, type"
326      }
327    }
328}
329
330# ----------------------------------------------------------------------
331# USAGE: parent ?-as <fval>? ?<path>?
332#
333# Clients use this to query the parent of a particular element.
334# This is just like the "element" method, but it returns the parent
335# of the element instead of the element itself.
336#
337# By default, this method returns a list of component names "type(id)".
338# This is changed by setting the -as argument to "id" (for tail
339# names of all children), to "type" (for the types of all children),
340# to "object" (for a list of objects representing the DOM nodes for
341# all children).
342# ----------------------------------------------------------------------
343itcl::body Rappture::LibraryObj::parent {args} {
344    array set params {
345        -as component
346    }
347    while {[llength $args] > 1} {
348        set first [lindex $args 0]
349        if {[string index $first 0] == "-"} {
350            set choices [array names params]
351            if {[lsearch $choices $first] < 0} {
352                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
353            }
354            set params($first) [lindex $args 1]
355            set args [lrange $args 2 end]
356        } else {
357            break
358        }
359    }
360    if {[llength $args] > 1} {
361        error "wrong # args: should be \"parent ?-as fval? ?path?\""
362    }
363    set path [lindex $args 0]
364
365    set node [find $path]
366    if {$node == ""} {
367        return ""
368    }
369    set node [$node parentNode]
370    if {$node == ""} {
371        return ""
372    }
373
374    switch -- $params(-as) {
375      object {
376          return [::Rappture::LibraryObj ::#auto $node]
377      }
378      component {
379          return [node2comp $node]
380      }
381      id {
382          return [node2name $node]
383      }
384      path {
385          return [node2path $node]
386      }
387      type {
388          return [$node nodeName]
389      }
390      default {
391          error "bad flavor \"$params(-as)\": should be component, id, object, path, type"
392      }
393    }
394}
395
396# ----------------------------------------------------------------------
397# USAGE: children ?-as <fval>? ?-type <name>? ?<path>?
398#
399# Clients use this to query the children of a particular element
400# within the entire data structure.  This is just like the "element"
401# method, but it returns the children of the element instead of the
402# element itself.  If the optional -type argument is specified, then
403# the return list is restricted to children of the specified type.
404#
405# By default, this method returns a list of component names "type(id)".
406# This is changed by setting the -as argument to "id" (for tail
407# names of all children), to "type" (for the types of all children),
408# to "object" (for a list of objects representing the DOM nodes for
409# all children).
410# ----------------------------------------------------------------------
411itcl::body Rappture::LibraryObj::children {args} {
412    array set params {
413        -as component
414        -type ""
415    }
416    while {[llength $args] > 1} {
417        set first [lindex $args 0]
418        if {[string index $first 0] == "-"} {
419            set choices [array names params]
420            if {[lsearch $choices $first] < 0} {
421                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
422            }
423            set params($first) [lindex $args 1]
424            set args [lrange $args 2 end]
425        } else {
426            break
427        }
428    }
429    if {[llength $args] > 1} {
430        error "wrong # args: should be \"children ?-as fval? ?-type name? ?path?\""
431    }
432    set path [lindex $args 0]
433    set node [find $path]
434    if {$node == ""} {
435        return ""
436    }
437
438    set nlist ""
439    foreach n [$node childNodes] {
440        set type [$n nodeName]
441        if {[regexp {^#} $type]} {
442            continue
443        }
444        if {$params(-type) != "" && $params(-type) != $type} {
445            continue
446        }
447        lappend nlist $n
448    }
449
450    set rlist ""
451    switch -- $params(-as) {
452      object {
453          foreach n $nlist {
454              lappend rlist [::Rappture::LibraryObj ::#auto $n]
455          }
456      }
457      component {
458          foreach n $nlist {
459              lappend rlist [node2comp $n]
460          }
461      }
462      id {
463          foreach n $nlist {
464              lappend rlist [node2name $n]
465          }
466      }
467      path {
468          foreach n $nlist {
469              lappend rlist [node2path $n]
470          }
471      }
472      type {
473          foreach n $nlist {
474              lappend rlist [$n nodeName]
475          }
476      }
477      default {
478          error "bad flavor \"$params(-as)\": should be component, id, object, path, type"
479      }
480    }
481    return $rlist
482}
483
484# ----------------------------------------------------------------------
485# USAGE: get ?-decode yes? ?<path>?
486#
487# Clients use this to query the value of a node. Clients can specify
488# if they want the data to be automatically decoded or no using the
489# -decode flag. This is useful for situations where you want to keep
490# the data encoded to pass to another system, like dx data in fields
491# sending data to nanovis. If the path is not
492# specified, it returns the value associated with the root node.
493# Otherwise, it returns the value for the element specified by the
494# path.
495# ----------------------------------------------------------------------
496itcl::body Rappture::LibraryObj::get {args} {
497    array set params {
498        -decode yes
499    }
500    while {[llength $args] > 0} {
501        set first [lindex $args 0]
502        if {[string index $first 0] == "-"} {
503            set choices [array names params]
504            if {[lsearch $choices $first] < 0} {
505                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
506            }
507            set params($first) [lindex $args 1]
508            set args [lrange $args 2 end]
509        } else {
510            break
511        }
512    }
513    if {[llength $args] > 1} {
514        error "wrong # args: should be \"get ?-decode yes? ?path?\""
515    }
516    if {[llength $args] == 1} {
517        set path [lindex $args 0]
518    } else {
519        set path ""
520    }
521
522    set node [find $path]
523    if {$node == ""} {
524        return ""
525    }
526    set string [string trim [$node text]]
527    if {$params(-decode)} {
528        set string [Rappture::encoding::decode -- $string]
529    }
530    return $string
531}
532
533# ----------------------------------------------------------------------
534# USAGE: put ?-append yes? ?-id num? ?-type string|file? ?-compress no? ?<path>? <string>
535#
536# Clients use this to set the value of a node.  If the path is not
537# specified, it sets the value for the root node.  Otherwise, it sets
538# the value for the element specified by the path.  If the value is a
539# string, then it is treated as the text within the tag at the tail
540# of the path.  If it is a DOM node or a library, then it is inserted
541# into the tree at the specified path.
542#
543# If the optional id is specified, then it sets the identifier for
544# the tag at the tail of the path.  If the optional append flag is
545# specified, then the value is appended to the current value.
546# Otherwise, the value replaces the current value.
547# ----------------------------------------------------------------------
548itcl::body Rappture::LibraryObj::put {args} {
549    array set params {
550        -id ""
551        -append no
552        -type string
553        -compress no
554    }
555    while {[llength $args] > 1} {
556        set first [lindex $args 0]
557        if {[string index $first 0] == "-"} {
558            set choices [array names params]
559            if {[lsearch $choices $first] < 0} {
560                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
561            }
562            set params($first) [lindex $args 1]
563            set args [lrange $args 2 end]
564        } else {
565            break
566        }
567    }
568    if {[llength $args] < 1 || [llength $args] > 2} {
569        error "wrong # args: should be \"put ?-append bval? ?-id num? ?-type string|file? ?-compress bval? ?path? string\""
570    }
571    if {[llength $args] == 2} {
572        set path [lindex $args 0]
573        set str [lindex $args 1]
574    } else {
575        set path ""
576        set str [lindex $args 0]
577    }
578
579    if {$params(-type) == "file"} {
580        set fileName $str
581        set fid [open $fileName r]
582        fconfigure $fid -translation binary -encoding binary
583        set str [read $fid]
584        close $fid
585    }
586
587    if {$params(-compress) || [Rappture::encoding::is binary $str]} {
588        set str [Rappture::encoding::encode -- $str]
589    }
590
591    set node [find -create $path]
592
593    #
594    # Clean up any nodes that don't belong.  If we're appending
595    # the value, then clean up only child <tag> nodes.  Otherwise,
596    # clean up all nodes.
597    #
598    set nlist ""
599    if {$params(-append)} {
600        foreach n [$node childNodes] {
601            if {[$n nodeType] != "TEXT_NODE"} {
602                lappend nlist $n
603            }
604        }
605    } else {
606        set nlist [$node childNodes]
607    }
608    foreach n $nlist {
609        $n delete
610    }
611
612    if {[Rappture::library isvalid $str]} {
613        foreach n [[$str info variable _node -value] childNodes] {
614            if { [$n nodeType] == "COMMENT_NODE" } {
615                continue
616            }
617            $node appendXML [$n asXML]
618        }
619    } else {
620        set n [$_document createText $str]
621        $node appendChild $n
622        if {"" != $params(-id)} {
623            $node setAttribute id $params(-id)
624        }
625    }
626    return ""
627}
628
629# ----------------------------------------------------------------------
630# USAGE: copy <path> from ?<xmlobj>? <path>
631#
632# Clients use this to copy the value from one xmlobj/path to another.
633# If the <xmlobj> is not specified, it is assumed to be the same as
634# the current object.
635# ----------------------------------------------------------------------
636itcl::body Rappture::LibraryObj::copy {path from args} {
637    if {[llength $args] == 1} {
638        set xmlobj $this
639        set fpath [lindex $args 0]
640    } elseif {[llength $args] == 2} {
641        set xmlobj [lindex $args 0]
642        set fpath [lindex $args 1]
643    } else {
644        error "wrong # args: should be \"copy path from ?xmlobj? path\""
645    }
646    if {$from != "from"} {
647        error "bad syntax: should be \"copy path from ?xmlobj? path\""
648    }
649
650    if {[llength [$xmlobj children $fpath]] == 0} {
651        set val [$xmlobj get $fpath]
652        put $path $val
653    } else {
654        set obj [$xmlobj element -as object $fpath]
655        put $path $obj
656        itcl::delete object $obj
657    }
658}
659
660# ----------------------------------------------------------------------
661# USAGE: remove ?<path>?
662#
663# Clients use this to remove the specified node.  Removes the node
664# from the tree.
665# ----------------------------------------------------------------------
666itcl::body Rappture::LibraryObj::remove {{path ""}} {
667    set node [find $path]
668    if {$node != ""} {
669        $node delete
670    }
671}
672
673# ----------------------------------------------------------------------
674# USAGE: xml ?<path>?
675#
676# Returns a string representing the XML information for the information
677# in this library.
678# ----------------------------------------------------------------------
679itcl::body Rappture::LibraryObj::xml {{path ""}} {
680    if {"" != $path} {
681        set n [find $path]
682    } else {
683        set n $_node
684    }
685    return [$n asXML]
686}
687
688# ----------------------------------------------------------------------
689# USAGE: diff <libobj>
690#
691# Compares the entities in this object to those in another and
692# returns a list of differences.  The result is a list of the form:
693# {op1 path1 oldval1 newval1 ...} where each "op" is +/-/c for
694# added/subtracted/changed, "path" is the path within the library
695# that is different, and "oldval"/"newval" give the values for the
696# object at the path.
697# ----------------------------------------------------------------------
698itcl::body Rappture::LibraryObj::diff {libobj} {
699    set rlist ""
700
701    # query the values for all entities in both objects
702    set thisv [Rappture::entities $this input]
703    set otherv [Rappture::entities $libobj input]
704
705    # add UQ checking
706    lappend thisv uq.type uq.args
707    lappend otherv uq.type uq.args
708
709    # scan through values for this object, and compare against other one
710    foreach path $thisv {
711        set i [lsearch -exact $otherv $path]
712        if {$i < 0} {
713            foreach {raw norm} [value $this $path] break
714            lappend rlist - $path $raw ""
715        } else {
716            foreach {traw tnorm} [value $this $path] break
717            foreach {oraw onorm} [value $libobj $path] break
718            if {![string equal $tnorm $onorm]} {
719                lappend rlist c $path $traw $oraw
720            }
721            set otherv [lreplace $otherv $i $i]
722        }
723    }
724
725    # add any values left over in the other object
726    foreach path $otherv {
727        foreach {oraw onorm} [value $libobj $path] break
728        lappend rlist + $path "" $oraw
729    }
730
731    return $rlist
732}
733
734# ----------------------------------------------------------------------
735# USAGE: value <object> <path>
736#
737# Used to query the "value" associated with the <path> in an XML
738# <object>.  This is a little more complicated than the object's
739# "get" method.  It handles things like structures and values
740# with normalized units.
741#
742# Returns a list of two items:  {raw norm} where "raw" is the raw
743# value from the "get" method and "norm" is the normalized value
744# produced by this routine.  Example:  {300K 300}
745#
746# Right now, it is a handy little utility used by the "diff" method.
747# Eventually, it should be moved to a better object-oriented
748# implementation, where each Rappture type could overload the
749# various bits of processing below.  So we leave it as a "proc"
750# now instead of a method, since it should be deprecated soon.
751# ----------------------------------------------------------------------
752itcl::body Rappture::LibraryObj::value {libobj path} {
753    switch -- [$libobj element -as type $path] {
754        structure {
755            set raw $path
756            # try to find a label to represent the structure
757            set val [$libobj get $path.about.label]
758            if {"" == $val} {
759                set val [$libobj get $path.current.about.label]
760            }
761            if {"" == $val} {
762                if {[$libobj element $path.current] != ""} {
763                    set comps [$libobj children $path.current.components]
764                    set val "<structure> with [llength $comps] components"
765                } else {
766                    set val "<structure>"
767                }
768            }
769            return [list $raw $val]
770        }
771        number {
772            # get the usual value...
773            set raw ""
774            set val ""
775            if {"" != [$libobj element $path.current]} {
776                set raw [$libobj get $path.current]
777            } elseif {"" != [$libobj element $path.default]} {
778                set raw [$libobj get $path.default]
779            }
780            if {"" != $raw} {
781                set val $raw
782                # then normalize to default units
783                set units [$libobj get $path.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
1053# ----------------------------------------------------------------------
1054# USAGE: uq_get_vars [$tfile]
1055#
1056# Scans number nodes in the input section for UQ parameters.
1057#
1058# Returns a string in JSON so it can easily be passed to PUQ. Strips units
1059# because PUQ does not need or recognize them.
1060#
1061# For example, 2 parameters, one gaussian and one uniform might return:
1062# [["height","m",["gaussian",100,10,{"min":0}]],["velocity","m/s",["uniform",80,90]]]
1063#
1064# Returns "" if there are no UQ parameters.
1065#
1066# If tfile is specified, write a template file out.
1067# ----------------------------------------------------------------------
1068itcl::body Rappture::LibraryObj::uq_get_vars {{tfile ""}} {
1069    set varout \[
1070    set varlist []
1071
1072    if {$tfile == ""} {
1073        set node $_node
1074    } else {
1075        set fid [::open $tfile r]
1076        set doc [dom parse [read $fid]]
1077        set node [$doc documentElement]
1078        close $fid
1079    }
1080
1081    set count 0
1082    set n [$node selectNodes /run/input//number]
1083    foreach _n $n {
1084        set x [$_n selectNodes current/text()]
1085        set val [$x nodeValue]
1086        if {[string equal -length 8 $val "uniform "] ||
1087            [string equal -length 9 $val "gaussian "]} {
1088
1089            set vname [$_n getAttribute id]
1090            if {[lsearch $varlist $vname] >= 0} {
1091                continue
1092            } else {
1093                lappend varlist $vname
1094            }
1095
1096            if {$count > 0} {
1097                append varout ,
1098            }
1099            incr count
1100
1101            set units ""
1102            set unode [$_n selectNodes units/text()]
1103            if {"" != $unode} {
1104                set units [$unode nodeValue]
1105                set val [Rappture::Units::mconvert $val \
1106                -context $units -to $units -units off]
1107            }
1108
1109            set v \[\"$vname\",\"$units\",
1110            set fmt "\[\"%s\",%.16g,%.16g"
1111            set val [format $fmt [lindex $val 0] [lindex $val 1] [lindex $val 2]]
1112            append v $val
1113
1114            if {[string equal -length 9 [$x nodeValue] "gaussian "]} {
1115                set minv ""
1116                set min_node [$_n selectNodes min/text()]
1117                if {"" != $min_node} {
1118                    set minv [$min_node nodeValue]
1119                    if {$units != ""} {
1120                        set minv [Rappture::Units::convert $minv -context $units -units off]
1121                    }
1122                }
1123
1124                set maxv ""
1125                set max_node [$_n selectNodes max/text()]
1126                if {"" != $max_node} {
1127                    set maxv [$max_node nodeValue]
1128                    if {$units != ""} {
1129                        set maxv [Rappture::Units::convert $maxv -context $units -units off]
1130                    }
1131                }
1132
1133                if {$minv != "" || $maxv != ""} {
1134                    append v ",{"
1135                    if {$minv != ""} {
1136                        append v "\"min\":$minv"
1137                        if {$maxv != ""} {append v ,}
1138                    }
1139                    if {$maxv != ""} {
1140                        append v "\"max\":$maxv"
1141                    }
1142                    append v "}"
1143                }
1144            }
1145
1146            if {$tfile != ""} {
1147                $x nodeValue @@[$_n getAttribute id]
1148            }
1149            append varout $v\]\]
1150        }
1151    }
1152    append varout \]
1153
1154    if {$tfile != ""} {
1155        set fid [open $tfile w]
1156        puts $fid "<?xml version=\"1.0\"?>"
1157        puts $fid [$node asXML]
1158        close $fid
1159        $doc delete
1160    }
1161    if {$varout == "\[\]"} {set varout ""}
1162    #puts "uq_get_vars returning $varout"
1163    return [list $varout $count]
1164}
Note: See TracBrowser for help on using the repository browser.