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]} ipv6res
  19 testConstraint ipv6 [expr {$ipv6res ne "ipv6 not supported"}]
  20
  21 test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} jim {
  22     catch {rename bgerror {}}
  23     proc bgerror msg {
  24         lappend ::x $msg
  25     }
  26     after idle {error "a simple error"}
  27     after idle {open non_existent}
  28     after idle {set errorInfo foobar; set errorCode xyzzy}
  29     set x {}
  30     update idletasks
  31     rename bgerror {}
  32     set x
  33 } {{a simple error} {non_existent: No such file or directory}}
  34
  35 test event-7.1 {bgerror / regular} {
  36     set errRes {}
  37     proc bgerror {err} {
  38         global errRes;
  39         set errRes $err;
  40     }
  41     after 0 {error err1}
  42     vwait errRes;
  43     set errRes;
  44 } err1
  45
  46 test event-7.2 {bgerror / accumulation} {
  47     set errRes {}
  48     proc bgerror {err} {
  49         global errRes;
  50         lappend errRes $err;
  51     }
  52     after 0 {error err1}
  53     after 0 {error err2}
  54     after 0 {error err3}
  55     update
  56     set errRes;
  57 } {err1 err2 err3}
  58
  59 test event-7.3 {bgerror / accumulation / break} {
  60     set errRes {}
  61     proc bgerror {err} {
  62         global errRes;
  63         lappend errRes $err;
  64         return -code break "skip!";
  65     }
  66     after 0 {error err1}
  67     after 0 {error err2}
  68     after 0 {error err3}
  69     update
  70     set errRes;
  71 } err1
  72
  73 # end of bgerror tests
  74 catch {rename bgerror {}}
  75
  76
  77 test event-10.1 {Tcl_Exit procedure} exec {
  78     set cmd [list exec [info nameofexecutable] "<<exit 3"]
  79     list [catch $cmd msg] [lindex $errorCode 0] \
  80         [lindex $errorCode 2]
  81 } {1 CHILDSTATUS 3}
  82
  83 test event-11.1 {Tcl_VwaitCmd procedure} {
  84     list [catch {vwait} msg] $msg
  85 } {1 {wrong # args: should be "vwait name"}}
  86 test event-11.2 {Tcl_VwaitCmd procedure} {
  87     list [catch {vwait a b} msg] $msg
  88 } {1 {wrong # args: should be "vwait name"}}
  89 test event-11.3 {Tcl_VwaitCmd procedure} jim {
  90     catch {unset x}
  91     set x 1
  92     list [catch {vwait x(1)} msg] $msg
  93 } {1 {can't read "x(1)": variable isn't array}}
  94 test event-11.4 {Tcl_VwaitCmd procedure} {
  95     foreach i [after info] {
  96         after cancel $i
  97     }
  98     after 10; update; # On Mac make sure update won't take long
  99     after 100 {set x x-done}
 100     after 200 {set y y-done}
 101     after 300 {set z z-done}
 102     after idle {set q q-done}
 103     set x before
 104     set y before
 105     set z before
 106     set q before
 107     list [vwait y] $x $y $z $q
 108 } {{} x-done y-done before q-done}
 109
 110 foreach i [after info] {
 111     after cancel $i
 112 }
 113
 114 test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {jim socket} {
 115     set f1 [open test1 w]
 116     proc accept {s args} {
 117         puts $s foobar
 118         close $s
 119     }
 120     set s1 [socket stream.server 5001]
 121     after 200
 122     set s2 [socket stream 127.0.0.1:5001]
 123     close $s1
 124     set x 0
 125     set y 0
 126     set z 0
 127     fileevent $s2 writable { incr z }
 128     vwait z
 129     fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
 130     fileevent $s2 writable { incr y; if { $x == 3 } { set z done } }
 131     vwait z
 132     close $f1
 133     close $s2
 134     file delete test1 test2
 135     list $x $y $z
 136 } {3 3 done}
 137
 138 # Note: This one doesn't really require socket, but mingw32 doesn't have socket and
 139 #       also doesn't allow file events (select) on non-sockets
 140 test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {socket} {
 141     file delete test1 test2
 142     set f1 [open test1 w]
 143     set f2 [open test2 w]
 144     set x 0
 145     set y 0
 146     set z 0
 147     update
 148     fileevent $f1 writable { incr x; if { $y == 3 } { set z done } }
 149     fileevent $f2 writable { incr y; if { $x == 3 } { set z done } }
 150     vwait z
 151     close $f1
 152     close $f2
 153     file delete test1 test2
 154     list $x $y $z
 155 } {3 3 done}
 156
 157 test event-12.1 {Tcl_UpdateCmd procedure} {
 158     list [catch {update a b} msg] $msg
 159 } {1 {wrong # args: should be "update ?idletasks?"}}
 160 test event-12.3 {Tcl_UpdateCmd procedure} {
 161     foreach i [after info] {
 162         after cancel $i
 163     }
 164     after 500 {set x after}
 165     after idle {set y after}
 166     after idle {set z "after, y = $y"}
 167     set x before
 168     set y before
 169     set z before
 170     update idletasks
 171     list $x $y $z
 172 } {before after {after, y = after}}
 173 test event-12.4 {Tcl_UpdateCmd procedure} {
 174     foreach i [after info] {
 175         after cancel $i
 176     }
 177     after 10; update; # On Mac make sure update won't take long
 178     after 200 {set x x-done}
 179     after 400 {set y y-done}
 180     after idle {set z z-done}
 181     set x before
 182     set y before
 183     set z before
 184     after 300
 185     update
 186     list $x $y $z
 187 } {x-done before z-done}
 188
 189 # cleanup
 190 foreach i [after info] {
 191     after cancel $i
 192 }
 193
 194 test event-13.1 "vwait/signal" signal {
 195     signal handle ALRM
 196     list [catch -signal {
 197         alarm 0.1
 198         # This is just to prevent the vwait from exiting immediately
 199         stdin readable { format test }
 200         vwait forever
 201     } msg] $msg
 202 } {5 SIGALRM}
 203
 204
 205 test event-14.1 {socket stream.server client address} {jim socket} {
 206     set s1 [socket stream.server 5001]
 207     after 200
 208     set s2 [socket stream 127.0.0.1:5001]
 209     set addr {}
 210     $s1 readable {
 211         $s1 accept addr
 212     }
 213     vwait addr
 214     $s1 close
 215     $s2 close
 216     # Return client address without the port.
 217     list [lindex [split $addr :] 0]
 218 } {127.0.0.1}
 219
 220 test event-14.2 {IPv6 socket stream.server client address} {jim socket ipv6} {
 221     set s1 [socket -ipv6 stream.server ::1:5001]
 222     after 200
 223     set s2 [socket -ipv6 stream ::1:5001]
 224     set addr6 {}
 225     $s1 readable {
 226         $s1 accept addr6
 227     }
 228     vwait addr6
 229     $s1 close
 230     $s2 close
 231     # Return client IPv6 address without the port.
 232     list [join [lrange [split $addr6 :] 0 end-1] :]
 233 } {{[::1]}}
 234
 235
 236 testreport