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
|
#
# Basic tests for [incr Tk] mega-widgets
# ----------------------------------------------------------------------
# AUTHOR: Michael J. McLennan
# Bell Labs Innovations for Lucent Technologies
# mmclennan@lucent.com
# http://www.tcltk.com/itcl
#
# RCS: $Id: option.test,v 1.4 2004/09/22 09:37:09 davygrvy Exp $
# ----------------------------------------------------------------------
# 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
# ----------------------------------------------------------------------
# Component option processing
# ----------------------------------------------------------------------
test option-1.1 {create a widget for the following tests} {
itcl::class TestOptComp {
inherit itk::Widget
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
}
private variable status ""
public method action {info} {
lappend status $info
}
public method do {cmd} {
eval $cmd
}
itk_option define -status status Status {} {
lappend status $itk_option(-status)
}
}
itcl::class TestOptWidget {
inherit itk::Widget
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
}
}
TestOptWidget .#auto
} {.testOptWidget0}
test option-1.2 {"keep" can be called more than once} {
.testOptWidget0 do {
itk_component add k0 {
TestOptComp $itk_interior.k0 -status "create"
} {
keep -background -foreground -cursor
keep -background -foreground -cursor
keep -status
keep -status
}
pack $itk_component(k0)
}
.testOptWidget0 configure -status "foo"
.testOptWidget0 component k0 do {set status}
} {create foo}
test option-1.3 {"rename" can be called more than once} {
.testOptWidget0 do {
itk_component add k1 {
TestOptComp $itk_interior.k1 -status "create"
} {
rename -status -test test Test
rename -status -test test Test
}
pack $itk_component(k1)
}
.testOptWidget0 configure -test "bar"
.testOptWidget0 component k1 do {set status}
} {create bar}
test option-1.4 {"ignore" overrides keep and rename} {
.testOptWidget0 do {
itk_component add k2 {
TestOptComp $itk_interior.k2 -status "create"
} {
keep -status
rename -status -test test Test
ignore -status
}
pack $itk_component(k2)
}
.testOptWidget0 configure -status k2 -test k2
.testOptWidget0 component k2 do {set status}
} {create foo bar}
# ----------------------------------------------------------------------
# Option processing with "usual" command
# ----------------------------------------------------------------------
test option-2.1 {create a widget for the following tests} {
TestOptComp .testUsual
} {.testUsual}
test option-2.2 {register some "usual" code} {
itk::usual TestOptComp-test {keep -cursor -foreground}
} {}
test option-2.3 {query back "usual" code} {
itk::usual TestOptComp-test
} {keep -cursor -foreground}
test option-2.4 {query back unknown "usual" code} {
itk::usual xyzzyxyzzy
} {}
test option-2.5 {add a component using "usual" code} {
.testUsual do {
itk_component add u0 {
label $itk_interior.u0 -text "Usual Test #0"
} {
usual TestOptComp-test
}
pack $itk_component(u0)
}
.testUsual configure -foreground green -cursor gumby
list [.testUsual component u0 cget -foreground] \
[.testUsual component u0 cget -cursor]
} {green gumby}
test option-2.6 {override "usual" options} {
.testUsual do {
itk_component add u1 {
label $itk_interior.u1 -text "Usual Test #1"
} {
usual TestOptComp-test
ignore -cursor
keep -background
}
pack $itk_component(u1)
}
.testUsual configure -foreground red -background white -cursor dot
list [.testUsual component u1 cget -foreground] \
[.testUsual component u1 cget -background] \
[.testUsual component u1 cget -cursor]
} {red white gumby}
set unique 0
foreach widget {button canvas checkbutton entry frame label listbox
menu menubutton message radiobutton scale scrollbar
text toplevel} {
set name "c[incr unique]"
test option-2.7.$name {verify "usual" options for all Tk widgets} {
.testUsual do [format {
itk_component add %s {
%s $itk_interior.%s
}
} $name $widget $name]
} $name
}
# ----------------------------------------------------------------------
# Clean up
# ----------------------------------------------------------------------
itcl::delete class TestOptComp TestOptWidget
::tcltest::cleanupTests
exit
|
