Changeset 2136

Timestamp:

Mar 14, 2011 11:05:14 AM (13 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

Files:

• example/fermi_broken.tcl (modified) (1 diff)
• example/tests/test3.xml (modified) (2 diffs)
• example/tests/test6.xml (modified) (2 diffs)
• scripts/Makefile.in (modified) (1 diff)
• scripts/images/blue-fwd-dep.png (added)
• scripts/images/blue-fwd-dis.png (added)
• scripts/images/blue-fwd.png (added)
• scripts/images/blue-rev-dep.png (added)
• scripts/images/blue-rev-dis.png (added)
• scripts/images/blue-rev.png (added)
• scripts/main.tcl (modified) (10 diffs)
• scripts/objview.tcl (added)
• scripts/statusheader.tcl (added)
• scripts/statuslist.tcl (modified) (11 diffs)
• scripts/stringdiffs.tcl (added)
• scripts/test.tcl (modified) (7 diffs)

trunk/tester/example/fermi_broken.tcl

@@ -34 +34 @@
 after 1000
 puts "making some progress"
-after 1000
+after 2000
 puts "done"
 Rappture::Utils::progress 10 -mesg "Starting, for real now."

trunk/tester/example/tests/test3.xml

@@ -3 +3 @@
     <test>
         <label>helium|0eV</label>
+        <description>Tests the Fermi-Dirac function at liquid helium temperatures, where the distribution is relatively sharp.  Should match in spite of the sharp distribution change, which is nearly a step function at this temperature.</description>
     </test>
     <tool>
@@ -55 +56 @@
         <curve id="f12">
             <about>
-                <label>Fermi-Dirac Factor</label>
+                <label>Fermi-Dirac Statistics</label>
             </about>
-            <xaxis>
-                <label>Fermi-Dirac Factor</label>
-            </xaxis>
             <yaxis>
                 <label>Energy</label>

trunk/tester/example/tests/test6.xml

@@ -3 +3 @@
     <test>
         <label>roomtemp|1V</label>
+        <description>This test should generate a warning due to differences in the input parameters.</description>
     </test>
     <tool>
@@ -50 +51 @@
             <current>1eV</current>
         </number>
+        <boolean id="extra">
+            <about>
+                <label>Control value</label>
+                <description>Old parameter that was removed.</description>
+            </about>
+            <default>true</default>
+        </boolean>
     </input>
     <output>
+        <number id="extra">
+            <about>
+                <label>Extra number in output</label>
+            </about>
+            <current>1234</current>
+        </number>
         <curve id="f12">
             <about>

trunk/tester/scripts/Makefile.in

@@ -19 +19 @@
 FILES           = \
                 $(srcdir)/main.tcl \
+                $(srcdir)/objview.tcl \
                 $(srcdir)/resultspage.tcl \
                 $(srcdir)/statuslist.tcl \
+                $(srcdir)/stringdiffs.tcl \
                 $(srcdir)/test.tcl \
                 $(srcdir)/testtree.tcl \

trunk/tester/scripts/main.tcl

@@ -43 +43 @@
 option add *Switch.textBackground white
 option add *Progress.barColor #ffffcc
+option add *Diffview.background white
 option add *Balloon.titleBackground #6666cc
 option add *Balloon.titleForeground white
@@ -58 +59 @@
 option add *BugReport*banner*font -*-helvetica-bold-r-normal-*-18-*
 
+option add *testdiffs.hd*background #666666
+option add *testdiffs.hd*highlightBackground #666666
+option add *testdiffs.hd*foreground white
+option add *testdiffs.hd.inner.highlightBackground #999999
+option add *testdiffs.hd.inner*font {Arial -12 bold}
+option add *testdiffs.hd.inner*help.font {Arial -10 italic}
+option add *testdiffs.hd.inner*help.padX 2
+option add *testdiffs.hd.inner*help.padY 2
+option add *testdiffs.hd.inner*help.borderWidth 1
+option add *testdiffs.hd.inner*help.relief flat
+option add *testdiffs.hd.inner*help.overRelief raised
+option add *testdiffs.legend*font {Arial -12}
+
 switch $tcl_platform(platform) {
     unix - windows {
@@ -72 +86 @@
 # fix the "grab" command to support a stack of grab windows
 Rappture::grab::init
+
+# bring in the Rappture object system
+Rappture::objects::init
 
 # add the local image directory onto the path
@@ -143 +160 @@
     "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."
 
-button $win.testview.bbar.viewoutputs -text "View outputs" -state disabled \
-    -command tester_view_outputs
-pack $win.testview.bbar.viewoutputs -side right 
-Rappture::Tooltip::for $win.testview.bbar.viewoutputs \
-    "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."
-
 pack $win.testview.bbar -side bottom -fill x
 
@@ -162 +173 @@
 pack $win.testview.details.scrl -expand yes -fill both
 Rappture::Tester::StatusList $win.testview.details.scrl.list \
-    -selectcommand tester_diff_show
+    -viewcommand tester_diff_show
 $win.testview.details.scrl contents $win.testview.details.scrl.list
 
@@ -180 +191 @@
 $win.testrun.scrl contents $win.testrun.scrl.info
 
-# Frame for viewing outputs
+# Frame for viewing diffs
 # ---------------------------------------------------------------------
-frame $win.testoutput
-Rappture::ResultsPage $win.testoutput.rp
-pack $win.testoutput.rp -expand yes -fill both
-button $win.testoutput.back -text "Back" -command tester_selection_changed
-pack $win.testoutput.back -side bottom -anchor e -pady {8 0}
-Rappture::Tooltip::for $win.testoutput.back \
-    "Return to the previous window displaying the details for this test case."
+frame .testdiffs -borderwidth 10 -relief flat
+
+# header at the top with info about the diff, help, and close button
+frame .testdiffs.hd -borderwidth 4 -relief flat
+pack .testdiffs.hd -side top -fill x
+frame .testdiffs.hd.inner -highlightthickness 1 -borderwidth 2 -relief flat
+pack .testdiffs.hd.inner -expand yes -fill both
+button .testdiffs.hd.inner.close -relief flat -overrelief raised \
+    -bitmap [Rappture::icon dismiss] -command tester_diff_hide
+pack .testdiffs.hd.inner.close -side right -padx 8
+label .testdiffs.hd.inner.title -compound left -anchor w -padx 8
+pack .testdiffs.hd.inner.title -side left
+button .testdiffs.hd.inner.help -anchor w -text "Help..." \
+    -command "::Rappture::Tooltip::tooltip show .testdiffs.hd.inner.help +10,0"
+pack .testdiffs.hd.inner.help -side left -padx 10
+
+# show add/deleted styles at the bottom
+frame .testdiffs.legend
+pack .testdiffs.legend -side bottom -fill x
+frame .testdiffs.legend.line -height 1 -background black
+pack .testdiffs.legend.line -side top -fill x -pady {0 2}
+label .testdiffs.legend.lleg -text "Legend: "
+pack .testdiffs.legend.lleg -side left
+frame .testdiffs.legend.add -width 16 -height 16 -borderwidth 1 -relief solid
+pack .testdiffs.legend.add -side left -padx {6 0}
+label .testdiffs.legend.addl -text "= Added"
+pack .testdiffs.legend.addl -side left
+frame .testdiffs.legend.del -width 16 -height 16 -borderwidth 1 -relief solid
+pack .testdiffs.legend.del -side left -padx {10 0}
+label .testdiffs.legend.dell -text "= Deleted"
+pack .testdiffs.legend.dell -side left
+
+# diff viewer goes in this spot
+frame .testdiffs.body
+pack .testdiffs.body -expand yes -fill both -padx 10 -pady {20 10}
+
+# viewer for attribute diffs
+Rappture::Tester::ObjView .testdiffs.body.attrs
+
+# viewer for value diffs where object is extra or missing
+frame .testdiffs.body.val
+Rappture::Tester::ObjView .testdiffs.body.val.obj -details max -showdiffs no
+pack .testdiffs.body.val.obj -expand yes -fill both
+
+# viewer for value diffs where we have just one string
+frame .testdiffs.body.val1str
+Rappture::Tester::ObjView .testdiffs.body.val1str.obj \
+    -details min -showdiffs no
+pack .testdiffs.body.val1str.obj -side top -fill x
+label .testdiffs.body.val1str.l -text "Value:"
+pack .testdiffs.body.val1str.l -anchor w -padx 10 -pady {10 0}
+Rappture::Scroller .testdiffs.body.val1str.scrl \
+    -xscrollmode auto -yscrollmode auto
+pack .testdiffs.body.val1str.scrl -expand yes -fill both -padx 10 -pady {0 10}
+text .testdiffs.body.val1str.scrl.text -width 10 -height 1 -wrap char
+.testdiffs.body.val1str.scrl contents .testdiffs.body.val1str.scrl.text
+
+# viewer for value diffs where we have two strings but no special viewers
+frame .testdiffs.body.val2strs
+Rappture::Tester::ObjView .testdiffs.body.val2strs.obj \
+    -details min -showdiffs no
+pack .testdiffs.body.val2strs.obj -side top -fill x
+Rappture::Tester::StringDiffs .testdiffs.body.val2strs.diffs \
+    -title1 "Expected this:" -title2 "Got this:"
+pack .testdiffs.body.val2strs.diffs -expand yes -fill both -padx 10 -pady 10
+
+# plug the proper diff colors into the legend area
+.testdiffs.legend.add configure \
+    -background [.testdiffs.body.attrs cget -addedbackground]
+.testdiffs.legend.del configure \
+    -background [.testdiffs.body.attrs cget -deletedbackground]
 
 # Load all tests in the test directory
@@ -250 +325 @@
             set testobj [lindex $tests 0]
             $testview.details.scrl.list delete 0 end
-            foreach {op path what v1 v2} [$testobj getDiffs] {
-                switch -- [lindex $what 0] {
+            foreach rec [$testobj getDiffs] {
+                catch {unset diff}
+                array set diff $rec
+
+                set section [string totitle [lindex [split $diff(-path) .] 0]]
+                set title "$section: [$testobj getTestInfo $diff(-path).about.label]"
+                set desc ""
+                set help ""
+
+                set difftype [lindex $diff(-what) 0]
+                set op [lindex $diff(-what) 1]
+                switch -- $difftype {
                   value {
-                    set title "Output: [$testobj getTestInfo $path.about.label]"
-                    set icon [Rappture::icon fail16]
-                    switch -- $op {
-                      - { set desc "Result is missing from current output" }
-                      + { set desc "Result was not expected to appear" }
-                      c { set desc "Result differs from expected value" }
-                      default {
-                          error "don't know how to handle difference $op"
-                      }
+                    if {$section eq "Output"} {
+                        set icon [Rappture::icon fail16]
+                        switch -- $op {
+                          - {
+                              set desc "Result is missing from current output"
+                              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."
+                          }
+                          + {
+                              set desc "Result was not expected to appear"
+                              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."
+                          }
+                          c {
+                              set desc "Result differs from expected value"
+                              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."
+                          }
+                          default {
+                            error "don't know how to handle difference $op"
+                          }
+                        }
+                    } elseif {$section eq "Input"} {
+                        set icon [Rappture::icon warn16]
+                        switch -- $op {
+                          - {
+                              set desc "Test case doesn't specify this input value"
+                              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."
+                          }
+                          + {
+                              set desc "Test case has this extra input value"
+                              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."
+                          }
+                          c {
+                              # don't give a warning in this case
+                              # input is supposed to be different from tool.xml
+                          }
+                          default {
+                            error "don't know how to handle difference $op"
+                          }
+                        }
                     }
                   }
-                  structure {
-                    set ppath [lindex $what 1]
-                    set title "Output: [$testobj getTestInfo $ppath.about.label]"
-                    set icon [Rappture::icon warn16]
-                    set pplen [string length $ppath]
-                    set tail [string range $path [expr {$pplen+1}] end]
-                    switch -- $op {
-                      - { set desc "Missing value \"$v1\" at $tail" }
-                      + { set desc "Extra value \"$v2\" at $tail" }
-                      c { set desc "Details at $tail have changed:\n       got: $v2\n  expected: $v1" }
-                      default {
-                          error "don't know how to handle difference $op"
-                      }
+                  attrs {
+                    if {$section eq "Output"} {
+                        set icon [Rappture::icon warn16]
+                        set desc "Details about this result have changed"
+                        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."
+                    } elseif {$section eq "Input"} {
+                        set icon [Rappture::icon warn16]
+                        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."
+                    }
+                  }
+                  type {
+                    if {$section eq "Output"} {
+                        set icon [Rappture::icon fail16]
+                        set desc "Result has the wrong type"
+                        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."
+                    } elseif {$section eq "Input"} {
+                        set icon [Rappture::icon warn16]
+                        set desc "Input value has a different type"
+                        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."
+                        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."
                     }
                   }
@@ -285 +406 @@
 
                 # add to the list of differences
-                $testview.details.scrl.list insert end \
-                    -title $title -subtitle $path -body $desc \
-                    -icon $icon -clientdata $testobj
+                if {$desc ne ""} {
+                    $testview.details.scrl.list insert end \
+                        -title $title -subtitle $diff(-path) \
+                        -icon $icon -body $desc -help $help \
+                        -clientdata [linsert $rec 0 -testobj $testobj]
+                }
             }
 
@@ -294 +418 @@
             pack forget $testview.details $testview.bbar.regoldenize
         }
-    }
-
-    # Show/hide the show outputs button
-    if {[llength $tests] == 1} {
-        $testview.bbar.viewoutputs configure -state normal
-        pack $testview.bbar.viewoutputs -side right
-    } else {
-        $testview.bbar.viewoutputs configure -state disabled
-        pack forget $testview.bbar.viewoutputs
     }
 }
@@ -398 +513 @@
 # ----------------------------------------------------------------------
 proc tester_diff_show {args} {
-    puts "SHOW DETAIL: $args"
+    global Viewers
+
+    set testtree [.pw pane 0].tree
+    set rhs [.pw pane 1]
+    set testview $rhs.testview
+
+    # show the test data in the header -- doesn't accept the -index, though
+    array set data $args
+puts "SHOW: [array get data]"
+    .testdiffs.hd.inner.title configure -image $data(-icon) -text $data(-body)
+
+    #
+    # Figure out how to visualize the difference.
+    #
+    array set diff $data(-clientdata)
+
+    if {[info exists data(-help)]} {
+        Rappture::Tooltip::text .testdiffs.hd.inner.help $data(-help)
+    } else {
+        Rappture::Tooltip::text .testdiffs.hd.inner.help ""
+    }
+
+    switch -glob -- $diff(-what) {
+        "value +" {
+            # get a string rep for the second value
+            if {[catch {Rappture::objects::import $diff(-obj2) $diff(-path)} val2] == 0 && $val2 ne ""} {
+                set status [$val2 export string str]
+                if {[lindex $status 0]} {
+                    set v2 $str
+                }
+                itcl::delete object $val2
+            }
+
+            if {[info exists v2]} {
+                # we have a value -- show it
+                set win .testdiffs.body.val1str
+                set bg [$win.obj cget -addedbackground]
+                $win.obj configure -background $bg \
+                    -testobj $diff(-testobj) -path $diff(-path)
+                $win.scrl.text configure -state normal
+                $win.scrl.text delete 1.0 end
+                $win.scrl.text insert end $v2
+                $win.scrl.text configure -state disabled -background $bg
+            } else {
+                # don't have a value -- show the attributes
+                set win .testdiffs.body.val
+                set bg [$win.obj cget -addedbackground]
+                $win.obj configure -background $bg \
+                    -testobj $diff(-testobj) -path $diff(-path)
+            }
+        }
+        "value -" {
+            # get a string rep for the first value
+            if {[catch {Rappture::objects::import $diff(-obj1) $diff(-path)} val1] == 0 && $val1 ne ""} {
+                set status [$val1 export string str]
+                if {[lindex $status 0]} {
+                    set v1 $str
+                }
+                itcl::delete object $val1
+            }
+
+            if {[info exists v1]} {
+                # we have a value -- show it
+                set win .testdiffs.body.val1str
+                set bg [$win.obj cget -deletedbackground]
+                $win.obj configure -background $bg \
+                    -testobj $diff(-testobj) -path $diff(-path)
+                $win.scrl.text configure -state normal
+                $win.scrl.text delete 1.0 end
+                $win.scrl.text insert end $v1
+                $win.scrl.text configure -state disabled -background $bg
+            } else {
+                # don't have a value -- show the attributes
+                set win .testdiffs.body.val
+                set bg [$win.obj cget -deletedbackground]
+                $win.obj configure -background $bg \
+                    -testobj $diff(-testobj) -path $diff(-path)
+            }
+        }
+        "value c" {
+            set win .testdiffs.body.val2strs
+            set bg [lindex [$win.obj configure -background] 3]
+            
+            $win.obj configure -background $bg \
+                -testobj $diff(-testobj) -path $diff(-path)
+
+            # get a string rep for the first value
+            set v1 "???"
+            if {[catch {Rappture::objects::import $diff(-obj1) $diff(-path)} val1] == 0 && $val1 ne ""} {
+                set status [$val1 export string str]
+                if {[lindex $status 0]} {
+                    set v1 $str
+                }
+                itcl::delete object $val1
+            }
+
+            # get a string rep for the second value
+            set v2 "???"
+            if {[catch {Rappture::objects::import $diff(-obj2) $diff(-path)} val2] == 0 && $val2 ne ""} {
+                set status [$val2 export string str]
+                if {[lindex $status 0]} {
+                    set v2 $str
+                }
+                itcl::delete object $val2
+            }
+
+            $win.diffs show $v1 $v2
+        }
+        "attrs *" {
+            set win .testdiffs.body.attrs
+            set bg [lindex [$win configure -background] 3]
+            $win configure -testobj $diff(-testobj) -background $bg \
+                -path $diff(-path) -details max -showdiffs yes
+        }
+        "type *" {
+            error "don't know how to show type diffs"
+        }
+    }
+    if {[pack slaves .testdiffs.body] ne $win} {
+        foreach w [pack slaves .testdiffs.body] {
+            pack forget $w
+        }
+        pack $win -expand yes -fill both
+    }
+
+    # pop up the viewer
+    place .testdiffs -x 0 -y 0 -anchor nw -relwidth 1 -relheight 1
+    raise .testdiffs
+}
+
+# ----------------------------------------------------------------------
+# USAGE: tester_diff_hide
+#
+# Takes down the panel posted by tester_diff_show.
+# ----------------------------------------------------------------------
+proc tester_diff_hide {} {
+    place forget .testdiffs
 }
 

trunk/tester/scripts/statuslist.tcl

@@ -1 +1 @@
 # ----------------------------------------------------------------------
-#  COMPONENT: testview - display the results of a test
-#
-#  Entire right hand side of the regression tester.  Displays the
-#  golden test results, and compares them to the new results if the test
-#  has been run.  Also show tree representation of all inputs and
-#  outputs.  The -test configuration option is used to provide a Test
-#  object to display.
+#  COMPONENT: statuslist - display differences within a test
+#
+#  This is the list of differences shown for a particular test failure.
+#  Each line in this list shows an icon (error or warning) and some
+#  details about the difference.  When you mouse over any entry, it
+#  pops up a "View" button that will invoke the -viewcommand to pop up
+#  a more detailed comparison.
 # ======================================================================
 #  AUTHOR:  Michael McLennan, Purdue University
@@ -27 +27 @@
     public variable subtitle ""
     public variable body ""
+    public variable help ""
     public variable icon ""
     public variable clientdata ""
@@ -39 +40 @@
     itk_option define -titlefont titleFont Font ""
     itk_option define -subtitlefont subTitleFont Font ""
-    itk_option define -selectcommand selectCommand SelectCommand ""
+    itk_option define -viewcommand viewCommand ViewCommand ""
     itk_option define -selectbackground selectBackground Foreground ""
 
@@ -49 +50 @@
     public method size {} { return [llength $_entries] }
     public method get {pos args}
+    public method invoke {{index "current"}}
+    public method view {{index "current"}}
 
     public method xview {args} {
@@ -58 +61 @@
 
     protected method _redraw {}
-    protected method _select {tag}
+    protected method _motion {y}
 
     private variable _dispatcher ""  ;# dispatcher for !events
     private variable _entries ""     ;# list of status entries
+    private variable _hover ""       ;# mouse is over item with this tag
 }
 
@@ -80 +84 @@
     pack $itk_component(listview) -expand yes -fill both
 
+    # add binding so that each item reacts to mouseover events
+    bind $itk_component(listview) <Motion> [itcl::code $this _motion %y]
+
+    # add binding for double-click-to-open
+    bind $itk_component(listview) <Double-Button-1> [itcl::code $this view]
+
+    # this pops up on each entry
+    itk_component add view {
+        button $itk_interior.view -text "View"
+    } {
+        usual
+        rename -highlightbackground -selectbackground selectBackground Foreground
+    }
+
     eval itk_initialize $args
 }
@@ -125 +143 @@
 }
 
+# ----------------------------------------------------------------------
+# USAGE: get <pos> ?-key?
+#
+# Queries information about a particular entry at index <pos>.  With
+# no extra args, it returns a list of "-key value -key value ..."
+# representing all of the data about that entry.  Otherwise, the value
+# for a particular -key can be requested.
+# ----------------------------------------------------------------------
+itcl::body Rappture::Tester::StatusList::get {pos {option ""}} {
+    set obj [lindex $_entries $pos]
+    if {$obj eq ""} {
+        return ""
+    }
+    if {$option eq ""} {
+        set vlist ""
+        foreach opt [$obj configure] {
+            lappend vlist [lindex $opt 0] [lindex $opt end]
+        }
+        return $vlist
+    }
+    return [$obj cget $option]
+}
+
+# ----------------------------------------------------------------------
+# USAGE: view ?<index>?
+#
+# Handles the action of clicking the "View" button on items in the
+# status list.  Invokes the -viewcommand to pop up a more detailed
+# view of the item.  Additional details about the item are appended
+# onto the command as a list of options and values.  These include
+# the integer -index for the position of the selected item, along
+# with details defined when the item was inserted into the list.
+# ----------------------------------------------------------------------
+itcl::body Rappture::Tester::StatusList::view {{index "current"}} {
+    if {$index eq "current"} {
+        set index $_hover
+    }
+    if {[string length $itk_option(-viewcommand)] > 0
+          && [string is integer -strict $index]} {
+
+        set obj [lindex $_entries $index]
+        set vlist ""
+        if {$obj ne ""} {
+            foreach opt [$obj configure] {
+                lappend vlist [lindex $opt 0] [lindex $opt end]
+            }
+        }
+        uplevel #0 $itk_option(-viewcommand) -index $index $vlist
+    }
+}
 
 # ----------------------------------------------------------------------
@@ -163 +231 @@
             set iconh [image height $icon]
         }
-        set x1 [expr {$x0+$iw+3}]
+        set x1 [expr {$x0+$iw+6}]
         set y1 $y0
 
         set title [$obj cget -title]
         if {$title ne ""} {
-            $c create text $x1 $y1 -anchor nw -text $title \
+            $c create text [expr {$x1-4}] $y1 -anchor nw -text $title \
                 -font $itk_option(-titlefont) -tags [list $tag main]
             set y1 [expr {$y1+$tlineh+2}]
@@ -202 +270 @@
         $c lower $id
 
-        foreach item [list $tag $tag:bg] {
-            $c bind $item <ButtonPress> \
-                [itcl::code $this _select $tag]
-        }
-
         set y0 [expr {$y1+10}]
         incr n
@@ -212 +275 @@
 
     # set the scrolling region to the "main" part (no bg boxes)
+    set x1 0; set y1 0
     foreach {x0 y0 x1 y1} [$c bbox main] break
     $c configure -scrollregion [list 0 0 [expr {$x1+4}] [expr {$y1+4}]]
@@ -217 +281 @@
 
 # ----------------------------------------------------------------------
-# USAGE: _select <tag>
-#
-# Called internally when the user clicks on an item in the status
-# list that shows specific test failures.  Highlights the item and
-# invokes any -statuscommand configured for the widget.  Additional
-# details about the item are appended onto the command as a list of
-# options and values.  These include the integer -index for the
-# position of the selected item, along with details defined when
-# the item was inserted into the list.
-# ----------------------------------------------------------------------
-itcl::body Rappture::Tester::StatusList::_select {tag} {
+# USAGE: _motion <y>
+#
+# Called internally when the user moves the mouse over an item in the
+# status list that shows specific test failures.  Highlights the item
+# and posts a "View" button on the right-hand side of the list.
+# ----------------------------------------------------------------------
+itcl::body Rappture::Tester::StatusList::_motion {y} {
     set c $itk_component(listview)
-    $c itemconfigure allbg -fill ""
-    $c itemconfigure $tag:bg -fill $itk_option(-selectbackground)
-
-    if {[string length $itk_option(-selectcommand)] > 0} {
-        set id ""; regexp {[0-9]+$} $tag id
-        set vlist ""
-        set obj [lindex $_entries $id]
-        if {$obj ne ""} {
-            foreach opt [$obj configure] {
-                lappend vlist [lindex $opt 0] [lindex $opt end]
+
+    set index ""
+    foreach id [$c find overlapping 10 $y 10 $y] {
+        foreach tag [$c gettags $id] {
+            if {[regexp {^entry([0-9]+)} $tag match n]} {
+                set index $n
+                break
             }
         }
-        uplevel #0 $itk_option(-selectcommand) -index $id $vlist
-    }
-}
+        if {$index ne ""} {
+            break
+        }
+    }
+
+    if {$index ne $_hover} {
+        $c itemconfigure allbg -fill ""
+        $c delete viewbtn
+
+        if {$index ne ""} {
+            set tag "entry$index:bg"
+            $c itemconfigure $tag -fill $itk_option(-selectbackground)
+
+            foreach {x0 y0 x1 y1} [$c bbox $tag] break
+            set w [winfo width $c]
+            $c create window [expr {$w-10}] [expr {($y0+$y1)/2}] \
+                -anchor e -window $itk_component(view) -tags viewbtn
+
+            $itk_component(view) configure \
+                -command [itcl::code $this view $index]
+        }
+        set _hover $index
+    }
+}

trunk/tester/scripts/test.tcl

@@ -23 +23 @@
 
     public method getResult {}
-    public method getTestInfo {path}
-    public method getDiffs {}
+    public method getTestInfo {args}
+    public method getDiffs {args}
 
     public method getRunobj {}
@@ -44 +44 @@
     private method _setResult {name}
     private method _computeDiffs {obj1 obj2 args}
-    private method _getStructure {xmlobj path}
 
     # use this to add tests to the "run" queue
@@ -98 +97 @@
 # ----------------------------------------------------------------------
 # USAGE: getTestInfo <path>
+# USAGE: getTestInfo children <path>
+# USAGE: getTestInfo element ?-as type? <path>
 # 
 # Returns info about the Test case at the specified <path> in the XML.
@@ -103 +104 @@
 # instead of an error.
 # ----------------------------------------------------------------------
-itcl::body Rappture::Tester::Test::getTestInfo {path} {
-    return [$_testobj get $path]
+itcl::body Rappture::Tester::Test::getTestInfo {args} {
+    if {[llength $args] == 1} {
+        set path [lindex $args 0]
+        return [$_testobj get $path]
+    }
+    return [eval $_testobj $args]
 }
 
@@ -142 +147 @@
         } elseif {[Rappture::library isvalid $result]} {
             set _runobj $result
-            set _diffs [_computeDiffs $_testobj $_runobj -section output]
+            set idiffs [_computeDiffs [$_toolobj xml] $_testobj -in input]
+            set odiffs [_computeDiffs $_testobj $_runobj -in output]
+            set _diffs [concat $idiffs $odiffs]
 puts "DIFFS:"
-foreach {op path what v1 v2} $_diffs {
-puts "  $op $path ($what) $v1 $v2"
+foreach rec $_diffs {
+puts ">> $rec"
 }
 
@@ -201 +208 @@
 
 # ----------------------------------------------------------------------
-# USAGE: getDiffs
-#
-# Returns a list of paths that exist in both the golden and new results,
-# but contain data that does not match according to the compareElements
-# method.  Throws an error if the test has not been run.
-# ----------------------------------------------------------------------
-itcl::body Rappture::Tester::Test::getDiffs {} {
-    return $_diffs
+# USAGE: getDiffs ?<path>?
+#
+# With no extra args, this returns a list of paths that differ between
+# the golden and new results--either because the data values are
+# different, or because elements are missing or their attributes have
+# changed.
+#
+# If a particular <path> is specified, then detailed diffs are returned
+# for that path.  This is useful for "structure" diffs, where many
+# things may be different within a single object.
+# ----------------------------------------------------------------------
+itcl::body Rappture::Tester::Test::getDiffs {args} {
+    if {[llength $args] == 0} {
+        return $_diffs
+    } elseif {[llength $args] != 1} {
+        error "wrong # args: should be \"getDiffs ?path?\""
+    }
+
+    set path [lindex $args 0]
+    if {[string match input.* $path]} {
+        # if we're matching input, compare the original XML vs. the test
+        return [_computeDiffs [$_toolobj xml] $_testobj -in $path -detail max]
+    }
+
+    # otherwise, compare the golden test vs. the test result
+    return [_computeDiffs $_testobj $_runobj -in $path -detail max]
 }
 
@@ -274 +299 @@
 
 # ----------------------------------------------------------------------
-# USAGE: _computeDiffs <xmlObj1> <xmlObj2> ?-section xxx? \
-#            ?-what value|structure|all?
+# USAGE: _computeDiffs <xmlObj1> <xmlObj2> ?-in xxx? \
+#            ?-what value|attrs|all? ?-detail min|max?
 #
 # Used internally to compute differences between two different XML
-# objects.  This is normally used to look for differences in the
-# output section between a test case and a new run, but can also
-# be used to look for differences in other sections via the -section
-# flag.
+# objects.  This is normally used to look for differences between an
+# entire test case and a new run, but can also be used to look at
+# differences within a particular section or element via the -in flag.
 #
 # Returns a list of the following form:
-#     <op> <path> <what> <val1> <val2>
-#
-#       where <op> is one of:
-#         - ...... element is missing from <xmlObj2>
-#         c ...... element changed between <xmlObj1> and <xmlObj2>
-#         + ...... element is missing from <xmlObj1>
-#
-#       and <what> is something like:
-#         value .............. difference affects "current" value 
-#         structure <path> ... affects structure of parent at <path>
+#     -what <diff> -path <path> -obj1 <xmlobj> -obj2 <xmlobj> \
+#           -v1 <value1> -v2 <value2>
+#
+#       where <diff> is one of:
+#         value - ....... element is missing from <xmlObj2>
+#         value c ....... element changed between <xmlObj1> and <xmlObj2>
+#         value + ....... element is missing from <xmlObj1>
+#         attrs c ....... attributes are different <xmlObj1> and <xmlObj2>
+#         type c ........ object types are different <xmlObj1> and <xmlObj2>
+#         attr - <path>.. attribute at <path> is missing from <xmlObj2>
+#         attr + <path>.. attribute at <path> is missing from <xmlObj1>
+#         attr c <path>.. attribute at <path> changed between objects
 # ----------------------------------------------------------------------
 itcl::body Rappture::Tester::Test::_computeDiffs {obj1 obj2 args} {
     Rappture::getopts args params {
-        value -section output
+        value -in output
         value -what all
+        value -detail min
     }
     if {$params(-what) == "all"} {
-        set params(-what) "structure value"
-    }
-
-    # query the values for all entities in both objects
-    set v1paths [Rappture::entities $obj1 $params(-section)]
-    set v2paths [Rappture::entities $obj2 $params(-section)]
-
-    # scan through values for obj1 and compare against obj2
+        set params(-what) "attrs value"
+    }
+
+    # scan through the specified sections or paths
     set rlist ""
-    foreach path $v1paths {
-puts "checking $path"
-        set i [lsearch -exact $v2paths $path]
-        if {$i < 0} {
-puts "  missing from $obj2"
-            # missing from obj2
-            foreach {raw norm} [Rappture::LibraryObj::value $obj1 $path] break
-            lappend rlist - $path value $raw ""
+    foreach elem $params(-in) {
+        if {[string first . $elem] >= 0} {
+            set v1paths $elem
+            set v2paths $elem
         } else {
-            foreach part $params(-what) {
-                switch -- $part {
-                  value {
-                    foreach {raw1 norm1} \
-                        [Rappture::LibraryObj::value $obj1 $path] break
-                    foreach {raw2 norm2} \
-                        [Rappture::LibraryObj::value $obj2 $path] break
-puts "  checking values $norm1 vs $norm2"
-                    if {![string equal $norm1 $norm2]} {
-puts "  => different!"
-                        # different from obj2
-                        lappend rlist c $path value $raw1 $raw2
+            # query the values for all entities in both objects
+            set v1paths [Rappture::entities $obj1 $elem]
+            set v2paths [Rappture::entities $obj2 $elem]
+        }
+
+        # scan through values for obj1 and compare against obj2
+        foreach path $v1paths {
+            set details [list -path $path -obj1 $obj1 -obj2 $obj2]
+
+            set i [lsearch -exact $v2paths $path]
+            if {$i < 0} {
+                # missing from obj2
+                lappend rlist [linsert $details 0 -what "value -"]
+            } else {
+                foreach part $params(-what) {
+                    switch -- $part {
+                      value {
+                        set val1 [Rappture::objects::import $obj1 $path]
+                        set val2 [Rappture::objects::import $obj2 $path]
+                        lappend details -val1 $val1 -val2 $val2
+
+puts "COMPARE: $path $obj1 =?= $obj2"
+puts "  $val1 =?= $val2"
+                        if {$val1 eq "" || $val2 eq ""} {
+                            lappend rlist [linsert $details 0 -what "value c"]
+                        } elseif {[$val1 info class] != [$val2 info class]} {
+                            lappend rlist [linsert $details 0 -what "value c"]
+                        } elseif {[$val1 compare $val2] != 0} {
+                            lappend rlist [linsert $details 0 -what "value c"]
+                        } else {
+                            itcl::delete object $val1 $val2
+                        }
+                        # handled this comparison
+                        set v2paths [lreplace $v2paths $i $i]
+                      }
+                      attrs {
+                        set what [list structure $path]
+                        set type1 [$obj1 element -as type $path]
+                        set type2 [$obj2 element -as type $path]
+                        if {$type1 eq $type2} {
+                          set same yes
+                          set alist [Rappture::objects::get $type1 -attributes]
+                          foreach rec $alist {
+                              array set attr [lrange $rec 1 end]
+                              set apath $path.$attr(-path)
+                              set v1 [$obj1 get $apath]
+                              set v2 [$obj2 get $apath]
+                              set dt [linsert $details end -v1 $v1 -v2 $v2]
+
+                              if {$v2 eq "" && $v1 ne ""} {
+                                  # missing from obj2
+                                  if {$params(-detail) == "max"} {
+                                      lappend rlist [linsert $dt 0 -what [list attr - $attr(-path)]]
+                                  } else {
+                                      set same no
+                                      break
+                                  }
+                              } elseif {$v1 eq "" && $v2 ne ""} {
+                                  # missing from obj1
+                                  if {$params(-detail) == "max"} {
+                                      lappend rlist [linsert $dt 0 -what [list attr + $attr(-path)]]
+                                  } else {
+                                      set same no
+                                      break
+                                  }
+                              } elseif {$v1 ne $v2} {
+                                  # different from obj2
+                                  if {$params(-detail) == "max"} {
+                                      lappend rlist [linsert $dt 0 -what [list attr c $attr(-path)]]
+                                  } else {
+                                      set same no
+                                      break
+                                  }
+                              }
+                          }
+                          if {$params(-detail) == "min" && !$same} {
+                              lappend details -what attrs
+                              lappend rlist [linsert $dt 0 -what "attrs c"]
+                          }
+                        } else {
+                          lappend details -val1 $type1 -val2 $type2
+                          lappend rlist [linsert $details 0 -what "type c"]
+                        }
+                      }
+                      default {
+                        error "bad part \"$part\": should be attrs, value"
+                      }
                     }
-                    # handled this comparison
-                    set v2paths [lreplace $v2paths $i $i]
-                  }
-                  structure {
-                    set what [list structure $path]
-                    set s1paths [_getStructure $obj1 $path]
-                    set s2paths [_getStructure $obj2 $path]
-                    foreach spath $s1paths {
-puts "  checking internal structure $spath"
-                        set i [lsearch -exact $s2paths $spath]
-                        if {$i < 0} {
-puts "    missing from $obj2"
-                            # missing from obj2
-                            set val1 [$obj1 get $spath]
-                            lappend rlist - $spath $what $val1 ""
-                        } else {
-                            set val1 [$obj1 get $spath]
-                            set val2 [$obj2 get $spath]
-                            if {![string match $val1 $val2]} {
-puts "    different from $obj2 ($val1 vs $val2)"
-                                # different from obj2
-                                lappend rlist c $spath $what $val1 $val2
-                            }
-                            # handled this comparison
-                            set s2paths [lreplace $s2paths $i $i]
-                        }
-                    }
-
-                    # look for leftover values
-                    foreach spath $s2paths {
-                        set val2 [$obj2 get $spath]
-puts "    extra $spath in $obj2"
-                        lappend rlist + $spath $what "" $val2
-                    }
-                  }
-                  default {
-                    error "bad part \"$part\": should be structure, value"
-                  }
-                }
-            }
-        }
-    }
-
-    # add any values left over in the obj2
-    foreach path $v2paths {
-puts "    extra $path in $obj2"
-        foreach {raw2 norm2} [Rappture::LibraryObj::value $obj2 $path] break
-        lappend rlist + $path value "" $raw2
-    }
-    return $rlist
-}
-
-# ----------------------------------------------------------------------
-# USAGE: _getStructure <xmlObj> <path>
-#
-# Used internally by _computeDiffs to get a list of paths for important
-# parts of the internal structure of an object.  Avoids the "current"
-# element, but includes "default", "units", etc.
-# ----------------------------------------------------------------------
-itcl::body Rappture::Tester::Test::_getStructure {xmlobj path} {
-    set rlist ""
-    set queue $path
-    while {[llength $queue] > 0} {
-        set qpath [lindex $queue 0]
-        set queue [lrange $queue 1 end]
-
-        foreach p [$xmlobj children -as path $qpath] {
-            if {[string match *.current $p]} {
-                continue
-            }
-            if {[llength [$xmlobj children $p]] > 0} {
-                # continue exploring nodes with children
-                lappend queue $p
-            } else {
-                # return the terminal nodes
-                lappend rlist $p
-            }
+                }
+            }
+        }
+
+        # add any values left over in the obj2
+        foreach path $v2paths {
+            set details [list -path $path -obj1 $obj1 -obj2 $obj2]
+            lappend rlist [linsert $details 0 -what "value +"]
         }
     }