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

Last change on this file since 2139 was 2139, checked in by mmc, 13 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: 8.5 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: legend - show a legend of color/line samples
3#
4#  This widget acts as a legend for the differences view.  It manages
5#  a series of samples, each with a block or line sample and a label.
6# ======================================================================
7#  AUTHOR:  Michael McLennan, Purdue University
8#  Copyright (c) 2010-2011  Purdue Research Foundation
9#
10#  See the file "license.terms" for information on usage and
11#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12# ======================================================================
13package require Itk
14
15namespace eval Rappture::Tester { # forward declaration }
16
17option add *Legend.font {Arial -12} widgetDefault
18option add *Legend.padX 12 widgetDefault
19
20itcl::class Rappture::Tester::LegendEntry {
21    public variable title ""
22    public variable shape "box" {
23        if {[lsearch {box line} $shape] < 0} {
24            error "bad value \"$shape\": should be box, line"
25        }
26    }
27    public variable color ""
28    public variable state "normal" {
29        if {[lsearch {normal disabled} $state] < 0} {
30            error "bad value \"$state\": should be normal, disabled"
31        }
32    }
33    public variable anchor "w" {
34        if {[lsearch {e w} $anchor] < 0} {
35            error "bad value \"$anchor\": should be e, w"
36        }
37    }
38
39    constructor {args} { eval configure $args }
40}
41
42itcl::class Rappture::Tester::Legend {
43    inherit itk::Widget
44
45    itk_option define -font font Font ""
46    itk_option define -padx padX PadX 1
47
48    constructor {args} { # defined later }
49    destructor { # defined later }
50
51    public method insert {pos args}
52    public method delete {from {to ""}}
53    public method itemconfigure {what args}
54    public method size {} { return [llength $_entries] }
55    public method get {pos args}
56
57    protected method _redraw {}
58
59    private variable _dispatcher ""  ;# dispatcher for !events
60    private variable _entries ""     ;# list of status entries
61}
62
63# ----------------------------------------------------------------------
64# CONSTRUCTOR
65# ----------------------------------------------------------------------
66itcl::body Rappture::Tester::Legend::constructor {args} {
67    Rappture::dispatcher _dispatcher
68    $_dispatcher register !redraw
69    $_dispatcher dispatch $this !redraw "[itcl::code $this _redraw]; list"
70
71    itk_component add area {
72        canvas $itk_interior.area -relief flat
73    }
74    pack $itk_component(area) -expand yes -fill both
75
76    bind $itk_component(hull) <Configure> \
77        [list $_dispatcher event -idle !redraw]
78
79    eval itk_initialize $args
80}
81
82itk::usual Legend {
83    keep -background -foreground -cursor -font
84}
85
86# ----------------------------------------------------------------------
87# DESTRUCTOR
88# ----------------------------------------------------------------------
89itcl::body Rappture::Tester::Legend::destructor {} {
90    delete 0 end
91}
92
93# ----------------------------------------------------------------------
94# USAGE: insert <pos> ?-option value -option value ...?
95#
96# Inserts a new entry into the legend at the given <pos>.  The options
97# are those recognized by a LegendEntry object.
98# ----------------------------------------------------------------------
99itcl::body Rappture::Tester::Legend::insert {pos args} {
100    set entry [eval Rappture::Tester::LegendEntry #auto $args]
101    set _entries [linsert $_entries $pos $entry]
102    $_dispatcher event -idle !redraw
103}
104
105# ----------------------------------------------------------------------
106# USAGE: delete <pos> ?<toPos>?
107#
108# Deletes a single entry or a range of entries from the legend
109# displayed in this widget.
110# ----------------------------------------------------------------------
111itcl::body Rappture::Tester::Legend::delete {pos {to ""}} {
112    if {$to eq ""} {
113        set to $pos
114    }
115    foreach obj [lrange $_entries $pos $to] {
116        itcl::delete object $obj
117    }
118    set _entries [lreplace $_entries $pos $to]
119    $_dispatcher event -idle !redraw
120}
121
122# ----------------------------------------------------------------------
123# USAGE: itemconfigure <what> ?-option? ?value -option value ...?
124#
125# Changes the options of a particular entry.  The <what> can be the
126# -title of the entry, or an integer index.  The options are those
127# recognized by a LegendEntry object.
128# ----------------------------------------------------------------------
129itcl::body Rappture::Tester::Legend::itemconfigure {what args} {
130    # first, see if the <what> parameter matches a title
131    set obj ""
132    foreach entry $_entries {
133        if {[$entry cget -title] eq $what} {
134            set obj $entry
135            break
136        }
137    }
138
139    # if not, see if it's an integer index
140    if {$obj eq "" && [string is integer -strict $what]} {
141        set obj [lindex $_entries $what]
142    }
143
144    if {$obj eq ""} {
145        error "bad option \"$what\": should be entry title or integer index"
146    }
147
148    # if this is a query operation, return the info
149    if {[llength $args] < 2} {
150        return [eval $obj configure $args]
151    }
152
153    # configure the entry and then schedule a redraw to show the change
154    eval $obj configure $args
155    $_dispatcher event -idle !redraw
156}
157
158# ----------------------------------------------------------------------
159# USAGE: get <pos> ?-key?
160#
161# Queries information about a particular entry at index <pos>.  With
162# no extra args, it returns a list of "-key value -key value ..."
163# representing all of the data about that entry.  Otherwise, the value
164# for a particular -key can be requested.
165# ----------------------------------------------------------------------
166itcl::body Rappture::Tester::Legend::get {pos {option ""}} {
167    set obj [lindex $_entries $pos]
168    if {$obj eq ""} {
169        return ""
170    }
171    if {$option eq ""} {
172        set vlist ""
173        foreach opt [$obj configure] {
174            lappend vlist [lindex $opt 0] [lindex $opt end]
175        }
176        return $vlist
177    }
178    return [$obj cget $option]
179}
180
181# ----------------------------------------------------------------------
182# USAGE: _redraw
183#
184# Used internally to update the detailed list of items maintained
185# by this widget.
186# ----------------------------------------------------------------------
187itcl::body Rappture::Tester::Legend::_redraw {} {
188    set c $itk_component(area)
189    set w [winfo width $c]
190    set ymid [expr {[winfo height $c]/2}]
191    set padx $itk_option(-padx)
192    set fn $itk_option(-font)
193    set ssize [expr {[font metrics $fn -linespace]-2}]
194
195    $c delete all
196
197    # left/right edges of the drawing area
198    set x0 2
199    set x1 [expr {[winfo width $c]-2}]
200
201    # overall label on the left
202    set id [$c create text $x0 $ymid -anchor w -text "Legend:" -font $fn]
203    foreach {bx0 by0 bx1 by1} [$c bbox $id] break
204    set x0 [expr {$x0 + $bx1-$bx0 + $padx}]
205
206    foreach obj $_entries {
207        if {[$obj cget -state] eq "disabled" || [$obj cget -title] eq ""
208              || [$obj cget -color] eq ""} {
209            continue
210        }
211
212        set labelw [font measure $fn [$obj cget -title]]
213        set entryw [expr {$labelw + $ssize + 3}]
214
215        switch -- [$obj cget -anchor] {
216            w {
217                set xpos $x0
218                set x0 [expr {$x0 + $entryw + $padx}]
219            }
220            e {
221                set xpos [expr {$x1 - $entryw}]
222                set x1 [expr {$x1 - $entryw - $padx}]
223            }
224        }
225
226        switch -- [$obj cget -shape] {
227            box {
228                # draw the box style
229                $c create rectangle \
230                    $xpos [expr {$ymid-$ssize/2}] \
231                    [expr {$xpos+$ssize}] [expr {$ymid+$ssize/2}] \
232                    -outline black -fill [$obj cget -color]
233            }
234            line {
235                # draw the line style
236                $c create line $xpos $ymid [expr {$xpos+$ssize}] $ymid \
237                    -width 2 -fill [$obj cget -color]
238            }
239        }
240        set xpos [expr {$xpos+$ssize+3}]
241
242        $c create text $xpos $ymid -anchor w -text [$obj cget -title] -font $fn
243
244        if {$x0 >= $x1} break
245    }
246
247    # fix the requested size for the widget based on the layout
248    $c configure -width [expr {$x0 + [winfo width $c]-$x1}]
249}
250
251# ----------------------------------------------------------------------
252# CONFIGURATION OPTIONS
253# ----------------------------------------------------------------------
254itcl::configbody Rappture::Tester::Legend::font {
255    set lineh [font metrics $itk_option(-font) -linespace]
256    $itk_component(area) configure -height [expr {$lineh+4}]
257    $_dispatcher event -idle !redraw
258}
Note: See TracBrowser for help on using the repository browser.