1 # This file contains a collection of tests for the procedures in the file
2 # tclEvent.c, which includes the "update", and "vwait" Tcl
3 # commands. Sourcing this file into Tcl runs the tests and generates
4 # output for errors. No output means no errors were found.
6 # Copyright (c) 1995-1997 Sun Microsystems, Inc.
7 # Copyright (c) 1998-1999 by Scriptics Corporation.
9 # See the file "license.terms" for information on usage and redistribution
10 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 source [file dirname [info script]]/testing.tcl
14 needs cmd after eventloop
15 testConstraint socket [expr {[info commands socket] ne ""}]
16 testConstraint exec [expr {[info commands exec] ne ""}]
17 testConstraint signal [expr {[info commands signal] ne ""}]
18 catch {[socket -ipv6 stream ::1:5000]} res
20 if {[string match "*not supported" $res]} {
23 # Also, if we can't bind an IPv6 socket, don't run IPv6 tests
25 [socket -ipv6 stream.server ::1:5000] close
30 testConstraint ipv6 $ipv6
32 test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} jim {
33 catch {rename bgerror {}}
37 after idle {error "a simple error"}
38 after idle {open non_existent}
39 after idle {set errorInfo foobar; set errorCode xyzzy}
44 } {{a simple error} {non_existent: No such file or directory}}
46 test event-7.1 {bgerror / regular} {
57 test event-7.2 {bgerror / accumulation} {
70 test event-7.3 {bgerror / accumulation / break} {
75 return -code break "skip!";
84 # end of bgerror tests
85 catch {rename bgerror {}}
88 test event-10.1 {Tcl_Exit procedure} exec {
89 set cmd [list exec [info nameofexecutable] "<<exit 3"]
90 list [catch $cmd msg] [lindex $errorCode 0] \
94 test event-11.1 {Tcl_VwaitCmd procedure} {
95 list [catch {vwait} msg] $msg
96 } {1 {wrong # args: should be "vwait name"}}
97 test event-11.2 {Tcl_VwaitCmd procedure} {
98 list [catch {vwait a b} msg] $msg
99 } {1 {wrong # args: should be "vwait name"}}
100 test event-11.3 {Tcl_VwaitCmd procedure} jim {
103 list [catch {vwait x(1)} msg] $msg
104 } {1 {can't read "x(1)": variable isn't array}}
105 test event-11.4 {Tcl_VwaitCmd procedure} {
106 foreach i [after info] {
109 after 10; update; # On Mac make sure update won't take long
110 after 100 {set x x-done}
111 after 200 {set y y-done}
112 after 300 {set z z-done}
113 after idle {set q q-done}
118 list [vwait y] $x $y $z $q
119 } {{} x-done y-done before q-done}
121 foreach i [after info] {
125 test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {jim socket} {
126 set f1 [open test1 w]
127 proc accept {s args} {
131 set s1 [socket stream.server 5001]
133 set s2 [socket stream 127.0.0.1:5001]
138 fileevent $s2 writable { incr z }
140 fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
141 fileevent $s2 writable { incr y; if { $x == 3 } { set z done } }
145 file delete test1 test2
149 # Note: This one doesn't really require socket, but mingw32 doesn't have socket and
150 # also doesn't allow file events (select) on non-sockets
151 test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {socket} {
152 file delete test1 test2
153 set f1 [open test1 w]
154 set f2 [open test2 w]
159 fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
160 fileevent $f2 writable { incr y; if { $x == 3 } { set z done } }
164 file delete test1 test2
168 test event-12.1 {Tcl_UpdateCmd procedure} {
169 list [catch {update a b} msg] $msg
170 } {1 {wrong # args: should be "update ?idletasks?"}}
171 test event-12.3 {Tcl_UpdateCmd procedure} {
172 foreach i [after info] {
175 after 500 {set x after}
176 after idle {set y after}
177 after idle {set z "after, y = $y"}
183 } {before after {after, y = after}}
184 test event-12.4 {Tcl_UpdateCmd procedure} {
185 foreach i [after info] {
188 after 10; update; # On Mac make sure update won't take long
189 after 200 {set x x-done}
190 after 400 {set y y-done}
191 after idle {set z z-done}
198 } {x-done before z-done}
201 foreach i [after info] {
205 test event-13.1 "vwait/signal" signal {
207 list [catch -signal {
209 # This is just to prevent the vwait from exiting immediately
210 stdin readable { format test }
216 test event-14.1 {socket stream.server client address} {jim socket} {
217 set s1 [socket stream.server 5001]
219 set s2 [socket stream 127.0.0.1:5001]
227 # Return client address without the port.
228 list [lindex [split $addr :] 0]
231 test event-14.2 {IPv6 socket stream.server client address} {jim socket ipv6} {
232 set s1 [socket -ipv6 stream.server ::1:5001]
234 set s2 [socket -ipv6 stream ::1:5001]
242 # Return client IPv6 address without the port.
243 list [join [lrange [split $addr6 :] 0 end-1] :]