Changeset 6


Ignore:
Timestamp:
Mar 23, 2005 8:19:29 PM (19 years ago)
Author:
mmc
Message:

Fixed the Tcl library to mirror the API developed for XML
libraries on the Python side. The Tcl Rappture::library
now has methods like "children", "element", "put", etc.
One difference: On the Tcl side, the default -flavor for
element/children is "component", since that works better
in Tcl code. In Python, the default is flavor=object.

Also fixed the Tcl install script to install not just
the tcl/scripts library, but also the ../gui and ../lib
directories.

Location:
trunk
Files:
2 added
10 edited

Legend:

Unmodified
Added
Removed

  • trunk/gui/apps/driver

    r1 r6  
    8282
    8383# open the XML file containing the material library
    84 set lib [Rappture::Library::open -std library.xml]
     84set lib [Rappture::library -std library.xml]
    8585                                                                               
    8686# open the XML file containing the tool parameters
    … …  
    8989    exit 1
    9090}
    91 set tool [Rappture::Library::open $toolfile]
     91set tool [Rappture::library $toolfile]
    9292                                                                               
    9393# open the XML file containing the configuration for this application
    … …  
    9696    exit 1
    9797}
    98 set config [Rappture::Library::open $configfile]
     98set config [Rappture::library $configfile]
    9999
    100100# ----------------------------------------------------------------------
    … …  
    148148# ----------------------------------------------------------------------
    149149set w $win.input
    150 set ndevs [$config get -count controls.device]
    151 if {$ndevs > 0} {
    152     for {set i 0} {$i < $ndevs} {incr i} {
    153         set obj [$config get -object controls.device$i]
     150set dfirst ""
     151set dlist [$config children -type structure controls]
     152if {"" != $dlist} {
     153    foreach dname $dlist {
     154        set obj [$config element -flavor object controls.$dname]
    154155        set name [$obj get label]
    155156        set devs($name) $obj
    … …  
    157158    set devlist [lsort [array names devs]]
    158159
    159     if {$ndevs > 1} {
     160    if {[array size devs] > 1} {
    160161        frame $w.devsel
    161162        pack $w.devsel -side top -fill x
    … …  
    173174
    174175    set first [lindex $devlist 0]
     176    set dfirst $devs($first)
    175177    Rappture::DeviceViewer1D $w.device -device $devs($first) \
    176178        -tool $tool -library $lib
    … …  
    185187set w $win.output
    186188Rappture::Analyzer $w.analyze -holdwindow $win.input \
    187     -tool $tool -analysis [$config get -object analysis] \
    188     -device $devs($first)
     189    -tool $tool -analysis [$config element -flavor object analysis] \
     190    -device $dfirst
    189191pack $w.analyze -expand yes -fill both
    190192
    … …  
    192194# HOOK UP ANY CONTROLS CALLED OUT IN CONFIG.XML
    193195# ----------------------------------------------------------------------
    194 set ncntls [$config get -count controls.access]
    195 for {set i 0} {$i < $ncntls} {incr i} {
    196     set name [$config get access$i]
     196foreach access [$config children -type access controls] {
     197    set name [$config get controls.$access]
    197198    switch -glob -- $name {
    198         parameters.ambient* - device* {
     199        parameters.ambient* - structure* {
    199200            $win.input.device controls add $name
    200201        }

  • trunk/gui/scripts/analyzer.tcl

    r1 r6  
    258258# ----------------------------------------------------------------------
    259259itcl::configbody Rappture::Analyzer::tool {
    260     if {![Rappture::Library::valid $itk_option(-tool)]} {
     260    if {![Rappture::library isvalid $itk_option(-tool)]} {
    261261        error "bad value \"$itk_option(-tool)\": should be Rappture::Library"
    262262    }
    … …  
    276276itcl::configbody Rappture::Analyzer::device {
    277277    if {$itk_option(-device) != ""
    278           && ![Rappture::Library::valid $itk_option(-device)]} {
     278          && ![Rappture::library isvalid $itk_option(-device)]} {
    279279        error "bad value \"$itk_option(-device)\": should be Rappture::Library"
    280280    }
    … …  
    289289# ----------------------------------------------------------------------
    290290itcl::configbody Rappture::Analyzer::analysis {
    291     if {![Rappture::Library::valid $itk_option(-analysis)]} {
     291    if {![Rappture::library isvalid $itk_option(-analysis)]} {
    292292        error "bad value \"$itk_option(-analysis)\": should be Rappture::Library"
    293293    }
    … …  
    299299
    300300    set counter 0
    301     foreach item [$itk_option(-analysis) get -children] {
     301    foreach item [$itk_option(-analysis) children] {
    302302        switch -glob -- $item {
    303303            xyplot* {
    … …  
    311311
    312312                set _widgets($item) [Rappture::Xyplot $page.#auto \
    313                     -layout [$itk_option(-analysis) get -object $item]]
     313                    -layout [$itk_option(-analysis) element -flavor object $item]]
    314314                pack $_widgets($item) -expand yes -fill both
    315315            }

  • trunk/gui/scripts/curve.tcl

    r1 r6  
    3838# ----------------------------------------------------------------------
    3939itcl::body Rappture::Curve::constructor {libobj path} {
    40     if {![Rappture::Library::valid $libobj]} {
     40    if {![Rappture::library isvalid $libobj]} {
    4141        error "bad value \"$libobj\": should be LibraryObj"
    4242    }
    4343    set _libobj $libobj
    44     set _curve [$libobj get -object $path]
     44    set _curve [$libobj element -flavor object $path]
    4545
    4646    # build up vectors for various components of the curve
    … …  
    144144    # vectors for each part.
    145145    #
    146     set max [$_curve get -count component]
    147     for {set i 0} {$i < $max} {incr i} {
     146    foreach cname [$_curve children -type component] {
    148147        set xv ""
    149148        set yv ""
    150149
    151         set xydata [$_curve get component$i.xy]
     150        set xydata [$_curve get $cname.xy]
    152151        if {"" != $xydata} {
    153152            set xv [blt::vector create x$_counter]
    … …  
    163162
    164163        if {$xv != "" && $yv != ""} {
    165             set _comp2vecs(component$i) [list $xv $yv]
     164            set _comp2vecs($cname) [list $xv $yv]
    166165            incr _counter
    167166        }

  • trunk/gui/scripts/deviceLayout1D.tcl

    r1 r6  
    182182    # see if any of the slabs has a label
    183183    if {$_device != ""} {
    184         foreach nn [$_device get -children recipe] {
     184        foreach nn [$_device children recipe] {
    185185            if {"" != [$_device get recipe.$nn.label]} {
    186186                set extra [expr {1.2*[font metrics $fnt -linespace]}]
    … …  
    192192
    193193    # a little extra height for the molecule image
    194     if {[$_device get -exists recipe.molecule]} {
     194    if {"" != [$_device element recipe.molecule]} {
    195195        set h [expr {$h+15}]
    196196    }
    … …  
    210210    set z 0
    211211    if {$_device != ""} {
    212         foreach nn [$_device get -children recipe] {
     212        foreach nn [$_device children recipe] {
    213213            switch -glob -- $nn {
    214214                slab* - molecule* {
    … …  
    310310    set h [expr {[winfo height $c]-1}]
    311311    # a little extra height for the molecule image
    312     if {[$_device get -exists recipe.molecule]} {
     312    if {"" != [$_device element recipe.molecule]} {
    313313        set h [expr {$h-15}]
    314314    }
    … …  
    361361    set h [expr {[winfo height $c]-1}]
    362362    # a little extra height for the molecule image
    363     if {[$_device get -exists recipe.molecule]} {
     363    if {"" != [$_device element recipe.molecule]} {
    364364        set h [expr {$h-15}]
    365365    }
    … …  
    395395    set h [expr {[winfo height $c]-1}]
    396396    # a little extra height for the molecule image
    397     if {[$_device get -exists recipe.molecule]} {
     397    if {"" != [$_device element recipe.molecule]} {
    398398        set h [expr {$h-15}]
    399399    }
    … …  
    448448    #
    449449    if {"" != $_device} {
    450         set label [$_device get "$elem.label"]
     450        set label [$_device get $elem.label]
    451451        if {"" != $label} {
    452452            set y [expr {$y-0.5*$lh}]
    … …  
    491491itcl::configbody Rappture::DeviceLayout1D::library {
    492492    if {$itk_option(-library) != ""} {
    493         if {![Rappture::Library::valid $itk_option(-library)]} {
     493        if {![Rappture::library isvalid $itk_option(-library)]} {
    494494            error "bad value \"$itk_option(-library)\": should be Rappture::Library"
    495495        }
    … …  
    508508itcl::configbody Rappture::DeviceLayout1D::device {
    509509    if {$itk_option(-device) != ""} {
    510         if {![Rappture::Library::valid $itk_option(-device)]} {
     510        if {![Rappture::library isvalid $itk_option(-device)]} {
    511511            error "bad value \"$itk_option(-device)\": should be Rappture::Library"
    512512        }

  • trunk/gui/scripts/deviceViewer1D.tcl

    r1 r6  
    186186    #
    187187    if {$_device != ""} {
    188         foreach nn [$_device get -children] {
     188        foreach nn [$_device children] {
    189189            if {[string match field* $nn]} {
    190190                set name [$_device get $nn.label]
    … …  
    516516itcl::body Rappture::DeviceViewer1D::_controlCreate {container libObj path} {
    517517    set presets ""
    518     set npre [$libObj get -count $path.preset]
    519     for {set i 0} {$i < $npre} {incr i} {
     518    foreach pre [$libObj children -type preset $path] {
    520519        lappend presets \
    521             [$libObj get $path.preset$i.value] \
    522             [$libObj get $path.preset$i.label]
     520            [$libObj get $path.$pre.value] \
     521            [$libObj get $path.$pre.label]
    523522    }
    524523
    … …  
    606605itcl::configbody Rappture::DeviceViewer1D::device {
    607606    if {$itk_option(-device) != ""} {
    608         if {![Rappture::Library::valid $itk_option(-device)]} {
     607        if {![Rappture::library isvalid $itk_option(-device)]} {
    609608            error "bad value \"$itk_option(-device)\": should be Rappture::Library"
    610609        }
    … …  
    623622itcl::configbody Rappture::DeviceViewer1D::tool {
    624623    if {$itk_option(-tool) != ""} {
    625         if {![Rappture::Library::valid $itk_option(-tool)]} {
     624        if {![Rappture::library isvalid $itk_option(-tool)]} {
    626625            error "bad value \"$itk_option(-tool)\": should be Rappture::Library"
    627626        }

  • trunk/gui/scripts/field.tcl

    r1 r6  
    4343# ----------------------------------------------------------------------
    4444itcl::body Rappture::Field::constructor {devobj libobj path} {
    45     if {![Rappture::Library::valid $devobj]} {
     45    if {![Rappture::library isvalid $devobj]} {
    4646        error "bad value \"$devobj\": should be LibraryObj"
    4747    }
    48     if {![Rappture::Library::valid $libobj]} {
     48    if {![Rappture::library isvalid $libobj]} {
    4949        error "bad value \"$libobj\": should be LibraryObj"
    5050    }
    5151    set _device $devobj
    5252    set _libobj $libobj
    53     set _field [$libobj get -object $path]
     53    set _field [$libobj element -flavor object $path]
    5454    set _units [$_field get units]
    5555
    5656    # determine the overall size of the device
    5757    set z0 [set z1 0]
    58     foreach elem [$_device get -children recipe] {
     58    foreach elem [$_device children recipe] {
    5959        switch -glob -- $elem {
    6060            slab* - molecule* {
    … …  
    192192    # vectors for each part.
    193193    #
    194     set max [$_field get -count component]
    195     for {set i 0} {$i < $max} {incr i} {
     194    foreach cname [$_field children -type component] {
    196195        set xv ""
    197196        set yv ""
    198197
    199         set val [$_field get component$i.constant]
     198        set val [$_field get $cname.constant]
    200199        if {$val != ""} {
    201             set domain [$_field get component$i.domain]
     200            set domain [$_field get $cname.domain]
    202201            if {$domain == "" || ![info exists _limits($domain)]} {
    203202                set z0 0
    … …  
    217216
    218217            set zm [expr {0.5*($z0+$z1)}]
    219             set _comp2cntls(component$i) \
    220                 [list component$i.constant $zm $val "$val$_units"]
     218            set _comp2cntls($cname) \
     219                [list $cname.constant $zm $val "$val$_units"]
    221220        } else {
    222             set xydata [$_field get component$i.xy]
     221            set xydata [$_field get $cname.xy]
    223222            if {"" != $xydata} {
    224223                set xv [blt::vector create x$_counter]
    … …  
    235234
    236235        if {$xv != "" && $yv != ""} {
    237             set _comp2vecs(component$i) [list $xv $yv]
     236            set _comp2vecs($cname) [list $xv $yv]
    238237            incr _counter
    239238        }

  • trunk/gui/scripts/xyplot.tcl

    r1 r6  
    9696    if {$layout != "" && $run != ""} {
    9797        set count 0
    98         foreach item [$layout get -children] {
     98        foreach item [$layout children] {
    9999          switch -glob -- $item {
    100100            title {
    … …  
    118118            field* {
    119119              set name [$layout get $item]
    120               if {[$run get -exists output.$name]} {
     120              if {"" != [$run element output.$name]} {
    121121                  set fobj [Rappture::Field ::#auto $_device $run output.$name]
    122122                  set _path2obj($name) $fobj
    … …  
    144144            curve* {
    145145              set name [$layout get $item]
    146               if {[$run get -exists output.$name]} {
     146              if {"" != [$run get element output.$name]} {
    147147                  set cobj [Rappture::Curve ::#auto $run output.$name]
    148148                  set _path2obj($name) $cobj
    … …  
    211211itcl::configbody Rappture::Xyplot::layout {
    212212    if {$itk_option(-layout) != ""} {
    213         if {![Rappture::Library::valid $itk_option(-layout)]} {
     213        if {![Rappture::library isvalid $itk_option(-layout)]} {
    214214            error "bad value \"$itk_option(-layout)\": should be Rappture::Library"
    215215        }
    … …  
    231231    }
    232232    if {$itk_option(-run) != ""} {
    233         if {![Rappture::Library::valid $itk_option(-run)]} {
     233        if {![Rappture::library isvalid $itk_option(-run)]} {
    234234            error "bad value \"$itk_option(-run)\": should be Rappture::Library"
    235235        }
    236         set _device [$itk_option(-run) get -object device]
     236        set _device [$itk_option(-run) element -flavor object device]
    237237    }
    238238    after cancel [itcl::code $this _rebuild]

  • trunk/python/Rappture/library.py

    r5 r6  
    364364                        if n.nodeName == type:
    365365                            pos = n
     366
    366367                    if pos:
    367368                        pos = pos.nextSibling

  • trunk/tcl/install

    r1 r6  
    4040set targetdir [file join $dir $package$version]
    4141
    42 mkindex scripts
    43 
    4442if {![file exists $targetdir]} {
    4543    puts "making directory $targetdir..."
    … …  
    4745}
    4846
    49 foreach file [find .] {
     47set origdir [pwd]
     48foreach context {. ../gui} {
     49    cd $context
     50
     51    foreach file [find .] {
     52        set target [file join $targetdir $file]
     53        if {[file isdirectory $file]} {
     54            puts "making directory $target..."
     55            catch {file mkdir $target}
     56            file attributes $target -permissions ugo+rx
     57        } else {
     58            puts "installing $target..."
     59            file copy -force $file $target
     60            file attributes $target -permissions ugo+r
     61        }
     62    }
     63}
     64
     65cd ..
     66catch {file mkdir [file join $targetdir lib]}
     67foreach file [find ./lib] {
    5068    set target [file join $targetdir $file]
    5169    if {[file isdirectory $file]} {
    … …  
    6078}
    6179
     80cd $origdir
     81
    6282set fid [open [file join $targetdir pkgIndex.tcl] w]
    6383puts $fid "# Tcl package index file"
    … …  
    6989close $fid
    7090
     91mkindex [file join $targetdir scripts]
     92
    7193puts "== $package-$version INSTALLED"

  • trunk/tcl/scripts/library.tcl

    r1 r6  
    1212
    1313namespace eval Rappture { # forward declaration }
    14 namespace eval Rappture::Library { # forward declaration }
    15 
    16 # ----------------------------------------------------------------------
    17 # USAGE: open ?-std? <file>
     14
     15# ----------------------------------------------------------------------
     16# USAGE: library ?-std? <file>
     17# USAGE: library isvalid <object>
    1818#
    1919# Used to open a <file> containing an XML description of tool
    … …  
    2323# If the -std flag is included, then the file is treated as the
    2424# name of a standard file, which is part of the Rappture installation.
    25 # ----------------------------------------------------------------------
    26 proc Rappture::Library::open {args} {
     25#
     26# The isvalid operation checks an <object> to see if it is a valid
     27# library object.  Returns 1 if so, and 0 otherwise.
     28# ----------------------------------------------------------------------
     29proc Rappture::library {args} {
     30    # handle the isvalid operation...
     31    if {[llength $args] > 1 && [lindex $args 0] == "isvalid"} {
     32        if {[llength $args] != 2} {
     33            error "wrong # args: should be \"library isvalid object\""
     34        }
     35        set obj [lindex $args 1]
     36        if {[catch {$obj isa ::Rappture::LibraryObj} valid] == 0 && $valid} {
     37            return 1
     38        }
     39        return 0
     40    }
     41
     42    # handle the open operation...
    2743    set stdfile 0
    2844    while {[llength $args] > 1} {
    … …  
    5167
    5268# ----------------------------------------------------------------------
    53 # USAGE: valid <obj>
    54 #
    55 # Checks to see if the given object is a valid Library.  Returns 1
    56 # if so, and 0 otherwise.
    57 # ----------------------------------------------------------------------
    58 proc Rappture::Library::valid {obj} {
    59     if {[catch {$obj isa ::Rappture::LibraryObj} valid] == 0 && $valid} {
    60         return 1
    61     }
    62     return 0
    63 }
    64 
    65 # ----------------------------------------------------------------------
    6669itcl::class Rappture::LibraryObj {
    6770    constructor {info} { # defined below }
    6871    destructor { # defined below }
    6972
    70     public method get {args}
     73    public method element {args}
     74    public method children {args}
     75    public method get {{path ""}}
    7176    public method put {args}
     77    public method remove {{path ""}}
    7278    public method xml {}
    7379
    7480    protected method find {path}
    7581    protected method path2list {path}
     82    protected method node2name {node}
     83    protected method node2comp {node}
    7684
    7785    private variable _root 0       ;# non-zero => this obj owns document
    … …  
    107115
    108116# ----------------------------------------------------------------------
    109 # USAGE: get ?-exists|-object|-type|-info|-count|-children? ?<path>?
    110 #
    111 # Searches the DOM inside this object for the information on the
    112 # requested <path>.  By default, it returns the -info associated
    113 # with the path.  The other flags can be used to query other
    114 # aspects of the information at the requested node.
    115 # ----------------------------------------------------------------------
    116 itcl::body Rappture::LibraryObj::get {args} {
    117     set format -info
    118     while {[llength $args] > 0} {
     117# USAGE: element ?-flavor <fval>? ?<path>?
     118#
     119# Clients use this to query a particular element within the entire
     120# data structure.  The path is a string of the form
     121# "structure.box(source).corner".  This example represents the tag
     122# <corner> within a tag <box id="source"> within a tag <structure>,
     123# which must be found at the top level within this document.
     124#
     125# By default, this method returns the component name "type(id)".
     126# This is changed by setting the -flavor argument to "id" (for name
     127# of the tail element), to "type" (for the type of the tail element),
     128# to "object" (for an object representing the DOM node referenced by
     129# the path.
     130# ----------------------------------------------------------------------
     131itcl::body Rappture::LibraryObj::element {args} {
     132    array set params {
     133        -flavor component
     134    }
     135    while {[llength $args] > 1} {
    119136        set first [lindex $args 0]
    120137        if {[string index $first 0] == "-"} {
    121             set choices {-exists -object -type -info -count -children}
     138            set choices [array names params]
    122139            if {[lsearch $choices $first] < 0} {
    123140                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
    124141            }
    125             set format $first
    126             set args [lrange $args 1 end]
     142            set params($first) [lindex $args 1]
     143            set args [lrange $args 2 end]
    127144        } else {
    128145            break
    … …  
    130147    }
    131148    if {[llength $args] > 1} {
    132         error "wrong # args: should be \"get ?-exists? ?-object? ?-type? ?-info? ?-count? ?-children? ?path?\""
     149        error "wrong # args: should be \"element ?-flavor fval? ?path?\""
    133150    }
    134151    set path [lindex $args 0]
    135152
    136153    set node [find $path]
    137 
    138     switch -- $format {
    139         -exists {
    140             if {$node != ""} {
    141                 return 1
    142             }
    143             return 0
    144         }
    145         -object {
    146             if {$node != ""} {
    147                 return [::Rappture::LibraryObj ::#auto $node]
    148             }
    149             return ""
    150         }
    151         -info {
    152             if {$node != ""} {
    153                 return [string trim [$node text]]
    154             }
    155             return ""
    156         }
    157         -type   {
    158             if {$node != ""} {
    159                 return [$node nodeName]
    160             }
    161         }
    162         -count {
    163             if {$node == ""} {
    164                 return ""
    165             }
    166             set node [$node parent]
    167             set type [lindex [path2list $path] end]
    168             set nlist [$node getElementsByTagName $type]
    169             return [llength $nlist]
    170         }
    171         -children {
    172             if {$node == ""} {
    173                 return ""
    174             }
    175             set rlist ""
    176             set nlist [$node childNodes]
    177             foreach n $nlist {
    178                 set type [$n nodeName]
    179                 if {[regexp {^#} $type]} {
    180                     continue
    181                 }
    182                 if {![info exists count($type)]} {
    183                     set count($type) 0
    184                     lappend rlist $type
    185                 } else {
    186                     lappend rlist "$type[incr count($type)]"
    187                 }
    188             }
    189             return $rlist
    190         }
    191     }
    192     return ""
    193 }
    194 
    195 # ----------------------------------------------------------------------
    196 # USAGE: put <path> ?-text|-object? <string>
    197 #
    198 # Inserts information into the DOM represented by this object.
    199 # The <path> is a path to the insertion point, which uses a syntax
    200 # similar to the "get" method.  The <string> being inserted can either
    201 # be ordinary text, or another LibraryObj object.
    202 # ----------------------------------------------------------------------
    203 itcl::body Rappture::LibraryObj::put {args} {
    204     set what "-text"
    205     set path [lindex $args 0]
    206     set args [lrange $args 1 end]
     154    if {$node == ""} {
     155        return ""
     156    }
     157
     158    switch -- $params(-flavor) {
     159      object {
     160          return [::Rappture::LibraryObj ::#auto $node]
     161      }
     162      component {
     163          return [node2comp $node]
     164      }
     165      id {
     166          return [node2name $node]
     167      }
     168      type {
     169          return [$node nodeName]
     170      }
     171      default {
     172          error "bad flavor \"$params(-flavor)\": should be object, id, type, component"
     173      }
     174    }
     175}
     176
     177# ----------------------------------------------------------------------
     178# USAGE: children ?-flavor <fval>? ?-type <name>? ?<path>?
     179#
     180# Clients use this to query the children of a particular element
     181# within the entire data structure.  This is just like the "element"
     182# method, but it returns the children of the element instead of the
     183# element itself.  If the optional -type argument is specified, then
     184# the return list is restricted to children of the specified type.
     185#
     186# By default, this method returns a list of component names "type(id)".
     187# This is changed by setting the -flavor argument to "id" (for tail
     188# names of all children), to "type" (for the types of all children),
     189# to "object" (for a list of objects representing the DOM nodes for
     190# all children).
     191# ----------------------------------------------------------------------
     192itcl::body Rappture::LibraryObj::children {args} {
     193    array set params {
     194        -flavor component
     195        -type ""
     196    }
    207197    while {[llength $args] > 1} {
    208198        set first [lindex $args 0]
    209         set args [lrange $args 1 end]
    210         if {$first != "-text" && $first != "-object"} {
    211             error "bad option \"$first\": should be -object, -text"
    212         }
    213         set what $first
    214     }
    215     if {[llength $args] != 1} {
    216         error "wrong # args: should be \"put path ?-text? ?-object? string\""
    217     }
    218     set str [lindex $args 0]
    219 
    220     switch -- $what {
    221         -text {
    222             set node [find -create $path]
    223             foreach n [$node childNodes] {
    224                 if {[$n nodeType] == "TEXT_NODE"} {
    225                     $n delete
    226                 }
    227             }
    228             set n [$_document createText $str]
    229             $node appendChild $n
    230         }
    231         -object {
    232             error "not yet implemented"
    233         }
     199        if {[string index $first 0] == "-"} {
     200            set choices [array names params]
     201            if {[lsearch $choices $first] < 0} {
     202                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
     203            }
     204            set params($first) [lindex $args 1]
     205            set args [lrange $args 2 end]
     206        } else {
     207            break
     208        }
     209    }
     210    if {[llength $args] > 1} {
     211        error "wrong # args: should be \"children ?-flavor fval? ?-type name? ?path?\""
     212    }
     213    set path [lindex $args 0]
     214
     215    set node [find $path]
     216    if {$node == ""} {
     217        return ""
     218    }
     219
     220    set nlist ""
     221    foreach n [$node childNodes] {
     222        set type [$n nodeName]
     223        if {[regexp {^#} $type]} {
     224            continue
     225        }
     226        if {$params(-type) != "" && $params(-type) != $type} {
     227            continue
     228        }
     229        lappend nlist $n
     230    }
     231
     232    set rlist ""
     233    switch -- $params(-flavor) {
     234      object {
     235          foreach n $nlist {
     236              lappend rlist [::Rappture::LibraryObj ::#auto $n]
     237          }
     238      }
     239      component {
     240          foreach n $nlist {
     241              lappend rlist [node2comp $n]
     242          }
     243      }
     244      id {
     245          foreach n $nlist {
     246              lappend rlist [node2name $n]
     247          }
     248      }
     249      type {
     250          foreach n $nlist {
     251              lappend rlist [$n nodeName]
     252          }
     253      }
     254      default {
     255          error "bad flavor \"$params(-flavor)\": should be object, id, type, component"
     256      }
     257    }
     258    return $rlist
     259}
     260
     261# ----------------------------------------------------------------------
     262# USAGE: get ?<path>?
     263#
     264# Clients use this to query the value of a node.  If the path is not
     265# specified, it returns the value associated with the root node.
     266# Otherwise, it returns the value for the element specified by the
     267# path.
     268# ----------------------------------------------------------------------
     269itcl::body Rappture::LibraryObj::get {{path ""}} {
     270    set node [find $path]
     271    if {$node == ""} {
     272        return ""
     273    }
     274    return [string trim [$node text]]
     275}
     276
     277# ----------------------------------------------------------------------
     278# USAGE: put ?-append yes? ?-id num? ?<path>? <string>
     279#
     280# Clients use this to set the value of a node.  If the path is not
     281# specified, it sets the value for the root node.  Otherwise, it sets
     282# the value for the element specified by the path.  If the value is a
     283# string, then it is treated as the text within the tag at the tail
     284# of the path.  If it is a DOM node or a library, then it is inserted
     285# into the tree at the specified path.
     286#
     287# If the optional id is specified, then it sets the identifier for
     288# the tag at the tail of the path.  If the optional append flag is
     289# specified, then the value is appended to the current value.
     290# Otherwise, the value replaces the current value.
     291# ----------------------------------------------------------------------
     292itcl::body Rappture::LibraryObj::put {args} {
     293    array set params {
     294        -id ""
     295        -append no
     296    }
     297    while {[llength $args] > 1} {
     298        set first [lindex $args 0]
     299        if {[string index $first 0] == "-"} {
     300            set choices [array names params]
     301            if {[lsearch $choices $first] < 0} {
     302                error "bad option \"$first\": should be [join [lsort $choices] {, }]"
     303            }
     304            set params($first) [lindex $args 1]
     305            set args [lrange $args 2 end]
     306        } else {
     307            break
     308        }
     309    }
     310    if {[llength $args] > 2} {
     311        error "wrong # args: should be \"put ?-append bval? ?-id num? ?path? string\""
     312    }
     313    if {[llength $args] == 2} {
     314        set path [lindex $args 0]
     315        set str [lindex $args 1]
     316    } else {
     317        set path ""
     318        set str [lindex $args 0]
     319    }
     320    set node [find -create $path]
     321
     322    #
     323    # Clean up any nodes that don't belong.  If we're appending
     324    # the value, then clean up only child <tag> nodes.  Otherwise,
     325    # clean up all nodes.
     326    #
     327    set nlist ""
     328    if {$params(-append)} {
     329        foreach n [$node childNodes] {
     330            if {[$n nodeType] != "TEXT_NODE"} {
     331                lappend nlist $n
     332            }
     333        }
     334    } else {
     335        set nlist [$node childNodes]
     336    }
     337    foreach n $nlist {
     338        $n delete
     339    }
     340
     341    if {[Rappture::library isvalid $str]} {
     342        error "not yet implemented"
     343    } else {
     344        set n [$_document createText $str]
     345        $node appendChild $n
     346        if {"" != $params(-id)} {
     347            $node setAttribute id $params(-id)
     348        }
     349    }
     350    return ""
     351}
     352
     353# ----------------------------------------------------------------------
     354# USAGE: remove ?<path>?
     355#
     356# Clients use this to remove the specified node.  Removes the node
     357# from the tree.
     358# ----------------------------------------------------------------------
     359itcl::body Rappture::LibraryObj::remove {{path ""}} {
     360    set node [find $path]
     361    if {$node != ""} {
     362        $node delete
    234363    }
    235364}
    … …  
    248377# USAGE: find ?-create? <path>
    249378#
    250 # Searches from the starting node for this object according to the
    251 # given <path>.  Returns the node found at the end of the path,
    252 # or "" if the node was not found.
     379# Used internally to find a particular element within the root node
     380# according to the path, which is a string of the form
     381# "typeNN(id).typeNN(id). ...", where each "type" is a tag <type>;
     382# if the optional NN is specified, it indicates an index for the
     383# <type> tag within its parent; if the optional (id) part is included,
     384# it indicates a tag of the form <type id="id">.
     385#
     386# By default, it looks for an element along the path and returns None
     387# if not found.  If the create flag is set, it creates various elements
     388# along the path as it goes.  This is useful for "put" operations.
     389#
     390# If you include "#" instead of a specific number, a node will be
     391# created automatically with a new number.  For example, the path
     392# "foo.bar#" called the first time will create "foo.bar", the second
     393# time "foo.bar1", the third time "foo.bar2" and so forth.
     394#
     395# Returns an object representing the element indicated by the path,
     396# or "" if the path is not found.
    253397# ----------------------------------------------------------------------
    254398itcl::body Rappture::LibraryObj::find {args} {
    … …  
    266410        error "wrong # args: should be \"find ?-create? path\""
    267411    }
    268     set path [path2list [lindex $args 0]]
     412    set path [lindex $args 0]
     413
     414    if {$path == ""} {
     415        return $_node
     416    }
     417    set path [path2list $path]
    269418
    270419    #
    271420    # Follow the given path and look for all of the parts.
    272421    #
    273     set nnum 1
    274422    set lastnode $_node
    275423    set node $lastnode
    276424    foreach part $path {
    277         if {[regexp {^([a-zA-Z_]+)([0-9]*)$} $part match type index]
    278               && ($index != "" || [$node getElementsByTagName $type] != "")} {
    279             #
    280             # If the name is like "type2", then look for elements with
    281             # the type name and return the one with the given index.
    282             # If the name is like "type", then assume the index is 0.
    283             #
     425        if {![regexp {^(([a-zA-Z_]+#?)([0-9]*))?(\(([^\)]+)\))?$} $part \
     426               match dummy type index dummy name]} {
     427            error "bad path component \"$part\""
     428        }
     429        #
     430        # If the name is like "type2", then look for elements with
     431        # the type name and return the one with the given index.
     432        # If the name is like "type", then assume the index is 0.
     433        #
     434        if {$name == ""} {
    284435            if {$index == ""} {
    285436                set index 0
    … …  
    287438            set nlist [$node getElementsByTagName $type]
    288439            set node [lindex $nlist $index]
    289         } elseif {[regexp {^([a-zA-Z_]+)\(([^\)]*)\)$} $part match type name]} {
     440        } else {
    290441            #
    291             # If the name is like "type(name)", then look for elements
     442            # If the name is like "type(id)", then look for elements
    292443            # that match the type and see if one has the requested name.
     444            # if the name is like "(id)", then look for any elements
     445            # with the requested name.
    293446            #
    294             set nlist [$node getElementsByTagName $type]
     447            if {$type != ""} {
     448                set nlist [$node getElementsByTagName $type]
     449            } else {
     450                set nlist [$node childNodes]
     451            }
    295452            set found 0
    296453            foreach n $nlist {
    297                 if {[catch {$n getAttribute name} tag]} { set tag "" }
     454                if {[catch {$n getAttribute id} tag]} { set tag "" }
    298455                if {$tag == $name} {
    299456                    set found 1
    … …  
    302459            }
    303460            set node [expr {($found) ? $n : ""}]
    304         } else {
    305             #
    306             # Otherwise, the name might be something like "name".
    307             # Scan through all elements and see if any has the
    308             # matching name.
    309             #
    310             set nlist [$node childNodes]
    311             set found 0
    312             foreach n $nlist {
    313                 if {[catch {$n getAttribute name} tag]} { set tag "" }
    314                 if {$tag == $part} {
    315                     set found 1
    316                     break
    317                 }
    318             }
    319             set node [expr {($found) ? $n : ""}]
    320461        }
    321462
    … …  
    324465                return ""
    325466            }
     467
     468            #
     469            # If the "create" flag is set, then create a node
     470            # with the specified "type(id)" and continue on.
     471            # If the type is "type#", then create a node with
     472            # an automatic number.
     473            #
    326474            if {![regexp {^([^\(]+)\(([^\)]+)\)$} $part match type name]} {
    327475                set type $part
    328476                set name ""
    329477            }
    330             set node [$_document createElement $type]
    331             $lastnode appendChild $node
    332 
     478
     479            if {[string match *# $type]} {
     480                set type [string trimright $type #]
     481                set node [$_document createElement $type]
     482
     483                # find the last node of same type and append there
     484                set pos ""
     485                foreach n [$lastnode childNodes] {
     486                    if {[$n nodeName] == $type} {
     487                        set pos $n
     488                    }
     489                }
     490                if {$pos != ""} {
     491                    set pos [$pos nextSibling]
     492                }
     493                if {$pos != ""} {
     494                    $lastnode insertBefore $node $pos
     495                } else {
     496                    $lastnode appendChild $node
     497                }
     498            } else {
     499                set node [$_document createElement $type]
     500                $lastnode appendChild $node
     501            }
    333502            if {"" != $name} {
    334                 $node setAttribute name $name
     503                $node setAttribute id $name
    335504            }
    336505        }
    337506        set lastnode $node
    338         incr nnum
    339507    }
    340508    return $node
    … …  
    366534    return $path
    367535}
     536
     537# ----------------------------------------------------------------------
     538# USAGE: node2name <node>
     539#
     540# Used internally to create a name for the specified node.  If the
     541# node doesn't have a specific name ("id" attribute) then a name of
     542# the form "type123" is constructed.
     543# ----------------------------------------------------------------------
     544itcl::body Rappture::LibraryObj::node2name {node} {
     545    if {[catch {$node getAttribute id} name]} { set name "" }
     546    if {$name == ""} {
     547        set pnode [$node parentNode]
     548        if {$pnode == ""} {
     549            return ""
     550        }
     551        set type [$node nodeName]
     552        set siblings [$pnode getElementsByTagName $type]
     553        set index [lsearch $siblings $node]
     554        if {$index == 0} {
     555            set name $type
     556        } else {
     557            set name "$type$index"
     558        }
     559    }
     560    return $name
     561}
     562
     563# ----------------------------------------------------------------------
     564# USAGE: node2comp <node>
     565#
     566# Used internally to create a path component name for the specified
     567# node.  A path component name has the form "type(id)" or just
     568# "type##" if the node doesn't have a name.  This name can be used
     569# in a path to uniquely address the component.
     570# ----------------------------------------------------------------------
     571itcl::body Rappture::LibraryObj::node2comp {node} {
     572    set type [$node nodeName]
     573    if {[catch {$node getAttribute id} name]} { set name "" }
     574    if {$name == ""} {
     575        set pnode [$node parentNode]
     576        if {$pnode == ""} {
     577            return ""
     578        }
     579        set siblings [$pnode getElementsByTagName $type]
     580        set index [lsearch $siblings $node]
     581        if {$index == 0} {
     582            set name $type
     583        } else {
     584            set name "$type$index"
     585        }
     586    } else {
     587        set name "${type}($name)"
     588    }
     589    return $name
     590}
Note: See TracChangeset for help on using the changeset viewer.