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

Last change on this file since 2083 was 2081, checked in by mmc, 14 years ago

Part 2 of the major reorganization to group all of the rappture utilties
under a single rappture command. Builds better now. Still need to fix
up the builder to work with the objects in a different location now.
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.