Changeset 2136 for trunk/tester/scripts


Ignore:
Timestamp:
Mar 14, 2011, 11:05:14 AM (14 years ago)
Author:
mmc
Message:

Regression tester is mostly working now, although it doesn't bring up
visualizers to plot the difference in output values. It does show
attribute differences and text differences for string results. It
also diffs the input side of the test and provides warnings when the
test seems out of date with respect to the tool definition.

Location:
trunk/tester/scripts
Files:
9 added
4 edited

Legend:

Unmodified
Added
Removed

  • trunk/tester/scripts/Makefile.in

    r2081 r2136  
    1919FILES           = \
    2020                $(srcdir)/main.tcl \
     21                $(srcdir)/objview.tcl \
    2122                $(srcdir)/resultspage.tcl \
    2223                $(srcdir)/statuslist.tcl \
     24                $(srcdir)/stringdiffs.tcl \
    2325                $(srcdir)/test.tcl \
    2426                $(srcdir)/testtree.tcl \

  • trunk/tester/scripts/main.tcl

    r2087 r2136  
    4343option add *Switch.textBackground white
    4444option add *Progress.barColor #ffffcc
     45option add *Diffview.background white
    4546option add *Balloon.titleBackground #6666cc
    4647option add *Balloon.titleForeground white
    … …  
    5859option add *BugReport*banner*font -*-helvetica-bold-r-normal-*-18-*
    5960
     61option add *testdiffs.hd*background #666666
     62option add *testdiffs.hd*highlightBackground #666666
     63option add *testdiffs.hd*foreground white
     64option add *testdiffs.hd.inner.highlightBackground #999999
     65option add *testdiffs.hd.inner*font {Arial -12 bold}
     66option add *testdiffs.hd.inner*help.font {Arial -10 italic}
     67option add *testdiffs.hd.inner*help.padX 2
     68option add *testdiffs.hd.inner*help.padY 2
     69option add *testdiffs.hd.inner*help.borderWidth 1
     70option add *testdiffs.hd.inner*help.relief flat
     71option add *testdiffs.hd.inner*help.overRelief raised
     72option add *testdiffs.legend*font {Arial -12}
     73
    6074switch $tcl_platform(platform) {
    6175    unix - windows {
    … …  
    7286# fix the "grab" command to support a stack of grab windows
    7387Rappture::grab::init
     88
     89# bring in the Rappture object system
     90Rappture::objects::init
    7491
    7592# add the local image directory onto the path
    … …  
    143160    "If this test result differs from the established test case, you would normally fix your tool to produce the correct result.  In some cases, however, your updated tool may be producing different, but correct, results.  In those cases, you can press this button to update the test itself to use the current output as the new golden standard for this test case."
    144161
    145 button $win.testview.bbar.viewoutputs -text "View outputs" -state disabled \
    146     -command tester_view_outputs
    147 pack $win.testview.bbar.viewoutputs -side right
    148 Rappture::Tooltip::for $win.testview.bbar.viewoutputs \
    149     "Display the outputs for this test case as they would be seen when running the tool normally.  If the test has completed with no error, the new results can be compared against the set of golden results."
    150 
    151162pack $win.testview.bbar -side bottom -fill x
    152163
    … …  
    162173pack $win.testview.details.scrl -expand yes -fill both
    163174Rappture::Tester::StatusList $win.testview.details.scrl.list \
    164     -selectcommand tester_diff_show
     175    -viewcommand tester_diff_show
    165176$win.testview.details.scrl contents $win.testview.details.scrl.list
    166177
    … …  
    180191$win.testrun.scrl contents $win.testrun.scrl.info
    181192
    182 # Frame for viewing outputs
     193# Frame for viewing diffs
    183194# ---------------------------------------------------------------------
    184 frame $win.testoutput
    185 Rappture::ResultsPage $win.testoutput.rp
    186 pack $win.testoutput.rp -expand yes -fill both
    187 button $win.testoutput.back -text "Back" -command tester_selection_changed
    188 pack $win.testoutput.back -side bottom -anchor e -pady {8 0}
    189 Rappture::Tooltip::for $win.testoutput.back \
    190     "Return to the previous window displaying the details for this test case."
     195frame .testdiffs -borderwidth 10 -relief flat
     196
     197# header at the top with info about the diff, help, and close button
     198frame .testdiffs.hd -borderwidth 4 -relief flat
     199pack .testdiffs.hd -side top -fill x
     200frame .testdiffs.hd.inner -highlightthickness 1 -borderwidth 2 -relief flat
     201pack .testdiffs.hd.inner -expand yes -fill both
     202button .testdiffs.hd.inner.close -relief flat -overrelief raised \
     203    -bitmap [Rappture::icon dismiss] -command tester_diff_hide
     204pack .testdiffs.hd.inner.close -side right -padx 8
     205label .testdiffs.hd.inner.title -compound left -anchor w -padx 8
     206pack .testdiffs.hd.inner.title -side left
     207button .testdiffs.hd.inner.help -anchor w -text "Help..." \
     208    -command "::Rappture::Tooltip::tooltip show .testdiffs.hd.inner.help +10,0"
     209pack .testdiffs.hd.inner.help -side left -padx 10
     210
     211# show add/deleted styles at the bottom
     212frame .testdiffs.legend
     213pack .testdiffs.legend -side bottom -fill x
     214frame .testdiffs.legend.line -height 1 -background black
     215pack .testdiffs.legend.line -side top -fill x -pady {0 2}
     216label .testdiffs.legend.lleg -text "Legend: "
     217pack .testdiffs.legend.lleg -side left
     218frame .testdiffs.legend.add -width 16 -height 16 -borderwidth 1 -relief solid
     219pack .testdiffs.legend.add -side left -padx {6 0}
     220label .testdiffs.legend.addl -text "= Added"
     221pack .testdiffs.legend.addl -side left
     222frame .testdiffs.legend.del -width 16 -height 16 -borderwidth 1 -relief solid
     223pack .testdiffs.legend.del -side left -padx {10 0}
     224label .testdiffs.legend.dell -text "= Deleted"
     225pack .testdiffs.legend.dell -side left
     226
     227# diff viewer goes in this spot
     228frame .testdiffs.body
     229pack .testdiffs.body -expand yes -fill both -padx 10 -pady {20 10}
     230
     231# viewer for attribute diffs
     232Rappture::Tester::ObjView .testdiffs.body.attrs
     233
     234# viewer for value diffs where object is extra or missing
     235frame .testdiffs.body.val
     236Rappture::Tester::ObjView .testdiffs.body.val.obj -details max -showdiffs no
     237pack .testdiffs.body.val.obj -expand yes -fill both
     238
     239# viewer for value diffs where we have just one string
     240frame .testdiffs.body.val1str
     241Rappture::Tester::ObjView .testdiffs.body.val1str.obj \
     242    -details min -showdiffs no
     243pack .testdiffs.body.val1str.obj -side top -fill x
     244label .testdiffs.body.val1str.l -text "Value:"
     245pack .testdiffs.body.val1str.l -anchor w -padx 10 -pady {10 0}
     246Rappture::Scroller .testdiffs.body.val1str.scrl \
     247    -xscrollmode auto -yscrollmode auto
     248pack .testdiffs.body.val1str.scrl -expand yes -fill both -padx 10 -pady {0 10}
     249text .testdiffs.body.val1str.scrl.text -width 10 -height 1 -wrap char
     250.testdiffs.body.val1str.scrl contents .testdiffs.body.val1str.scrl.text
     251
     252# viewer for value diffs where we have two strings but no special viewers
     253frame .testdiffs.body.val2strs
     254Rappture::Tester::ObjView .testdiffs.body.val2strs.obj \
     255    -details min -showdiffs no
     256pack .testdiffs.body.val2strs.obj -side top -fill x
     257Rappture::Tester::StringDiffs .testdiffs.body.val2strs.diffs \
     258    -title1 "Expected this:" -title2 "Got this:"
     259pack .testdiffs.body.val2strs.diffs -expand yes -fill both -padx 10 -pady 10
     260
     261# plug the proper diff colors into the legend area
     262.testdiffs.legend.add configure \
     263    -background [.testdiffs.body.attrs cget -addedbackground]
     264.testdiffs.legend.del configure \
     265    -background [.testdiffs.body.attrs cget -deletedbackground]
    191266
    192267# Load all tests in the test directory
    … …  
    250325            set testobj [lindex $tests 0]
    251326            $testview.details.scrl.list delete 0 end
    252             foreach {op path what v1 v2} [$testobj getDiffs] {
    253                 switch -- [lindex $what 0] {
     327            foreach rec [$testobj getDiffs] {
     328                catch {unset diff}
     329                array set diff $rec
     330
     331                set section [string totitle [lindex [split $diff(-path) .] 0]]
     332                set title "$section: [$testobj getTestInfo $diff(-path).about.label]"
     333                set desc ""
     334                set help ""
     335
     336                set difftype [lindex $diff(-what) 0]
     337                set op [lindex $diff(-what) 1]
     338                switch -- $difftype {
    254339                  value {
    255                     set title "Output: [$testobj getTestInfo $path.about.label]"
    256                     set icon [Rappture::icon fail16]
    257                     switch -- $op {
    258                       - { set desc "Result is missing from current output" }
    259                       + { set desc "Result was not expected to appear" }
    260                       c { set desc "Result differs from expected value" }
    261                       default {
    262                           error "don't know how to handle difference $op"
    263                       }
     340                    if {$section eq "Output"} {
     341                        set icon [Rappture::icon fail16]
     342                        switch -- $op {
     343                          - {
     344                              set desc "Result is missing from current output"
     345                              set help "This result was defined in the test case, but was missing from the output from the current test run.  Perhaps the tool is not producing the result as it should, or else the latest version of the tool no longer produces that result and the test case needs to be updated."
     346                          }
     347                          + {
     348                              set desc "Result was not expected to appear"
     349                              set help "The test run contained a result that was not part of the expected output.  Perhaps the tool is not supposed to produce that result, or else the latest version produces a new result and the test case needs to be updated."
     350                          }
     351                          c {
     352                              set desc "Result differs from expected value"
     353                              set help "The result from the test run doesn't match the expected result in the test case.  The tool should be fixed to produce the expected result.  If you can verify that the tool is working correctly, then the test case should be updated to contain this new result."
     354                          }
     355                          default {
     356                            error "don't know how to handle difference $op"
     357                          }
     358                        }
     359                    } elseif {$section eq "Input"} {
     360                        set icon [Rappture::icon warn16]
     361                        switch -- $op {
     362                          - {
     363                              set desc "Test case doesn't specify this input value"
     364                              set help "The test case is missing a setting for this input value that appears in the current tool definition.  Is this a new input that was recently added to the tool?  If so, the test case should be updated."
     365                          }
     366                          + {
     367                              set desc "Test case has this extra input value"
     368                              set help "The test case has an extra input value that does not appear in the current tool definition.  Was this input recently removed from the tool?  If so, the test case should be updated."
     369                          }
     370                          c {
     371                              # don't give a warning in this case
     372                              # input is supposed to be different from tool.xml
     373                          }
     374                          default {
     375                            error "don't know how to handle difference $op"
     376                          }
     377                        }
    264378                    }
    265379                  }
    266                   structure {
    267                     set ppath [lindex $what 1]
    268                     set title "Output: [$testobj getTestInfo $ppath.about.label]"
    269                     set icon [Rappture::icon warn16]
    270                     set pplen [string length $ppath]
    271                     set tail [string range $path [expr {$pplen+1}] end]
    272                     switch -- $op {
    273                       - { set desc "Missing value \"$v1\" at $tail" }
    274                       + { set desc "Extra value \"$v2\" at $tail" }
    275                       c { set desc "Details at $tail have changed:\n       got: $v2\n  expected: $v1" }
    276                       default {
    277                           error "don't know how to handle difference $op"
    278                       }
     380                  attrs {
     381                    if {$section eq "Output"} {
     382                        set icon [Rappture::icon warn16]
     383                        set desc "Details about this result have changed"
     384                        set help "The test run produced an output with slightly different information.  This may be as simple as a change in the label or description, or as serious as a change in the physical system of units.  Perhaps the tool is producing the wrong output, or else the tool has been modified and the test case needs to be updated."
     385                    } elseif {$section eq "Input"} {
     386                        set icon [Rappture::icon warn16]
     387                        set help "The test run contains an input with slightly different information.  This may be as simple as a change in the label or description, or as serious as a change in the physical system of units.  Perhaps this input has been modified in the latest version of the tool and the test case is outdated."
     388                    }
     389                  }
     390                  type {
     391                    if {$section eq "Output"} {
     392                        set icon [Rappture::icon fail16]
     393                        set desc "Result has the wrong type"
     394                        set help "The test run contains an output that is completely different from what was expected--not even the same type of object.  The tool should be fixed to produce the expected result.  If you can verify that the tool is working correctly, then the test case should be updated to contain this new result."
     395                    } elseif {$section eq "Input"} {
     396                        set icon [Rappture::icon warn16]
     397                        set desc "Input value has a different type"
     398                        set help "The test run contains an output that is completely different from what was expected--not even the same type of object.  The tool should be fixed to produce the expected result.  If you can verify that the tool is working correctly, then the test case should be updated to contain this new result."
     399                        set help "The test run contains an input value that is completely different from the corresponding input defined in the test case.  Was this input recently modified in the tool?  If so, the test case should be updated."
    279400                    }
    280401                  }
    … …  
    285406
    286407                # add to the list of differences
    287                 $testview.details.scrl.list insert end \
    288                     -title $title -subtitle $path -body $desc \
    289                     -icon $icon -clientdata $testobj
     408                if {$desc ne ""} {
     409                    $testview.details.scrl.list insert end \
     410                        -title $title -subtitle $diff(-path) \
     411                        -icon $icon -body $desc -help $help \
     412                        -clientdata [linsert $rec 0 -testobj $testobj]
     413                }
    290414            }
    291415
    … …  
    294418            pack forget $testview.details $testview.bbar.regoldenize
    295419        }
    296     }
    297 
    298     # Show/hide the show outputs button
    299     if {[llength $tests] == 1} {
    300         $testview.bbar.viewoutputs configure -state normal
    301         pack $testview.bbar.viewoutputs -side right
    302     } else {
    303         $testview.bbar.viewoutputs configure -state disabled
    304         pack forget $testview.bbar.viewoutputs
    305420    }
    306421}
    … …  
    398513# ----------------------------------------------------------------------
    399514proc tester_diff_show {args} {
    400     puts "SHOW DETAIL: $args"
     515    global Viewers
     516
     517    set testtree [.pw pane 0].tree
     518    set rhs [.pw pane 1]
     519    set testview $rhs.testview
     520
     521    # show the test data in the header -- doesn't accept the -index, though
     522    array set data $args
     523puts "SHOW: [array get data]"
     524    .testdiffs.hd.inner.title configure -image $data(-icon) -text $data(-body)
     525
     526    #
     527    # Figure out how to visualize the difference.
     528    #
     529    array set diff $data(-clientdata)
     530
     531    if {[info exists data(-help)]} {
     532        Rappture::Tooltip::text .testdiffs.hd.inner.help $data(-help)
     533    } else {
     534        Rappture::Tooltip::text .testdiffs.hd.inner.help ""
     535    }
     536
     537    switch -glob -- $diff(-what) {
     538        "value +" {
     539            # get a string rep for the second value
     540            if {[catch {Rappture::objects::import $diff(-obj2) $diff(-path)} val2] == 0 && $val2 ne ""} {
     541                set status [$val2 export string str]
     542                if {[lindex $status 0]} {
     543                    set v2 $str
     544                }
     545                itcl::delete object $val2
     546            }
     547
     548            if {[info exists v2]} {
     549                # we have a value -- show it
     550                set win .testdiffs.body.val1str
     551                set bg [$win.obj cget -addedbackground]
     552                $win.obj configure -background $bg \
     553                    -testobj $diff(-testobj) -path $diff(-path)
     554                $win.scrl.text configure -state normal
     555                $win.scrl.text delete 1.0 end
     556                $win.scrl.text insert end $v2
     557                $win.scrl.text configure -state disabled -background $bg
     558            } else {
     559                # don't have a value -- show the attributes
     560                set win .testdiffs.body.val
     561                set bg [$win.obj cget -addedbackground]
     562                $win.obj configure -background $bg \
     563                    -testobj $diff(-testobj) -path $diff(-path)
     564            }
     565        }
     566        "value -" {
     567            # get a string rep for the first value
     568            if {[catch {Rappture::objects::import $diff(-obj1) $diff(-path)} val1] == 0 && $val1 ne ""} {
     569                set status [$val1 export string str]
     570                if {[lindex $status 0]} {
     571                    set v1 $str
     572                }
     573                itcl::delete object $val1
     574            }
     575
     576            if {[info exists v1]} {
     577                # we have a value -- show it
     578                set win .testdiffs.body.val1str
     579                set bg [$win.obj cget -deletedbackground]
     580                $win.obj configure -background $bg \
     581                    -testobj $diff(-testobj) -path $diff(-path)
     582                $win.scrl.text configure -state normal
     583                $win.scrl.text delete 1.0 end
     584                $win.scrl.text insert end $v1
     585                $win.scrl.text configure -state disabled -background $bg
     586            } else {
     587                # don't have a value -- show the attributes
     588                set win .testdiffs.body.val
     589                set bg [$win.obj cget -deletedbackground]
     590                $win.obj configure -background $bg \
     591                    -testobj $diff(-testobj) -path $diff(-path)
     592            }
     593        }
     594        "value c" {
     595            set win .testdiffs.body.val2strs
     596            set bg [lindex [$win.obj configure -background] 3]
     597           
     598            $win.obj configure -background $bg \
     599                -testobj $diff(-testobj) -path $diff(-path)
     600
     601            # get a string rep for the first value
     602            set v1 "???"
     603            if {[catch {Rappture::objects::import $diff(-obj1) $diff(-path)} val1] == 0 && $val1 ne ""} {
     604                set status [$val1 export string str]
     605                if {[lindex $status 0]} {
     606                    set v1 $str
     607                }
     608                itcl::delete object $val1
     609            }
     610
     611            # get a string rep for the second value
     612            set v2 "???"
     613            if {[catch {Rappture::objects::import $diff(-obj2) $diff(-path)} val2] == 0 && $val2 ne ""} {
     614                set status [$val2 export string str]
     615                if {[lindex $status 0]} {
     616                    set v2 $str
     617                }
     618                itcl::delete object $val2
     619            }
     620
     621            $win.diffs show $v1 $v2
     622        }
     623        "attrs *" {
     624            set win .testdiffs.body.attrs
     625            set bg [lindex [$win configure -background] 3]
     626            $win configure -testobj $diff(-testobj) -background $bg \
     627                -path $diff(-path) -details max -showdiffs yes
     628        }
     629        "type *" {
     630            error "don't know how to show type diffs"
     631        }
     632    }
     633    if {[pack slaves .testdiffs.body] ne $win} {
     634        foreach w [pack slaves .testdiffs.body] {
     635            pack forget $w
     636        }
     637        pack $win -expand yes -fill both
     638    }
     639
     640    # pop up the viewer
     641    place .testdiffs -x 0 -y 0 -anchor nw -relwidth 1 -relheight 1
     642    raise .testdiffs
     643}
     644
     645# ----------------------------------------------------------------------
     646# USAGE: tester_diff_hide
     647#
     648# Takes down the panel posted by tester_diff_show.
     649# ----------------------------------------------------------------------
     650proc tester_diff_hide {} {
     651    place forget .testdiffs
    401652}
    402653

  • trunk/tester/scripts/statuslist.tcl

    r2081 r2136  
    11# ----------------------------------------------------------------------
    2 #  COMPONENT: testview - display the results of a test
    3 #
    4 #  Entire right hand side of the regression tester.  Displays the
    5 #  golden test results, and compares them to the new results if the test
    6 #  has been run.  Also show tree representation of all inputs and
    7 #  outputs.  The -test configuration option is used to provide a Test
    8 #  object to display.
     2#  COMPONENT: statuslist - display differences within a test
     3#
     4#  This is the list of differences shown for a particular test failure.
     5#  Each line in this list shows an icon (error or warning) and some
     6#  details about the difference.  When you mouse over any entry, it
     7#  pops up a "View" button that will invoke the -viewcommand to pop up
     8#  a more detailed comparison.
    99# ======================================================================
    1010#  AUTHOR:  Michael McLennan, Purdue University
    … …  
    2727    public variable subtitle ""
    2828    public variable body ""
     29    public variable help ""
    2930    public variable icon ""
    3031    public variable clientdata ""
    … …  
    3940    itk_option define -titlefont titleFont Font ""
    4041    itk_option define -subtitlefont subTitleFont Font ""
    41     itk_option define -selectcommand selectCommand SelectCommand ""
     42    itk_option define -viewcommand viewCommand ViewCommand ""
    4243    itk_option define -selectbackground selectBackground Foreground ""
    4344
    … …  
    4950    public method size {} { return [llength $_entries] }
    5051    public method get {pos args}
     52    public method invoke {{index "current"}}
     53    public method view {{index "current"}}
    5154
    5255    public method xview {args} {
    … …  
    5861
    5962    protected method _redraw {}
    60     protected method _select {tag}
     63    protected method _motion {y}
    6164
    6265    private variable _dispatcher ""  ;# dispatcher for !events
    6366    private variable _entries ""     ;# list of status entries
     67    private variable _hover ""       ;# mouse is over item with this tag
    6468}
    6569
    … …  
    8084    pack $itk_component(listview) -expand yes -fill both
    8185
     86    # add binding so that each item reacts to mouseover events
     87    bind $itk_component(listview) <Motion> [itcl::code $this _motion %y]
     88
     89    # add binding for double-click-to-open
     90    bind $itk_component(listview) <Double-Button-1> [itcl::code $this view]
     91
     92    # this pops up on each entry
     93    itk_component add view {
     94        button $itk_interior.view -text "View"
     95    } {
     96        usual
     97        rename -highlightbackground -selectbackground selectBackground Foreground
     98    }
     99
    82100    eval itk_initialize $args
    83101}
    … …  
    125143}
    126144
     145# ----------------------------------------------------------------------
     146# USAGE: get <pos> ?-key?
     147#
     148# Queries information about a particular entry at index <pos>.  With
     149# no extra args, it returns a list of "-key value -key value ..."
     150# representing all of the data about that entry.  Otherwise, the value
     151# for a particular -key can be requested.
     152# ----------------------------------------------------------------------
     153itcl::body Rappture::Tester::StatusList::get {pos {option ""}} {
     154    set obj [lindex $_entries $pos]
     155    if {$obj eq ""} {
     156        return ""
     157    }
     158    if {$option eq ""} {
     159        set vlist ""
     160        foreach opt [$obj configure] {
     161            lappend vlist [lindex $opt 0] [lindex $opt end]
     162        }
     163        return $vlist
     164    }
     165    return [$obj cget $option]
     166}
     167
     168# ----------------------------------------------------------------------
     169# USAGE: view ?<index>?
     170#
     171# Handles the action of clicking the "View" button on items in the
     172# status list.  Invokes the -viewcommand to pop up a more detailed
     173# view of the item.  Additional details about the item are appended
     174# onto the command as a list of options and values.  These include
     175# the integer -index for the position of the selected item, along
     176# with details defined when the item was inserted into the list.
     177# ----------------------------------------------------------------------
     178itcl::body Rappture::Tester::StatusList::view {{index "current"}} {
     179    if {$index eq "current"} {
     180        set index $_hover
     181    }
     182    if {[string length $itk_option(-viewcommand)] > 0
     183          && [string is integer -strict $index]} {
     184
     185        set obj [lindex $_entries $index]
     186        set vlist ""
     187        if {$obj ne ""} {
     188            foreach opt [$obj configure] {
     189                lappend vlist [lindex $opt 0] [lindex $opt end]
     190            }
     191        }
     192        uplevel #0 $itk_option(-viewcommand) -index $index $vlist
     193    }
     194}
    127195
    128196# ----------------------------------------------------------------------
    … …  
    163231            set iconh [image height $icon]
    164232        }
    165         set x1 [expr {$x0+$iw+3}]
     233        set x1 [expr {$x0+$iw+6}]
    166234        set y1 $y0
    167235
    168236        set title [$obj cget -title]
    169237        if {$title ne ""} {
    170             $c create text $x1 $y1 -anchor nw -text $title \
     238            $c create text [expr {$x1-4}] $y1 -anchor nw -text $title \
    171239                -font $itk_option(-titlefont) -tags [list $tag main]
    172240            set y1 [expr {$y1+$tlineh+2}]
    … …  
    202270        $c lower $id
    203271
    204         foreach item [list $tag $tag:bg] {
    205             $c bind $item <ButtonPress> \
    206                 [itcl::code $this _select $tag]
    207         }
    208 
    209272        set y0 [expr {$y1+10}]
    210273        incr n
    … …  
    212275
    213276    # set the scrolling region to the "main" part (no bg boxes)
     277    set x1 0; set y1 0
    214278    foreach {x0 y0 x1 y1} [$c bbox main] break
    215279    $c configure -scrollregion [list 0 0 [expr {$x1+4}] [expr {$y1+4}]]
    … …  
    217281
    218282# ----------------------------------------------------------------------
    219 # USAGE: _select <tag>
    220 #
    221 # Called internally when the user clicks on an item in the status
    222 # list that shows specific test failures.  Highlights the item and
    223 # invokes any -statuscommand configured for the widget.  Additional
    224 # details about the item are appended onto the command as a list of
    225 # options and values.  These include the integer -index for the
    226 # position of the selected item, along with details defined when
    227 # the item was inserted into the list.
    228 # ----------------------------------------------------------------------
    229 itcl::body Rappture::Tester::StatusList::_select {tag} {
     283# USAGE: _motion <y>
     284#
     285# Called internally when the user moves the mouse over an item in the
     286# status list that shows specific test failures.  Highlights the item
     287# and posts a "View" button on the right-hand side of the list.
     288# ----------------------------------------------------------------------
     289itcl::body Rappture::Tester::StatusList::_motion {y} {
    230290    set c $itk_component(listview)
    231     $c itemconfigure allbg -fill ""
    232     $c itemconfigure $tag:bg -fill $itk_option(-selectbackground)
    233 
    234     if {[string length $itk_option(-selectcommand)] > 0} {
    235         set id ""; regexp {[0-9]+$} $tag id
    236         set vlist ""
    237         set obj [lindex $_entries $id]
    238         if {$obj ne ""} {
    239             foreach opt [$obj configure] {
    240                 lappend vlist [lindex $opt 0] [lindex $opt end]
     291
     292    set index ""
     293    foreach id [$c find overlapping 10 $y 10 $y] {
     294        foreach tag [$c gettags $id] {
     295            if {[regexp {^entry([0-9]+)} $tag match n]} {
     296                set index $n
     297                break
    241298            }
    242299        }
    243         uplevel #0 $itk_option(-selectcommand) -index $id $vlist
    244     }
    245 }
     300        if {$index ne ""} {
     301            break
     302        }
     303    }
     304
     305    if {$index ne $_hover} {
     306        $c itemconfigure allbg -fill ""
     307        $c delete viewbtn
     308
     309        if {$index ne ""} {
     310            set tag "entry$index:bg"
     311            $c itemconfigure $tag -fill $itk_option(-selectbackground)
     312
     313            foreach {x0 y0 x1 y1} [$c bbox $tag] break
     314            set w [winfo width $c]
     315            $c create window [expr {$w-10}] [expr {($y0+$y1)/2}] \
     316                -anchor e -window $itk_component(view) -tags viewbtn
     317
     318            $itk_component(view) configure \
     319                -command [itcl::code $this view $index]
     320        }
     321        set _hover $index
     322    }
     323}

  • trunk/tester/scripts/test.tcl

    r2086 r2136  
    2323
    2424    public method getResult {}
    25     public method getTestInfo {path}
    26     public method getDiffs {}
     25    public method getTestInfo {args}
     26    public method getDiffs {args}
    2727
    2828    public method getRunobj {}
    … …  
    4444    private method _setResult {name}
    4545    private method _computeDiffs {obj1 obj2 args}
    46     private method _getStructure {xmlobj path}
    4746
    4847    # use this to add tests to the "run" queue
    … …  
    9897# ----------------------------------------------------------------------
    9998# USAGE: getTestInfo <path>
     99# USAGE: getTestInfo children <path>
     100# USAGE: getTestInfo element ?-as type? <path>
    100101#
    101102# Returns info about the Test case at the specified <path> in the XML.
    … …  
    103104# instead of an error.
    104105# ----------------------------------------------------------------------
    105 itcl::body Rappture::Tester::Test::getTestInfo {path} {
    106     return [$_testobj get $path]
     106itcl::body Rappture::Tester::Test::getTestInfo {args} {
     107    if {[llength $args] == 1} {
     108        set path [lindex $args 0]
     109        return [$_testobj get $path]
     110    }
     111    return [eval $_testobj $args]
    107112}
    108113
    … …  
    142147        } elseif {[Rappture::library isvalid $result]} {
    143148            set _runobj $result
    144             set _diffs [_computeDiffs $_testobj $_runobj -section output]
     149            set idiffs [_computeDiffs [$_toolobj xml] $_testobj -in input]
     150            set odiffs [_computeDiffs $_testobj $_runobj -in output]
     151            set _diffs [concat $idiffs $odiffs]
    145152puts "DIFFS:"
    146 foreach {op path what v1 v2} $_diffs {
    147 puts "  $op $path ($what) $v1 $v2"
     153foreach rec $_diffs {
     154puts ">> $rec"
    148155}
    149156
    … …  
    201208
    202209# ----------------------------------------------------------------------
    203 # USAGE: getDiffs
    204 #
    205 # Returns a list of paths that exist in both the golden and new results,
    206 # but contain data that does not match according to the compareElements
    207 # method.  Throws an error if the test has not been run.
    208 # ----------------------------------------------------------------------
    209 itcl::body Rappture::Tester::Test::getDiffs {} {
    210     return $_diffs
     210# USAGE: getDiffs ?<path>?
     211#
     212# With no extra args, this returns a list of paths that differ between
     213# the golden and new results--either because the data values are
     214# different, or because elements are missing or their attributes have
     215# changed.
     216#
     217# If a particular <path> is specified, then detailed diffs are returned
     218# for that path.  This is useful for "structure" diffs, where many
     219# things may be different within a single object.
     220# ----------------------------------------------------------------------
     221itcl::body Rappture::Tester::Test::getDiffs {args} {
     222    if {[llength $args] == 0} {
     223        return $_diffs
     224    } elseif {[llength $args] != 1} {
     225        error "wrong # args: should be \"getDiffs ?path?\""
     226    }
     227
     228    set path [lindex $args 0]
     229    if {[string match input.* $path]} {
     230        # if we're matching input, compare the original XML vs. the test
     231        return [_computeDiffs [$_toolobj xml] $_testobj -in $path -detail max]
     232    }
     233
     234    # otherwise, compare the golden test vs. the test result
     235    return [_computeDiffs $_testobj $_runobj -in $path -detail max]
    211236}
    212237
    … …  
    274299
    275300# ----------------------------------------------------------------------
    276 # USAGE: _computeDiffs <xmlObj1> <xmlObj2> ?-section xxx? \
    277 #            ?-what value|structure|all?
     301# USAGE: _computeDiffs <xmlObj1> <xmlObj2> ?-in xxx? \
     302#            ?-what value|attrs|all? ?-detail min|max?
    278303#
    279304# Used internally to compute differences between two different XML
    280 # objects.  This is normally used to look for differences in the
    281 # output section between a test case and a new run, but can also
    282 # be used to look for differences in other sections via the -section
    283 # flag.
     305# objects.  This is normally used to look for differences between an
     306# entire test case and a new run, but can also be used to look at
     307# differences within a particular section or element via the -in flag.
    284308#
    285309# Returns a list of the following form:
    286 #     <op> <path> <what> <val1> <val2>
    287 #
    288 #       where <op> is one of:
    289 #         - ...... element is missing from <xmlObj2>
    290 #         c ...... element changed between <xmlObj1> and <xmlObj2>
    291 #         + ...... element is missing from <xmlObj1>
    292 #
    293 #       and <what> is something like:
    294 #         value .............. difference affects "current" value
    295 #         structure <path> ... affects structure of parent at <path>
     310#     -what <diff> -path <path> -obj1 <xmlobj> -obj2 <xmlobj> \
     311#           -v1 <value1> -v2 <value2>
     312#
     313#       where <diff> is one of:
     314#         value - ....... element is missing from <xmlObj2>
     315#         value c ....... element changed between <xmlObj1> and <xmlObj2>
     316#         value + ....... element is missing from <xmlObj1>
     317#         attrs c ....... attributes are different <xmlObj1> and <xmlObj2>
     318#         type c ........ object types are different <xmlObj1> and <xmlObj2>
     319#         attr - <path>.. attribute at <path> is missing from <xmlObj2>
     320#         attr + <path>.. attribute at <path> is missing from <xmlObj1>
     321#         attr c <path>.. attribute at <path> changed between objects
    296322# ----------------------------------------------------------------------
    297323itcl::body Rappture::Tester::Test::_computeDiffs {obj1 obj2 args} {
    298324    Rappture::getopts args params {
    299         value -section output
     325        value -in output
    300326        value -what all
     327        value -detail min
    301328    }
    302329    if {$params(-what) == "all"} {
    303         set params(-what) "structure value"
    304     }
    305 
    306     # query the values for all entities in both objects
    307     set v1paths [Rappture::entities $obj1 $params(-section)]
    308     set v2paths [Rappture::entities $obj2 $params(-section)]
    309 
    310     # scan through values for obj1 and compare against obj2
     330        set params(-what) "attrs value"
     331    }
     332
     333    # scan through the specified sections or paths
    311334    set rlist ""
    312     foreach path $v1paths {
    313 puts "checking $path"
    314         set i [lsearch -exact $v2paths $path]
    315         if {$i < 0} {
    316 puts "  missing from $obj2"
    317             # missing from obj2
    318             foreach {raw norm} [Rappture::LibraryObj::value $obj1 $path] break
    319             lappend rlist - $path value $raw ""
     335    foreach elem $params(-in) {
     336        if {[string first . $elem] >= 0} {
     337            set v1paths $elem
     338            set v2paths $elem
    320339        } else {
    321             foreach part $params(-what) {
    322                 switch -- $part {
    323                   value {
    324                     foreach {raw1 norm1} \
    325                         [Rappture::LibraryObj::value $obj1 $path] break
    326                     foreach {raw2 norm2} \
    327                         [Rappture::LibraryObj::value $obj2 $path] break
    328 puts "  checking values $norm1 vs $norm2"
    329                     if {![string equal $norm1 $norm2]} {
    330 puts "  => different!"
    331                         # different from obj2
    332                         lappend rlist c $path value $raw1 $raw2
     340            # query the values for all entities in both objects
     341            set v1paths [Rappture::entities $obj1 $elem]
     342            set v2paths [Rappture::entities $obj2 $elem]
     343        }
     344
     345        # scan through values for obj1 and compare against obj2
     346        foreach path $v1paths {
     347            set details [list -path $path -obj1 $obj1 -obj2 $obj2]
     348
     349            set i [lsearch -exact $v2paths $path]
     350            if {$i < 0} {
     351                # missing from obj2
     352                lappend rlist [linsert $details 0 -what "value -"]
     353            } else {
     354                foreach part $params(-what) {
     355                    switch -- $part {
     356                      value {
     357                        set val1 [Rappture::objects::import $obj1 $path]
     358                        set val2 [Rappture::objects::import $obj2 $path]
     359                        lappend details -val1 $val1 -val2 $val2
     360
     361puts "COMPARE: $path $obj1 =?= $obj2"
     362puts "  $val1 =?= $val2"
     363                        if {$val1 eq "" || $val2 eq ""} {
     364                            lappend rlist [linsert $details 0 -what "value c"]
     365                        } elseif {[$val1 info class] != [$val2 info class]} {
     366                            lappend rlist [linsert $details 0 -what "value c"]
     367                        } elseif {[$val1 compare $val2] != 0} {
     368                            lappend rlist [linsert $details 0 -what "value c"]
     369                        } else {
     370                            itcl::delete object $val1 $val2
     371                        }
     372                        # handled this comparison
     373                        set v2paths [lreplace $v2paths $i $i]
     374                      }
     375                      attrs {
     376                        set what [list structure $path]
     377                        set type1 [$obj1 element -as type $path]
     378                        set type2 [$obj2 element -as type $path]
     379                        if {$type1 eq $type2} {
     380                          set same yes
     381                          set alist [Rappture::objects::get $type1 -attributes]
     382                          foreach rec $alist {
     383                              array set attr [lrange $rec 1 end]
     384                              set apath $path.$attr(-path)
     385                              set v1 [$obj1 get $apath]
     386                              set v2 [$obj2 get $apath]
     387                              set dt [linsert $details end -v1 $v1 -v2 $v2]
     388
     389                              if {$v2 eq "" && $v1 ne ""} {
     390                                  # missing from obj2
     391                                  if {$params(-detail) == "max"} {
     392                                      lappend rlist [linsert $dt 0 -what [list attr - $attr(-path)]]
     393                                  } else {
     394                                      set same no
     395                                      break
     396                                  }
     397                              } elseif {$v1 eq "" && $v2 ne ""} {
     398                                  # missing from obj1
     399                                  if {$params(-detail) == "max"} {
     400                                      lappend rlist [linsert $dt 0 -what [list attr + $attr(-path)]]
     401                                  } else {
     402                                      set same no
     403                                      break
     404                                  }
     405                              } elseif {$v1 ne $v2} {
     406                                  # different from obj2
     407                                  if {$params(-detail) == "max"} {
     408                                      lappend rlist [linsert $dt 0 -what [list attr c $attr(-path)]]
     409                                  } else {
     410                                      set same no
     411                                      break
     412                                  }
     413                              }
     414                          }
     415                          if {$params(-detail) == "min" && !$same} {
     416                              lappend details -what attrs
     417                              lappend rlist [linsert $dt 0 -what "attrs c"]
     418                          }
     419                        } else {
     420                          lappend details -val1 $type1 -val2 $type2
     421                          lappend rlist [linsert $details 0 -what "type c"]
     422                        }
     423                      }
     424                      default {
     425                        error "bad part \"$part\": should be attrs, value"
     426                      }
    333427                    }
    334                     # handled this comparison
    335                     set v2paths [lreplace $v2paths $i $i]
    336                   }
    337                   structure {
    338                     set what [list structure $path]
    339                     set s1paths [_getStructure $obj1 $path]
    340                     set s2paths [_getStructure $obj2 $path]
    341                     foreach spath $s1paths {
    342 puts "  checking internal structure $spath"
    343                         set i [lsearch -exact $s2paths $spath]
    344                         if {$i < 0} {
    345 puts "    missing from $obj2"
    346                             # missing from obj2
    347                             set val1 [$obj1 get $spath]
    348                             lappend rlist - $spath $what $val1 ""
    349                         } else {
    350                             set val1 [$obj1 get $spath]
    351                             set val2 [$obj2 get $spath]
    352                             if {![string match $val1 $val2]} {
    353 puts "    different from $obj2 ($val1 vs $val2)"
    354                                 # different from obj2
    355                                 lappend rlist c $spath $what $val1 $val2
    356                             }
    357                             # handled this comparison
    358                             set s2paths [lreplace $s2paths $i $i]
    359                         }
    360                     }
    361 
    362                     # look for leftover values
    363                     foreach spath $s2paths {
    364                         set val2 [$obj2 get $spath]
    365 puts "    extra $spath in $obj2"
    366                         lappend rlist + $spath $what "" $val2
    367                     }
    368                   }
    369                   default {
    370                     error "bad part \"$part\": should be structure, value"
    371                   }
    372                 }
    373             }
    374         }
    375     }
    376 
    377     # add any values left over in the obj2
    378     foreach path $v2paths {
    379 puts "    extra $path in $obj2"
    380         foreach {raw2 norm2} [Rappture::LibraryObj::value $obj2 $path] break
    381         lappend rlist + $path value "" $raw2
    382     }
    383     return $rlist
    384 }
    385 
    386 # ----------------------------------------------------------------------
    387 # USAGE: _getStructure <xmlObj> <path>
    388 #
    389 # Used internally by _computeDiffs to get a list of paths for important
    390 # parts of the internal structure of an object.  Avoids the "current"
    391 # element, but includes "default", "units", etc.
    392 # ----------------------------------------------------------------------
    393 itcl::body Rappture::Tester::Test::_getStructure {xmlobj path} {
    394     set rlist ""
    395     set queue $path
    396     while {[llength $queue] > 0} {
    397         set qpath [lindex $queue 0]
    398         set queue [lrange $queue 1 end]
    399 
    400         foreach p [$xmlobj children -as path $qpath] {
    401             if {[string match *.current $p]} {
    402                 continue
    403             }
    404             if {[llength [$xmlobj children $p]] > 0} {
    405                 # continue exploring nodes with children
    406                 lappend queue $p
    407             } else {
    408                 # return the terminal nodes
    409                 lappend rlist $p
    410             }
     428                }
     429            }
     430        }
     431
     432        # add any values left over in the obj2
     433        foreach path $v2paths {
     434            set details [list -path $path -obj1 $obj1 -obj2 $obj2]
     435            lappend rlist [linsert $details 0 -what "value +"]
    411436        }
    412437    }
Note: See TracChangeset for help on using the changeset viewer.