blob: 9f14f6d315dbeeec858b9e6eace4f9e82158e6d2 (
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
|
source testing.tcl
test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} {
catch {rename bgerror {}}
proc bgerror msg {
lappend ::x $msg
}
after 100 {error "a simple error"}
after 200 {open non_existent}
set x {}
vwait dummy
rename bgerror {}
set x
} {{a simple error} {non_existent: No such file or directory}}
test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} {
proc bgerror msg {
lappend ::x $msg
return -code break
}
after 100 {error "a simple error"}
after 200 {open non_existent}
set x {}
vwait dummy
rename bgerror {}
set x
} {{a simple error}}
test event-7.1 {bgerror / regular} {
set errRes {}
proc bgerror {err} {
set ::errRes $err;
}
after 0 {error err1}
vwait errRes;
set errRes;
} err1
test event-7.2 {bgerror / accumulation} {
set errRes {}
proc bgerror {err} {
lappend ::errRes $err;
}
after 0 {error err1}
after 1 {error err2}
after 2 {error err3}
vwait dummy
set errRes;
} {err1 err2 err3}
test event-7.3 {bgerror / accumulation / break} {
set errRes {}
proc bgerror {err} {
lappend ::errRes $err;
return -code break "skip!";
}
after 0 {error err1}
after 1 {error err2}
after 2 {error err3}
vwait dummy
set errRes
} err1
# end of bgerror tests
catch {rename bgerror {}}
test event-11.1 {Tcl_VwaitCmd procedure} {
list [catch {vwait} msg] $msg
} {1 {wrong # args: should be "vwait name"}}
test event-11.2 {Tcl_VwaitCmd procedure} {
list [catch {vwait a b} msg] $msg
} {1 {wrong # args: should be "vwait name"}}
test event-11.3 {Tcl_VwaitCmd procedure} {
catch {unset x}
set x 1
list [catch {vwait x(1)} msg] $msg
} {1 {can't read "x(1)": variable isn't array}}
test event-11.4 {Tcl_VwaitCmd procedure} {
vwait dummy
lappend ids [after 100 {set x x-done}]
lappend ids [after 200 {set y y-done}]
lappend ids [after 300 {set z z-done}]
set x before
set y before
set z before
set q before
list [vwait y] $x $y $z $q
} {{} x-done y-done before before}
foreach i $ids {
after cancel $i
}
test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {
set f1 [open test1 w]
proc accept {s args} {
puts $s foobar
close $s
}
catch {set s1 [socket stream.server 5001]}
after 1000
catch {set s2 [socket stream 5001]}
close $s1
set x 0
set y 0
set z 0
$s2 readable { incr z }
vwait z
$f1 writable { incr x; if { $y == 3 } { set z done } }
$s2 readable { incr y; if { $x == 3 } { set z done } }
vwait z
close $f1
close $s2
file delete test1 test2
list $x $y $z
} {3 3 done}
test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
file delete test1 test2
set f1 [open test1 w]
set f2 [open test2 w]
set x 0
set y 0
set z 0
vwait dummy
$f1 writable { incr x; if { $y == 3 } { set z done } }
$f2 writable { incr y; if { $x == 3 } { set z done } }
vwait z
close $f1
close $f2
file delete test1 test2
list $x $y $z
} {3 3 done}
test event-12.3 {Tcl_UpdateCmd procedure} {
after 500 {set x after}
after 1 {set y after}
after 2 {set z "after, y = $y"}
set x before
set y before
set z before
vwait z
list $x $y $z
} {before after {after, y = after}}
vwait dummy
testreport
|
