source: trunk/tester/scripts/testtree.tcl @ 2139

Last change on this file since 2139 was 2139, checked in by mmc, 10 years ago

Finished everything for a 1.0 version of the tester tool. The tester
successfully reports errors for the tool in the "example" directory.
It catches differences in input values and output results. It can look
for tests that are expected to fail and detect mismatches in their
standard output. Still needs a "build" mode to create/modify tests,
but this much handles the regression testing part pretty well.

File size: 11.4 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: testtree - provides hierarchical view of regression tests
3#
4#  Used to display a collapsible view of all tests found in the test
5#  directory.  In each test xml, a label must be located at the path
6#  test.label.  Test labels may be organized hierarchically by using
7#  dots to separate components of the test label.  The directory
8#  containing a set of test xml files, as well as the location of the
9#  new tool.xml must be given as configuration options.
10# ======================================================================
11#  AUTHOR:  Ben Rafferty, Purdue University
12#  Copyright (c) 2010  Purdue Research Foundation
13#
14#  See the file "license.terms" for information on usage and
15#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
16# ======================================================================
17package require Itk
18package require BLT
19package require Rappture
20
21namespace eval Rappture::Tester::TestTree { #forward declaration }
22
23option add *TestTree.font \
24    -*-helvetica-medium-r-normal-*-12-* widgetDefault
25option add *TestTree.codeFont \
26    -*-courier-medium-r-normal-*-12-* widgetDefault
27option add *TestTree.textFont \
28    -*-helvetica-medium-r-normal-*-12-* widgetDefault
29option add *TestTree.boldTextFont \
30    -*-helvetica-bold-r-normal-*-12-* widgetDefault
31
32itcl::class Rappture::Tester::TestTree {
33    inherit itk::Widget
34
35    constructor {args} { #defined later }
36    destructor { #defined later }
37
38    public method add {args}
39    public method clear {}
40    public method curselection {}
41
42    protected method _getLeaves {{id 0}}
43    protected method _getTest {id}
44    protected method _refresh {args}
45
46    # add support for a spinning icon
47    proc spinner {op}
48
49    private common spinner
50    set spinner(frames) 8
51    set spinner(current) 0
52    set spinner(pending) ""
53    set spinner(uses) 0
54
55    for {set n 0} {$n < $spinner(frames)} {incr n} {
56        set spinner(frame$n) [Rappture::icon circle-ball[expr {$n+1}]]
57    }
58    set spinner(image) [image create photo -width [image width $spinner(frame0)] -height [image height $spinner(frame0)]]
59}
60 
61itk::usual TestTree {
62    keep -background -foreground -font
63}
64
65# ----------------------------------------------------------------------
66# CONSTRUCTOR
67# ----------------------------------------------------------------------
68itcl::body Rappture::Tester::TestTree::constructor {args} {
69    itk_component add scrollbars {
70        Rappture::Scroller $itk_interior.scroller \
71            -xscrollmode auto -yscrollmode auto
72    }
73    pack $itk_component(scrollbars) -expand yes -fill both
74
75    itk_component add treeview {
76        blt::treeview $itk_component(scrollbars).treeview -separator | \
77            -autocreate true -selectmode multiple \
78            -icons [list [Rappture::icon folder] [Rappture::icon folder2]] \
79            -activeicons ""
80    } {
81        keep -foreground -font -cursor
82        keep -selectcommand
83    }
84    $itk_component(treeview) column insert 0 result -title "Result"
85    $itk_component(treeview) column insert end test -hide yes
86    $itk_component(treeview) column configure treeView -justify left -title "Test Case"
87    $itk_component(treeview) sort configure -mode dictionary -column treeView
88    $itk_component(treeview) sort auto yes
89
90    $itk_component(scrollbars) contents $itk_component(treeview)
91
92    itk_component add bottomBar {
93        frame $itk_interior.bottomBar
94    }
95    pack $itk_component(bottomBar) -fill x -side bottom -pady {8 0}
96
97    itk_component add selLabel {
98        label $itk_component(bottomBar).selLabel -anchor w -text "Select:"
99    }
100    pack $itk_component(selLabel) -side left
101
102    itk_component add bSelectAll {
103        button $itk_component(bottomBar).bSelectAll -text "All" \
104            -command "$itk_component(treeview) selection set 0 end"
105    }
106    pack $itk_component(bSelectAll) -side left
107
108    itk_component add bSelectNone {
109        button $itk_component(bottomBar).bSelectNone -text "None" \
110            -command "$itk_component(treeview) selection clearall"
111    }
112    pack $itk_component(bSelectNone) -side left
113
114
115    eval itk_initialize $args
116}
117
118# ----------------------------------------------------------------------
119# DESTRUCTOR
120# ----------------------------------------------------------------------
121itcl::body Rappture::Tester::TestTree::destructor {} {
122    clear
123}
124
125# ----------------------------------------------------------------------
126# USAGE: add ?<testObj> <testObj> ...?
127#
128# Adds one or more Test objects to the tree shown in this viewer.
129# Once added, these objects become property of this widget and
130# are destroyed when the widget is cleared or deleted.
131# ----------------------------------------------------------------------
132itcl::body Rappture::Tester::TestTree::add {args} {
133    set icon [Rappture::icon testcase]
134
135    foreach obj $args {
136        if {[catch {$obj isa Rappture::Tester::Test} valid] || !$valid} {
137            error "bad value \"$obj\": should be Test object"
138        }
139
140        # add each Test object into the tree
141        set testpath [$obj getTestInfo test.label]
142        set n [$itk_component(treeview) insert end $testpath \
143             -data [list test $obj] -icons [list $icon $icon]]
144
145        # tag this node so we can find it easily later
146        $itk_component(treeview) tag add $obj $n
147
148        # monitor state changes on the object
149        $obj configure -notifycommand [itcl::code $this _refresh]
150    }
151}
152
153# ----------------------------------------------------------------------
154# USAGE: clear
155#
156# Clears the contents of the tree so that it's completely empty.
157# All Test objects stored internally are destroyed.
158# ----------------------------------------------------------------------
159itcl::body Rappture::Tester::TestTree::clear {} {
160    foreach id [_getLeaves] {
161        itcl::delete object [_getTest $id]
162    }
163    $itk_component(treeview) delete 0
164}
165
166# ----------------------------------------------------------------------
167# USAGE: curselection
168#
169# Returns a list ids for all currently selected tests (leaf nodes) and
170# the child tests of any currently selected branch nodes.  Tests can
171# only be leaf nodes in the tree (the ids in the returned list will
172# correspond to leaf nodes only).
173# ----------------------------------------------------------------------
174itcl::body Rappture::Tester::TestTree::curselection {} {
175    set rlist ""
176    foreach id [$itk_component(treeview) curselection] {
177        foreach node [_getLeaves $id] {
178            catch {unset data}
179            array set data [$itk_component(treeview) entry cget $node -data]
180
181            if {[lsearch -exact $rlist $data(test)] < 0} {
182                lappend rlist $data(test)
183            }
184        }
185    }
186    return $rlist
187}
188
189# ----------------------------------------------------------------------
190# USAGE _getTest <nodeId>
191#
192# Returns the test object associated with a given treeview node id.  If
193# no id is given, return the test associated with the currently focused
194# node.  Returns empty string if the given id / focused node is a
195# branch node.
196# ----------------------------------------------------------------------
197itcl::body Rappture::Tester::TestTree::_getTest {id} {
198    if {[lsearch -exact [_getLeaves] $id] < 0} {
199        # Return empty string if branch node selected
200        return ""
201    }
202    array set darray [$itk_component(treeview) entry cget $id -data]
203    return $darray(test)
204}
205
206# ----------------------------------------------------------------------
207# USAGE: _refresh ?<testObj> <testObj> ...?
208#
209# Invoked whenever the state of a <testObj> changes.  Finds the
210# corresponding entry in the tree and updates the "Result" column
211# to show the new status.
212# ----------------------------------------------------------------------
213itcl::body Rappture::Tester::TestTree::_refresh {args} {
214    foreach obj $args {
215        set n [$itk_component(treeview) index $obj]
216        if {$n ne ""} {
217            catch {unset data}
218            array set data [$itk_component(treeview) entry cget $n -data]
219
220            # getting rid of a spinner? then drop it
221            if {[info exists data(result)]
222                  && $data(result) == "@$spinner(image)"} {
223                spinner drop
224            }
225
226            # plug in the new icon
227            switch -- [$obj getResult] {
228                Pass    { set data(result) "@[Rappture::icon pass16]" }
229                Fail    { set data(result) "@[Rappture::icon fail16]" }
230                Waiting { set data(result) "@[Rappture::icon wait16]" }
231                Running { set data(result) "@[spinner use]" }
232                default { set data(result) "" }
233            }
234            $itk_component(treeview) entry configure $n -data [array get data]
235
236            # if the node that's changed is selected, invoke the
237            # -selectcommand code so the GUI will react to the new state
238            if {[$itk_component(treeview) selection includes $n]} {
239                set cmd [$itk_component(treeview) cget -selectcommand]
240                if {[string length $cmd] > 0} {
241                    uplevel #0 $cmd
242                }
243            }
244        }
245    }
246}
247
248# ----------------------------------------------------------------------
249# USAGE: _getLeaves ?id?
250#
251# Returns a list of ids for all tests contained in the tree.  If an
252# optional id is given as an input parameter, then the returned list
253# will contain the ids of all tests that are descendants of the given
254# id.  Tests can only be leaf nodes.
255# ----------------------------------------------------------------------
256itcl::body Rappture::Tester::TestTree::_getLeaves {{id 0}} {
257    set clist [$itk_component(treeview) entry children $id]
258    if {$clist == "" && $id == 0} {
259        # Return nothing if tree is empty
260        return ""
261    }
262    if {$clist == ""} {
263        return $id
264    }
265    set tests [list]
266    foreach child $clist {
267        set tests [concat $tests [_getLeaves $child]]
268    }
269    return $tests
270}
271
272# ----------------------------------------------------------------------
273# USAGE: spinner use|drop|next
274#
275# Used to update the spinner icon that represents running test cases.
276# The "use" option returns the spinner icon and starts the animation,
277# if it isn't already running.  The "drop" operation lets go of the
278# spinner.  If nobody is using it, the animation stops.  The "next"
279# option is used internally to change the animation to the next frame.
280# ----------------------------------------------------------------------
281itcl::body Rappture::Tester::TestTree::spinner {op} {
282    switch -- $op {
283        use {
284            if {$spinner(pending) == ""} {
285                set spinner(current) 0
286                set spinner(pending) [after 100 Rappture::Tester::TestTree::spinner next]
287            }
288            incr spinner(uses)
289            return $spinner(image)
290        }
291        drop {
292            if {[incr spinner(uses) -1] <= 0} {
293                after cancel $spinner(pending)
294                set spinner(pending) ""
295                set spinner(uses) 0
296            }
297        }
298        next {
299            set n $spinner(current)
300            $spinner(image) copy $spinner(frame$n)
301
302            # go to the next frame
303            if {[incr spinner(current)] >= $spinner(frames)} {
304                set spinner(current) 0
305            }
306
307            # update again after a short delay
308            set spinner(pending) [after 100 Rappture::Tester::TestTree::spinner next]
309        }
310        default {
311            error "bad option \"$op\": should be use, drop, next"
312        }
313    }
314}
Note: See TracBrowser for help on using the repository browser.