tests/event.test

   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.
   5 #
   6 # Copyright (c) 1995-1997 Sun Microsystems, Inc.
   7 # Copyright (c) 1998-1999 by Scriptics Corporation.
   8 #
   9 # See the file "license.terms" for information on usage and redistribution
  10 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11
  12 source [file dirname [info script]]/testing.tcl
  13
  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
  19 set ipv6 1
  20 if {[string match "*not supported" $res]} {
  21     set ipv6 0
  22 } else {
  23     # Also, if we can't bind an IPv6 socket, don't run IPv6 tests
  24     if {[catch {
  25         [socket -ipv6 stream.server ::1:5000] close
  26     } msg opts]} {
  27         set ipv6 0
  28     }
  29 }
  30 testConstraint ipv6 $ipv6
  31
  32 test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} jim {
  33     catch {rename bgerror {}}
  34     proc bgerror msg {
  35         lappend ::x $msg
  36     }
  37     after idle {error "a simple error"}
  38     after idle {open non_existent}
  39     after idle {set errorInfo foobar; set errorCode xyzzy}
  40     set x {}
  41     update idletasks
  42     rename bgerror {}
  43     set x
  44 } {{a simple error} {non_existent: No such file or directory}}
  45
  46 test event-7.1 {bgerror / regular} {
  47     set errRes {}
  48     proc bgerror {err} {
  49         global errRes;
  50         set errRes $err;
  51     }
  52     after 0 {error err1}
  53     vwait errRes;
  54     set errRes;
  55 } err1
  56
  57 test event-7.2 {bgerror / accumulation} {
  58     set errRes {}
  59     proc bgerror {err} {
  60         global errRes;
  61         lappend errRes $err;
  62     }
  63     after 0 {error err1}
  64     after 0 {error err2}
  65     after 0 {error err3}
  66     update
  67     set errRes;
  68 } {err1 err2 err3}
  69
  70 test event-7.3 {bgerror / accumulation / break} {
  71     set errRes {}
  72     proc bgerror {err} {
  73         global errRes;
  74         lappend errRes $err;
  75         return -code break "skip!";
  76     }
  77     after 0 {error err1}
  78     after 0 {error err2}
  79     after 0 {error err3}
  80     update
  81     set errRes;
  82 } err1
  83
  84 # end of bgerror tests
  85 catch {rename bgerror {}}
  86
  87
  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] \
  91         [lindex $errorCode 2]
  92 } {1 CHILDSTATUS 3}
  93
  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 {
 101     catch {unset x}
 102     set x 1
 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] {
 107         after cancel $i
 108     }
 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}
 114     set x before
 115     set y before
 116     set z before
 117     set q before
 118     list [vwait y] $x $y $z $q
 119 } {{} x-done y-done before q-done}
 120
 121 foreach i [after info] {
 122     after cancel $i
 123 }
 124
 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} {
 128         puts $s foobar
 129         close $s
 130     }
 131     set s1 [socket stream.server 5001]
 132     after 200
 133     set s2 [socket stream 127.0.0.1:5001]
 134     close $s1
 135     set x 0
 136     set y 0
 137     set z 0
 138     fileevent $s2 writable { incr z }
 139     vwait 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 } }
 142     vwait z
 143     close $f1
 144     close $s2
 145     file delete test1 test2
 146     list $x $y $z
 147 } {3 3 done}
 148
 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]
 155     set x 0
 156     set y 0
 157     set z 0
 158     update
 159     fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
 160     fileevent $f2 writable { incr y; if { $x == 3 } { set z done } }
 161     vwait z
 162     close $f1
 163     close $f2
 164     file delete test1 test2
 165     list $x $y $z
 166 } {3 3 done}
 167
 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] {
 173         after cancel $i
 174     }
 175     after 500 {set x after}
 176     after idle {set y after}
 177     after idle {set z "after, y = $y"}
 178     set x before
 179     set y before
 180     set z before
 181     update idletasks
 182     list $x $y $z
 183 } {before after {after, y = after}}
 184 test event-12.4 {Tcl_UpdateCmd procedure} {
 185     foreach i [after info] {
 186         after cancel $i
 187     }
 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}
 192     set x before
 193     set y before
 194     set z before
 195     after 300
 196     update
 197     list $x $y $z
 198 } {x-done before z-done}
 199
 200 # cleanup
 201 foreach i [after info] {
 202     after cancel $i
 203 }
 204
 205 test event-13.1 "vwait/signal" signal {
 206     signal handle ALRM
 207     list [catch -signal {
 208         alarm 0.1
 209         # This is just to prevent the vwait from exiting immediately
 210         stdin readable { format test }
 211         vwait forever
 212     } msg] $msg
 213 } {5 SIGALRM}
 214
 215
 216 test event-14.1 {socket stream.server client address} {jim socket} {
 217     set s1 [socket stream.server 5001]
 218     after 200
 219     set s2 [socket stream 127.0.0.1:5001]
 220     set addr {}
 221     $s1 readable {
 222         $s1 accept addr
 223     }
 224     vwait addr
 225     $s1 close
 226     $s2 close
 227     # Return client address without the port.
 228     list [lindex [split $addr :] 0]
 229 } {127.0.0.1}
 230
 231 test event-14.2 {IPv6 socket stream.server client address} {jim socket ipv6} {
 232     set s1 [socket -ipv6 stream.server ::1:5001]
 233     after 200
 234     set s2 [socket -ipv6 stream ::1:5001]
 235     set addr6 {}
 236     $s1 readable {
 237         $s1 accept addr6
 238     }
 239     vwait addr6
 240     $s1 close
 241     $s2 close
 242     # Return client IPv6 address without the port.
 243     list [join [lrange [split $addr6 :] 0 end-1] :]
 244 } {{[::1]}}
 245
 246
 247 testreport