# This file contains a collection of tests for the procedures in the file

 # tclEvent.c, which includes the "update", and "vwait" Tcl

 # commands.  Sourcing this file into Tcl runs the tests and generates

 # output for errors.  No output means no errors were found.

 #

 # Copyright (c) 1995-1997 Sun Microsystems, Inc.

 # Copyright (c) 1998-1999 by Scriptics Corporation.

 #

 # See the file "license.terms" for information on usage and redistribution

 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.

 #

 # RCS: @(#) $Id: event.test,v 1.20.2.1 2006/11/28 16:29:47 kennykb Exp $

 package require tcltest 2

 namespace import -force ::tcltest::*

 testConstraint testfilehandler [llength [info commands testfilehandler]]

 testConstraint testexithandler [llength [info commands testexithandler]]

 testConstraint testfilewait [llength [info commands testfilewait]]

 test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} {

     testfilehandler close

     testfilehandler create 0 readable off

     testfilehandler clear 0

     testfilehandler oneevent

     set result ""

     lappend result [testfilehandler counts 0]

     testfilehandler fillpartial 0

     testfilehandler oneevent

     lappend result [testfilehandler counts 0]

     testfilehandler oneevent

     lappend result [testfilehandler counts 0]

     testfilehandler close

     set result

 } {{0 0} {1 0} {2 0}}

 test event-1.2 {Tcl_CreateFileHandler, writing} {testfilehandler nonPortable} {

     # This test is non-portable because on some systems (e.g.

     # SunOS 4.1.3) pipes seem to be writable always.

     testfilehandler close

     testfilehandler create 0 off writable

     testfilehandler clear 0

     testfilehandler oneevent

     set result ""

     lappend result [testfilehandler counts 0]

     testfilehandler fillpartial 0

     testfilehandler oneevent

     lappend result [testfilehandler counts 0]

     testfilehandler fill 0

     testfilehandler oneevent

     lappend result [testfilehandler counts 0]

     testfilehandler close

     set result

 } {{0 1} {0 2} {0 2}}

 test event-1.3 {Tcl_DeleteFileHandler} {testfilehandler nonPortable} {

     testfilehandler close

     testfilehandler create 2 disabled disabled

     testfilehandler create 1 readable writable

     testfilehandler create 0 disabled disabled

     testfilehandler fillpartial 1

     set result ""

     testfilehandler oneevent

     lappend result [testfilehandler counts 1]

     testfilehandler oneevent

     lappend result [testfilehandler counts 1]

     testfilehandler oneevent

     lappend result [testfilehandler counts 1]

     testfilehandler create 1 off off

     testfilehandler oneevent

     lappend result [testfilehandler counts 1]

     testfilehandler close

     set result

 } {{0 1} {1 1} {1 2} {0 0}}

 test event-2.1 {Tcl_DeleteFileHandler} {testfilehandler nonPortable} {

     testfilehandler close

     testfilehandler create 2 disabled disabled

     testfilehandler create 1 readable writable

     testfilehandler fillpartial 1

     set result ""

     testfilehandler oneevent

     lappend result [testfilehandler counts 1]

     testfilehandler oneevent

     lappend result [testfilehandler counts 1]

     testfilehandler oneevent

     lappend result [testfilehandler counts 1]

     testfilehandler create 1 off off

     testfilehandler oneevent

     lappend result [testfilehandler counts 1]

     testfilehandler close

     set result

 } {{0 1} {1 1} {1 2} {0 0}}

 test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} \

 	{testfilehandler nonPortable} {

     testfilehandler close

     testfilehandler create 0 readable writable

     testfilehandler fillpartial 0

     set result ""

     testfilehandler oneevent

     lappend result [testfilehandler counts 0]

     testfilehandler close

     testfilehandler create 0 readable writable

     testfilehandler oneevent

     lappend result [testfilehandler counts 0]

     testfilehandler close

     set result

 } {{0 1} {0 0}}

 test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off } {testfilehandler} {

     testfilehandler close

     testfilehandler create 1 readable writable

     testfilehandler fillpartial 1

     testfilehandler windowevent

     set result [testfilehandler counts 1]

     testfilehandler close

     set result

 } {0 0}

 test event-4.1 {FileHandlerEventProc, race between event and disabling} \

 	{testfilehandler nonPortable} {

     update

     testfilehandler close

     testfilehandler create 2 disabled disabled

     testfilehandler create 1 readable writable

     testfilehandler fillpartial 1

     set result ""

     testfilehandler oneevent

     lappend result [testfilehandler counts 1]

     testfilehandler oneevent

     lappend result [testfilehandler counts 1]

     testfilehandler oneevent

     lappend result [testfilehandler counts 1]

     testfilehandler create 1 disabled disabled

     testfilehandler oneevent

     lappend result [testfilehandler counts 1]

     testfilehandler close

     set result

 } {{0 1} {1 1} {1 2} {0 0}}

 test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} \

 	{testfilehandler nonPortable} {

     update

     testfilehandler close

     testfilehandler create 1 readable writable

     testfilehandler create 2 readable writable

     testfilehandler fillpartial 1

     testfilehandler fillpartial 2

     testfilehandler oneevent

     set result ""

     lappend result [testfilehandler counts 1] [testfilehandler counts 2]

     testfilehandler windowevent

     lappend result [testfilehandler counts 1] [testfilehandler counts 2]

     testfilehandler close

     set result

 } {{0 0} {0 1} {0 0} {0 1}}

 update

 test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} {

     catch {rename bgerror {}}

     proc bgerror msg {

 	global errorInfo errorCode x

 	lappend x [list $msg $errorInfo $errorCode]

     }

     after idle {error "a simple error"}

     after idle {open non_existent}

     after idle {set errorInfo foobar; set errorCode xyzzy}

     set x {}

     update idletasks

     rename bgerror {}

     regsub -all [file join {} non_existent] $x "non_existent" x

     set x

 } {{{a simple error} {a simple error

     while executing

 "error "a simple error""

     ("after" script)} NONE} {{couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory

     while executing

 "open non_existent"

     ("after" script)} {POSIX ENOENT {no such file or directory}}}}

 test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} {

     catch {rename bgerror {}}

     proc bgerror msg {

 	global x

 	lappend x $msg

 	return -code break

     }

     after idle {error "a simple error"}

     after idle {open non_existent}

     set x {}

     update idletasks

     rename bgerror {}

     set x

 } {{a simple error}}

 test event-6.1 {BgErrorDeleteProc procedure} {

     catch {interp delete foo}

     interp create foo

     set erroutfile [makeFile Unmodified err.out]

     foo eval [list set erroutfile $erroutfile]

     foo eval {

 	proc bgerror args {

 	    global errorInfo erroutfile

 	    set f [open $erroutfile r+]

 	    seek $f 0 end

 	    puts $f "$args $errorInfo"

 	    close $f

 	}

 	after 100 {error "first error"}

 	after 100 {error "second error"}

     }

     after 100 {interp delete foo}

     after 200

     update

     set f [open $erroutfile r]

     set result [read $f]

     close $f

     removeFile $erroutfile

     set result

 } {Unmodified

 }

 test event-7.1 {bgerror / regular} {

     set errRes {}

     proc bgerror {err} {

 	global errRes;

 	set errRes $err;

     }

     after 0 {error err1}

     vwait errRes;

     set errRes;

 } err1

 test event-7.2 {bgerror / accumulation} {

     set errRes {}

     proc bgerror {err} {

 	global errRes;

 	lappend errRes $err;

     }

     after 0 {error err1}

     after 0 {error err2}

     after 0 {error err3}

     update

     set errRes;

 } {err1 err2 err3}

 test event-7.3 {bgerror / accumulation / break} {

     set errRes {}

     proc bgerror {err} {

 	global errRes;

 	lappend errRes $err;

 	return -code break "skip!";

     }

     after 0 {error err1}

     after 0 {error err2}

     after 0 {error err3}

     update

     set errRes;

 } err1

 test event-7.4 {tkerror is nothing special anymore to tcl} {

     set errRes {}

     # we don't just rename bgerror to empty because it could then

     # be autoloaded...

     proc bgerror {err} {

 	global errRes;

 	lappend errRes "bg:$err";

     }

     proc tkerror {err} {

 	global errRes;

 	lappend errRes "tk:$err";

     }

     after 0 {error err1}

     update

     rename tkerror {}

     set errRes

 } bg:err1

 testConstraint exec [llength [info commands exec]]

 test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} {exec} {

     set script {

 	after 1000 error hello

 	after 2000 set a 0

 	vwait a

     }

     list [catch {exec [interpreter] << $script} errMsg] $errMsg

 } {1 {hello

     while executing

 "error hello"

     ("after" script)}}

 # someday : add a test checking that 

 # when there is no bgerror, an error msg goes to stderr

 # ideally one would use sub interp and transfer a fake stderr

 # to it, unfortunatly the current interp tcl API does not allow

 # that. the other option would be to use fork a test but it

 # then becomes more a file/exec test than a bgerror test.

 # end of bgerror tests

 catch {rename bgerror {}}

 test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {

     set child [open |[list [interpreter]] r+]

     puts $child "testexithandler create 41; testexithandler create 4"

     puts $child "testexithandler create 6; exit"

     flush $child

     set result [read $child]

     close $child

     set result

 } {even 6

 even 4

 odd 41

 }

 test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {

     set child [open |[list [interpreter]] r+]

     puts $child "testexithandler create 41; testexithandler create 4"

     puts $child "testexithandler create 6; testexithandler delete 41"

     puts $child "testexithandler create 16; exit"

     flush $child

     set result [read $child]

     close $child

     set result

 } {even 16

 even 6

 even 4

 }

 test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {

     set child [open |[list [interpreter]] r+]

     puts $child "testexithandler create 41; testexithandler create 4"

     puts $child "testexithandler create 6; testexithandler delete 4"

     puts $child "testexithandler create 16; exit"

     flush $child

     set result [read $child]

     close $child

     set result

     } {even 16

 even 6

 odd 41

 }

 test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {

     set child [open |[list [interpreter]] r+]

     puts $child "testexithandler create 41; testexithandler create 4"

     puts $child "testexithandler create 6; testexithandler delete 6"

     puts $child "testexithandler create 16; exit"

     flush $child

     set result [read $child]

     close $child

     set result

 } {even 16

 even 4

 odd 41

 }

 test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {

     set child [open |[list [interpreter]] r+]

     puts $child "testexithandler create 41; testexithandler delete 41"

     puts $child "testexithandler create 16; exit"

     flush $child

     set result [read $child]

     close $child

     set result

 } {even 16

 }

 test event-10.1 {Tcl_Exit procedure} {stdio} {

     set child [open |[list [interpreter]] r+]

     puts $child "exit 3"

     list [catch {close $child} msg] $msg [lindex $errorCode 0] \

         [lindex $errorCode 2]

 } {1 {child process exited abnormally} CHILDSTATUS 3}

 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 trace "x(1)": variable isn't array}}

 test event-11.4 {Tcl_VwaitCmd procedure} {} {

     foreach i [after info] {

 	after cancel $i

     }

     after 10; update; # On Mac make sure update won't take long

     after 100 {set x x-done}

     after 200 {set y y-done}

     after 300 {set z z-done}

     after idle {set q q-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 q-done}

 foreach i [after info] {

     after cancel $i

 }

 test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} {

     set test1file [makeFile "" test1]

     set f1 [open $test1file w]

     proc accept {s args} {

 	puts $s foobar

 	close $s

     }

     catch {set s1 [socket -server accept 0]}

     after 1000

     catch {set s2 [socket 127.0.0.1 [lindex [fconfigure $s1 -sockname] 2]]}

     close $s1

     set x 0

     set y 0

     set z 0

     fileevent $s2 readable {incr z}

     vwait z

     fileevent $f1 writable {incr x; if {$y == 3} {set z done}}

     fileevent $s2 readable {incr y; if {$x == 3} {set z done}}

     vwait z

     close $f1

     close $s2

     removeFile $test1file

     list $x $y $z

 } {3 3 done}

 test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {

     set test1file [makeFile "" test1]

     set test2file [makeFile "" test2]

     set f1 [open $test1file w]

     set f2 [open $test2file w]

     set x 0

     set y 0

     set z 0

     update

     fileevent $f1 writable {incr x; if {$y == 3} {set z done}}

     fileevent $f2 writable {incr y; if {$x == 3} {set z done}}

     vwait z

     close $f1

     close $f2

     removeFile $test1file

     removeFile $test2file

     list $x $y $z

 } {3 3 done}

 test event-12.1 {Tcl_UpdateCmd procedure} {

     list [catch {update a b} msg] $msg

 } {1 {wrong # args: should be "update ?idletasks?"}}

 test event-12.2 {Tcl_UpdateCmd procedure} {

     list [catch {update bogus} msg] $msg

 } {1 {bad option "bogus": must be idletasks}}

 test event-12.3 {Tcl_UpdateCmd procedure} {

     foreach i [after info] {

 	after cancel $i

     }

     after 500 {set x after}

     after idle {set y after}

     after idle {set z "after, y = $y"}

     set x before

     set y before

     set z before

     update idletasks

     list $x $y $z

 } {before after {after, y = after}}

 test event-12.4 {Tcl_UpdateCmd procedure} {

     foreach i [after info] {

 	after cancel $i

     }

     after 10; update; # On Mac make sure update won't take long

     after 200 {set x x-done}

     after 600 {set y y-done}

     after idle {set z z-done}

     set x before

     set y before

     set z before

     after 300

     update

     list $x $y $z

 } {x-done before z-done}

 test event-13.1 {Tcl_WaitForFile procedure, readable} {testfilehandler} {

     foreach i [after info] {

 	after cancel $i

     }

     after 100 set x timeout

     testfilehandler close

     testfilehandler create 1 off off

     set x "no timeout"

     set result [testfilehandler wait 1 readable 0]

     update

     testfilehandler close

     list $result $x

 } {{} {no timeout}}

 test event-13.2 {Tcl_WaitForFile procedure, readable} testfilehandler {

     foreach i [after info] {

 	after cancel $i

     }

     after 100 set x timeout

     testfilehandler close

     testfilehandler create 1 off off

     set x "no timeout"

     set result [testfilehandler wait 1 readable 100]

     update

     testfilehandler close

     list $result $x

 } {{} timeout}

 test event-13.3 {Tcl_WaitForFile procedure, readable} testfilehandler {

     foreach i [after info] {

 	after cancel $i

     }

     after 100 set x timeout

     testfilehandler close

     testfilehandler create 1 off off

     testfilehandler fillpartial 1

     set x "no timeout"

     set result [testfilehandler wait 1 readable 100]

     update

     testfilehandler close

     list $result $x

 } {readable {no timeout}}

 test event-13.4 {Tcl_WaitForFile procedure, writable} \

 	{testfilehandler nonPortable} {

     foreach i [after info] {

 	after cancel $i

     }

     after 100 set x timeout

     testfilehandler close

     testfilehandler create 1 off off

     testfilehandler fill 1

     set x "no timeout"

     set result [testfilehandler wait 1 writable 0]

     update

     testfilehandler close

     list $result $x

 } {{} {no timeout}}

 test event-13.5 {Tcl_WaitForFile procedure, writable} \

 	{testfilehandler nonPortable} {

     foreach i [after info] {

 	after cancel $i

     }

     after 100 set x timeout

     testfilehandler close

     testfilehandler create 1 off off

     testfilehandler fill 1

     set x "no timeout"

     set result [testfilehandler wait 1 writable 100]

     update

     testfilehandler close

     list $result $x

 } {{} timeout}

 test event-13.6 {Tcl_WaitForFile procedure, writable} testfilehandler {

     foreach i [after info] {

 	after cancel $i

     }

     after 100 set x timeout

     testfilehandler close

     testfilehandler create 1 off off

     set x "no timeout"

     set result [testfilehandler wait 1 writable 100]

     update

     testfilehandler close

     list $result $x

 } {writable {no timeout}}

 test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} testfilehandler {

     foreach i [after info] {

 	after cancel $i

     }

     after 100 lappend x timeout

     after idle lappend x idle

     testfilehandler close

     testfilehandler create 1 off off

     set x ""

     set result [list [testfilehandler wait 1 readable 200] $x]

     update

     testfilehandler close

     lappend result $x

 } {{} {} {timeout idle}}

 test event-13.8 {Tcl_WaitForFile procedure, waiting indefinitely} testfilewait {

     set f [open "|sleep 2" r]

     set result ""

     lappend result [testfilewait $f readable 100]

     lappend result [testfilewait $f readable -1]

     close $f

     set result

 } {{} readable}

 test event-14.1 {Tcl_WaitForFile procedure, readable, big fd} \

     -constraints {testfilehandler unix} \

     -setup {

 	set chanList {}

 	for {set i 0} {$i < 32} {incr i} {

 	    lappend chanList [open /dev/null r]

 	}

     } \

     -body {

 	foreach i [after info] {

 	    after cancel $i

 	}

 	after 100 set x timeout

 	testfilehandler close

 	testfilehandler create 1 off off

 	set x "no timeout"

 	set result [testfilehandler wait 1 readable 0]

 	update

 	testfilehandler close

 	list $result $x

     } \

     -result {{} {no timeout}} \

     -cleanup {

 	foreach chan $chanList {close $chan}

     }

 test event-14.2 {Tcl_WaitForFile procedure, readable, big fd} \

     -constraints {testfilehandler unix} \

     -setup {

 	set chanList {}

 	for {set i 0} {$i < 32} {incr i} {

 	    lappend chanList [open /dev/null r]

 	}

     } \

     -body {

 	foreach i [after info] {

 	    after cancel $i

 	}

 	after 100 set x timeout

 	testfilehandler close

 	testfilehandler create 1 off off

 	set x "no timeout"

 	set result [testfilehandler wait 1 readable 100]

 	update

 	testfilehandler close

 	list $result $x

     } \

     -result {{} timeout} \

     -cleanup {

 	foreach chan $chanList {close $chan}

     }

 test event-14.3 {Tcl_WaitForFile procedure, readable, big fd} \

     -constraints {testfilehandler unix} \

     -setup {

 	set chanList {}

 	for {set i 0} {$i < 32} {incr i} {

 	    lappend chanList [open /dev/null r]

 	}

     } \

     -body {

 	foreach i [after info] {

 	    after cancel $i

 	}

 	after 100 set x timeout

 	testfilehandler close

 	testfilehandler create 1 off off

 	testfilehandler fillpartial 1

 	set x "no timeout"

 	set result [testfilehandler wait 1 readable 100]

 	update

 	testfilehandler close

 	list $result $x

     } \

     -result {readable {no timeout}} \

     -cleanup {

 	foreach chan $chanList {close $chan}

     }

 test event-14.4 {Tcl_WaitForFile procedure, writable, big fd} \

     -constraints {testfilehandler unix nonPortable} \

     -setup {

 	set chanList {}

 	for {set i 0} {$i < 32} {incr i} {

 	    lappend chanList [open /dev/null r]

 	}

     } \

     -body {

 	foreach i [after info] {

 	    after cancel $i

 	}

 	after 100 set x timeout

 	testfilehandler close

 	testfilehandler create 1 off off

 	testfilehandler fill 1

 	set x "no timeout"

 	set result [testfilehandler wait 1 writable 0]

 	update

 	testfilehandler close

 	list $result $

     } \

     -result {{} {no timeout}} \

     -cleanup {

 	foreach chan $chanList {close $chan}

     }

 test event-14.5 {Tcl_WaitForFile procedure, writable, big fd} \

     -constraints {testfilehandler unix nonPortable} \

     -setup {

 	set chanList {}

 	for {set i 0} {$i < 32} {incr i} {

 	    lappend chanList [open /dev/null r]

 	}

     } \

     -body {

 	foreach i [after info] {

 	    after cancel $i

 	}

 	after 100 set x timeout

 	testfilehandler close

 	testfilehandler create 1 off off

 	testfilehandler fill 1

 	set x "no timeout"

 	set result [testfilehandler wait 1 writable 100]

 	update

 	testfilehandler close

 	list $result $x

     } \

     -result {{} timeout} \

     -cleanup {

 	foreach chan $chanList {close $chan}

     }

 test event-14.6 {Tcl_WaitForFile procedure, writable, big fd} \

     -constraints {testfilehandler unix} \

     -setup {

 	set chanList {}

 	for {set i 0} {$i < 32} {incr i} {

 	    lappend chanList [open /dev/null r]

 	}

     } \

     -body {

 	foreach i [after info] {

 	    after cancel $i

 	}

 	after 100 set x timeout

 	testfilehandler close

 	testfilehandler create 1 off off

 	set x "no timeout"

 	set result [testfilehandler wait 1 writable 100]

 	update

 	testfilehandler close

 	list $result $x

     } \

     -result {writable {no timeout}} \

     -cleanup {

 	foreach chan $chanList {close $chan}

     }

 test event-14.7 {Tcl_WaitForFile, don't call other event handlers, big fd} \

     -constraints {testfilehandler unix} \

     -setup {

 	set chanList {}

 	for {set i 0} {$i < 32} {incr i} {

 	    lappend chanList [open /dev/null r]

 	}

     } \

     -body {

 	foreach i [after info] {

 	    after cancel $i

 	}

 	after 100 lappend x timeout

 	after idle lappend x idle

 	testfilehandler close

 	testfilehandler create 1 off off

 	set x ""

 	set result [list [testfilehandler wait 1 readable 200] $x]

 	update

 	testfilehandler close

 	lappend result $x

     } \

     -result {{} {} {timeout idle}} \

     -cleanup {

 	foreach chan $chanList {close $chan}

     }

 test event-14.8 {Tcl_WaitForFile procedure, waiting indefinitely, big fd} \

     -constraints {testfilewait unix} \

     -body {

 	set f [open "|sleep 2" r]

 	set result ""

 	lappend result [testfilewait $f readable 100]

 	lappend result [testfilewait $f readable -1]

 	close $f

 	set result

     } \

     -setup {

 	set chanList {}

 	for {set i 0} {$i < 32} {incr i} {

 	    lappend chanList [open /dev/null r]

 	}

     } \

     -result {{} readable} \

     -cleanup {

 	foreach chan $chanList {close $chan}

     }

 # cleanup

 foreach i [after info] {

     after cancel $i

 }

 ::tcltest::cleanupTests

 return