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

Last change on this file since 4503 was 3177, checked in by mmc, 8 years ago

Updated all of the copyright notices to reference the transfer to
the new HUBzero Foundation, LLC.

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) 2004-2012  HUBzero Foundation, LLC
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.