diff options
Diffstat (limited to 'tests')
-rw-r--r-- | tests/chanio.test | 6 | ||||
-rw-r--r-- | tests/clock.test | 9 | ||||
-rw-r--r-- | tests/io.test | 18 | ||||
-rw-r--r-- | tests/ioCmd.test | 106 | ||||
-rw-r--r-- | tests/iogt.test | 52 | ||||
-rw-r--r-- | tests/socket.test | 35 |
6 files changed, 215 insertions, 11 deletions
diff --git a/tests/chanio.test b/tests/chanio.test index b195f7b..2f2540e 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -41,7 +41,7 @@ namespace eval ::tcl::test::io { # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... - testConstraint largefileSupport 0 + testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}] # some tests can only be run is umask is 2 # if "umask" cannot be run, the tests will be skipped. @@ -4427,10 +4427,10 @@ test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} { chan puts -nonewline $f abcdef lappend l [chan tell $f] chan close $f - lappend l [file size $f] + lappend l [file size $path(test3)] # truncate... chan close [open $path(test3) w] - lappend l [file size $f] + lappend l [file size $path(test3)] set l } {0 6 6 4294967296 4294967302 4294967302 0} diff --git a/tests/clock.test b/tests/clock.test index fea1fc9..7d62a60 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -36927,6 +36927,15 @@ test clock-67.1 {clock format, %% with a letter following [Bug 2819334]} { clock format [clock seconds] -format %%r } %r +test clock-67.2 {Bug d19a30db57} -body { + # error, not segfault + tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222 +} -returnCodes error -match glob -result * +test clock-67.3 {Bug d19a30db57} -body { + # error, not segfault + tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222 +} -returnCodes error -match glob -result * + # cleanup namespace delete ::testClock diff --git a/tests/io.test b/tests/io.test index bfe6051..d9f133c 100644 --- a/tests/io.test +++ b/tests/io.test @@ -41,7 +41,7 @@ testConstraint testthread [llength [info commands testthread]] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... -testConstraint largefileSupport 0 +testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}] # some tests can only be run is umask is 2 # if "umask" cannot be run, the tests will be skipped. @@ -6626,11 +6626,23 @@ test io-52.4 {TclCopyChannel} {fcopy} { fconfigure $f1 -translation lf -blocking 0 fconfigure $f2 -translation cr -blocking 0 fcopy $f1 $f2 -size 40 - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + lappend result [file size $path(test1)] +} {0 0 0 40} +test io-52.4.1 {TclCopyChannel} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + fconfigure $f1 -translation lf -blocking 0 -buffersize 10000000 + fconfigure $f2 -translation cr -blocking 0 + fcopy $f1 $f2 -size 40 + set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 close $f2 lappend result [file size $path(test1)] -} {0 0 40} +} {0 0 0 40} test io-52.5 {TclCopyChannel, all} {fcopy} { file delete $path(test1) set f1 [open $thisScript] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 8f0bfbf..5a76d48 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -755,6 +755,90 @@ test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match g rename foo {} set res } -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}} +test iocmd-21.20 {Bug 88aef05cda} -setup { + proc foo {method chan args} { + switch -- $method blocking { + chan configure $chan -blocking [lindex $args 0] + return + } initialize { + return {initialize finalize watch blocking read write + configure cget cgetall} + } finalize { + return + } + } + set ch [chan create {read write} foo] +} -body { + list [catch {chan configure $ch -blocking 0} m] $m +} -cleanup { + close $ch + rename foo {} +} -match glob -result {1 {*nested eval*}} +test iocmd-21.21 {[close] in [read] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + close $chan + return a + } + } + set ch [chan create read foo] +} -body { + read $ch 0 +} -cleanup { + close $ch + rename foo {} +} -result {} +test iocmd-21.22 {[close] in [read] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return a + } + } + set ch [chan create read foo] +} -body { + read $ch 1 +} -returnCodes error -cleanup { + catch {close $ch} + rename foo {} +} -match glob -result {*invalid argument*} +test iocmd-21.23 {[close] in [gets] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return \n + } + } + set ch [chan create read foo] +} -body { + gets $ch +} -cleanup { + catch {close $ch} + rename foo {} +} -result {} +test iocmd-21.24 {[close] in binary [gets] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return \n + } + } + set ch [chan create read foo] +} -body { + chan configure $ch -translation binary + gets $ch +} -cleanup { + catch {close $ch} + rename foo {} +} -result {} # --- --- --- --------- --------- --------- # Helper commands to record the arguments to handler methods. @@ -1013,6 +1097,20 @@ test iocmd-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glo rename foo {} unset res } -result {{read rc* 4096} {} 0} +test iocmd-23.11 {chan read, close pulls the rug out} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + set args [lassign $args sub id] + if {$sub ne "read"} {return} + close $id + return {} + } + set c [chan create {r} foo] + note [read $c] + rename foo {} + set res +} -result {{read rc* 4096} {}} # --- === *** ########################### # method write @@ -1927,8 +2025,6 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -match glob -body { - # This test segfaults; Ought to fix that. - set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> @@ -1942,7 +2038,8 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m proc foo {args} { oninit; onfinal; track; # destroy interpreter during channel access - suicide} + suicide + } set chan [chan create {r w} foo] fconfigure $chan -buffering none set chan @@ -1966,8 +2063,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m set res }] set res -} -constraints {testchannel knownBug} \ - -result {Owner lost} +} -constraints {testchannel} -result {Owner lost} test iocmd-32.2 {delete interp of reflected chan} { # Bug 3034840 diff --git a/tests/iogt.test b/tests/iogt.test index 0a25418..0e2eb3c 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -242,6 +242,36 @@ proc id_fulltrail {var op data} { return $res } +proc id_torture {chan op data} { + switch -- $op { + create/write - + create/read - + delete/write - + delete/read - + clear_read {;#ignore} + flush/write - + flush/read {} + write { + global level + if {$level} { + return + } + incr level + testchannel unstack $chan + testchannel transform $chan \ + -command [namespace code [list id_torture $chan]] + return $data + } + read { + testchannel unstack $chan + testchannel transform $chan \ + -command [namespace code [list id_torture $chan]] + return $data + } + query/maxRead {return -1} + } +} + proc counter {var op data} { variable $var upvar 0 $var n @@ -364,6 +394,10 @@ proc audit_flow {var -attach channel} { testchannel transform $channel -command [namespace code [list id_fulltrail $var]] } +proc torture {-attach channel} { + testchannel transform $channel -command [namespace code [list id_torture $channel]] +} + proc stopafter {var n -attach channel} { variable $var upvar 0 $var vn @@ -632,6 +666,24 @@ delete/read {} *ignored* flush/write {} {} delete/write {} *ignored*} +test iogt-2.4 {basic I/O, mixed trail} {testchannel} { + set fh [open $path(dummy) r] + torture -attach $fh + chan configure $fh -buffersize 2 + set x [read $fh] + testchannel unstack $fh + close $fh + set x +} {} +test iogt-2.5 {basic I/O, mixed trail} {testchannel} { + set ::level 0 + set fh [open $path(dummyout) w] + torture -attach $fh + puts -nonewline $fh abcdef + flush $fh + testchannel unstack $fh + close $fh +} {} test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} \ {testchannel knownBug} { diff --git a/tests/socket.test b/tests/socket.test index 0ae5abd..1b7c5fa 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -67,6 +67,10 @@ namespace import -force ::tcltest::* testConstraint testthread [llength [info commands testthread]] testConstraint exec [llength [info commands exec]] +# Produce a random port number in the Dynamic/Private range +# from 49152 through 65535. +proc randport {} { expr {int(rand()*16383+49152)} } + # If remoteServerIP or remoteServerPort are not set, check in the # environment variables for externally set values. # @@ -1683,6 +1687,37 @@ if {[string match sock* $commandSocket] == 1} { } catch {close $commandSocket} catch {close $remoteProcChan} +test socket-14.13 {testing writable event when quick failure} -constraints {socket win supported_inet} -body { + # Test for bug 336441ed59 where a quick background fail was ignored + + # Test only for windows as socket -async 255.255.255.255 fails + # directly on unix + + # The following connect should fail very quickly + set a1 [after 2000 {set x timeout}] + set s [socket -async 255.255.255.255 43434] + fileevent $s writable {set x writable} + vwait x + set x +} -cleanup { + catch {close $s} + after cancel $a1 +} -result writable + +test socket-14.14 {testing fileevent readable on failed async socket connect} -constraints [list socket] -body { + # Test for bug 581937ab1e + + set a1 [after 5000 {set x timeout}] + # This connect should fail + set s [socket -async localhost [randport]] + fileevent $s readable {set x readable} + vwait x + set x +} -cleanup { + catch {close $s} + after cancel $a1 +} -result readable + ::tcltest::cleanupTests flush stdout return |