Changeset 2138 for trunk/lang


Ignore:
Timestamp:
Mar 18, 2011 8:42:59 AM (13 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
Files:
2 added
7 edited

Legend:

Unmodified
Added
Removed

  • trunk/lang/tcl/scripts/Makefile.in

    r2081 r2138  
    7575        $(TCLSH) $(srcdir)/../tclconfig/mkindex.tcl --srcdir $(srcdir) \
    7676                --outfile tclIndex
     77        $(TCLSH) $(srcdir)/../tclconfig/mkobjects.tcl --srcdir $(srcdir) \
     78                $(OBJECTS)
    7779
    7880install: tclIndex

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

    r2134 r2138  
    5656    $attrParser alias help Rappture::objects::parse_help
    5757    $attrParser alias import Rappture::objects::parse_import
     58    $attrParser alias method Rappture::objects::parse_method
    5859    $attrParser alias palettes Rappture::objects::parse_palettes
    5960    $attrParser alias storage Rappture::objects::parse_storage
    … …  
    6162    $attrParser alias unknown Rappture::objects::parse_attr_unknown
    6263    proc ::Rappture::objects::parse_attr_unknown {args} {
    63         error "bad option \"[lindex $args 0]\": should be attr, check, clear, compare, export, help, import, palettes, storage, terminal"
     64        error "bad option \"[lindex $args 0]\": should be attr, check, clear, compare, export, help, import, method, palettes, storage, terminal"
    6465    }
    6566
    … …  
    181182    }
    182183
     184    set name [string tolower $name]  ;# doesn't matter: Tool or tool
    183185    if {![info exists objDefs($name)]} {
    184186        error "bad object type \"$name\": should be one of [join [lsort [array names objDefs]] {, }]"
    185187    }
    186188
    187     set name [string tolower $name]  ;# doesn't matter: Tool or tool
    188189    set info(-image) [$objDefs($name) cget -image]
    189190    set info(-help) [$objDefs($name) cget -help]
    … …  
    207208        set olist [lrange $olist 1 end]
    208209
    209         foreach aname [$obj get] {
    210             lappend rlist [$obj get $aname]
     210        foreach aname [$obj getAttr] {
     211            lappend rlist [$obj getAttr $aname]
    211212        }
    212213    }
    … …  
    244245    # can't seem to load anything -- return null
    245246    itcl::delete object $obj
     247    return ""
     248}
     249
     250# ----------------------------------------------------------------------
     251# USAGE: Rappture::objects::viewer <objVal>|<objDef>|<type> \
     252    ?-for input|output? ?-parent win?
     253#
     254# Used to find/create a viewer for the given object.  The object can
     255# be specified by an ObjVal object, an ObjDef object definition, or
     256# a string name <type>.  The -for flag indicates whether the viewer
     257# widget is for input or output.  The -parent indicates the parent
     258# containing the widget.  If the widget already exists, it is returned
     259# directly.  Otherwise, it is created and returned.
     260# ----------------------------------------------------------------------
     261proc Rappture::objects::viewer {what args} {
     262    variable objDefs
     263
     264    # figure out the name of the desired object type
     265    if {[catch {$what isa ::Rappture::objects::ObjVal} valid] == 0 && $valid} {
     266        set type [[$what definition] type]
     267    } elseif {[catch {$what isa ::Rappture::objects::ObjDef} valid] == 0
     268                        && $valid} {
     269        set type [$what type]
     270    } else {
     271        set type [string tolower $what]  ;# doesn't matter: Number or number
     272        if {![info exists objDefs($type)]} {
     273            error "bad object type \"$type\": should be one of [join [lsort [array names objDefs]] {, }]"
     274        }
     275    }
     276
     277    # process additional options
     278    array set opt {
     279        -for output
     280        -parent "."
     281    }
     282    foreach {key val} $args {
     283        if {![info exists opt($key)]} {
     284            error "bad option \"$key\": should be [join [array names opt] {, }]"
     285        }
     286        set opt($key) $val
     287    }
     288    if {![winfo exists $opt(-parent)]} {
     289        error "bad parent window \"$opt(-parent)\""
     290    }
     291    if {$opt(-parent) eq "."} {
     292        set opt(-parent) ""  ;# avoid ".." below when we say: $parent.foo
     293    }
     294    if {[lsearch {input output} $opt(-for)] < 0} {
     295        error "bad value \"$opt(-for)\": should be input, output"
     296    }
     297
     298    # build the class name and widget name:
     299    #   class: Rappture::objects::CurveOutput
     300    #  widget: .foo.bar.curveOutput
     301    set which [string totitle $opt(-for)]
     302    set class "::Rappture::objects::[string totitle $type]$which"
     303    set win "$opt(-parent).v$type$opt(-for)"
     304
     305    if {[winfo exists $win]} {
     306        return $win
     307    }
     308    if {[catch {$class $win} err] == 0} {
     309        return $win
     310    }
    246311    return ""
    247312}
    … …  
    335400        import ""
    336401        export ""
    337     }
    338 
    339     set currObjDef [Rappture::objects::ObjDef ::#auto -inherit $ilist]
     402        method ""
     403    }
     404
     405    set currObjDef [Rappture::objects::ObjDef ::#auto $name -inherit $ilist]
    340406
    341407    set cmds {
    … …  
    362428        append ovdefn "public method clear {} [list $currObjValDef(clear)]\n"
    363429        append ovdefn "public method definition {} {return $currObjDef}\n"
     430
     431        # define extra methods added specially to this object
     432        foreach mn $currObjValDef(method) {
     433            append ovdefn [list public method $mn $currObjValDef(m-$mn-arglist) $currObjValDef(m-$mn-body)] "\n"
     434        }
    364435
    365436        append ovdefn [format "private method importTypes {} { return %s }\n" [list $currObjValDef(import)]]
    … …  
    592663
    593664# ----------------------------------------------------------------------
     665# PARSER:  Rappture::objects::parse_method
     666#
     667# Used internally to parse the definition of an object method within
     668# a Rappture object definition:
     669#
     670#   method <name> <arglist> <body>
     671#
     672# A method is an extra function supported by this object, used to
     673# query or modify the object value (usually by the GUI viewer).
     674# The <arglist> defines the arguments to the method, and the <body>
     675# is the body of code invoked to implement the method.
     676# ----------------------------------------------------------------------
     677proc Rappture::objects::parse_method {name arglist body} {
     678    variable currObjValDef
     679
     680    set i [lsearch $currObjValDef(method) $name]
     681    if {$i >= 0} {
     682        error "method \"$name\" already defined"
     683    }
     684    lappend currObjValDef(method) $name
     685    set currObjValDef(m-$name-arglist) $arglist
     686    set currObjValDef(m-$name-body) $body
     687}
     688
     689# ----------------------------------------------------------------------
    594690# PARSER:  Rappture::objects::parse_palettes
    595691#
    … …  
    660756    public variable palettes ""
    661757
    662     constructor {args} {
     758    constructor {type args} {
     759        set _type $type
    663760        set _checks(num) 0
    664761        eval configure $args
     762    }
     763
     764    public method type {} {
     765        return $_type
    665766    }
    666767
    … …  
    687788    }
    688789
    689     public method get {{name ""}} {
    690         if {"" == $name} {
    691             return $_attrs
    692         } elseif {[info exists _attr2def($name)]} {
     790    public method getAttr {args} {
     791        if {[llength $args] == 0} {
     792            set rlist ""
     793            foreach baseobj [cget -inherit] {
     794                eval lappend rlist [$baseobj getAttr]
     795            }
     796            eval lappend rlist $_attrs
     797            return $rlist
     798        } elseif {[llength $args] > 2} {
     799            error "wrong # args: should be \"getAttrs ?name? ?-part?\""
     800        }
     801
     802        set name [lindex $args 0]
     803        set part [lindex $args 1]
     804
     805        # handle attributes defined right in this class
     806        if {[info exists _attr2def($name)]} {
    693807            set rlist $name
    694808            foreach opt [$_attr2def($name) configure] {
     809                if {[lindex $opt 0] eq $part} {
     810                    return [lindex $opt 2]
     811                }
    695812                lappend rlist [lindex $opt 0] [lindex $opt 2]
    696813            }
    697814            return $rlist
    698815        }
     816
     817        # handle attributes defined in a base class
     818        foreach baseobj [cget -inherit] {
     819            set rval [eval $baseobj getAttr $name $part]
     820            if {$rval ne ""} {
     821                return $rval
     822            }
     823        }
     824        return ""
    699825    }
    700826
    … …  
    718844    }
    719845
     846    private variable _type ""   ;# type name (lowercase) for object type
    720847    private variable _attrs ""  ;# list of attr names in order
    721848    private variable _attr2def  ;# maps attr name => ObjAttr object
    … …  
    742869# ----------------------------------------------------------------------
    743870itcl::class Rappture::objects::ObjVal {
     871    public method definition {} { # returns the ObjDef class for this value }
     872
     873    public method attr {option args} {
     874        switch -- $option {
     875            get {
     876                if {[llength $args] == 0} {
     877                    return [[$this definition] getAttr]
     878                } elseif {[llength $args] == 1} {
     879                    set name [lindex $args 0]
     880                    if {[catch {[$this definition] getAttr $name}]} {
     881                        error "attribute \"$name\" not defined on $this"
     882                    }
     883                    if {[info exists attr($name)]} {
     884                        return $attr($name)
     885                    }
     886                    return ""
     887                } else {
     888                    error "wrong # args: should be \"attr get ?name?\""
     889                }
     890            }
     891            set {
     892                if {[llength $args] != 2} {
     893                    error "wrong # args: should be \"attr set name value\""
     894                }
     895                set name [lindex $args 0]
     896                set val [lindex $args 1]
     897                if {[catch {[$this definition] getAttr $name}] == 0} {
     898                    set attr($name) $val
     899                }
     900                return $val
     901            }
     902            info {
     903                if {[llength $args] == 1} {
     904                    set name [lindex $args 0]
     905                    return [[$this definition] getAttr $name]
     906                } else {
     907                    error "wrong # args: should be \"attr info name\""
     908                }
     909            }
     910            import {
     911                if {[llength $args] != 2} {
     912                    error "wrong # args: should be \"attr import xmlobj path\""
     913                }
     914                set xmlobj [lindex $args 0]
     915                set path [lindex $args 1]
     916
     917                set odef [$this definition]
     918                foreach name [$odef getAttr] {
     919                    set tail [$odef getAttr $name -path]
     920                    set apath $path.$tail
     921                    if {[$xmlobj element -as type $apath] ne ""} {
     922                        set attr($name) [$xmlobj get $apath]
     923                    }
     924                }
     925            }
     926            export {
     927                if {[llength $args] != 2} {
     928                    error "wrong # args: should be \"attr export xmlobj path\""
     929                }
     930                set xmlobj [lindex $args 0]
     931                set path [lindex $args 1]
     932
     933                set odef [$this definition]
     934                foreach name [$odef getAttr] {
     935                    if {[info exists attr($name)]} {
     936                        set tail [$odef getAttr $name -path]
     937                        $xmlobj put $path.$tail $attr($name)
     938                    }
     939                }
     940            }
     941            default {
     942                error "bad option \"$option\": should be get, set, info, import, export"
     943            }
     944        }
     945    }
     946    protected variable attr  ;# maps attribute name => value
     947
    744948    public method clear {} { # nothing to do for base class }
    745949
    … …  
    779983        }
    780984        return [concat 0 $errs]
    781     }
    782 
    783     # use this to query the current attribute value from an XML definition
    784     public method getAttr {name xmlobj path} {
    785         array set attr [lrange [[$this definition] get $name] 1 end]
    786 puts "getAttr: [$xmlobj get $path.$attr(-path)] at $xmlobj $path.$attr(-path)"
    787         return [$xmlobj get $path.$attr(-path)]
    788985    }
    789986

  • 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.