# This file contains a collection of tests for the procedures in the file # tclEvent.c, which includes the "after", "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-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # "@(#) event.test 1.20 96/04/09 15:54:05" if {[string compare test [info procs test]] == 1} then {source defs} if {[catch {testfilehandler create 0 off off}] == 0 } { test event-1.1 {Tcl_CreateFileHandler, reading} { 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} {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 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 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 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 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 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 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}} testfilehandler close update } test event-5.1 {Tcl_CreateTimerHandler procedure} { foreach i [after info] { after cancel $i } set x "" foreach i {100 200 1000 50 150} { after $i lappend x $i } after 200 update set x } {50 100 150 200} test event-6.1 {Tcl_DeleteTimerHandler procedure} { foreach i [after info] { after cancel $i } set x "" foreach i {100 200 300 50 150} { after $i lappend x $i } after cancel lappend x 150 after cancel lappend x 50 after 200 update set x } {100 200} if {[info commands testmodal] != ""} { test event-7.1 {Tcl_CreateModalTimeout and Tcl_DeleteModalTimeout procedures} { update set x {} set result {} testmodal create 50 first testmodal create 200 second after 100 testmodal eventnotimers lappend result $x after 150 testmodal eventnotimers lappend result $x testmodal delete testmodal eventnotimers lappend result $x testmodal eventnotimers lappend result $x testmodal delete testmodal eventnotimers lappend result $x } {{} second {second first} {second first first} {second first first}} test event-8.1 {TimerHandlerSetupProc procedure, choosing correct timer} { update set x {} after 100 {lappend x normal} testmodal create 200 modal vwait x testmodal delete set x } {normal} test event-8.2 {TimerHandlerSetupProc procedure, choosing correct timer} { update set x {} after 200 {lappend x normal} testmodal create 100 modal vwait x testmodal delete set x } {modal} } # No tests for TimerHandlerCheckProc: it's already tested by other tests # above and below. test event-9.1 {TimerHandlerEventProc procedure} { foreach i [after info] { after cancel $i } foreach i {100 200 300} { after $i lappend x $i } after 100 set result "" set x "" update lappend result $x after 100 update lappend result $x after 100 update lappend result $x } {100 {100 200} {100 200 300}} # No tests for Tcl_DoWhenIdle: it's already tested by other tests # below. test event-10.1 {Tk_CancelIdleCall procedure} { foreach i [after info] { after cancel $i } set x before set y before set z before after idle set x after1 after idle set y after2 after idle set z after3 after cancel set y after2 update idletasks concat $x $y $z } {after1 before after3} test event-10.2 {Tk_CancelIdleCall procedure} { foreach i [after info] { after cancel $i } set x before set y before set z before after idle set x after1 after idle set y after2 after idle set z after3 after cancel set x after1 update idletasks concat $x $y $z } {before after2 after3} test event-11.1 {Tcl_ServiceIdle, self-rescheduling handlers} { foreach i [after info] { after cancel $i } set x 1 set y 23 after idle {incr x; after idle {incr x; after idle {incr x}}} after idle {incr y} vwait x set result "$x $y" update idletasks lappend result $x } {2 24 4} test event-12.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 {} 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-12.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-13.1 {BgErrorDeleteProc procedure} { catch {interp delete foo} interp create foo foo eval { proc bgerror args { global errorInfo set f [open err.out r+] seek $f 0 end puts $f "$args $errorInfo" close $f } after 100 {error "first error"} after 100 {error "second error"} } makeFile Unmodified err.out after 100 {interp delete foo} after 200 update set f [open err.out r] set result [read $f] close $f removeFile err.out set result } {Unmodified } test event-14.1 {tkerror/bgerror backwards compabitility} { catch {rename bgerror {}} proc tkerror {x y} { return [expr $x + $y] } list [tkerror 4 7] [bgerror 8 -3] } {11 5} test event-14.2 {tkerror/bgerror backwards compabitility} { proc bgerror {x y} { return [expr 1 + $x + $y] } list [tkerror 6 -2] [bgerror 7 2] } {5 10} test event-14.3 {tkerror/bgerror backwards compabitility} { proc bgerror {x y} { return [expr 1 + $x + $y] } set result [list [info commands bgerror] [info commands tkerror]] rename tkerror {} lappend result [info commands bgerror] [info commands tkerror] } {bgerror tkerror {} {}} test event-14.4 {tkerror/bgerror backwards compabitility} { proc tkerror {x y} { return [expr 1 + $x + $y] } set result [list [info commands bgerror] [info commands tkerror]] rename bgerror {} lappend result [info commands bgerror] [info commands tkerror] } {bgerror tkerror {} {}} test event-14.5 {tkerror/bgerror backwards compabitility} { proc tkerror {x y} { return [expr 1 + $x + $y] } rename tkerror foo list [info commands bgerror] [info commands tkerror] [foo 4 3] } {{} {} 8} test event-14.6 {tkerror/bgerror backwards compabitility} { proc bgerror {x y} { return [expr 1 + $x + $y] } catch {rename foo {}} rename bgerror foo list [info commands bgerror] [info commands tkerror] [foo 4 3] } {{} {} 8} test event-14.7 {tkerror/bgerror backwards compabitility} { proc foo args {return $args} catch {rename tkerror {}} rename foo tkerror list [info commands bgerror] [info commands tkerror] [info commands foo] [tkerror a b c d] } {bgerror tkerror {} {a b c d}} test event-14.8 {tkerror/bgerror backwards compabitility} { proc foo args {return $args} catch {rename bgerror {}} rename foo bgerror list [info commands bgerror] [info commands tkerror] [info commands foo] [tkerror a b c d] } {bgerror tkerror {} {a b c d}} test event-14.9 {tkerror/bgerror backwards compabitility} { proc bgerror args {return $args} list [catch {rename bgerror tkerror} msg] $msg } {1 {can't rename to "tkerror": command already exists}} rename bgerror {} if {[info commands testexithandler] != ""} { test event-15.1 {Tcl_CreateExitHandler procedure} {unixOrPc} { set child [open |[list [info nameofexecutable]] 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-16.1 {Tcl_DeleteExitHandler procedure} {unixOrPc} { set child [open |[list [info nameofexecutable]] 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-16.2 {Tcl_DeleteExitHandler procedure} {unixOrPc} { set child [open |[list [info nameofexecutable]] 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-16.3 {Tcl_DeleteExitHandler procedure} {unixOrPc} { set child [open |[list [info nameofexecutable]] 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-16.4 {Tcl_DeleteExitHandler procedure} {unixOrPc} { set child [open |[list [info nameofexecutable]] 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-17.1 {Tcl_Exit procedure} {unixOrPc} { set child [open |[list [info nameofexecutable]] 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-18.1 {Tcl_AfterCmd procedure, basics} { list [catch {after} msg] $msg } {1 {wrong # args: should be "after option ?arg arg ...?"}} test event-18.2 {Tcl_AfterCmd procedure, basics} { list [catch {after 2x} msg] $msg } {1 {expected integer but got "2x"}} test event-18.3 {Tcl_AfterCmd procedure, basics} { list [catch {after gorp} msg] $msg } {1 {bad argument "gorp": must be cancel, idle, info, or a number}} test event-18.4 {Tcl_AfterCmd procedure, ms argument} { set x before after 400 {set x after} after 200 update set y $x after 400 update list $y $x } {before after} test event-18.5 {Tcl_AfterCmd procedure, ms argument} { set x before after 300 set x after after 200 update set y $x after 200 update list $y $x } {before after} test event-18.6 {Tcl_AfterCmd procedure, cancel option} { list [catch {after cancel} msg] $msg } {1 {wrong # args: should be "after cancel id|command"}} test event-18.7 {Tcl_AfterCmd procedure, cancel option} { after cancel after#1 } {} test event-18.8 {Tcl_AfterCmd procedure, cancel option} { after cancel {foo bar} } {} test event-18.9 {Tcl_AfterCmd procedure, cancel option} { foreach i [after info] { after cancel $i } set x before set y [after 100 set x after] after cancel $y after 200 update set x } {before} test event-18.10 {Tcl_AfterCmd procedure, cancel option} { foreach i [after info] { after cancel $i } set x before after 100 set x after after cancel {set x after} after 200 update set x } {before} test event-18.11 {Tcl_AfterCmd procedure, cancel option} { foreach i [after info] { after cancel $i } set x before after 100 set x after set id [after 300 set x after] after cancel $id after 200 update set y $x set x cleared after 200 update list $y $x } {after cleared} test event-18.12 {Tcl_AfterCmd procedure, cancel option} { foreach i [after info] { after cancel $i } set x first after idle lappend x second after idle lappend x third set i [after idle lappend x fourth] after cancel {lappend x second} after cancel $i update idletasks set x } {first third} test event-18.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} { foreach i [after info] { after cancel $i } set x first after idle lappend x second after idle lappend x third set i [after idle lappend x fourth] after cancel lappend x second after cancel $i update idletasks set x } {first third} test event-18.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} { foreach i [after info] { after cancel $i } set id [ after 100 { set x done after cancel $id } ] vwait x } {} test event-18.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} { foreach i [after info] { after cancel $i } interp create x x eval {set a before; set b before; after idle {set a a-after}; after idle {set b b-after}} set result [llength [x eval after info]] lappend result [llength [after info]] after cancel {set b b-after} set a aaa set b bbb x eval {after cancel set a a-after} update idletasks lappend result $a $b [x eval {list $a $b}] interp delete x set result } {2 0 aaa bbb {before b-after}} test event-18.16 {Tcl_AfterCmd procedure, idle option} { list [catch {after idle} msg] $msg } {1 {wrong # args: should be "after idle script script ..."}} test event-18.17 {Tcl_AfterCmd procedure, idle option} { set x before after idle {set x after} set y $x update idletasks list $y $x } {before after} test event-18.18 {Tcl_AfterCmd procedure, idle option} { set x before after idle set x after set y $x update idletasks list $y $x } {before after} set event1 [after idle event 1] set event2 [after 1000 event 2] interp create x set childEvent [x eval {after idle event in child}] test event-18.19 {Tcl_AfterCmd, info option} { lsort [after info] } "$event1 $event2" test event-18.20 {Tcl_AfterCmd, info option} { list [catch {after info a b} msg] $msg } {1 {wrong # args: should be "after info ?id?"}} test event-18.21 {Tcl_AfterCmd, info option} { list [catch {after info $childEvent} msg] $msg } "1 {event \"$childEvent\" doesn't exist}" test event-18.22 {Tcl_AfterCmd, info option} { list [after info $event1] [after info $event2] } {{{event 1} idle} {{event 2} timer}} after cancel $event1 after cancel $event2 interp delete x set event [after idle foo bar] scan $event after#%d id test event-19.1 {GetAfterEvent procedure} { list [catch {after info xfter#$id} msg] $msg } "1 {event \"xfter#$id\" doesn't exist}" test event-19.2 {GetAfterEvent procedure} { list [catch {after info afterx$id} msg] $msg } "1 {event \"afterx$id\" doesn't exist}" test event-19.3 {GetAfterEvent procedure} { list [catch {after info after#ab} msg] $msg } {1 {event "after#ab" doesn't exist}} test event-19.4 {GetAfterEvent procedure} { list [catch {after info after#} msg] $msg } {1 {event "after#" doesn't exist}} test event-19.5 {GetAfterEvent procedure} { list [catch {after info after#${id}x} msg] $msg } "1 {event \"after#${id}x\" doesn't exist}" test event-19.6 {GetAfterEvent procedure} { list [catch {after info afterx[expr $id+1]} msg] $msg } "1 {event \"afterx[expr $id+1]\" doesn't exist}" after cancel $event test event-20.1 {AfterProc procedure} { set x before proc foo {} { set x untouched after 100 {set x after} after 200 update return $x } list [foo] $x } {untouched after} test event-20.2 {AfterProc procedure} { catch {rename bgerror {}} proc bgerror msg { global x errorInfo set x [list $msg $errorInfo] } set x empty after 100 {error "After error"} after 200 set y $x update catch {rename bgerror {}} list $y $x } {empty {{After error} {After error while executing "error "After error"" ("after" script)}}} test event-20.3 {AfterProc procedure, deleting handler from itself} { foreach i [after info] { after cancel $i } proc foo {} { global x set x {} foreach i [after info] { lappend x [after info $i] } after cancel foo } after idle foo after 1000 {error "I shouldn't ever have executed"} update idletasks set x } {{{error "I shouldn't ever have executed"} timer}} test event-20.4 {AfterProc procedure, deleting handler from itself} { foreach i [after info] { after cancel $i } proc foo {} { global x set x {} foreach i [after info] { lappend x [after info $i] } after cancel foo } after 1000 {error "I shouldn't ever have executed"} after idle foo update idletasks set x } {{{error "I shouldn't ever have executed"} timer}} foreach i [after info] { after cancel $i } test event-21.1 {AfterCleanupProc procedure} { catch {interp delete x} interp create x x eval {after 200 { lappend x after puts "part 1: this message should not appear" }} after 200 {lappend x after2} x eval {after 200 { lappend x after3 puts "part 2: this message should not appear" }} after 200 {lappend x after4} x eval {after 200 { lappend x after5 puts "part 3: this message should not appear" }} interp delete x set x before after 300 update set x } {before after2 after4} test event-22.1 {Tcl_VwaitCmd procedure} { list [catch {vwait} msg] $msg } {1 {wrong # args: should be "vwait name"}} test event-22.2 {Tcl_VwaitCmd procedure} { list [catch {vwait a b} msg] $msg } {1 {wrong # args: should be "vwait name"}} test event-22.3 {Tcl_VwaitCmd procedure} { foreach i [after info] { after cancel $i } 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} test event-23.1 {Tcl_UpdateCmd procedure} { list [catch {update a b} msg] $msg } {1 {wrong # args: should be "update ?idletasks?"}} test event-23.2 {Tcl_UpdateCmd procedure} { list [catch {update bogus} msg] $msg } {1 {bad option "bogus": must be idletasks}} test event-23.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-23.4 {Tcl_UpdateCmd procedure} { foreach i [after info] { after cancel $i } after 200 {set x x-done} after 500 {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} if {[info commands testfilehandler] != ""} { test event-24.1 {Tcl_WaitForFile procedure, readable} unixOnly { 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-24.2 {Tcl_WaitForFile procedure, readable} unixOnly { 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-24.3 {Tcl_WaitForFile procedure, readable} unixOnly { 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-24.4 {Tcl_WaitForFile procedure, writable} {unixOnly 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-24.5 {Tcl_WaitForFile procedure, writable} {unixOnly 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-24.6 {Tcl_WaitForFile procedure, writable} unixOnly { 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-24.7 {Tcl_WaitForFile procedure, don't call other event handlers} unixOnly { 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-24.8 {Tcl_WaitForFile procedure, waiting indefinitely} unixOnly { 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} } foreach i [after info] { after cancel $i }