966 lines
28 KiB
Plaintext
966 lines
28 KiB
Plaintext
|
# 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.
|
|||
|
|
|
|||
|
|
if {"::tcltest" ni [namespace children]} {
|
|||
|
|
package require tcltest 2.5
|
|||
|
|
namespace import -force ::tcltest::*
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
catch {
|
|||
|
|
::tcltest::loadTestedCommands
|
|||
|
|
package require -exact Tcltest [info patchlevel]
|
|||
|
|
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
|
|||
|
|
testConstraint testfilehandler [llength [info commands testfilehandler]]
|
|||
|
|
testConstraint testexithandler [llength [info commands testexithandler]]
|
|||
|
|
testConstraint testfilewait [llength [info commands testfilewait]]
|
|||
|
|
testConstraint exec [llength [info commands exec]]
|
|||
|
|
testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}]
|
|||
|
|
|
|||
|
|
test event-1.1 {Tcl_CreateFileHandler, reading} -setup {
|
|||
|
|
testfilehandler close
|
|||
|
|
set result ""
|
|||
|
|
} -constraints {testfilehandler notOSX} -body {
|
|||
|
|
testfilehandler create 0 readable off
|
|||
|
|
testfilehandler clear 0
|
|||
|
|
testfilehandler oneevent
|
|||
|
|
lappend result [testfilehandler counts 0]
|
|||
|
|
testfilehandler fillpartial 0
|
|||
|
|
update idletasks
|
|||
|
|
testfilehandler oneevent
|
|||
|
|
lappend result [testfilehandler counts 0]
|
|||
|
|
testfilehandler oneevent
|
|||
|
|
lappend result [testfilehandler counts 0]
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
} -result {{0 0} {1 0} {2 0}}
|
|||
|
|
test event-1.2 {Tcl_CreateFileHandler, writing} -setup {
|
|||
|
|
testfilehandler close
|
|||
|
|
set result ""
|
|||
|
|
} -constraints {testfilehandler nonPortable} -body {
|
|||
|
|
# This test is non-portable because on some systems (e.g., SunOS 4.1.3)
|
|||
|
|
# pipes seem to be writable always.
|
|||
|
|
testfilehandler create 0 off writable
|
|||
|
|
testfilehandler clear 0
|
|||
|
|
testfilehandler oneevent
|
|||
|
|
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]
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
} -result {{0 1} {0 2} {0 2}}
|
|||
|
|
test event-1.3 {Tcl_DeleteFileHandler} -setup {
|
|||
|
|
testfilehandler close
|
|||
|
|
set result ""
|
|||
|
|
} -constraints {testfilehandler nonPortable} -body {
|
|||
|
|
testfilehandler create 2 disabled disabled
|
|||
|
|
testfilehandler create 1 readable writable
|
|||
|
|
testfilehandler create 0 disabled disabled
|
|||
|
|
testfilehandler fillpartial 1
|
|||
|
|
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]
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
} -result {{0 1} {1 1} {1 2} {0 0}}
|
|||
|
|
|
|||
|
|
test event-2.1 {Tcl_DeleteFileHandler} -setup {
|
|||
|
|
testfilehandler close
|
|||
|
|
set result ""
|
|||
|
|
} -constraints {testfilehandler nonPortable} -body {
|
|||
|
|
testfilehandler create 2 disabled disabled
|
|||
|
|
testfilehandler create 1 readable writable
|
|||
|
|
testfilehandler fillpartial 1
|
|||
|
|
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]
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
} -result {{0 1} {1 1} {1 2} {0 0}}
|
|||
|
|
test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} -setup {
|
|||
|
|
testfilehandler close
|
|||
|
|
set result ""
|
|||
|
|
} -constraints {testfilehandler nonPortable} -body {
|
|||
|
|
testfilehandler create 0 readable writable
|
|||
|
|
testfilehandler fillpartial 0
|
|||
|
|
testfilehandler oneevent
|
|||
|
|
lappend result [testfilehandler counts 0]
|
|||
|
|
testfilehandler close
|
|||
|
|
testfilehandler create 0 readable writable
|
|||
|
|
testfilehandler oneevent
|
|||
|
|
lappend result [testfilehandler counts 0]
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
} -result {{0 1} {0 0}}
|
|||
|
|
|
|||
|
|
test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off} -setup {
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints {testfilehandler} -body {
|
|||
|
|
testfilehandler create 1 readable writable
|
|||
|
|
testfilehandler fillpartial 1
|
|||
|
|
testfilehandler windowevent
|
|||
|
|
testfilehandler counts 1
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
} -result {0 0}
|
|||
|
|
|
|||
|
|
test event-4.1 {FileHandlerEventProc, race between event and disabling} -setup {
|
|||
|
|
update
|
|||
|
|
testfilehandler close
|
|||
|
|
set result ""
|
|||
|
|
} -constraints {testfilehandler nonPortable} -body {
|
|||
|
|
testfilehandler create 2 disabled disabled
|
|||
|
|
testfilehandler create 1 readable writable
|
|||
|
|
testfilehandler fillpartial 1
|
|||
|
|
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]
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
} -result {{0 1} {1 1} {1 2} {0 0}}
|
|||
|
|
test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} -setup {
|
|||
|
|
update
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints {testfilehandler nonPortable} -body {
|
|||
|
|
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]
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
} -result {{0 0} {0 1} {0 0} {0 1}}
|
|||
|
|
update
|
|||
|
|
|
|||
|
|
test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} -setup {
|
|||
|
|
catch {rename bgerror {}}
|
|||
|
|
} -body {
|
|||
|
|
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
|
|||
|
|
regsub -all [file join {} non_existent] $x "non_existent"
|
|||
|
|
} -cleanup {
|
|||
|
|
rename bgerror {}
|
|||
|
|
} -result {{{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} -setup {
|
|||
|
|
catch {rename bgerror {}}
|
|||
|
|
} -body {
|
|||
|
|
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
|
|||
|
|
return $x
|
|||
|
|
} -cleanup {
|
|||
|
|
rename bgerror {}
|
|||
|
|
} -result {{a simple error}}
|
|||
|
|
test event-5.3 {HandleBgErrors: [Bug 1670155]} -setup {
|
|||
|
|
variable x
|
|||
|
|
proc demo args {variable x done}
|
|||
|
|
variable target [list [namespace which demo] x]
|
|||
|
|
proc trial args {variable target; string length $target}
|
|||
|
|
trace add execution demo enter [namespace code trial]
|
|||
|
|
variable save [interp bgerror {}]
|
|||
|
|
interp bgerror {} $target
|
|||
|
|
} -body {
|
|||
|
|
after 0 {error bar}
|
|||
|
|
vwait [namespace which -variable x]
|
|||
|
|
} -cleanup {
|
|||
|
|
interp bgerror {} $save
|
|||
|
|
unset x target save
|
|||
|
|
rename demo {}
|
|||
|
|
rename trial {}
|
|||
|
|
} -result {}
|
|||
|
|
test event-5.3.1 {Default [interp bgerror] handler} -body {
|
|||
|
|
::tcl::Bgerror
|
|||
|
|
} -returnCodes error -match glob -result {*msg options*}
|
|||
|
|
test event-5.4 {Default [interp bgerror] handler} -body {
|
|||
|
|
::tcl::Bgerror {}
|
|||
|
|
} -returnCodes error -match glob -result {*msg options*}
|
|||
|
|
test event-5.5 {Default [interp bgerror] handler} -body {
|
|||
|
|
::tcl::Bgerror {} {} {}
|
|||
|
|
} -returnCodes error -match glob -result {*msg options*}
|
|||
|
|
test event-5.6 {Default [interp bgerror] handler} -body {
|
|||
|
|
::tcl::Bgerror {} {}
|
|||
|
|
} -returnCodes error -match glob -result {*-level*}
|
|||
|
|
test event-5.7 {Default [interp bgerror] handler} -body {
|
|||
|
|
::tcl::Bgerror {} {-level foo}
|
|||
|
|
} -returnCodes error -match glob -result {*expected integer*}
|
|||
|
|
test event-5.8 {Default [interp bgerror] handler} -body {
|
|||
|
|
::tcl::Bgerror {} {-level 0}
|
|||
|
|
} -returnCodes error -match glob -result {*-code*}
|
|||
|
|
test event-5.9 {Default [interp bgerror] handler} -body {
|
|||
|
|
::tcl::Bgerror {} {-level 0 -code ok}
|
|||
|
|
} -returnCodes error -match glob -result {*expected integer*}
|
|||
|
|
test event-5.10 {Default [interp bgerror] handler} -body {
|
|||
|
|
proc bgerror {m} {append ::res $m}
|
|||
|
|
set ::res {}
|
|||
|
|
::tcl::Bgerror {} {-level 0 -code 0}
|
|||
|
|
return $::res
|
|||
|
|
} -cleanup {
|
|||
|
|
rename bgerror {}
|
|||
|
|
} -result {}
|
|||
|
|
test event-5.11 {Default [interp bgerror] handler} -body {
|
|||
|
|
proc bgerror {m} {append ::res $m}
|
|||
|
|
set ::res {}
|
|||
|
|
::tcl::Bgerror msg {-level 0 -code 1}
|
|||
|
|
return $::res
|
|||
|
|
} -cleanup {
|
|||
|
|
rename bgerror {}
|
|||
|
|
} -result {msg}
|
|||
|
|
test event-5.12 {Default [interp bgerror] handler} -body {
|
|||
|
|
proc bgerror {m} {append ::res $m}
|
|||
|
|
set ::res {}
|
|||
|
|
::tcl::Bgerror msg {-level 0 -code 2}
|
|||
|
|
return $::res
|
|||
|
|
} -cleanup {
|
|||
|
|
rename bgerror {}
|
|||
|
|
} -result {command returned bad code: 2}
|
|||
|
|
test event-5.13 {Default [interp bgerror] handler} -body {
|
|||
|
|
proc bgerror {m} {append ::res $m}
|
|||
|
|
set ::res {}
|
|||
|
|
::tcl::Bgerror msg {-level 0 -code 3}
|
|||
|
|
return $::res
|
|||
|
|
} -cleanup {
|
|||
|
|
rename bgerror {}
|
|||
|
|
} -result {invoked "break" outside of a loop}
|
|||
|
|
test event-5.14 {Default [interp bgerror] handler} -body {
|
|||
|
|
proc bgerror {m} {append ::res $m}
|
|||
|
|
set ::res {}
|
|||
|
|
::tcl::Bgerror msg {-level 0 -code 4}
|
|||
|
|
return $::res
|
|||
|
|
} -cleanup {
|
|||
|
|
rename bgerror {}
|
|||
|
|
} -result {invoked "continue" outside of a loop}
|
|||
|
|
test event-5.15 {Default [interp bgerror] handler} -body {
|
|||
|
|
proc bgerror {m} {append ::res $m}
|
|||
|
|
set ::res {}
|
|||
|
|
::tcl::Bgerror msg {-level 0 -code 5}
|
|||
|
|
return $::res
|
|||
|
|
} -cleanup {
|
|||
|
|
rename bgerror {}
|
|||
|
|
} -result {command returned bad code: 5}
|
|||
|
|
|
|||
|
|
test event-6.1 {BgErrorDeleteProc procedure} -setup {
|
|||
|
|
catch {interp delete foo}
|
|||
|
|
interp create foo
|
|||
|
|
set erroutfile [makeFile Unmodified err.out]
|
|||
|
|
} -body {
|
|||
|
|
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
|
|||
|
|
return $result
|
|||
|
|
} -cleanup {
|
|||
|
|
removeFile $erroutfile
|
|||
|
|
} -result {Unmodified
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
test event-7.1 {bgerror / regular} {
|
|||
|
|
set errRes {}
|
|||
|
|
proc bgerror {err} {
|
|||
|
|
global errRes
|
|||
|
|
set errRes $err
|
|||
|
|
}
|
|||
|
|
after 0 {error err1}
|
|||
|
|
vwait errRes
|
|||
|
|
return $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
|
|||
|
|
return $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
|
|||
|
|
return $errRes
|
|||
|
|
} err1
|
|||
|
|
test event-7.4 {tkerror is nothing special anymore to tcl} -body {
|
|||
|
|
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
|
|||
|
|
return $errRes
|
|||
|
|
} -cleanup {
|
|||
|
|
rename tkerror {}
|
|||
|
|
} -result bg:err1
|
|||
|
|
test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} -body {
|
|||
|
|
exec [interpreter] << {
|
|||
|
|
after 1000 error hello
|
|||
|
|
after 2000 set a 0
|
|||
|
|
vwait a
|
|||
|
|
}
|
|||
|
|
} -constraints {exec} -returnCodes error -result {hello
|
|||
|
|
while executing
|
|||
|
|
"error hello"
|
|||
|
|
("after" script)}
|
|||
|
|
test event-7.6 {safe hidden bgerror fallback} -setup {
|
|||
|
|
variable result {}
|
|||
|
|
interp create -safe safe
|
|||
|
|
} -body {
|
|||
|
|
safe alias puts puts
|
|||
|
|
safe alias result ::append [namespace which -variable result]
|
|||
|
|
safe eval {proc bgerror m {result $m\n$::errorCode\n$::errorInfo\n}}
|
|||
|
|
safe hide bgerror
|
|||
|
|
safe eval after 0 error foo
|
|||
|
|
update
|
|||
|
|
return $result
|
|||
|
|
} -cleanup {
|
|||
|
|
interp delete safe
|
|||
|
|
} -result {foo
|
|||
|
|
NONE
|
|||
|
|
foo
|
|||
|
|
while executing
|
|||
|
|
"error foo"
|
|||
|
|
("after" script)
|
|||
|
|
}
|
|||
|
|
test event-7.7 {safe hidden bgerror fallback} -setup {
|
|||
|
|
variable result {}
|
|||
|
|
interp create -safe safe
|
|||
|
|
} -body {
|
|||
|
|
safe alias puts puts
|
|||
|
|
safe alias result ::append [namespace which -variable result]
|
|||
|
|
safe eval {proc bgerror m {result $m\n$::errorCode\n$::errorInfo\n}}
|
|||
|
|
safe hide bgerror
|
|||
|
|
safe eval {proc bgerror m {error bar soom baz}}
|
|||
|
|
safe eval after 0 error foo
|
|||
|
|
update
|
|||
|
|
return $result
|
|||
|
|
} -cleanup {
|
|||
|
|
interp delete safe
|
|||
|
|
} -result {foo
|
|||
|
|
NONE
|
|||
|
|
foo
|
|||
|
|
while executing
|
|||
|
|
"error foo"
|
|||
|
|
("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 "catch {load $::tcltestlib Tcltest}"
|
|||
|
|
puts $child "testexithandler create 41; testexithandler create 4"
|
|||
|
|
puts $child "testexithandler create 6; exit"
|
|||
|
|
flush $child
|
|||
|
|
set result [read $child]
|
|||
|
|
close $child
|
|||
|
|
return $result
|
|||
|
|
} {even 6
|
|||
|
|
even 4
|
|||
|
|
odd 41
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
|
|||
|
|
set child [open |[list [interpreter]] r+]
|
|||
|
|
puts $child "catch {load $::tcltestlib Tcltest}"
|
|||
|
|
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
|
|||
|
|
return $result
|
|||
|
|
} {even 16
|
|||
|
|
even 6
|
|||
|
|
even 4
|
|||
|
|
}
|
|||
|
|
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
|
|||
|
|
set child [open |[list [interpreter]] r+]
|
|||
|
|
puts $child "catch {load $::tcltestlib Tcltest}"
|
|||
|
|
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
|
|||
|
|
return $result
|
|||
|
|
} {even 16
|
|||
|
|
even 6
|
|||
|
|
odd 41
|
|||
|
|
}
|
|||
|
|
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
|
|||
|
|
set child [open |[list [interpreter]] r+]
|
|||
|
|
puts $child "catch {load $::tcltestlib Tcltest}"
|
|||
|
|
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
|
|||
|
|
return $result
|
|||
|
|
} {even 16
|
|||
|
|
even 4
|
|||
|
|
odd 41
|
|||
|
|
}
|
|||
|
|
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
|
|||
|
|
set child [open |[list [interpreter]] r+]
|
|||
|
|
puts $child "catch {load $::tcltestlib Tcltest}"
|
|||
|
|
puts $child "testexithandler create 41; testexithandler delete 41"
|
|||
|
|
puts $child "testexithandler create 16; exit"
|
|||
|
|
flush $child
|
|||
|
|
set result [read $child]
|
|||
|
|
close $child
|
|||
|
|
return $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} -returnCodes error -body {
|
|||
|
|
vwait
|
|||
|
|
} -result {wrong # args: should be "vwait name"}
|
|||
|
|
test event-11.2 {Tcl_VwaitCmd procedure} -returnCodes error -body {
|
|||
|
|
vwait a b
|
|||
|
|
} -result {wrong # args: should be "vwait name"}
|
|||
|
|
test event-11.3 {Tcl_VwaitCmd procedure} -setup {
|
|||
|
|
catch {unset x}
|
|||
|
|
} -body {
|
|||
|
|
set x 1
|
|||
|
|
vwait x(1)
|
|||
|
|
} -returnCodes error -result {can't trace "x(1)": variable isn't array}
|
|||
|
|
test event-11.4 {Tcl_VwaitCmd procedure} -setup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
after 10; update; # On Mac make sure update won't take long
|
|||
|
|
} -body {
|
|||
|
|
after 100 {set x x-done}
|
|||
|
|
after 200 {set y y-done}
|
|||
|
|
after 400 {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
|
|||
|
|
} -cleanup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
} -result {{} x-done y-done before q-done}
|
|||
|
|
test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} -setup {
|
|||
|
|
set test1file [makeFile "" test1]
|
|||
|
|
} -constraints {socket} -body {
|
|||
|
|
set f1 [open $test1file w]
|
|||
|
|
proc accept {s args} {
|
|||
|
|
puts $s foobar
|
|||
|
|
close $s
|
|||
|
|
}
|
|||
|
|
set s1 [socket -server accept -myaddr 127.0.0.1 0]
|
|||
|
|
after 1000
|
|||
|
|
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
|
|||
|
|
list $x $y $z
|
|||
|
|
} -cleanup {
|
|||
|
|
removeFile $test1file
|
|||
|
|
} -result {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-11.7 {Bug 16828b3744} {
|
|||
|
|
after idle {
|
|||
|
|
set ::t::v 1
|
|||
|
|
namespace delete ::t
|
|||
|
|
}
|
|||
|
|
namespace eval ::t {
|
|||
|
|
vwait ::t::v
|
|||
|
|
}
|
|||
|
|
} {}
|
|||
|
|
test event-11.8 {Bug 16828b3744} -setup {
|
|||
|
|
oo::class create A {
|
|||
|
|
variable continue
|
|||
|
|
|
|||
|
|
method start {} {
|
|||
|
|
after idle [self] destroy
|
|||
|
|
|
|||
|
|
set continue 0
|
|||
|
|
vwait [namespace current]::continue
|
|||
|
|
}
|
|||
|
|
destructor {
|
|||
|
|
set continue 1
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
} -body {
|
|||
|
|
[A new] start
|
|||
|
|
} -cleanup {
|
|||
|
|
A destroy
|
|||
|
|
} -result {}
|
|||
|
|
|
|||
|
|
test event-12.1 {Tcl_UpdateCmd procedure} -returnCodes error -body {
|
|||
|
|
update a b
|
|||
|
|
} -result {wrong # args: should be "update ?idletasks?"}
|
|||
|
|
test event-12.2 {Tcl_UpdateCmd procedure} -returnCodes error -body {
|
|||
|
|
update bogus
|
|||
|
|
} -result {bad option "bogus": must be idletasks}
|
|||
|
|
test event-12.3 {Tcl_UpdateCmd procedure} -setup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
} -body {
|
|||
|
|
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
|
|||
|
|
} -cleanup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
} -result {before after {after, y = after}}
|
|||
|
|
test event-12.4 {Tcl_UpdateCmd procedure} -setup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
} -body {
|
|||
|
|
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
|
|||
|
|
} -cleanup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
} -result {x-done before z-done}
|
|||
|
|
|
|||
|
|
test event-13.1 {Tcl_WaitForFile procedure, readable} -setup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints {testfilehandler} -body {
|
|||
|
|
after 100 set x timeout
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
set x "no timeout"
|
|||
|
|
set result [testfilehandler wait 1 readable 0]
|
|||
|
|
update
|
|||
|
|
list $result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
} -result {{} {no timeout}}
|
|||
|
|
test event-13.2 {Tcl_WaitForFile procedure, readable} -setup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints testfilehandler -body {
|
|||
|
|
after 100 set x timeout
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
set x "no timeout"
|
|||
|
|
set result [testfilehandler wait 1 readable 100]
|
|||
|
|
update
|
|||
|
|
list $result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
} -result {{} timeout}
|
|||
|
|
test event-13.3 {Tcl_WaitForFile procedure, readable} -setup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints testfilehandler -body {
|
|||
|
|
after 100 set x timeout
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
testfilehandler fillpartial 1
|
|||
|
|
set x "no timeout"
|
|||
|
|
set result [testfilehandler wait 1 readable 100]
|
|||
|
|
update
|
|||
|
|
list $result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
} -result {readable {no timeout}}
|
|||
|
|
test event-13.4 {Tcl_WaitForFile procedure, writable} -setup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints {testfilehandler nonPortable} -body {
|
|||
|
|
after 100 set x timeout
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
testfilehandler fill 1
|
|||
|
|
set x "no timeout"
|
|||
|
|
set result [testfilehandler wait 1 writable 0]
|
|||
|
|
update
|
|||
|
|
list $result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
} -result {{} {no timeout}}
|
|||
|
|
test event-13.5 {Tcl_WaitForFile procedure, writable} -setup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints {testfilehandler nonPortable} -body {
|
|||
|
|
after 100 set x timeout
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
testfilehandler fill 1
|
|||
|
|
set x "no timeout"
|
|||
|
|
set result [testfilehandler wait 1 writable 100]
|
|||
|
|
update
|
|||
|
|
list $result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
} -result {{} timeout}
|
|||
|
|
test event-13.6 {Tcl_WaitForFile procedure, writable} -setup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints testfilehandler -body {
|
|||
|
|
after 100 set x timeout
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
set x "no timeout"
|
|||
|
|
set result [testfilehandler wait 1 writable 100]
|
|||
|
|
update
|
|||
|
|
list $result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
} -result {writable {no timeout}}
|
|||
|
|
test event-13.7 {Tcl_WaitForFile procedure, don't call other event handlers} -setup {
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints testfilehandler -body {
|
|||
|
|
after 100 lappend x timeout
|
|||
|
|
after idle lappend x idle
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
set x ""
|
|||
|
|
set result [list [testfilehandler wait 1 readable 200] $x]
|
|||
|
|
update
|
|||
|
|
lappend result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
} -result {{} {} {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
|
|||
|
|
return $result
|
|||
|
|
} {{} readable}
|
|||
|
|
|
|||
|
|
test event-14.1 {Tcl_WaitForFile procedure, readable, big fd} -setup {
|
|||
|
|
set chanList {}
|
|||
|
|
for {set i 0} {$i < 32} {incr i} {
|
|||
|
|
lappend chanList [open /dev/null r]
|
|||
|
|
}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints {testfilehandler unix} -body {
|
|||
|
|
after 100 set x timeout
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
set x "no timeout"
|
|||
|
|
set result [testfilehandler wait 1 readable 0]
|
|||
|
|
update
|
|||
|
|
list $result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach chan $chanList {close $chan}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
} -result {{} {no timeout}}
|
|||
|
|
test event-14.2 {Tcl_WaitForFile procedure, readable, big fd} -setup {
|
|||
|
|
set chanList {}
|
|||
|
|
for {set i 0} {$i < 32} {incr i} {
|
|||
|
|
lappend chanList [open /dev/null r]
|
|||
|
|
}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints {testfilehandler unix} -body {
|
|||
|
|
after 100 set x timeout
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
set x "no timeout"
|
|||
|
|
set result [testfilehandler wait 1 readable 100]
|
|||
|
|
update
|
|||
|
|
list $result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach chan $chanList {close $chan}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
} -result {{} timeout}
|
|||
|
|
test event-14.3 {Tcl_WaitForFile procedure, readable, big fd} -setup {
|
|||
|
|
set chanList {}
|
|||
|
|
for {set i 0} {$i < 32} {incr i} {
|
|||
|
|
lappend chanList [open /dev/null r]
|
|||
|
|
}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints {testfilehandler unix} -body {
|
|||
|
|
after 100 set x timeout
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
testfilehandler fillpartial 1
|
|||
|
|
set x "no timeout"
|
|||
|
|
set result [testfilehandler wait 1 readable 100]
|
|||
|
|
update
|
|||
|
|
list $result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach chan $chanList {close $chan}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
} -result {readable {no timeout}}
|
|||
|
|
test event-14.4 {Tcl_WaitForFile procedure, writable, big fd} -setup {
|
|||
|
|
set chanList {}
|
|||
|
|
for {set i 0} {$i < 32} {incr i} {
|
|||
|
|
lappend chanList [open /dev/null r]
|
|||
|
|
}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints {testfilehandler unix nonPortable} -body {
|
|||
|
|
after 100 set x timeout
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
testfilehandler fill 1
|
|||
|
|
set x "no timeout"
|
|||
|
|
set result [testfilehandler wait 1 writable 0]
|
|||
|
|
update
|
|||
|
|
list $result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach chan $chanList {close $chan}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
} -result {{} {no timeout}}
|
|||
|
|
test event-14.5 {Tcl_WaitForFile procedure, writable, big fd} -setup {
|
|||
|
|
set chanList {}
|
|||
|
|
for {set i 0} {$i < 32} {incr i} {
|
|||
|
|
lappend chanList [open /dev/null r]
|
|||
|
|
}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints {testfilehandler unix nonPortable} -body {
|
|||
|
|
after 100 set x timeout
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
testfilehandler fill 1
|
|||
|
|
set x "no timeout"
|
|||
|
|
set result [testfilehandler wait 1 writable 100]
|
|||
|
|
update
|
|||
|
|
list $result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach chan $chanList {close $chan}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
} -result {{} timeout}
|
|||
|
|
test event-14.6 {Tcl_WaitForFile procedure, writable, big fd} -setup {
|
|||
|
|
set chanList {}
|
|||
|
|
for {set i 0} {$i < 32} {incr i} {
|
|||
|
|
lappend chanList [open /dev/null r]
|
|||
|
|
}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints {testfilehandler unix} -body {
|
|||
|
|
after 100 set x timeout
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
set x "no timeout"
|
|||
|
|
set result [testfilehandler wait 1 writable 100]
|
|||
|
|
update
|
|||
|
|
list $result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach chan $chanList {close $chan}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
} -result {writable {no timeout}}
|
|||
|
|
test event-14.7 {Tcl_WaitForFile, don't call other event handlers, big fd} -setup {
|
|||
|
|
set chanList {}
|
|||
|
|
for {set i 0} {$i < 32} {incr i} {
|
|||
|
|
lappend chanList [open /dev/null r]
|
|||
|
|
}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
testfilehandler close
|
|||
|
|
} -constraints {testfilehandler unix} -body {
|
|||
|
|
after 100 lappend x timeout
|
|||
|
|
after idle lappend x idle
|
|||
|
|
testfilehandler create 1 off off
|
|||
|
|
set x ""
|
|||
|
|
set result [list [testfilehandler wait 1 readable 200] $x]
|
|||
|
|
update
|
|||
|
|
lappend result $x
|
|||
|
|
} -cleanup {
|
|||
|
|
testfilehandler close
|
|||
|
|
foreach chan $chanList {close $chan}
|
|||
|
|
foreach i [after info] {after cancel $i}
|
|||
|
|
} -result {{} {} {timeout idle}}
|
|||
|
|
test event-14.8 {Tcl_WaitForFile procedure, waiting indefinitely, big fd} -setup {
|
|||
|
|
set chanList {}
|
|||
|
|
for {set i 0} {$i < 32} {incr i} {
|
|||
|
|
lappend chanList [open /dev/null r]
|
|||
|
|
}
|
|||
|
|
} -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
|
|||
|
|
return $result
|
|||
|
|
} -cleanup {
|
|||
|
|
foreach chan $chanList {close $chan}
|
|||
|
|
} -result {{} readable}
|
|||
|
|
|
|||
|
|
# cleanup
|
|||
|
|
foreach i [after info] {
|
|||
|
|
after cancel $i
|
|||
|
|
}
|
|||
|
|
::tcltest::cleanupTests
|
|||
|
|
return
|
|||
|
|
|
|||
|
|
# Local Variables:
|
|||
|
|
# mode: tcl
|
|||
|
|
# End:
|