# 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