source: trunk/tester/testtree.tcl @ 2080

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

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...

File size: 11.3 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(scrollbars) contents $itk_component(treeview)
88
89    itk_component add bottomBar {
90        frame $itk_interior.bottomBar
91    }
92    pack $itk_component(bottomBar) -fill x -side bottom -pady {8 0}
93
94    itk_component add selLabel {
95        label $itk_component(bottomBar).selLabel -anchor w -text "Select:"
96    }
97    pack $itk_component(selLabel) -side left
98
99    itk_component add bSelectAll {
100        button $itk_component(bottomBar).bSelectAll -text "All" \
101            -command "$itk_component(treeview) selection set 0 end"
102    }
103    pack $itk_component(bSelectAll) -side left
104
105    itk_component add bSelectNone {
106        button $itk_component(bottomBar).bSelectNone -text "None" \
107            -command "$itk_component(treeview) selection clearall"
108    }
109    pack $itk_component(bSelectNone) -side left
110
111
112    eval itk_initialize $args
113}
114
115# ----------------------------------------------------------------------
116# DESTRUCTOR
117# ----------------------------------------------------------------------
118itcl::body Rappture::Tester::TestTree::destructor {} {
119    clear
120}
121
122# ----------------------------------------------------------------------
123# USAGE: add ?<testObj> <testObj> ...?
124#
125# Adds one or more Test objects to the tree shown in this viewer.
126# Once added, these objects become property of this widget and
127# are destroyed when the widget is cleared or deleted.
128# ----------------------------------------------------------------------
129itcl::body Rappture::Tester::TestTree::add {args} {
130    set icon [Rappture::icon testcase]
131
132    foreach obj $args {
133        if {[catch {$obj isa Rappture::Tester::Test} valid] || !$valid} {
134            error "bad value \"$obj\": should be Test object"
135        }
136
137        # add each Test object into the tree
138        set testpath [$obj getTestInfo test.label]
139        set n [$itk_component(treeview) insert end $testpath \
140             -data [list test $obj] -icons [list $icon $icon]]
141
142        # tag this node so we can find it easily later
143        $itk_component(treeview) tag add $obj $n
144
145        # monitor state changes on the object
146        $obj configure -notifycommand [itcl::code $this _refresh]
147    }
148}
149
150# ----------------------------------------------------------------------
151# USAGE: clear
152#
153# Clears the contents of the tree so that it's completely empty.
154# All Test objects stored internally are destroyed.
155# ----------------------------------------------------------------------
156itcl::body Rappture::Tester::TestTree::clear {} {
157    foreach id [_getLeaves] {
158        itcl::delete object [_getTest $id]
159    }
160    $itk_component(treeview) delete 0
161}
162
163# ----------------------------------------------------------------------
164# USAGE: curselection
165#
166# Returns a list ids for all currently selected tests (leaf nodes) and
167# the child tests of any currently selected branch nodes.  Tests can
168# only be leaf nodes in the tree (the ids in the returned list will
169# correspond to leaf nodes only).
170# ----------------------------------------------------------------------
171itcl::body Rappture::Tester::TestTree::curselection {} {
172    set rlist ""
173    foreach id [$itk_component(treeview) curselection] {
174        foreach node [_getLeaves $id] {
175            catch {unset data}
176            array set data [$itk_component(treeview) entry cget $node -data]
177
178            if {[lsearch -exact $rlist $data(test)] < 0} {
179                lappend rlist $data(test)
180            }
181        }
182    }
183    return $rlist
184}
185
186# ----------------------------------------------------------------------
187# USAGE _getTest <nodeId>
188#
189# Returns the test object associated with a given treeview node id.  If
190# no id is given, return the test associated with the currently focused
191# node.  Returns empty string if the given id / focused node is a
192# branch node.
193# ----------------------------------------------------------------------
194itcl::body Rappture::Tester::TestTree::_getTest {id} {
195    if {[lsearch -exact [_getLeaves] $id] < 0} {
196        # Return empty string if branch node selected
197        return ""
198    }
199    array set darray [$itk_component(treeview) entry cget $id -data]
200    return $darray(test)
201}
202
203# ----------------------------------------------------------------------
204# USAGE: _refresh ?<testObj> <testObj> ...?
205#
206# Invoked whenever the state of a <testObj> changes.  Finds the
207# corresponding entry in the tree and updates the "Result" column
208# to show the new status.
209# ----------------------------------------------------------------------
210itcl::body Rappture::Tester::TestTree::_refresh {args} {
211    foreach obj $args {
212        set n [$itk_component(treeview) index $obj]
213        if {$n ne ""} {
214            catch {unset data}
215            array set data [$itk_component(treeview) entry cget $n -data]
216
217            # getting rid of a spinner? then drop it
218            if {[info exists data(result)]
219                  && $data(result) == "@$spinner(image)"} {
220                spinner drop
221            }
222
223            # plug in the new icon
224            switch -- [$obj getResult] {
225                Pass    { set data(result) "@[Rappture::icon pass16]" }
226                Fail    { set data(result) "@[Rappture::icon fail16]" }
227                Waiting { set data(result) "@[Rappture::icon wait16]" }
228                Running { set data(result) "@[spinner use]" }
229                default { set data(result) "" }
230            }
231puts "ICON: $data(result)"
232            $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            }
242        }
243    }
244}
245
246# ----------------------------------------------------------------------
247# USAGE: _getLeaves ?id?
248#
249# Returns a list of ids for all tests contained in the tree.  If an
250# optional id is given as an input parameter, then the returned list
251# will contain the ids of all tests that are descendants of the given
252# id.  Tests can only be leaf nodes.
253# ----------------------------------------------------------------------
254itcl::body Rappture::Tester::TestTree::_getLeaves {{id 0}} {
255    set clist [$itk_component(treeview) entry children $id]
256    if {$clist == "" && $id == 0} {
257        # Return nothing if tree is empty
258        return ""
259    }
260    if {$clist == ""} {
261        return $id
262    }
263    set tests [list]
264    foreach child $clist {
265        set tests [concat $tests [_getLeaves $child]]
266    }
267    return $tests
268}
269
270# ----------------------------------------------------------------------
271# USAGE: spinner use|drop|next
272#
273# Used to update the spinner icon that represents running test cases.
274# The "use" option returns the spinner icon and starts the animation,
275# if it isn't already running.  The "drop" operation lets go of the
276# spinner.  If nobody is using it, the animation stops.  The "next"
277# option is used internally to change the animation to the next frame.
278# ----------------------------------------------------------------------
279itcl::body Rappture::Tester::TestTree::spinner {op} {
280    switch -- $op {
281        use {
282            if {$spinner(pending) == ""} {
283                set spinner(current) 0
284                set spinner(pending) [after 100 Rappture::Tester::TestTree::spinner next]
285            }
286            incr spinner(uses)
287            return $spinner(image)
288        }
289        drop {
290            if {[incr spinner(uses) -1] <= 0} {
291                after cancel $spinner(pending)
292                set spinner(pending) ""
293                set spinner(uses) 0
294            }
295        }
296        next {
297            set n $spinner(current)
298            $spinner(image) copy $spinner(frame$n)
299
300            # go to the next frame
301            if {[incr spinner(current)] >= $spinner(frames)} {
302                set spinner(current) 0
303            }
304
305            # update again after a short delay
306            set spinner(pending) [after 100 Rappture::Tester::TestTree::spinner next]
307        }
308        default {
309            error "bad option \"$op\": should be use, drop, next"
310        }
311    }
312}
Note: See TracBrowser for help on using the repository browser.