blob: 5b29f66ca9d69fb87607d2ee4ec0d1b409b4bb94 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
#
# Tests for [incr Tk] widgets based on itk::Toplevel
# ----------------------------------------------------------------------
# AUTHOR: Michael J. McLennan
# Bell Labs Innovations for Lucent Technologies
# mmclennan@lucent.com
# http://www.tcltk.com/itcl
#
# RCS: $Id$
# ----------------------------------------------------------------------
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
# ======================================================================
# See the file "license.terms" for information on usage and
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest
namespace import -force ::tcltest::*
::tcltest::loadTestedCommands
# ----------------------------------------------------------------------
# Toplevel mega-widget
# ----------------------------------------------------------------------
test toplevel-1.1 {define a toplevel mega-widget class} {
option add *TestToplevel.background linen
option add *TestToplevel.cursor ""
option add *TestToplevel.foreground navy
option add *TestToplevel.highlight white
option add *TestToplevel.normal ivory
option add *TestToplevel.text ""
itcl::class TestToplevel {
inherit itk::Toplevel
constructor {args} {
itk_component add test1 {
label $itk_interior.t1
} {
keep -background -foreground -cursor
keep -text
}
pack $itk_component(test1) -side left -padx 2
eval itk_initialize $args
}
public method do {cmd} {
eval $cmd
}
private variable status ""
itk_option define -background background Background {} {
lappend status "background: $itk_option(-background)"
}
}
TestToplevel .#auto
} {.testToplevel0}
test toplevel-1.2 {check the list of configuration options} {
.testToplevel0 configure
} {{-background background Background linen linen} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-takefocus takeFocus TakeFocus 0 0} {-text text Text {} {}} {-title title Title {} {}}}
test toplevel-1.3 {check the list components} {
lsort [.testToplevel0 component]
} {hull test1}
test toplevel-1.4 {check the propagation of configuration options} {
.testToplevel0 configure -background red
list [.testToplevel0 component hull cget -background] \
[.testToplevel0 component test1 cget -background] \
[.testToplevel0 do {set status}]
} {red red {{background: linen} {background: red}}}
test toplevel-1.5 {mega-widgets show up on the object list} {
itcl::find objects .testToplevel*
} {.testToplevel0}
test toplevel-1.6 {when a mega-widget is destroyed, its object is deleted} {
destroy .testToplevel0
itcl::find objects .testToplevel*
} {}
test toplevel-1.7 {when an mega-widget object is deleted, its window and any
components are destroyed } {
TestToplevel .delme
set label [.delme component test1]
itcl::delete object .delme
list [winfo exists .delme] [winfo exists $label]
} {0 0}
test toplevel-1.8 {when a mega-widget object is deleted, its window and any
components are destroyed (even if in another window) } {
catch {destroy .t1}
catch {destroy .t2}
catch {rename .t2 {}}
catch {itcl::delete class ButtonTop}
itcl::class ButtonTop {
inherit itk::Toplevel
constructor {args} {
eval itk_initialize $args
itk_component add button {
button $itk_option(-container).b -text Button
} {}
pack $itk_component(button)
}
itk_option define -container container Container {}
}
toplevel .t1
ButtonTop .t2 -container .t1
set button [.t2 component button]
itcl::delete object .t2
set result [list $button [winfo exists $button]]
itcl::delete class ButtonTop
destroy .t1
set result
} {.t1.b 0}
test toplevel-1.9 {when a window that contains a megawidget component
is destroyed, the component is removed from the megawidget} {
catch {destroy .t1}
catch {destroy .t2}
catch {rename .t2 {}}
catch {itcl::delete class ButtonTop}
itcl::class ButtonTop {
inherit itk::Toplevel
constructor {args} {
eval itk_initialize $args
itk_component add button {
button $itk_option(-container).b -text Button
} {}
pack $itk_component(button)
}
itk_option define -container container Container {}
}
toplevel .t1
ButtonTop .t2 -container .t1
set result [list [.t2 component]]
destroy .t1
lappend result [list [.t2 component]]
itcl::delete object .t2
itcl::delete class ButtonTop
set result
} {{button hull} hull}
test toplevel-1.10 {when destroying a component that is inside another
window protect against that case where one component destroy
actually destroys other contained components} {
catch {destroy .t1}
catch {destroy .t2}
catch {rename .t2 {}}
catch {itcl::delete class ButtonTop}
itcl::class ButtonTop {
inherit itk::Toplevel
constructor {args} {
eval itk_initialize $args
# Note, the component names matter here since
# [.t2 component] returns names in hash order.
# We need to delete cframe first since it
# is the parent of cbutton.
itk_component add cframe {
button $itk_option(-container).cframe
} {}
pack $itk_component(cframe)
itk_component add cbutton {
button $itk_component(cframe).b -text Button
} {}
pack $itk_component(cbutton)
}
itk_option define -container container Container {}
}
toplevel .t1
ButtonTop .t2 -container .t1
set result [list [.t2 component]]
# destructor should destroy cframe but not cbutton
itcl::delete object .t2
lappend result [winfo exists .t1.cframe]
destroy .t1
itcl::delete class ButtonTop
set result
} {{hull cframe cbutton} 0}
# ----------------------------------------------------------------------
# Clean up
# ----------------------------------------------------------------------
itcl::delete class TestToplevel
::tcltest::cleanupTests
exit
|
