blob: 4dad5da4b6c943e3fc7f802f05910024ee068512 (
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
|
# Test the "tk::fontchooser" command
#
# Copyright (c) 2008 Pat Thoyts
package require tcltest 2.1
eval tcltest::configure $argv
tcltest::loadTestedCommands
# the following helper functions are related to the functions used
# in winDialog.test where they are used to send messages to the win32
# dialog (hence the wierdness).
proc start {cmd} {
set ::tk_dialog {}
set ::iter_after 0
after 1 $cmd
}
proc then {cmd} {
set ::command $cmd
set ::dialogresult {}
set ::testfont {}
afterbody
vwait ::dialogresult
return $::dialogresult
}
proc afterbody {} {
if {$::tk_dialog == {}} {
if {[incr ::iter_after] > 30} {
set ::dialogresult ">30 iterations waiting for tk_dialog"
return
}
after 150 {afterbody}
return
}
uplevel #0 {set dialogresult [eval $command]}
}
proc Click {button} {
switch -exact -- $button {
ok { $::tk_dialog.ok invoke }
cancel { $::tk_dialog.cancel invoke }
apply { $::tk_dialog.apply invoke }
default { return -code error "invalid button name \"$button\"" }
}
}
proc ApplyFont {font} {
# puts stderr "apply: $font"
set ::testfont $font
}
# -------------------------------------------------------------------------
test fontchooser-1.1 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser -z
} -result {unknown or ambiguous subcommand "-z": must be configure, hide, or show}
test fontchooser-1.2 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -z
} -match glob -result {bad option "-z":*}
test fontchooser-1.3 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -parent . -font
} -result {value for "-font" missing}
test fontchooser-1.4 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -parent . -title
} -result {value for "-title" missing}
test fontchooser-1.5 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -parent . -command
} -result {value for "-command" missing}
test fontchooser-1.6 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -title . -parent
} -result {value for "-parent" missing}
test fontchooser-1.7 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -parent abc
} -result {bad window path name "abc"}
test fontchooser-1.8 {tk fontchooser: usage} -returnCodes ok -body {
tk fontchooser configure -visible
} -result {0}
test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body {
tk fontchooser configure -visible 1
} -match glob -result {*}
# -------------------------------------------------------------------------
#
# The remaining tests in this file are only relevant for the script
# implementation. They can be tested by sourcing the script file but
# the Tk tests are run with -singleproc 1 and doing this affects the
# result of later attempts to test the native implementations.
#
testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]]
test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -title "Hello"
tk::fontchooser::Show
}
then {
set x [wm title $::tk_dialog]
Click cancel
}
set x
} -result {Hello}
test fontchooser-2.1 {fontchooser -title (cyrillic)} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure \
-title "\u041f\u0440\u0438\u0432\u0435\u0442"
tk::fontchooser::Show
}
then {
set x [wm title $::tk_dialog]
Click cancel
}
set x
} -result "\u041f\u0440\u0438\u0432\u0435\u0442"
test fontchooser-3.0 {fontchooser -parent} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -parent .
tk::fontchooser::Show
}
then {
set x [winfo parent $::tk_dialog]
Click cancel
}
set x
} -result {.}
test fontchooser-3.1 {fontchooser -parent (invalid)} -constraints scriptImpl -body {
tk::fontchooser::Configure -parent junk
} -returnCodes error -match glob -result {bad window path *}
test fontchooser-4.0 {fontchooser -font} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -command ApplyFont -font courier
tk::fontchooser::Show
}
then {
Click cancel
}
set ::testfont
} -result {}
test fontchooser-4.1 {fontchooser -font} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -command ApplyFont -font courier
tk::fontchooser::Show
}
then {
Click ok
}
expr {$::testfont ne {}}
} -result {1}
test fontchooser-4.2 {fontchooser -font} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -command ApplyFont -font TkDefaultFont
tk::fontchooser::Show
}
then {
Click ok
}
expr {$::testfont ne {}}
} -result {1}
test fontchooser-4.3 {fontchooser -font} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
tk::fontchooser::Show
}
then {
Click ok
}
expr {$::testfont ne {}}
} -result {1}
test fontchooser-4.4 {fontchooser -font} -constraints scriptImpl -body {
start {
tk::fontchooser::Configure -command ApplyFont -font {times 14 bold}
tk::fontchooser::Show
}
then {
Click ok
}
lrange $::testfont 1 end
} -result {14 bold}
# -------------------------------------------------------------------------
cleanupTests
return
# Local Variables:
# mode: tcl
# indent-tabs-mode: nil
# End:
|
