933 lines
25 KiB
Plaintext
933 lines
25 KiB
Plaintext
|
# 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.21 96/08/19 12:53:40"
|
||
|
|
||
|
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} {
|
||
|
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-22.4 {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
|
||
|
}
|