blob: f58cf677bfe987a3a73dfcc685f0a7df35260cbf (
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
|
package require Tcl 8.4
package require Tk 8.4
tk appname tktest
wm title . tktest
package require tcltest 2.1
namespace eval tk {
if {[namespace exists test]} {
namespace delete test
}
namespace eval test {
namespace eval bg {
# Manage a background process.
# Replace with slave interp or thread?
namespace import ::tcltest::interpreter
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\""
}
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 import -force tk::test::*
namespace import -force tcltest::testConstraint
testConstraint userInteraction 0
testConstraint nonUnixUserInteraction [expr {[testConstraint userInteraction]
|| [testConstraint unix]}]
testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)]
testConstraint noExceed [expr {![testConstraint unix]
|| [catch {font actual "\{xyz"}]}]
testConstraint testImageType [expr {[lsearch [image types] test] >= 0}]
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
}
eval tcltest::configure $argv
namespace import -force tcltest::test
deleteWindows
wm geometry . {}
raise .
|
