source: trunk/tester/tester.tcl @ 2008

#! /bin/sh
# ----------------------------------------------------------------------
# RAPPTURE REGRESSION TESTER
#
# This program will read a set of test xml files typically located in
# a tool's "tests" subdirectory, and provide an interactive test suite.
# The test xml files should contain a complete set of inputs and outputs
# for one run of an application.  In each test xml, a label must be
# located at the path test.label.  Test labels may be organized
# hierarchically by using dots to separate components of the test label
# (example: roomtemp.1eV).  A description may optionally be located at
# the path test.description.  Input arguments are the path to the
# tool.xml of the version being tested, and the path the the directory
# containing a set of test xml files.  If the arguments are missing,
# the program will attempt to locate them automatically.
#
# USAGE: tester.tcl ?-tool tool.xml? ?-testdir tests?
# ======================================================================
#  AUTHOR:  Ben Rafferty, Purdue University
#  Copyright (c) 2010  Purdue Research Foundation
#
#  See the file "license.terms" for information on usage and
#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# ======================================================================
#\
exec tclsh "$0" $*
# ----------------------------------------------------------------------
# wish executes everything from here on...

# TODO: Won't need this once tied in with the rest of the package 
lappend auto_path [file dirname $argv0]

package require Itk
package require Rappture
package require RapptureGUI

Rappture::getopts argv params {
    value -tool ""
    value -testdir ""
}

# If tool.xml and test directory locations are not given, try to find them.
if {$params(-tool) == ""} {
    if {[file exists tool.xml]} {
        set params(-tool) tool.xml
    } elseif {[file exists [file join rappture tool.xml]]} {
        set params(-tool) [file join rappture tool.xml]
    } else {
        error "Cannot find tool.xml"
    }
}

if {$params(-testdir) == ""} {
    set tooldir [file dirname $params(-tool)]
    if {[file isdirectory [file join $tooldir tests]]} {
        set params(-testdir) [file join $tooldir tests]
    } elseif {[file isdirectory [file join [file dirname $tooldir] tests]]} {
        set params(-testdir) [file join [file dirname $tooldir] tests]
    } else {
        error "Cannot find test directory."
    }
}

# ----------------------------------------------------------------------
# INITIALIZE WINDOW
# ----------------------------------------------------------------------
wm title . "Rappture Regression Tester"
panedwindow .pw
.pw add [Rappture::Tester::TestTree .tree \
    -testdir $params(-testdir) \
    -command Rappture::Tester::runSelected \
    -selectcommand Rappture::Tester::selectionHandler]
.pw add [Rappture::Tester::TestView .view $params(-tool)]
pack .pw -expand yes -fill both

# ----------------------------------------------------------------------
# USAGE: runAll ?-force?
#
# When this method is invoked, all tests contained in the TestTree will
# be ran sequentially.
# ----------------------------------------------------------------------
proc Rappture::Tester::runAll {args} {
    foreach id [.tree getTests] {
        runTest $id $args
    }
    .view update [.tree getData focus] 
}

# ----------------------------------------------------------------------
# USAGE: runSelected ?-force?
#
# When this method is invoked, all tests that are currently selected
# will be ran.  If a branch node (folder) is selected, all of its
# descendant tests will be ran as well.
# TODO: Parallel exection
# ----------------------------------------------------------------------
proc Rappture::Tester::runSelected {args} {
    foreach id [.tree getSelected] {
        runTest $id $args
    }
    .view update [.tree getData focus]
}

# ----------------------------------------------------------------------
# USAGE: runTest id ?-force?
#
# Called by runAll and runSelected to run a single test at the tree node
# specified by the given ide.  In most cases, this method should not be
# called directly.  A driver object is generated by the makeDriver
# procedure in compare.tcl, and the results given by the new version are
# compared to the golden result by the compare procedure in compare.tcl
# ----------------------------------------------------------------------
proc Rappture::Tester::runTest {id args} {
    array set data [.tree getData $id]
    global params
    if {$data(ran) && [lsearch -exact $args "-force"] == -1} {
        # Already ran. Skip.
        return
    }
    set data(result) "Running"
    .tree setData $id [array get data]

    set driver [Rappture::Tester::makeDriver $params(-tool) $data(testxml)]
    set tool [Rappture::Tool ::#auto $driver [file dirname $params(-tool)]]
    foreach {status result} [eval $tool run] break
    set data(ran) yes
    if {$status == 0 && [Rappture::library isvalid $result]} {
        set golden [Rappture::library $data(testxml)]
        set diffs [Rappture::Tester::compare $golden $result output]
        if {$diffs == ""} {
            set data(result) Pass
        } else {
            set data(result) Fail
        }
        set data(diffs) $diffs
        set data(runfile) [$tool getRunFile]
    } else {
        set data(result) Error
        set data(runfile) ""
    }
    .tree setData $id [array get data]
}

# ----------------------------------------------------------------------
# USAGE: selectionHandler
#
# Used internally to communicate between the test tree and the right
# hand side viewer.  Upon selecting a new tree node, pass the focused
# node's data to the right hand side.
# ----------------------------------------------------------------------
proc Rappture::Tester::selectionHandler {} {
    .view update [.tree getData focus]
}