Changeset 2080 for trunk/tester


Ignore:
Timestamp:
Feb 2, 2011 4:51:29 PM (9 years ago)
Author:
mmc
Message:

Part 1 of a major reorganization of content. Moving "instant" to "builder"
and setting up "builder" more like the "gui" part as a package. Moving the
Rappture::object stuff from the builder into the main installation, so it
can be shared by the tester as well. Moving "driver" into gui/scripts
where it belongs. Creating a new "launcher.tcl" script that decides
which of the three parts to launch based on command line options. Still
need to sort out the Makefiles to get this all right...

Location:
trunk/tester
Files:
3 added
1 deleted
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/tester/test.tcl

    r2077 r2080  
    2424    public method getResult {}
    2525    public method getTestInfo {path}
     26    public method getDiffs {}
    2627
    2728    public method run {args}
     
    3233    private variable _testobj ""  ;# Rappture::Library object for _testxml
    3334
    34     private variable _added ""
    35     private variable _diffs ""
    36     private variable _missing ""
    37     private variable _result "?"
    38     private variable _runobj ""
     35    private variable _result "?"  ;# current status of this test
     36    private variable _runobj ""   ;# results from last run
     37    private variable _diffs ""    ;# diffs with respect to _runobj
    3938
    4039    # don't need this?
    41     public method getAdded {}
    42     public method getDiffs {}
    43     public method getInputs {{path input}}
    44     public method getMissing {}
    45     public method getOutputs {{path output}}
    4640    public method getRunobj {}
    47     public method getTestobj {}
    48 
     41
     42    private method _setWaiting {{newval ""}}
    4943    private method _setResult {name}
    50     private method added {lib1 lib2 {path output}}
    51     private method compareElements {lib1 lib2 path}
    52     private method diffs {lib1 lib2 {path output}}
    53     private method merge {toolobj golden driver {path input}}
    54     private method missing {lib1 lib2 {path output}}
     44    private method _computeDiffs {obj1 obj2 args}
     45    private method _getStructure {xmlobj path}
     46
     47    # use this to add tests to the "run" queue
     48    public proc queue {op args}
     49
     50    private common _queue       ;# queue of objects waiting to run
     51    set _queue(tests) ""        ;# list of tests in the queue
     52    set _queue(pending) ""      ;# after event for "next" call
     53    set _queue(running) ""      ;# test object currently running
     54    set _queue(outputcmd) ""    ;# callback for reporting output
    5555}
    5656
     
    118118        itcl::delete object $_runobj
    119119        set _runobj ""
     120        set _diffs ""
    120121    }
    121122
    122123    # copy inputs from the test into the run file
     124    $_toolobj reset
    123125    foreach path [Rappture::entities -as path $_testobj input] {
    124126        if {[$_testobj element -as type $path.current] ne ""} {
     
    130132    # run the test case...
    131133    _setResult "Running"
    132     foreach {status _runobj} [eval $_toolobj run $args] break
    133 
    134     if {$status == 0 && [Rappture::library isvalid $_runobj]} {
    135         # HACK: Add a new input to differentiate between results
    136         $_runobj put input.TestRun.current "Test result"
    137         set _diffs [diffs $_testobj $_runobj]
    138         set _missing [missing $_testobj $_runobj]
    139         set _added [added $_testobj $_runobj]
    140         if {$_diffs == "" && $_missing == "" && $_added == ""} {
    141             _setResult "Pass"
     134    foreach {status result} [eval $_toolobj run $args] break
     135
     136    if {$status == 0} {
     137        if {$result eq "ABORT"} {
     138            _setResult "?"
     139            return "aborted"
     140        } elseif {[Rappture::library isvalid $result]} {
     141            set _runobj $result
     142            set _diffs [_computeDiffs $_testobj $_runobj -section output]
     143puts "DIFFS:"
     144foreach {op path what v1 v2} $_diffs {
     145puts "  $op $path ($what) $v1 $v2"
     146}
     147
     148            # HACK: Add a new input to differentiate between results
     149            $_runobj put input.TestRun.current "Test result"
     150
     151            # any differences from expected result mean test failed
     152            if {[llength $_diffs] == 0} {
     153                _setResult "Pass"
     154            } else {
     155                _setResult "Fail"
     156            }
     157            return "finished"
    142158        } else {
    143159            _setResult "Fail"
     160            return "failed: $result"
    144161        }
    145162    } else {
    146         set _runobj ""
    147         set _setResult "Error"
     163        _setResult "Fail"
     164        tk_messageBox -icon error -message "Tool failed: $result"
     165        return "finished"
    148166    }
    149167}
     
    160178itcl::body Rappture::Tester::Test::regoldenize {} {
    161179    if {$_runobj eq ""} {
    162         error "Test has not yet been run."
     180        error "no test result to goldenize"
    163181    }
    164182    $_runobj put test.label [$_testobj get test.label]
    165183    $_runobj put test.description [$_testobj get test.description]
     184
    166185    set fid [open $_testxml w]
    167186    puts $fid "<?xml version=\"1.0\"?>"
    168187    puts $fid [$_runobj xml]
    169188    close $fid
     189
     190    itcl::delete object $_testobj
    170191    set _testobj $_runobj
     192
     193    set _runobj ""
    171194    set _diffs ""
    172     set _added ""
    173     set _missing ""
    174195    _setResult Pass
    175 }
    176 
    177 # ----------------------------------------------------------------------
    178 # USAGE: getAdded
    179 #
    180 # Return a list of paths that have been added that do not exist in the
    181 # golden results.  Throws an error if the test has not been ran.
    182 # ----------------------------------------------------------------------
    183 itcl::body Rappture::Tester::Test::getAdded {} {
    184     if {$_runobj eq ""} {
    185         error "Test has not yet been run."
    186     }
    187     return $_added
    188196}
    189197
     
    196204# ----------------------------------------------------------------------
    197205itcl::body Rappture::Tester::Test::getDiffs {} {
    198     return [list \
    199         input.number(temperature) label \
    200         output.curve(f12) units \
    201         output.curve(f12) result]
    202 }
    203 
    204 # -----------------------------------------------------------------------
    205 # USAGE: getInputs
    206 #
    207 # Returns a list of key value pairs for all inputs given in the test xml.
    208 # Each key is the path to the input element, and each key is its current
    209 # value.
    210 # -----------------------------------------------------------------------
    211 itcl::body Rappture::Tester::Test::getInputs {{path input}} {
    212     set retval [list]
    213     foreach child [$_testobj children $path] {
    214         set fullpath $path.$child
    215         if {$fullpath != "input.TestRun"} {
    216             set val [$_testobj get $fullpath.current]
    217             if {$val != ""} {
    218                 lappend retval $fullpath $val
    219             }
    220         }
    221         append retval [getInputs $fullpath]
    222     }
    223     return $retval
    224 }
    225 
    226 # ----------------------------------------------------------------------
    227 # USAGE: getMissing
    228 #
    229 # Return a list of paths that are present in the golden results, but are
    230 # missing in the new test results.  Throws an error if the test has not
    231 # been ran.
    232 # ----------------------------------------------------------------------
    233 itcl::body Rappture::Tester::Test::getMissing {} {
    234     if {$_runobj eq ""} {
    235         error "Test has not yet been run."
    236     }
    237     return $_missing
    238 }
    239 
    240 # ----------------------------------------------------------------------
    241 # USAGE: getOutputs
    242 #
    243 # Returns a list of key value pairs for all outputs in the runfile
    244 # generated by the last run of the test.  Each key is the path to the
    245 # element, and each value is its status (ok, diff, added, or missing).
    246 # Throws an error if the test has not been run.
    247 # ----------------------------------------------------------------------
    248 itcl::body Rappture::Tester::Test::getOutputs {{path output}} {
    249     if {$_runobj eq ""} {
    250         error "Test has not yet been run."
    251     }
    252     set retval [list]
    253     foreach child [$_runobj children $path] {
    254         set fullpath $path.$child
    255         if {$fullpath != "output.time" && $fullpath != "output.user" \
    256             && $fullpath != "output.status"} {
    257             if {[lsearch $fullpath [getDiffs]] != -1} {
    258                 set status diff
    259             } elseif {[lsearch $fullpath [getAdded]] != -1} {
    260                 set status added
    261             } else {
    262                 if {[$_runobj get $fullpath] != ""} {
    263                     set status ok
    264                 } else {
    265                     set status ""
    266                 }
    267             }
    268             lappend retval $fullpath $status
    269         }
    270         append retval " [getOutputs $fullpath]"
    271     }
    272     # We won't find missing elements by searching through runobj.  Instead,
    273     # tack on all missing items at the end (only do this once)
    274     if {$path == "output"} {
    275         foreach item $_missing {
    276             lappend retval $item missing
    277         }
    278     }
    279     return $retval
     206    return $_diffs
    280207}
    281208
     
    294221
    295222# ----------------------------------------------------------------------
    296 # USAGE: getTestobj
    297 #
    298 # Returns the test library object containing the set of golden results.
    299 # ----------------------------------------------------------------------
    300 itcl::body Rappture::Tester::Test::getTestobj {} {
    301     return $_testobj
    302 }
    303 
    304 # ----------------------------------------------------------------------
    305 # USAGE: added lib1 lib2 ?path?
    306 #
    307 # Compares two library objects and returns a list of paths that have
    308 # been added in the second library and do not exist in the first.
    309 # Return value will contain all differences that occur as descendants of
    310 # an optional starting path.  If the path argument is not given, then
    311 # only the output sections will be compared.
    312 # ----------------------------------------------------------------------
    313 itcl::body Rappture::Tester::Test::added {lib1 lib2 {path output}} {
    314     set paths [list]
    315     foreach child [$lib2 children $path] {
    316         foreach p [added $lib1 $lib2 $path.$child] {
    317             lappend paths $p
    318         }
    319     }
    320     if {[$lib1 get $path] == "" && [$lib2 get $path] != ""} {
    321         lappend paths $path
    322     }
    323     return $paths
    324 }
    325 
    326 # ----------------------------------------------------------------------
    327 # USAGE: compareElements <lib1> <lib2> <path>
    328 #
    329 # Compare data found in two library objects at the given path.  Returns
    330 # 1 if match, 0 if no match.  For now, just check if ascii identical.
    331 # Later, we can do something more sophisticated for different types of
    332 # elements.
    333 # ----------------------------------------------------------------------
    334 itcl::body Rappture::Tester::Test::compareElements {lib1 lib2 path} {
    335     set val1 [$lib1 get $path]
    336     set val2 [$lib2 get $path]
    337     return [expr {$val1} != {$val2}]
    338 }
    339 
    340 # ----------------------------------------------------------------------
    341 # USAGE: diffs <lib1> <lib2> ?path?
    342 #
    343 # Compares two library objects and returns a list of paths that do not
    344 # match.  Only paths which exist in both libraries are considered.
    345 # Return value will contain all differences that occur as descendants of
    346 # an optional starting path.  If the path argument is not given, then
    347 # only the output sections will be compared.
    348 # ----------------------------------------------------------------------
    349 itcl::body Rappture::Tester::Test::diffs {lib1 lib2 {path output}} {
    350     set paths [list]
    351     set clist1 [$lib1 children $path]
    352     set clist2 [$lib2 children $path]
    353     foreach child $clist1 {
    354         # Ignore if not present in both libraries
    355         if {[lsearch -exact $clist2 $child] != -1} {
    356             foreach p [diffs $lib1 $lib2 $path.$child] {
    357                 lappend paths $p
    358             }
    359         }
    360     }
    361     if {[compareElements $lib1 $lib2 $path]} {
    362         # Ignore output.time and output.user
    363         if {$path != "output.time" && $path != "output.user"} {
    364             lappend paths $path
    365         }
    366     }
    367     return $paths
    368 }
    369 
    370 # ----------------------------------------------------------------------
    371 # USAGE: merge <toolobj> <golden> <driver> ?path?
    372 #
    373 # Used to recursively build up a driver library object for running a
    374 # test.  Should not be called directly - see makeDriver.
    375 # ----------------------------------------------------------------------
    376 itcl::body Rappture::Tester::Test::merge {toolobj golden driver {path input}} {
    377     foreach child [$toolobj children $path] {
    378         set val [$golden get $path.$child.current]
    379         if {$val != ""} {
    380             $driver put $path.$child.current $val
    381         } else {
    382             set def [$toolobj get $path.$child.default]
    383             if {$def != ""} {
    384                 $driver put $path.$child.current $def
    385             }
    386         }
    387         merge $toolobj $golden $driver $path.$child
    388     }
    389     return $driver
    390 }
    391 
    392 # ----------------------------------------------------------------------
    393 # USAGE: added lib1 lib2 ?path?
    394 #
    395 # Compares two library objects and returns a list of paths that do not
    396 # exist in the first library and have been added in the second.
    397 # Return value will contain all differences that occur as descendants of
    398 # an optional starting path.  If the path argument is not given, then
    399 # only the output sections will be compared.
    400 # ----------------------------------------------------------------------
    401 itcl::body Rappture::Tester::Test::missing {lib1 lib2 {path output}} {
    402     set paths [list]
    403     foreach child [$lib1 children $path] {
    404         foreach p [missing $lib1 $lib2 $path.$child] {
    405             lappend paths $p
    406         }
    407     }
    408     if {[$lib1 get $path] != "" && [$lib2 get $path] == ""} {
    409         lappend paths $path
    410     }
    411     return $paths
    412 }
    413 
    414 # ----------------------------------------------------------------------
    415223# USAGE: _setResult ?|Pass|Fail|Waiting|Running
    416224#
     
    420228# ----------------------------------------------------------------------
    421229itcl::body Rappture::Tester::Test::_setResult {name} {
    422 puts "CHANGED: $this => $name"
    423230    set _result $name
    424231    if {[string length $notifycommand] > 0} {
    425 puts "  notified $notifycommand"
    426232        uplevel #0 $notifycommand $this
    427233    }
    428234}
     235
     236# ----------------------------------------------------------------------
     237# USAGE: _setWaiting ?boolean?
     238#
     239# Used to mark a Test as "waiting".  This usually happens when a test
     240# is added to the queue, about to be run.
     241# ----------------------------------------------------------------------
     242itcl::body Rappture::Tester::Test::_setWaiting {{newval ""}} {
     243    if {$newval ne "" && [string is boolean $newval]} {
     244        if {$newval} {
     245            _setResult "Waiting"
     246        } else {
     247            _setResult "?"
     248        }
     249    }
     250    return $_result
     251}
     252
     253# ----------------------------------------------------------------------
     254# USAGE: _computeDiffs <xmlObj1> <xmlObj2> ?-section xxx? \
     255#            ?-what value|structure|all?
     256#
     257# Used internally to compute differences between two different XML
     258# objects.  This is normally used to look for differences in the
     259# output section between a test case and a new run, but can also
     260# be used to look for differences in other sections via the -section
     261# flag.
     262#
     263# Returns a list of the following form:
     264#     <op> <path> <what> <val1> <val2>
     265#
     266#       where <op> is one of:
     267#         - ...... element is missing from <xmlObj2>
     268#         c ...... element changed between <xmlObj1> and <xmlObj2>
     269#         + ...... element is missing from <xmlObj1>
     270#
     271#       and <what> is something like:
     272#         value .............. difference affects "current" value
     273#         structure <path> ... affects structure of parent at <path>
     274# ----------------------------------------------------------------------
     275itcl::body Rappture::Tester::Test::_computeDiffs {obj1 obj2 args} {
     276    Rappture::getopts args params {
     277        value -section output
     278        value -what all
     279    }
     280    if {$params(-what) == "all"} {
     281        set params(-what) "structure value"
     282    }
     283
     284    # query the values for all entities in both objects
     285    set v1paths [Rappture::entities $obj1 $params(-section)]
     286    set v2paths [Rappture::entities $obj2 $params(-section)]
     287
     288    # scan through values for obj1 and compare against obj2
     289    set rlist ""
     290    foreach path $v1paths {
     291puts "checking $path"
     292        set i [lsearch -exact $v2paths $path]
     293        if {$i < 0} {
     294puts "  missing from $obj2"
     295            # missing from obj2
     296            foreach {raw norm} [Rappture::LibraryObj::value $obj1 $path] break
     297            lappend rlist - $path value $raw ""
     298        } else {
     299            foreach part $params(-what) {
     300                switch -- $part {
     301                  value {
     302                    foreach {raw1 norm1} \
     303                        [Rappture::LibraryObj::value $obj1 $path] break
     304                    foreach {raw2 norm2} \
     305                        [Rappture::LibraryObj::value $obj2 $path] break
     306puts "  checking values $norm1 vs $norm2"
     307                    if {![string equal $norm1 $norm2]} {
     308puts "  => different!"
     309                        # different from obj2
     310                        lappend rlist c $path value $raw1 $raw2
     311                    }
     312                    # handled this comparison
     313                    set v2paths [lreplace $v2paths $i $i]
     314                  }
     315                  structure {
     316                    set what [list structure $path]
     317                    set s1paths [_getStructure $obj1 $path]
     318                    set s2paths [_getStructure $obj2 $path]
     319                    foreach spath $s1paths {
     320puts "  checking internal structure $spath"
     321                        set i [lsearch -exact $s2paths $spath]
     322                        if {$i < 0} {
     323puts "    missing from $obj2"
     324                            # missing from obj2
     325                            set val1 [$obj1 get $spath]
     326                            lappend rlist - $spath $what $val1 ""
     327                        } else {
     328                            set val1 [$obj1 get $spath]
     329                            set val2 [$obj2 get $spath]
     330                            if {![string match $val1 $val2]} {
     331puts "    different from $obj2 ($val1 vs $val2)"
     332                                # different from obj2
     333                                lappend rlist c $spath $what $val1 $val2
     334                            }
     335                            # handled this comparison
     336                            set s2paths [lreplace $s2paths $i $i]
     337                        }
     338                    }
     339
     340                    # look for leftover values
     341                    foreach spath $s2paths {
     342                        set val2 [$obj2 get $spath]
     343puts "    extra $spath in $obj2"
     344                        lappend rlist + $spath $what "" $val2
     345                    }
     346                  }
     347                  default {
     348                    error "bad part \"$part\": should be structure, value"
     349                  }
     350                }
     351            }
     352        }
     353    }
     354
     355    # add any values left over in the obj2
     356    foreach path $v2paths {
     357puts "    extra $path in $obj2"
     358        foreach {raw2 norm2} [Rappture::LibraryObj::value $obj2 $path] break
     359        lappend rlist + $path value "" $raw2
     360    }
     361    return $rlist
     362}
     363
     364# ----------------------------------------------------------------------
     365# USAGE: _getStructure <xmlObj> <path>
     366#
     367# Used internally by _computeDiffs to get a list of paths for important
     368# parts of the internal structure of an object.  Avoids the "current"
     369# element, but includes "default", "units", etc.
     370# ----------------------------------------------------------------------
     371itcl::body Rappture::Tester::Test::_getStructure {xmlobj path} {
     372    set rlist ""
     373    set queue $path
     374    while {[llength $queue] > 0} {
     375        set qpath [lindex $queue 0]
     376        set queue [lrange $queue 1 end]
     377
     378        foreach p [$xmlobj children -as path $qpath] {
     379            if {[string match *.current $p]} {
     380                continue
     381            }
     382            if {[llength [$xmlobj children $p]] > 0} {
     383                # continue exploring nodes with children
     384                lappend queue $p
     385            } else {
     386                # return the terminal nodes
     387                lappend rlist $p
     388            }
     389        }
     390    }
     391    return $rlist
     392}
     393
     394# ======================================================================
     395# RUN QUEUE
     396# ======================================================================
     397# USAGE: queue add <testObj> <testObj>...
     398# USAGE: queue clear ?<testObj> <testObj>...?
     399# USAGE: queue status <command>
     400# USAGE: queue next
     401# USAGE: queue output <string>
     402#
     403# Used to manipulate the run queue for the program as a whole.
     404#
     405# The "queue add" option adds the given <testObj> objects to the run
     406# queue.  As soon as an object is added to the queue, it is marked
     407# "waiting".  When it runs, it is marked "running", and it finally
     408# goes to the "pass" or "fail" state.  If an object is already in
     409# the queue, then this operation does nothing.
     410#
     411# The "queue clear" option clears specific objects from the queue.
     412# If no objects are specified, then it clears all remaining objects.
     413#
     414# The "queue status" option is used to set the callback for handling
     415# output from runs.  This command is called two ways:
     416#    command start <testObj>
     417#    command add <testObj> "string of output"
     418#
     419# The "queue next" option is used internally to run the next object
     420# in the queue.  The "queue output" option is also used internally
     421# to handle the output coming back from a run.  The output gets
     422# shuttled along to the callback specified by "queue status".
     423# ----------------------------------------------------------------------
     424itcl::body Rappture::Tester::Test::queue {option args} {
     425    switch -- $option {
     426        add {
     427            # add these tests to the run queue
     428            foreach obj $args {
     429                if {[catch {$obj isa Rappture::Tester::Test} valid] || !$valid} {
     430                    error "bad value \"$obj\": should be Test object"
     431                }
     432                if {[lsearch $_queue(tests) $obj] < 0} {
     433                    $obj _setWaiting 1
     434                    lappend _queue(tests) $obj
     435                }
     436            }
     437            if {$_queue(running) eq "" && $_queue(pending) eq ""} {
     438                set _queue(pending) [after idle \
     439                    Rappture::Tester::Test::queue next]
     440            }
     441        }
     442        clear {
     443            # remove these tests from the run queue
     444            foreach obj $args {
     445                if {[catch {$obj isa Rappture::Tester::Test} valid] || !$valid} {
     446                    error "bad value \"$obj\": should be Test object"
     447                }
     448
     449                # remove the test from the queue
     450                set i [lsearch $_queue(tests) $obj]
     451                if {$i >= 0} {
     452                    set _queue(tests) [lreplace $_queue(tests) $i $i]
     453                }
     454
     455                # mark object as no longer "waiting"
     456                if {[$obj _setWaiting]} {
     457                    $obj _setWaiting 0
     458                }
     459            }
     460        }
     461        status {
     462            if {[llength $args] != 1} {
     463                error "wrong # args: should be \"status command\""
     464            }
     465            set _queue(outputcmd) [lindex $args 0]
     466        }
     467        next {
     468            set _queue(pending) ""
     469
     470            # get the next object from the queue
     471            set obj [lindex $_queue(tests) 0]
     472            set _queue(tests) [lrange $_queue(tests) 1 end]
     473
     474            if {$obj ne ""} {
     475                set _queue(running) $obj
     476                # invoke the callback to signal start of a run
     477                if {[string length $_queue(outputcmd)] > 0} {
     478                    uplevel #0 $_queue(outputcmd) start $obj
     479                }
     480
     481                # run the test
     482                set callback "Rappture::Tester::Test::queue output"
     483                set status [$obj run -output $callback]
     484                set _queue(running) ""
     485
     486                if {$status == "aborted"} {
     487                    # if the test was aborted, clear any waiting tests
     488                    Rappture::Tester::Test::queue clear
     489                } elseif {[string match failed:* $status]} {
     490                    bgerror $status
     491                }
     492
     493                # set up to run the next test in the queue
     494                set _queue(pending) [after idle \
     495                    Rappture::Tester::Test::queue next]
     496            }
     497        }
     498        output {
     499            if {[llength $args] != 1} {
     500                error "wrong # args: should be \"output string\""
     501            }
     502            if {[string length $_queue(outputcmd)] > 0} {
     503                uplevel #0 $_queue(outputcmd) add $_queue(running) $args
     504            }
     505        }
     506        default {
     507            error "bad option \"$option\": should be add, clear, status, output, next"
     508        }
     509    }
     510}
  • trunk/tester/tester.tcl

    r2077 r2080  
    7777set Rappture::icon::iconpath [linsert $Rappture::icon::iconpath 0 [file join $testerdir images]]
    7878
    79 # current list of running tests
    80 set RunQueue ""
    81 
    8279
    8380Rappture::getopts argv params {
     
    161158# ----------------------------------------------------------------------
    162159frame $win.testrun
     160label $win.testrun.title -text "Output from test run:" -anchor w
     161pack $win.testrun.title -side top -anchor w
     162
    163163button $win.testrun.abort -text "Abort"
    164 pack $win.testrun.abort -side bottom
     164pack $win.testrun.abort -side bottom -pady {8 0}
    165165
    166166Rappture::Scroller $win.testrun.scrl -xscrollmode auto -yscrollmode auto
     
    213213            pack forget $win
    214214        }
    215         pack $detailwidget -expand yes -fill both
     215        if {$detailwidget ne ""} {
     216            pack $detailwidget -expand yes -fill both -padx 8 -pady 8
     217        }
    216218    }
    217219
    218220    if {[llength $tests] > 0} {
    219221        eval $testview.overview show $tests
    220         pack $testview -expand yes -fill both -padx 8 -pady 8
    221222        if {[llength $tests] == 1 && [$tests getResult] eq "Fail"} {
    222223            pack $testview.regoldenize -side bottom -anchor w
     
    228229            set testobj [lindex $tests 0]
    229230            $testview.details.scrl.list delete 0 end
    230             foreach {path info} [$testobj getDiffs] {
    231                 set title [$testobj getTestInfo $path.about.label]
    232                 if {[string match output.* $path]} {
    233                     set title "Output: $title"
    234                 }
    235                 switch -- [lindex $info 0] {
    236                     result {
    237                         set desc "Result differs from expected value"
    238                         set icon [Rappture::icon fail16]
     231            foreach {op path what v1 v2} [$testobj getDiffs] {
     232                switch -- [lindex $what 0] {
     233                  value {
     234                    set title "Output: [$testobj getTestInfo $path.about.label]"
     235                    set icon [Rappture::icon fail16]
     236                    switch -- $op {
     237                      - { set desc "Result is missing from current output" }
     238                      + { set desc "Result was not expected to appear" }
     239                      c { set desc "Result differs from expected value" }
     240                      default {
     241                          error "don't know how to handle difference $op"
     242                      }
    239243                    }
    240                     default {
    241                         set desc $info
    242                         set icon [Rappture::icon warn16]
     244                  }
     245                  structure {
     246                    set ppath [lindex $what 1]
     247                    set title "Output: [$testobj getTestInfo $ppath.about.label]"
     248                    set icon [Rappture::icon warn16]
     249                    set pplen [string length $ppath]
     250                    set tail [string range $path [expr {$pplen+1}] end]
     251                    switch -- $op {
     252                      - { set desc "Missing value \"$v1\" at $tail" }
     253                      + { set desc "Extra value \"$v2\" at $tail" }
     254                      c { set desc "Details at $tail have changed:\n       got: $v2\n  expected: $v1" }
     255                      default {
     256                          error "don't know how to handle difference $op"
     257                      }
    243258                    }
     259                  }
     260                  default {
     261                    error "don't know how to handle difference \"$what\""
     262                  }
    244263                }
    245264
     
    265284# ----------------------------------------------------------------------
    266285proc tester_run {args} {
    267     global RunQueue
    268     set testtree [.pw pane 0].tree
     286    # set up a callback for handling output from runs
     287    Rappture::Tester::Test::queue status tester_run_output
    269288
    270289    # add these tests to the run queue
    271     foreach obj $args {
    272         if {[lsearch $RunQueue $obj] < 0} {
    273             lappend RunQueue $obj
    274         }
    275     }
    276 
    277     after idle tester_run_next
    278 }
    279 
    280 # ----------------------------------------------------------------------
    281 # USAGE: tester_run_next
    282 #
    283 # Takes the next test from the queue and runs it.  Displays any
    284 # output during the run, then compares results and shows a final
    285 # pass/fail status.
    286 # ----------------------------------------------------------------------
    287 proc tester_run_next {} {
    288     global RunQueue
    289 
    290     set obj [lindex $RunQueue 0]
    291     set RunQueue [lrange $RunQueue 1 end]
    292 
    293     if {$obj ne ""} {
    294 puts "RUNNING: $obj"
    295         set testrun [.pw pane 1].testrun
    296         $testrun.abort configure -command [list $obj abort]
    297         $obj run -output tester_run_output
    298     }
    299 
    300     # keep running remaining tests
    301     after idle tester_run_next
    302 }
    303 
    304 # ----------------------------------------------------------------------
    305 # USAGE: tester_run_output <string>
    306 #
    307 # Adds the <string> output from running a test case into the viewer
    308 # for that test.
    309 # ----------------------------------------------------------------------
    310 proc tester_run_output {string} {
     290    eval Rappture::Tester::Test::queue add $args
     291
     292    # show the run output window
     293    set rhs [.pw pane 1]
     294    foreach win [pack slaves $rhs] {
     295        pack forget $win
     296    }
     297    pack $rhs.testrun -expand yes -fill both -padx 8 -pady 8
     298}
     299
     300# ----------------------------------------------------------------------
     301# USAGE: tester_run_output start <testObj>
     302# USAGE: tester_run_output add <testObj> <string>
     303#
     304# Handles the output from running tests.  The "start" option clears
     305# the current output area.  The "add" option adds output from a run.
     306# ----------------------------------------------------------------------
     307proc tester_run_output {option testobj args} {
    311308    set testrun [.pw pane 1].testrun
    312     $testrun.scrl.info configure -state normal
    313     $testrun.scrl.info insert end $string
    314 
    315     # if there are too many lines, delete some
    316     set lines [lindex [split [$testrun.scrl.info index end-2char] .] 0]
    317     if {$lines > 500} {
    318         set extra [expr {$lines-500+1}]
    319         $testrun.scrl.info delete 1.0 $extra.0
    320     }
    321 
    322     # show the newest stuff
    323     $testrun.scrl.info see end
    324     $testrun.scrl.info configure -state disabled
     309
     310    switch -- $option {
     311        start {
     312            # clear out any previous output
     313            $testrun.scrl.info configure -state normal
     314            $testrun.scrl.info delete 1.0 end
     315            $testrun.scrl.info configure -state disabled
     316
     317            # plug this object into the "Abort" button
     318            $testrun.abort configure -command [list $testobj abort]
     319        }
     320        add {
     321            $testrun.scrl.info configure -state normal
     322            $testrun.scrl.info insert end [lindex $args 0]
     323
     324            # if there are too many lines, delete some
     325            set lines [lindex [split [$testrun.scrl.info index end-2char] .] 0]
     326            if {$lines > 500} {
     327                set extra [expr {$lines-500+1}]
     328                $testrun.scrl.info delete 1.0 $extra.0
     329            }
     330
     331            # show the newest stuff
     332            $testrun.scrl.info see end
     333            $testrun.scrl.info configure -state disabled
     334        }
     335        default {
     336            error "bad option \"$option\": should be start, add"
     337        }
     338    }
    325339}
    326340
  • trunk/tester/testtree.tcl

    r2077 r2080  
    225225                Pass    { set data(result) "@[Rappture::icon pass16]" }
    226226                Fail    { set data(result) "@[Rappture::icon fail16]" }
    227                 Waiting { set data(result) "@[Rappture::icon wait]" }
     227                Waiting { set data(result) "@[Rappture::icon wait16]" }
    228228                Running { set data(result) "@[spinner use]" }
    229229                default { set data(result) "" }
     
    231231puts "ICON: $data(result)"
    232232            $itk_component(treeview) entry configure $n -data [array get data]
     233
     234            # if the node that's changed is selected, invoke the
     235            # -selectcommand code so the GUI will react to the new state
     236            if {[$itk_component(treeview) selection includes $n]} {
     237                set cmd [$itk_component(treeview) cget -selectcommand]
     238                if {[string length $cmd] > 0} {
     239                    uplevel #0 $cmd
     240                }
     241            }
    233242        }
    234243    }
  • trunk/tester/testview.tcl

    r2077 r2080  
    144144                    set color $itk_option(-statusfailcolor)
    145145                }
     146                Running - Waiting {
     147                    set smesg "Test waiting to run"
     148                    set sicon [Rappture::icon wait64]
     149                    set color $itk_option(-statuspasscolor)
     150                }
    146151                default { error "unknown test state \"[$obj getResult]\"" }
    147152            }
     
    161166        }
    162167        default {
    163             array set states { ? 0  Pass 0  Fail 0  total 0 }
     168            array set states { ? 0  Pass 0  Fail 0  Running 0  Waiting 0  total 0 }
    164169            foreach obj $_testobjs {
    165170                incr states(total)
Note: See TracChangeset for help on using the changeset viewer.