blob: a6c52da05a3711d3c82daec08a8983f108b65dda (
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
|
package require Tcl 8.4
package require Tk 8.4
package require tcltest 2.1
namespace import -force tcltest::testConstraint
testConstraint userInteraction 0
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
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
}
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 {
puts $fd exit
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} {
variable fd
variable Data
variable Done
puts $fd "[list catch $cmd msg]; update; puts \$msg;\
puts **DONE**; flush stdout"
flush $fd
set Done 0
set Data {}
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 import -force ::tk::test::*
|
