Ignore:
Timestamp:
Mar 18, 2011, 8:42:59 AM (14 years ago)
Author:
mmc
Message:

More changes for the regression tester tool. Added a way for all ObjVal?
objects to import their attribute values. Once an ObjVal? has been imported,
it knows everything about itself without having to consult the XML.

Added Rappture::objects::viewer, which can be used to query the viewer for
a particular object type. Each object can have an "input" viewer for
specifying input values, and an "output" viewer for visualizing output
results. Right now, there is only one viewer implemented: an output viewer
for the CurveValue? object. We should create output viewers for all object
types, and then work on the input side too.

Added a "mkobjects.tcl" script used by the Makefile to build up the tclIndex
file. It looks for input/output viewers for all object classes and adds
them to tclIndex so they can be autoloaded.

Location:
trunk/lang/tcl/scripts/objects
Files:
1 added
5 edited

Legend:

Unmodified
Added
Removed

  • trunk/lang/tcl/scripts/objects/boolean/boolean.rp

    r2134 r2138  
    1111
    1212    import xml {xmlobj path} {
     13        attr import $xmlobj $path
    1314        import_string [$xmlobj get $path.current]
    1415    }

  • trunk/lang/tcl/scripts/objects/curve/curve.rp

    r2134 r2138  
    3535
    3636    storage {
    37         private variable _xvecs    ;# maps comp name => x-axis vector
    38         private variable _yvecs    ;# maps comp name => y-axis vector
     37        private variable _xvecs       ;# maps comp name => x-axis vector
     38        private variable _yvecs       ;# maps comp name => y-axis vector
     39        private variable _hints       ;# store "hints" based on attributes
     40        private variable _xmarkers "" ;# list of {x,label,options} for markers
     41        private variable _ymarkers "" ;# list of {y,label,options} for markers
    3942    }
    4043    clear {
    … …  
    4548        catch {unset _xvecs}
    4649        catch {unset _yvecs}
    47     }
    48 
     50        catch {unset _hints}
     51        set _xmarkers ""
     52        set _ymarkers ""
     53    }
     54
     55    # ------------------------------------------------------------------
     56    # IMPORT: string
     57    # ------------------------------------------------------------------
    4958    import string {val} {
    5059        set xv [blt::vector create \#auto]
    … …  
    95104    }
    96105
     106    # ------------------------------------------------------------------
     107    # EXPORT: string
     108    # ------------------------------------------------------------------
    97109    export string {var} {
    98110        upvar $var v
    … …  
    113125    }
    114126
     127    # ------------------------------------------------------------------
     128    # IMPORT: xml
     129    # ------------------------------------------------------------------
    115130    import xml {xmlobj path} {
     131        attr import $xmlobj $path
     132
    116133        foreach cname [$xmlobj children -type component $path] {
    117134            set xv [blt::vector create \#auto]
    … …  
    141158            set _yvecs($cname) $yv
    142159        }
    143     }
    144 
     160
     161        foreach elem [$xmlobj children -type "marker" $path.xaxis] {
     162            set at     [$xmlobj get $path.xaxis.$elem.at]
     163            set label  [$xmlobj get $path.xaxis.$elem.label]
     164            set styles [$xmlobj get $path.xaxis.$elem.style]
     165            lappend _xmarkers [list $at $label $styles]
     166        }
     167        foreach elem [$xmlobj children -type "marker" $path.yaxis] {
     168            set at     [$xmlobj get $path.yaxis.$elem.at]
     169            set label  [$xmlobj get $path.yaxis.$elem.label]
     170            set styles [$xmlobj get $path.yaxis.$elem.style]
     171            lappend _ymarkers [list $at $label $styles]
     172        }
     173    }
     174
     175    # ------------------------------------------------------------------
     176    # EXPORT: xml
     177    # ------------------------------------------------------------------
    145178    export xml {xmlobj path} {
    146179        foreach cname [array names _xvecs] {
    … …  
    158191    }
    159192
     193    # ------------------------------------------------------------------
     194    # COMPARE
     195    # ------------------------------------------------------------------
    160196    compare {
    161197        if {[array size _xvecs] != [array size _xvecs2]} {
    162 puts "components: [array size _xvecs] vs [array size _xvecs2]"
    163198            return 1  ;# different numbers of components
    164199        }
    165200        foreach cname [array names _xvecs] cname2 [array names _xvecs2] {
    166 puts "checking component $cname..."
    167201            # take a quick look at the x vector
    168202            set xvlen [$_xvecs($cname) length]
    169 puts "  x-lengths: [$_xvecs($cname) length] [$_xvecs2($cname2) length]"
    170203            if {$xvlen != [$_xvecs2($cname2) length]} {
    171 puts "  different lengths"
    172204                return 1  ;# different lengths of this component
    173205            }
    … …  
    175207            # take a quick look at the y vector
    176208            set yvlen [$_yvecs($cname) length]
    177 puts "  y-lengths: [$_yvecs($cname) length] [$_yvecs2($cname2) length]"
    178209            if {$yvlen != [$_yvecs2($cname2) length]} {
    179 puts "  different lengths"
    180210                return 1  ;# different lengths of this component
    181211            }
    … …  
    184214            set xv $_xvecs($cname)
    185215            set xv2 $_xvecs2($cname2)
    186 puts "  comparing: $xv vs $xv2"
    187216            set scale [blt::vector expr {0.5*(abs(max($xv)-min($xv))
    188217                + abs(max($xv2)-min($xv2)))}]
    … …  
    197226            set yv $_yvecs($cname)
    198227            set yv2 $_yvecs2($cname2)
    199 puts "  comparing: $yv vs $yv2"
    200228            set scale [blt::vector expr {0.5*(abs(max($yv)-min($yv))
    201229                + abs(max($yv2)-min($yv2)))}]
    … …  
    209237        return 0  ;# same!
    210238    }
     239
     240    # ------------------------------------------------------------------
     241    # USAGE: components ?<pattern>?
     242    #
     243    # Returns a list of names for the various components of this
     244    # curve.  If the optional glob-style <pattern> is specified, then
     245    # it returns only the component names matching the pattern.
     246    # ------------------------------------------------------------------
     247    method components {{pattern *}} {
     248        set rlist ""
     249        foreach cname [array names _xvecs] {
     250            if {[string match $pattern $cname]} {
     251                lappend rlist $cname
     252            }
     253        }
     254        return $rlist
     255    }
     256
     257    # ------------------------------------------------------------------
     258    # USAGE: mesh <name>
     259    #
     260    # Returns the xvec for the specified curve component <name>.
     261    # ------------------------------------------------------------------
     262    method mesh {cname} {
     263        if {[info exists _xvecs($cname)]} {
     264            return $_xvecs($cname)  ;# return xv
     265        }
     266        error "bad option \"$cname\": should be [join [lsort [array names _xvecs]] {, }]"
     267    }
     268
     269    # ------------------------------------------------------------------
     270    # USAGE: values <name>
     271    #
     272    # Returns the yvec for the specified curve component <name>.
     273    # ------------------------------------------------------------------
     274    method values {cname} {
     275        if {[info exists _yvecs($cname)]} {
     276            return $_yvecs($cname)  ;# return yv
     277        }
     278        error "bad option \"$cname\": should be [join [lsort [array names _yvecs]] {, }]"
     279    }
     280
     281    # ------------------------------------------------------------------
     282    # USAGE: limits x|xlin|xlog|y|ylin|ylog
     283    #
     284    # Returns the {min max} limits for the specified axis.
     285    # ------------------------------------------------------------------
     286    method limits {which} {
     287        set min ""
     288        set max ""
     289        switch -- $which {
     290            x - xlin { set pos 0; set log 0; set axis xaxis }
     291            xlog { set pos 0; set log 1; set axis xaxis }
     292            y - ylin - v - vlin { set pos 1; set log 0; set axis yaxis }
     293            ylog - vlog { set pos 1; set log 1; set axis yaxis }
     294            default {
     295                error "bad option \"$which\": should be x, xlin, xlog, y, ylin, ylog, v, vlin, vlog"
     296            }
     297        }
     298
     299        blt::vector create tmp zero
     300        foreach comp [array names _xvecs] {
     301            set arrvar [lindex {_xvecs _yvecs} $pos]
     302            set vname [set ${arrvar}($comp)]
     303            $vname variable vec
     304
     305            if {$log} {
     306                # on a log scale, use abs value and ignore 0's
     307                $vname dup tmp
     308                $vname dup zero
     309                zero expr {tmp == 0}            ;# find the 0's
     310                tmp expr {abs(tmp)}             ;# get the abs value
     311                tmp expr {tmp + zero*max(tmp)}  ;# replace 0's with abs max
     312                set vmin [blt::vector expr min(tmp)]
     313                set vmax [blt::vector expr max(tmp)]
     314            } else {
     315                set vmin $vec(min)
     316                set vmax $vec(max)
     317            }
     318
     319            if {"" == $min} {
     320                set min $vmin
     321            } elseif {$vmin < $min} {
     322                set min $vmin
     323            }
     324            if {"" == $max} {
     325                set max $vmax
     326            } elseif {$vmax > $max} {
     327                set max $vmax
     328            }
     329        }
     330        blt::vector destroy tmp zero
     331
     332        set val [attr get min]
     333        if {$val ne "" && $min ne ""} {
     334            if {$val > $min} {
     335                # tool specified this min -- don't go any lower
     336                set min $val
     337            }
     338        }
     339
     340        set val [attr get max]
     341        if {$val ne "" && $max ne ""} {
     342            if {$val < $max} {
     343                # tool specified this max -- don't go any higher
     344                set max $val
     345            }
     346        }
     347
     348        return [list $min $max]
     349    }
     350
     351    # ------------------------------------------------------------------
     352    # USAGE: xmarkers
     353    #
     354    # Returns the list of settings for each marker on the x-axis.
     355    # If no markers have been specified the empty string is returned.
     356    # ------------------------------------------------------------------
     357    method xmarkers {} {
     358        return $_xmarkers
     359    }
     360
     361    # ------------------------------------------------------------------
     362    # USAGE: ymarkers
     363    #
     364    # Returns the list of settings for each marker on the y-axis.
     365    # If no markers have been specified the empty string is returned.
     366    # ------------------------------------------------------------------
     367    method ymarkers {} {
     368        return $_ymarkers
     369    }
     370
     371    # ------------------------------------------------------------------
     372    # USAGE: hints ?keyword?
     373    #
     374    # This has been replaced by the "attrs" method in the ObjVal
     375    # base class, but is provided here for backward-compatibility
     376    # with the XyResult viewer.
     377    #
     378    # With no args, it returns a list of keywords and corresponding
     379    # values for all attributes in this object.  If a particular
     380    # keyword is specified, then it returns the value for that
     381    # attribute.  There are a few more "hints" defined here beyond
     382    # the object attributes.
     383    # ------------------------------------------------------------------
     384    method hints {{keyword ""}} {
     385        # first time through, build all of these hint values
     386        if {![info exists _hints]} {
     387            # start with all of the usual attributes
     388            foreach key [attr get] {
     389                set _hints($key) [attr get $key]
     390            }
     391
     392            # tweak them a little to produce the values needed for XyResult
     393            if {[info exists _hints(xlabel)] && "" != $_hints(xlabel)
     394                  && [info exists _hints(xunits)] && "" != $_hints(xunits)} {
     395                set _hints(xlabel) "$_hints(xlabel) ($_hints(xunits))"
     396            }
     397            if {[info exists _hints(ylabel)] && "" != $_hints(ylabel)
     398                  && [info exists _hints(yunits)] && "" != $_hints(yunits)} {
     399                set _hints(ylabel) "$_hints(ylabel) ($_hints(yunits))"
     400            }
     401
     402            if {[info exists _hints(group)] && [info exists _hints(label)]} {
     403                # pop-up help for each curve
     404                set _hints(tooltip) $_hints(label)
     405            }
     406        }
     407        if {$keyword != ""} {
     408            if {[info exists _hints($keyword)]} {
     409                return $_hints($keyword)
     410            }
     411            return ""
     412        }
     413        return [array get _hints]
     414    }
    211415}

  • trunk/lang/tcl/scripts/objects/integer/integer.rp

    r2134 r2138  
    3131
    3232    import xml {xmlobj path} {
     33        attr import $xmlobj $path
    3334        import_string [$xmlobj get $path.current]
    3435    }

  • trunk/lang/tcl/scripts/objects/number/number.rp

    r2134 r2138  
    8585
    8686    import xml {xmlobj path} {
    87         set units [getAttr units $xmlobj $path]
    88         import_string [$xmlobj get $path.current] $units
     87        attr import $xmlobj $path
     88        import_string [$xmlobj get $path.current] [attr get units]
    8989    }
    9090

  • trunk/lang/tcl/scripts/objects/string/string.rp

    r2134 r2138  
    1313
    1414    import xml {xmlobj path} {
     15        attr import $xmlobj $path
    1516        import_string [$xmlobj get $path.current]
    1617    }
Note: See TracChangeset for help on using the changeset viewer.