1#
2# Tests for [incr Tk] widgets based on itk::Widget
3# ----------------------------------------------------------------------
4#   AUTHOR:  Michael J. McLennan
5#            Bell Labs Innovations for Lucent Technologies
6#            mmclennan@lucent.com
7#            http://www.tcltk.com/itcl
8#
9#      RCS:  $Id: widget.test,v 1.6 2004/09/22 09:37:09 davygrvy Exp $
10# ----------------------------------------------------------------------
11#            Copyright (c) 1993-1998  Lucent Technologies, Inc.
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 tcltest
17namespace import -force ::tcltest::*
18
19::tcltest::loadTestedCommands
20
21
22# ----------------------------------------------------------------------
23#  Simple mega-widget
24# ----------------------------------------------------------------------
25test widget-1.1 {define a simple mega-widget class} {
26    option add *TestWidget.background linen
27    option add *TestWidget.borderWidth 2
28    option add *TestWidget.command ""
29    option add *TestWidget.cursor ""
30    option add *TestWidget.foreground navy
31    option add *TestWidget.highlight white
32    option add *TestWidget.normal ivory
33    option add *TestWidget.text ""
34
35    itcl::class TestWidget {
36        inherit itk::Widget
37        constructor {args} {
38            itk_component add test1 {
39                label $itk_interior.t1
40            } {
41                keep -background -foreground -cursor
42                keep -text
43            }
44            pack $itk_component(test1) -side left -padx 2
45
46            itk_component add test2 {
47                button $itk_interior.t2 -text "Push Me"
48            } {
49                keep -foreground -cursor -borderwidth -command
50                rename -background -normal normal Background
51                rename -activebackground -highlight highlight Foreground
52            }
53            pack $itk_component(test2) -side right -fill x -pady 2
54
55            eval itk_initialize $args
56        }
57        private variable status ""
58        public method action {info} {
59            lappend status $info
60        }
61
62        public method do {cmd} {
63            eval $cmd
64        }
65
66        itk_option define -status status Status {} {
67            lappend status $itk_option(-status)
68        }
69    }
70    TestWidget .#auto
71} {.testWidget0}
72
73pack .testWidget0
74
75test widget-1.2 {check the list of configuration options} {
76    .testWidget0 configure
77} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}} {-text text Text {} {}}}
78
79set unique 0
80foreach test {
81    {-background  {-background background Background linen linen}}
82    {-borderwidth {-borderwidth borderWidth BorderWidth 2 2}}
83    {-clientdata  {-clientdata clientData ClientData {} {}}}
84    {-command     {-command command Command {} {}}}
85    {-cursor      {-cursor cursor Cursor {} {}}}
86    {-foreground  {-foreground foreground Foreground navy navy}}
87    {-highlight   {-highlight highlight Foreground white white}}
88    {-normal      {-normal normal Background ivory ivory}}
89    {-status      {-status status Status {} {}}}
90    {-text        {-text text Text {} {}}}
91} {
92    set opt [lindex $test 0]
93    set result [lindex $test 1]
94
95    test widget-1.3.[incr unique] {check individual configuration options} {
96        .testWidget0 configure $opt
97    } $result
98}
99
100set unique 0
101foreach test {
102    {-background  red}
103    {-borderwidth 1}
104    {-clientdata  "foo bar"}
105    {-command     {puts "hello!"}}
106    {-cursor      trek}
107    {-foreground  IndianRed}
108    {-highlight   MistyRose}
109    {-normal      MistyRose2}
110    {-status      "test message"}
111    {-text        "Label:"}
112} {
113    set opt [lindex $test 0]
114    set value [lindex $test 1]
115
116    test widget-1.4.[incr unique] {set individual configuration options} {
117        list [.testWidget0 configure $opt $value] \
118             [.testWidget0 cget $opt] \
119             [.testWidget0 do "set itk_option($opt)"]
120    } [list "" $value $value]
121}
122
123test widget-1.5 {check the list components} {
124    lsort [.testWidget0 component]
125} {hull test1 test2}
126
127set unique 0
128foreach test {
129    {hull  .testWidget0}
130    {test1 .testWidget0.t1}
131    {test2 .testWidget0.t2}
132} {
133    set name [lindex $test 0]
134    set win  [lindex $test 1]
135
136    test widget-1.6 {check the window for each component} {
137        list [.testWidget0 component $name] \
138             [.testWidget0 do "set itk_component($name)"]
139    } [list $win $win]
140}
141
142test widget-1.7 {check the propagation of configuration options} {
143    list [.testWidget0 component hull cget -cursor] \
144         [.testWidget0 component test1 cget -cursor] \
145         [.testWidget0 component test2 cget -cursor]
146} {trek trek trek}
147
148test widget-1.8 {check the propagation of configuration options} {
149    list [.testWidget0 component hull cget -background] \
150         [.testWidget0 component test1 cget -background] \
151         [.testWidget0 component test2 cget -background]
152} {red red MistyRose2}
153
154test widget-1.9 {check the propagation of configuration options} {
155    list [.testWidget0 component test1 cget -text] \
156         [.testWidget0 component test2 cget -text]
157} {Label: {Push Me}}
158
159test widget-1.10 {check the invocation of "config" code} {
160    .testWidget0 do {set status}
161} {{} {test message}}
162
163test widget-1.11a {configure using the "code" command} {
164    .testWidget0 do {configure -command [itcl::code $this action "button press"]}
165    .testWidget0 cget -command
166} {namespace inscope ::TestWidget {::.testWidget0 action {button press}}}
167
168test widget-1.11b {execute some code created by "code" command} {
169    .testWidget0 do {set status ""}
170    .testWidget0 component test2 invoke
171    .testWidget0 configure -status "in between"
172    .testWidget0 component test2 invoke
173    .testWidget0 do {set status}
174} {{button press} {in between} {button press}}
175
176test widget-1.12a {components can be added on the fly} {
177    .testWidget0 do {
178        itk_component add test3 {
179            label $itk_interior.t3 -text "Temporary"
180        } {
181            keep -background -foreground -cursor
182        }
183    }
184} {test3}
185
186test widget-1.12b {components can be added on the fly} {
187    .testWidget0 do {
188        pack $itk_component(test3) -fill x
189    }
190} {}
191
192test widget-1.13 {new components show up on the component list} {
193    lsort [.testWidget0 component]
194} {hull test1 test2 test3}
195
196test widget-1.14 {new components are initialized properly} {
197    list [.testWidget0 component test3 cget -background] \
198         [.testWidget0 component test3 cget -foreground] \
199         [.testWidget0 component test3 cget -cursor]
200} {red IndianRed trek}
201
202test widget-1.15 {components can be deleted like ordinary widgets} {
203    destroy [.testWidget0 component test3]
204} {}
205
206test widget-1.16 {dead components are removed from the component list} {
207    lsort [.testWidget0 component]
208} {hull test1 test2}
209
210test widget-1.17 {use "configbody" command to change "config" code} {
211    itcl::configbody TestWidget::status {lappend status "new"}
212} {}
213
214test widget-1.18 {"config" code can really change} {
215    .testWidget0 do {set status ""}
216    .testWidget0 configure -status "test message"
217    .testWidget0 configure -status "another"
218    .testWidget0 do {set status}
219} {new new}
220
221test widget-1.19 {"config" code can change back} {
222    itcl::configbody TestWidget::status {lappend status $itk_option(-status)}
223} {}
224
225test widget-1.20 {mega-widgets show up on the object list} {
226    itcl::find objects .testWidget*
227} {.testWidget0}
228
229test widget-1.21 {when a mega-widget is destroyed, its object is deleted} {
230    destroy .testWidget0
231    itcl::find objects .testWidget*
232} {}
233
234test widget-1.22 {recreate a test widget} {
235    TestWidget .testWidget0
236    itcl::find objects .testWidget*
237} {.testWidget0}
238
239test widget-1.23 {when an object is deleted the widget is destroyed} {
240    itcl::delete object .testWidget0
241    winfo exists .testWidget0
242} {0}
243
244test widget-1.24 {recreate another test widget} {
245    TestWidget .testWidget
246} {.testWidget}
247
248test widget-1.25 {when an internal component is destroyed, it is removed from the list of components, and any dead options disappear} {
249    list [lsort [.testWidget component]] \
250         [.testWidget configure] \
251      [catch {destroy [.testWidget component test1]}] \
252         [.testWidget component] \
253         [.testWidget do {return [lsort [array names itk_component]]}] \
254         [.testWidget configure]
255} {{hull test1 test2} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}} {-text text Text {} {}}} 0 {hull test2} {hull test2} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}}}}
256
257test widget-1.26 {when an internal component is deleted (but not destroyed) it is disconnected from the option list and its binding tags are updated} {
258    set comp [.testWidget component test2]
259    list [bindtags $comp] \
260         [bind itk-destroy-$comp <Destroy>] \
261      [catch {.testWidget do {itk_component delete test2}}] \
262         [bindtags $comp] \
263         [bind itk-destroy-$comp <Destroy>] \
264         [.testWidget configure]
265} {{itk-destroy-.testWidget.t2 .testWidget.t2 Button . all} {namespace inscope ::itk::Archetype {::.testWidget itk_component delete test2}} 0 {.testWidget.t2 Button . all} {} {{-background background Background linen linen} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor {} {}} {-status status Status {} {}}}}
266
267test widget-1.27 {when a mega-widget object is deleted, its window and any
268        components are destroyed (even if in another window) } {
269    catch {destroy .t1}
270    catch {rename .t1.bw {}}
271    catch {itcl::delete class ButtonWidget}
272
273    itcl::class ButtonWidget {
274        inherit itk::Widget
275
276        constructor {args} {
277            eval itk_initialize $args
278
279            itk_component add button {
280                button $itk_option(-container).b -text Button
281            } {}
282            pack $itk_component(button)
283        }
284
285        itk_option define -container container Container {}
286    }
287
288    toplevel .t1
289    frame .t1.f
290    ButtonWidget .t1.bw -container .t1.f
291
292    pack .t1.f
293    pack .t1.bw
294
295    set button [.t1.bw component button]
296    itcl::delete object .t1.bw
297    set result [list $button [winfo exists $button]]
298    destroy .t1
299    itcl::delete class ButtonWidget
300    set result
301} {.t1.f.b 0}
302
303test widget-1.28 {when a window that contains a megawidget component
304        is destroyed, the component is removed from the megawidget} {
305    catch {destroy .t1}
306    catch {rename .t1.bw {}}
307    catch {itcl::delete class ButtonWidget}
308
309    itcl::class ButtonWidget {
310        inherit itk::Widget
311
312        constructor {args} {
313            eval itk_initialize $args
314
315            itk_component add button {
316                button $itk_option(-container).b -text Button
317            } {}
318            pack $itk_component(button)
319        }
320
321        itk_option define -container container Container {}
322    }
323
324    toplevel .t1
325    frame .t1.f
326    ButtonWidget .t1.bw -container .t1.f
327
328    pack .t1.f
329    pack .t1.bw
330    set result [list [.t1.bw component]]
331    destroy .t1.f
332    lappend result [list [.t1.bw component]]
333
334    itcl::delete object .t1.bw
335    destroy .t1
336    itcl::delete class ButtonWidget
337    set result
338} {{button hull} hull}
339
340test widget-1.29 {when destroying a component that is inside another
341        window protect against that case where one component destroy
342        actually destroys other contained components} {
343    catch {destroy .t1}
344    catch {rename .t1.bw {}}
345    catch {itcl::delete class ButtonWidget}
346
347    itcl::class ButtonWidget {
348        inherit itk::Widget
349
350        constructor {args} {
351            eval itk_initialize $args
352
353            # Note, the component names matter here since
354            # [.t2 component] returns names in hash order.
355            # We need to delete cframe first since it
356            # is the parent of cbutton.
357
358            itk_component add cframe {
359                button $itk_option(-container).cframe
360            } {}
361            pack $itk_component(cframe)
362
363            itk_component add cbutton {
364                button $itk_component(cframe).b -text Button
365            } {}
366            pack $itk_component(cbutton)
367        }
368
369        itk_option define -container container Container {}
370    }
371
372    toplevel .t1
373    frame .t1.f
374    ButtonWidget .t1.bw -container .t1.f
375
376    pack .t1.f
377    pack .t1.bw
378    set result [list [.t1.bw component]]
379    # destructor should destroy cframe but not cbutton
380    itcl::delete object .t1.bw
381    lappend result [winfo exists .t1.f.cframe]
382
383    destroy .t1
384    itcl::delete class ButtonWidget
385    set result
386} {{hull cframe cbutton} 0}
387
388
389# ----------------------------------------------------------------------
390#  Clean up
391# ----------------------------------------------------------------------
392itcl::delete class TestWidget
393
394::tcltest::cleanupTests
395exit
396