source: trunk/tester/mainwin.tcl @ 1968

# ----------------------------------------------------------------------
#  COMPONENT: mainwin - main application window for regression tester 
#
#  This widget acts as the main window for the Rappture regression
#  tester.  Constructor accepts the location of the tool.xml of the new 
#  version to be tested, and the location of a directory containg test 
#  xml files.
# ======================================================================
#  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.
# ======================================================================
package require Itk
package require Rappture
package require RapptureGUI

namespace eval Rappture::Tester::MainWin { #forward declaration }

itcl::class Rappture::Tester::MainWin {
    inherit itk::Toplevel

    constructor {toolxml testdir args} { #defined later }
    public method runAll {args}
    public method runSelected {args}

    private method selectionHandler {}
    private method runTest {id args}

    private variable _testdir
    private variable _toolxml
    private variable _toolobj

}

# ----------------------------------------------------------------------
# CONSTRUCTOR
# ----------------------------------------------------------------------
itcl::body Rappture::Tester::MainWin::constructor {toolxml testdir args} {
    if {[file exists $toolxml]} {
        set _toolxml $toolxml
        set _toolobj [Rappture::library $_toolxml]
    } else {
        error "File \"$toolxml\" does not exist."
    }

    if {[file isdirectory $testdir]} {
        set _testdir $testdir
    } else {
        error "Directory \"$testdir\" does not exist."
    }

    itk_component add pw {
        panedwindow $itk_interior.pw 
    } {
    }
    pack $itk_component(pw) -expand yes -fill both

    itk_component add tree {
        Rappture::Tester::TestTree $itk_component(pw).tree \
            -command "[itcl::code $itk_interior runSelected]" \
            -testdir $_testdir \
            -selectcommand "[itcl::code $itk_interior selectionHandler]"
    }
    $itk_component(pw) add $itk_component(tree)

    itk_component add view {
        Rappture::Tester::TestView $itk_component(pw).view \
            [Rappture::Tool ::#auto $_toolobj [file dirname $_toolxml]]
    }
    $itk_component(pw) add $itk_component(view)

    eval itk_initialize $args
}

# ----------------------------------------------------------------------
# USAGE: runAll ?-force?
#
# When this method is invoked, all tests contained in the TestTree will
# be ran sequentially.
# ----------------------------------------------------------------------
itcl::body Rappture::Tester::MainWin::runAll {args} {
    set tests [$itk_component(tree) getTests]
    foreach id $tests {
        runTest $id $args
    }
}

# ----------------------------------------------------------------------
# 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.
# ----------------------------------------------------------------------
itcl::body Rappture::Tester::MainWin::runSelected {args} {
    set selected [$itk_component(tree) getSelected]
    foreach id $selected {
        runTest $id $args
    }
}

# ----------------------------------------------------------------------
# USAGE: runTest id ?-force?
#
# Called by runAll and runSelected to run a single test at tree node 
# specified by the given id.  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 test xml by the compare procedure in compare.tcl
# ----------------------------------------------------------------------
itcl::body Rappture::Tester::MainWin::runTest {id args} {
    array set data [$itk_component(tree) getData $id]
    if {$data(ran) && [lsearch -exact $args "-force"]==-1} {
        # Already ran.  Skip.
        return
    }
    set data(result) "Running"
    $itk_component(tree) setData $id [array get data]

    set driver [Rappture::Tester::makeDriver $_toolxml $data(testxml)]
    set tool [Rappture::Tool ::#auto $driver [file dirname $_toolxml]]
    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) Fail
            set data(diffs) $diffs
        } else {
            set data(result) Pass
        }
        set data(runfile) [$tool getRunFile]
    } else {
        set data(result) Error
        set data(runfile) ""
    }
    $itk_component(tree) setData $id [array get data]

    # Call selectionHandler to refresh right hand side view
    selectionHandler

}

# ----------------------------------------------------------------------
# USAGE: selectionHandler
#
# Used internally to communicate between the test tree and the right
# hand side whenever the tree's selection has changed.
# ----------------------------------------------------------------------
itcl::body Rappture::Tester::MainWin::selectionHandler {} {
    array set data [$itk_component(tree) getData focus]
    # Data array is empty for branch nodes
    if {[array names data] != ""} {
        if {$data(ran)} {
            switch $data(result) {
                Pass {$itk_component(view) showText "Test passed."}
                Fail {$itk_component(view) showText "Diffs: $data(diffs)"}
                Error {$itk_component(view) showText "Error while running test"}
            }
            if {$data(runfile) != ""} {
                $itk_component(view) display $data(runfile) $data(testxml)
            } else {
                $itk_component(view) clear
            }
        } else {
            $itk_component(view) showText "Test has not ben ran."
            $itk_component(view) clear
        }
    } else {
        $itk_component(view) showDefault
    }
}