blob: 19013ec2f67a8d271d9f84ea24b1950299370942 (
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
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
|
if {[namespace exists tk::test]} {
deleteWindows
wm geometry . {}
raise .
return
}
package require Tcl 8.4
package require Tk 8.4
tk appname tktest
wm title . tktest
# If the main window isn't already mapped (e.g. because the tests are
# being run automatically) , specify a precise size for it so that the
# user won't have to position it manually.
if {![winfo ismapped .]} {
wm geometry . +0+0
update
}
package require tcltest 2.1
namespace eval tk {
namespace eval test {
namespace export loadTkCommand
proc loadTkCommand {} {
set tklib {}
foreach pair [info loaded {}] {
foreach {lib pfx} $pair break
if {$pfx eq "Tk"} {
set tklib $lib
break
}
}
return [list load $tklib Tk]
}
namespace eval bg {
# Manage a background process.
# Replace with slave interp or thread?
namespace import ::tcltest::interpreter
namespace import ::tk::test::loadTkCommand
namespace export setup cleanup do
proc cleanup {} {
variable fd
# catch in case the background process has closed $fd
catch {puts $fd exit}
catch {close $fd}
set fd ""
}
proc setup args {
variable fd
if {[info exists fd] && [string length $fd]} {
cleanup
}
set fd [open "|[list [interpreter] \
-geometry +0+0 -name tktest] $args" r+]
puts $fd "puts foo; flush stdout"
flush $fd
if {[gets $fd data] < 0} {
error "unexpected EOF from \"[interpreter]\""
}
if {$data ne "foo"} {
error "unexpected output from\
background process: \"$data\""
}
puts $fd [loadTkCommand]
flush $fd
fileevent $fd readable [namespace code Ready]
}
proc Ready {} {
variable fd
variable Data
variable Done
set x [gets $fd]
if {[eof $fd]} {
fileevent $fd readable {}
set Done 1
} elseif {$x eq "**DONE**"} {
set Done 1
} else {
append Data $x
}
}
proc do {cmd {block 0}} {
variable fd
variable Data
variable Done
if {$block} {
fileevent $fd readable {}
}
puts $fd "[list catch $cmd msg]; update; puts \$msg;\
puts **DONE**; flush stdout"
flush $fd
set Data {}
if {$block} {
while {![eof $fd]} {
set line [gets $fd]
if {$line eq "**DONE**"} {
break
}
append Data $line
}
} else {
set Done 0
vwait [namespace which -variable Done]
}
return $Data
}
}
proc Export {internal as external} {
uplevel 1 [list namespace import $internal]
uplevel 1 [list rename [namespace tail $internal] $external]
uplevel 1 [list namespace export $external]
}
Export bg::setup as setupbg
Export bg::cleanup as cleanupbg
Export bg::do as dobg
namespace export deleteWindows
proc deleteWindows {} {
eval destroy [winfo children .]
}
namespace export fixfocus
proc fixfocus {} {
catch {destroy .focus}
toplevel .focus
wm geometry .focus +0+0
entry .focus.e
.focus.e insert 0 "fixfocus"
pack .focus.e
update
focus -force .focus.e
destroy .focus
}
}
}
namespace import -force tk::test::*
namespace import -force tcltest::testConstraint
testConstraint userInteraction [expr {[tk windowingsystem] ne "aqua"}]
testConstraint userInteraction 0
testConstraint nonUnixUserInteraction [expr {
[testConstraint userInteraction] || [testConstraint unix]
}]
testConstraint haveDISPLAY [info exists env(DISPLAY)]
testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)]
testConstraint noExceed [expr {
![testConstraint unix] || [catch {font actual "\{xyz"}]
}]
# constraints for testing facilities defined in the tktest executable...
testConstraint testImageType [expr {[lsearch [image types] test] >= 0}]
testConstraint testbitmap [llength [info commands testbitmap]]
testConstraint testborder [llength [info commands testborder]]
testConstraint testcbind [llength [info commands testcbind]]
testConstraint testclipboard [llength [info commands testclipboard]]
testConstraint testcolor [llength [info commands testcolor]]
testConstraint testcursor [llength [info commands testcursor]]
testConstraint testembed [llength [info commands testembed]]
testConstraint testfont [llength [info commands testfont]]
testConstraint testmakeexist [llength [info commands testmakeexist]]
testConstraint testmenubar [llength [info commands testmenubar]]
testConstraint testmenubar [llength [info commands testmenubar]]
testConstraint testmetrics [llength [info commands testmetrics]]
testConstraint testobjconfig [llength [info commands testobjconfig]]
testConstraint testsend [llength [info commands testsend]]
testConstraint testtext [llength [info commands testtext]]
testConstraint testwinevent [llength [info commands testwinevent]]
testConstraint testwrapper [llength [info commands testwrapper]]
# constraint to see what sort of fonts are available
testConstraint fonts 1
destroy .e
entry .e -width 0 -font {Helvetica -12} -bd 1
.e insert end a.bcd
if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
testConstraint fonts 0
}
destroy .e
destroy .t
text .t -width 80 -height 20 -font {Times -14} -bd 1
pack .t
.t insert end "This is\na dot."
update
set x [list [.t bbox 1.3] [.t bbox 2.5]]
destroy .t
if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} {
testConstraint fonts 0
}
testConstraint textfonts [expr {
[testConstraint fonts] || $tcl_platform(platform) eq "windows"
}]
# constraints for the visuals available..
testConstraint pseudocolor8 [expr {
([catch {
toplevel .t -visual {pseudocolor 8} -colormap new
}] == 0) && ([winfo depth .t] == 8)
}]
destroy .t
testConstraint haveTruecolor24 [expr {
[lsearch -exact [winfo visualsavailable .] {truecolor 24}] >= 0
}]
testConstraint haveGrayscale8 [expr {
[lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0
}]
testConstraint defaultPseudocolor8 [expr {
([winfo visual .] eq "pseudocolor") && ([winfo depth .] == 8)
}]
# constraint based on whether our display is secure
setupbg
set app [dobg {tk appname}]
testConstraint secureserver 0
if {[llength [info commands send]]} {
testConstraint secureserver 1
if {[catch {send $app set a 0} msg] == 1} {
if {[string match "X server insecure *" $msg]} {
testConstraint secureserver 0
}
}
}
cleanupbg
eval tcltest::configure $argv
namespace import -force tcltest::test
namespace import -force tcltest::makeFile
namespace import -force tcltest::removeFile
namespace import -force tcltest::makeDirectory
namespace import -force tcltest::removeDirectory
namespace import -force tcltest::interpreter
namespace import -force tcltest::testsDirectory
namespace import -force tcltest::cleanupTests
namespace import -force tcltest::bytestring
deleteWindows
wm geometry . {}
raise .
|
