source: trunk/tester/scripts/statuslist.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: 10.9 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: statuslist - display differences within a test
3#
4#  This is the list of differences shown for a particular test failure.
5#  Each line in this list shows an icon (error or warning) and some
6#  details about the difference.  When you mouse over any entry, it
7#  pops up a "View" button that will invoke the -viewcommand to pop up
8#  a more detailed comparison.
9# ======================================================================
10#  AUTHOR:  Michael McLennan, Purdue University
11#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
12#
13#  See the file "license.terms" for information on usage and
14#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15# ======================================================================
16package require Itk
17package require RapptureGUI
18
19namespace eval Rappture::Tester { # forward declaration }
20
21option add *StatusList.font {Arial -12} widgetDefault
22option add *StatusList.titleFont {Arial -12 bold} widgetDefault
23option add *StatusList.subTitleFont {Arial -10} widgetDefault
24
25itcl::class Rappture::Tester::StatusEntry {
26    public variable title ""
27    public variable subtitle ""
28    public variable body ""
29    public variable help ""
30    public variable icon ""
31    public variable clientdata ""
32
33    constructor {args} { eval configure $args }
34}
35
36itcl::class Rappture::Tester::StatusList {
37    inherit itk::Widget
38
39    itk_option define -font font Font ""
40    itk_option define -titlefont titleFont Font ""
41    itk_option define -subtitlefont subTitleFont Font ""
42    itk_option define -viewcommand viewCommand ViewCommand ""
43    itk_option define -selectbackground selectBackground Foreground ""
44
45    constructor {args} { # defined later }
46    destructor { # defined later }
47
48    public method insert {pos args}
49    public method delete {from {to ""}}
50    public method size {} { return [llength $_entries] }
51    public method get {pos args}
52    public method view {{index "current"}}
53
54    public method xview {args} {
55        return [eval $itk_component(listview) xview $args]
56    }
57    public method yview {args} {
58        return [eval $itk_component(listview) yview $args]
59    }
60
61    protected method _redraw {}
62    protected method _motion {y}
63
64    private variable _dispatcher ""  ;# dispatcher for !events
65    private variable _entries ""     ;# list of status entries
66    private variable _hover ""       ;# mouse is over item with this tag
67}
68
69# ----------------------------------------------------------------------
70# CONSTRUCTOR
71# ----------------------------------------------------------------------
72itcl::body Rappture::Tester::StatusList::constructor {args} {
73    Rappture::dispatcher _dispatcher
74    $_dispatcher register !redraw
75    $_dispatcher dispatch $this !redraw "[itcl::code $this _redraw]; list"
76
77    itk_component add listview {
78        canvas $itk_interior.lv -relief flat
79    } {
80        usual
81        keep -xscrollcommand -yscrollcommand
82    }
83    pack $itk_component(listview) -expand yes -fill both
84
85    # add binding so that each item reacts to mouseover events
86    bind $itk_component(listview) <Motion> [itcl::code $this _motion %y]
87
88    # add binding for double-click-to-open
89    bind $itk_component(listview) <Double-Button-1> [itcl::code $this view]
90
91    # this pops up on each entry
92    itk_component add view {
93        button $itk_interior.view -text "View"
94    } {
95        usual
96        rename -highlightbackground -selectbackground selectBackground Foreground
97    }
98
99    eval itk_initialize $args
100}
101
102itk::usual StatusList {
103    keep -background -foreground -cursor
104    keep -selectbackground
105    keep -font -titlefont -subtitlefont
106}
107
108# ----------------------------------------------------------------------
109# DESTRUCTOR
110# ----------------------------------------------------------------------
111itcl::body Rappture::Tester::StatusList::destructor {} {
112    delete 0 end
113}
114
115# ----------------------------------------------------------------------
116# USAGE: insert <pos> ?-option value -option value ...?
117#
118# Inserts a new entry into the list at the given <pos>.  The options
119# are those recognized by a StatusEntry object.
120# ----------------------------------------------------------------------
121itcl::body Rappture::Tester::StatusList::insert {pos args} {
122    set entry [eval Rappture::Tester::StatusEntry #auto $args]
123    set _entries [linsert $_entries $pos $entry]
124    $_dispatcher event -idle !redraw
125}
126
127# ----------------------------------------------------------------------
128# USAGE: delete <pos> ?<toPos>?
129#
130# Deletes a single entry or a range of entries from the list displayed
131# in this widget.
132# ----------------------------------------------------------------------
133itcl::body Rappture::Tester::StatusList::delete {pos {to ""}} {
134    if {$to eq ""} {
135        set to $pos
136    }
137    foreach obj [lrange $_entries $pos $to] {
138        itcl::delete object $obj
139    }
140    set _entries [lreplace $_entries $pos $to]
141    $_dispatcher event -idle !redraw
142}
143
144# ----------------------------------------------------------------------
145# USAGE: get <pos> ?-key?
146#
147# Queries information about a particular entry at index <pos>.  With
148# no extra args, it returns a list of "-key value -key value ..."
149# representing all of the data about that entry.  Otherwise, the value
150# for a particular -key can be requested.
151# ----------------------------------------------------------------------
152itcl::body Rappture::Tester::StatusList::get {pos {option ""}} {
153    set obj [lindex $_entries $pos]
154    if {$obj eq ""} {
155        return ""
156    }
157    if {$option eq ""} {
158        set vlist ""
159        foreach opt [$obj configure] {
160            lappend vlist [lindex $opt 0] [lindex $opt end]
161        }
162        return $vlist
163    }
164    return [$obj cget $option]
165}
166
167# ----------------------------------------------------------------------
168# USAGE: view ?<index>?
169#
170# Handles the action of clicking the "View" button on items in the
171# status list.  Invokes the -viewcommand to pop up a more detailed
172# view of the item.  Additional details about the item are appended
173# onto the command as a list of options and values.  These include
174# the integer -index for the position of the selected item, along
175# with details defined when the item was inserted into the list.
176# ----------------------------------------------------------------------
177itcl::body Rappture::Tester::StatusList::view {{index "current"}} {
178    if {$index eq "current"} {
179        set index $_hover
180    }
181    if {[string length $itk_option(-viewcommand)] > 0
182          && [string is integer -strict $index]} {
183
184        set obj [lindex $_entries $index]
185        set vlist ""
186        if {$obj ne ""} {
187            foreach opt [$obj configure] {
188                lappend vlist [lindex $opt 0] [lindex $opt end]
189            }
190        }
191        uplevel #0 $itk_option(-viewcommand) -index $index $vlist
192    }
193}
194
195# ----------------------------------------------------------------------
196# USAGE: _redraw
197#
198# Used internally to update the detailed list of items maintained
199# by this widget.
200# ----------------------------------------------------------------------
201itcl::body Rappture::Tester::StatusList::_redraw {} {
202    set c $itk_component(listview)
203    $c delete all
204
205    # figure out the maximum size of all icons
206    set iw 0
207    set ih 0
208    foreach obj $_entries {
209        set icon [$obj cget -icon]
210        if {$icon ne ""} {
211            if {[image width $icon] > $iw} { set iw [image width $icon] }
212            if {[image height $icon] > $ih} { set ih [image height $icon] }
213        }
214    }
215
216    set tlineh [font metrics $itk_option(-titlefont) -linespace]
217    set stlineh [font metrics $itk_option(-subtitlefont) -linespace]
218
219    set x0 2
220    set y0 2
221    set n 0
222    foreach obj $_entries {
223        set tag "entry$n"
224
225        set icon [$obj cget -icon]
226        set iconh 0
227        if {$icon ne ""} {
228            $c create image [expr {$x0+$iw}] $y0 -anchor ne -image $icon \
229                -tags [list $tag main]
230            set iconh [image height $icon]
231        }
232        set x1 [expr {$x0+$iw+6}]
233        set y1 $y0
234
235        set title [$obj cget -title]
236        if {$title ne ""} {
237            $c create text [expr {$x1-4}] $y1 -anchor nw -text $title \
238                -font $itk_option(-titlefont) -tags [list $tag main]
239            set y1 [expr {$y1+$tlineh+2}]
240        }
241
242        set subtitle [$obj cget -subtitle]
243        if {$subtitle ne ""} {
244            $c create text $x1 $y1 -anchor nw -text $subtitle \
245                -font $itk_option(-subtitlefont) -tags [list $tag main]
246            set y1 [expr {$y1+$stlineh+2}]
247        }
248
249        set body [$obj cget -body]
250        if {$body ne ""} {
251            # a little space between the title/subtitle and the body
252            if {$y1 != $y0} { incr y1 4 }
253
254            set id [$c create text $x1 $y1 -anchor nw -text $body \
255                -font $itk_option(-font) -tags [list $tag main]]
256
257            foreach {tx0 ty0 tx1 ty1} [$c bbox $id] break
258            set y1 [expr {$y1 + ($ty1-$ty0)}]
259        }
260
261        # make sure that y1 is at the bottom of the icon too
262        if {$y1 < $y0+$iconh+2} {
263            set y1 [expr {$y0+$iconh+2}]
264        }
265
266        # make a background selection rectangle
267        set id [$c create rectangle 0 [expr {$y0-2}] 1000 $y1 \
268            -outline "" -fill "" -tags [list allbg $tag:bg]]
269        $c lower $id
270
271        set y0 [expr {$y1+10}]
272        incr n
273    }
274
275    # set the scrolling region to the "main" part (no bg boxes)
276    set x1 0; set y1 0
277    foreach {x0 y0 x1 y1} [$c bbox main] break
278    $c configure -scrollregion [list 0 0 [expr {$x1+4}] [expr {$y1+4}]]
279}
280
281# ----------------------------------------------------------------------
282# USAGE: _motion <y>
283#
284# Called internally when the user moves the mouse over an item in the
285# status list that shows specific test failures.  Highlights the item
286# and posts a "View" button on the right-hand side of the list.
287# ----------------------------------------------------------------------
288itcl::body Rappture::Tester::StatusList::_motion {y} {
289    set c $itk_component(listview)
290
291    # translate the screen y to the canvas y (may be scrolled down)
292    set y [$c canvasy $y]
293
294    set index ""
295    foreach id [$c find overlapping 10 $y 10 $y] {
296        foreach tag [$c gettags $id] {
297            if {[regexp {^entry([0-9]+)} $tag match n]} {
298                set index $n
299                break
300            }
301        }
302        if {$index ne ""} {
303            break
304        }
305    }
306
307    if {$index ne $_hover} {
308        $c itemconfigure allbg -fill ""
309        $c delete viewbtn
310
311        if {$index ne ""} {
312            set tag "entry$index:bg"
313            $c itemconfigure $tag -fill $itk_option(-selectbackground)
314
315            foreach {x0 y0 x1 y1} [$c bbox $tag] break
316            set w [winfo width $c]
317            $c create window [expr {$w-10}] [expr {($y0+$y1)/2}] \
318                -anchor e -window $itk_component(view) -tags viewbtn
319
320            $itk_component(view) configure \
321                -command [itcl::code $this view $index]
322        }
323        set _hover $index
324    }
325}
Note: See TracBrowser for help on using the repository browser.