Import Tcl 8.6.10
This commit is contained in:
Steve Dower
@@ -12,11 +12,22 @@
|
||||
|
||||
package prefer latest
|
||||
package require Tcl 8.5-
|
||||
package require tcltest 2.2
|
||||
namespace import tcltest::*
|
||||
configure {*}$argv -testdir [file dir [info script]]
|
||||
package require tcltest 2.5
|
||||
namespace import ::tcltest::*
|
||||
|
||||
configure {*}$argv -testdir [file dirname [file dirname [file normalize [
|
||||
info script]/...]]]
|
||||
|
||||
if {[singleProcess]} {
|
||||
interp debug {} -frame 1
|
||||
}
|
||||
runAllTests
|
||||
proc exit args {}
|
||||
|
||||
set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
|
||||
unset -nocomplain env(ERROR_ON_FAILURES)
|
||||
if {[runAllTests] && $ErrorOnFailures} {exit 1}
|
||||
# if calling direct only (avoid rewrite exit if inlined or interactive):
|
||||
if { [info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]
|
||||
&& !([info exists ::tcl_interactive] && $::tcl_interactive)
|
||||
} {
|
||||
proc exit args {}
|
||||
}
|
||||
@@ -1584,6 +1584,12 @@ test assemble-15.7 {listIndexImm} {
|
||||
}
|
||||
-result c
|
||||
}
|
||||
test assemble-15.8 {listIndexImm} {
|
||||
assemble {push {a b c}; listIndexImm end+2}
|
||||
} {}
|
||||
test assemble-15.9 {listIndexImm} {
|
||||
assemble {push {a b c}; listIndexImm -1-1}
|
||||
} {}
|
||||
|
||||
# assemble-16 - invokeStk
|
||||
|
||||
|
||||
@@ -21,6 +21,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testasync [llength [info commands testasync]]
|
||||
testConstraint threaded [::tcl::pkgconfig get threaded]
|
||||
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
|
||||
|
||||
proc async1 {result code} {
|
||||
global aresult acode
|
||||
@@ -157,17 +158,24 @@ test async-4.1 {async interrupting bytecode sequence} -constraints {
|
||||
}
|
||||
} -body {
|
||||
apply {{handle} {
|
||||
global aresult
|
||||
set aresult {Async event not delivered}
|
||||
testasync marklater $handle
|
||||
for {set i 0} {
|
||||
$i < 2500000 && $aresult eq "Async event not delivered"
|
||||
} {incr i} {
|
||||
nothing
|
||||
}
|
||||
global aresult
|
||||
set aresult {Async event not delivered}
|
||||
testasync marklater $handle
|
||||
# allow plenty of time to pass in case valgrind is running
|
||||
set start [clock seconds]
|
||||
while {
|
||||
[clock seconds] - $start < 180 && $aresult eq "Async event not delivered"
|
||||
} {
|
||||
# be less busy
|
||||
after 100
|
||||
nothing
|
||||
}
|
||||
return $aresult
|
||||
}} $hm
|
||||
} -result {test pattern} -cleanup {
|
||||
# give other threads some time to go way so that valgrind doesn't pick up
|
||||
# "still reachable" cases from early thread termination
|
||||
after 100
|
||||
testasync delete $hm
|
||||
}
|
||||
test async-4.2 {async interrupting straight bytecode sequence} -constraints {
|
||||
@@ -179,16 +187,24 @@ test async-4.2 {async interrupting straight bytecode sequence} -constraints {
|
||||
global aresult
|
||||
set aresult {Async event not delivered}
|
||||
testasync marklater $handle
|
||||
for {set i 0} {
|
||||
$i < 2500000 && $aresult eq "Async event not delivered"
|
||||
} {incr i} {}
|
||||
# allow plenty of time to pass in case valgrind is running
|
||||
set start [clock seconds]
|
||||
while {
|
||||
[clock seconds] - $start < 180 && $aresult eq "Async event not delivered"
|
||||
} {
|
||||
# be less busy
|
||||
after 100
|
||||
}
|
||||
return $aresult
|
||||
}} $hm
|
||||
} -result {test pattern} -cleanup {
|
||||
# give other threads some time to go way so that valgrind doesn't pick up
|
||||
# "still reachable" cases from early thread termination
|
||||
after 100
|
||||
testasync delete $hm
|
||||
}
|
||||
test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
|
||||
testasync threaded
|
||||
testasync threaded knownMsvcBug
|
||||
} -setup {
|
||||
set hm [testasync create async3]
|
||||
} -body {
|
||||
@@ -201,6 +217,9 @@ test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
|
||||
return $aresult
|
||||
}]] $hm
|
||||
} -result {test pattern} -cleanup {
|
||||
# give other threads some time to go way so that valgrind doesn't pick up
|
||||
# "still reachable" cases from early thread termination
|
||||
after 100
|
||||
testasync delete $hm
|
||||
}
|
||||
|
||||
|
||||
@@ -962,6 +962,24 @@ test basic-48.23.$noComp {expansion: handle return codes} -constraints $constrai
|
||||
unset res t
|
||||
} -result {0 10 1 Hejsan}
|
||||
|
||||
test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
|
||||
unset -nocomplain a
|
||||
} -body {
|
||||
run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
|
||||
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}
|
||||
|
||||
test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -constraints $constraints -setup {
|
||||
unset -nocomplain ::CRLF
|
||||
set ::CRLF "\r\n"
|
||||
} -body {
|
||||
# Force variant that turned up in Bug 2c154a40be as that's externally
|
||||
# noticeable in an important downstream project.
|
||||
run {scan [list {*}$::CRLF]x %c%c%c}
|
||||
} -cleanup {
|
||||
unset -nocomplain ::CRLF
|
||||
} -result {120 {} {}}
|
||||
|
||||
|
||||
} ;# End of noComp loop
|
||||
|
||||
test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
|
||||
|
||||
@@ -2711,6 +2711,46 @@ test binary-73.30 {binary decode base64} -body {
|
||||
test binary-73.31 {binary decode base64} -body {
|
||||
list [string length [set r [binary decode base64 WA==WFla]]] $r
|
||||
} -returnCodes error -match glob -result {invalid base64 character *}
|
||||
test binary-73.32 {binary decode base64, bug [00d04c4f12]} -body {
|
||||
list \
|
||||
[string length [binary decode base64 =]] \
|
||||
[string length [binary decode base64 " ="]] \
|
||||
[string length [binary decode base64 " ="]] \
|
||||
[string length [binary decode base64 "\r\n\t="]] \
|
||||
} -result [lrepeat 4 0]
|
||||
test binary-73.33 {binary decode base64, bug [00d04c4f12]} -body {
|
||||
list \
|
||||
[string length [binary decode base64 ==]] \
|
||||
[string length [binary decode base64 " =="]] \
|
||||
[string length [binary decode base64 " =="]] \
|
||||
[string length [binary decode base64 " =="]] \
|
||||
} -result [lrepeat 4 0]
|
||||
test binary-73.34 {binary decode base64, (compatibility) unfulfilled base64 (single char) in non-strict mode} -body {
|
||||
list \
|
||||
[expr {[binary decode base64 a] eq [binary decode base64 ""]}] \
|
||||
[expr {[binary decode base64 abcda] eq [binary decode base64 "abcd"]}]
|
||||
} -result [lrepeat 2 1]
|
||||
test binary-73.35 {binary decode base64, bad base64 in strict mode} -body {
|
||||
set r {}
|
||||
foreach c {a " a" " a" " a" " a" abcda abcdabcda a= a== abcda= abcda==} {
|
||||
lappend r \
|
||||
[catch {binary decode base64 $c}] \
|
||||
[catch {binary decode base64 -strict $c}]
|
||||
}
|
||||
set r
|
||||
} -result [lrepeat 11 0 1]
|
||||
test binary-73.36 {binary decode base64: check encoded & decoded equals original} -body {
|
||||
set r {}
|
||||
for {set i 0} {$i < 255 && [llength $r] < 20} {incr i} {
|
||||
foreach c {1 2 3 4 5 6 7 8} {
|
||||
set c [string repeat [format %c $i] $c]
|
||||
if {[set a [binary decode base64 [set x [binary encode base64 $c]]]] ne $c} {
|
||||
lappend r "encode & decode is wrong on string `$c` (encoded: $x): `$a` != `$c`"
|
||||
}
|
||||
}
|
||||
}
|
||||
join $r \n
|
||||
} -result {}
|
||||
|
||||
test binary-74.1 {binary encode uuencode} -body {
|
||||
binary encode uuencode
|
||||
|
||||
@@ -13,16 +13,11 @@
|
||||
# See the file "license.terms" for information on usage and redistribution of
|
||||
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
# TODO: This test is likely worthless. Confirm and remove
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testbytestring [llength [info commands testbytestring]]
|
||||
|
||||
namespace eval ::tcl::test::io {
|
||||
namespace import ::tcltest::*
|
||||
|
||||
@@ -35,18 +30,20 @@ namespace eval ::tcl::test::io {
|
||||
variable msg
|
||||
variable expected
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
catch {
|
||||
::tcltest::loadTestedCommands
|
||||
package require -exact Tcltest [info patchlevel]
|
||||
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
|
||||
}
|
||||
package require tcltests
|
||||
|
||||
testConstraint testbytestring [llength [info commands testbytestring]]
|
||||
testConstraint testchannel [llength [info commands testchannel]]
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
testConstraint openpipe 1
|
||||
testConstraint fileevent [llength [info commands fileevent]]
|
||||
testConstraint fcopy [llength [info commands fcopy]]
|
||||
testConstraint testfevent [llength [info commands testfevent]]
|
||||
testConstraint testchannelevent [llength [info commands testchannelevent]]
|
||||
testConstraint testmainthread [llength [info commands testmainthread]]
|
||||
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
|
||||
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
|
||||
|
||||
# You need a *very* special environment to do some tests. In particular,
|
||||
# many file systems do not support large-files...
|
||||
@@ -130,10 +127,10 @@ test chan-io-1.8 {Tcl_WriteChars: WriteChars} {
|
||||
# Executing this test without the fix for the referenced bug applied to
|
||||
# tcl will cause tcl, more specifically WriteChars, to go into an infinite
|
||||
# loop.
|
||||
set f [open $path(test2) w]
|
||||
chan configure $f -encoding iso2022-jp
|
||||
chan puts -nonewline $f [format %s%c [string repeat " " 4] 12399]
|
||||
chan close $f
|
||||
set f [open $path(test2) w]
|
||||
chan configure $f -encoding iso2022-jp
|
||||
chan puts -nonewline $f [format %s%c [string repeat " " 4] 12399]
|
||||
chan close $f
|
||||
contents $path(test2)
|
||||
} " \x1b\$B\$O\x1b(B"
|
||||
test chan-io-1.9 {Tcl_WriteChars: WriteChars} {
|
||||
@@ -248,7 +245,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod
|
||||
test chan-io-3.4 {WriteChars: loop over stage buffer} {
|
||||
# stage buffer maps to more than can be queued at once.
|
||||
set f [open $path(test1) w]
|
||||
chan configure $f -encoding jis0208 -buffersize 16
|
||||
chan configure $f -encoding jis0208 -buffersize 16
|
||||
chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
|
||||
set x [list [contents $path(test1)]]
|
||||
chan close $f
|
||||
@@ -259,7 +256,7 @@ test chan-io-3.5 {WriteChars: saved != 0} {
|
||||
# be moved to beginning of next channel buffer to preserve requested
|
||||
# buffersize.
|
||||
set f [open $path(test1) w]
|
||||
chan configure $f -encoding jis0208 -buffersize 17
|
||||
chan configure $f -encoding jis0208 -buffersize 17
|
||||
chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
|
||||
set x [list [contents $path(test1)]]
|
||||
chan close $f
|
||||
@@ -288,7 +285,7 @@ test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} {
|
||||
# on flush. The truncated bytes are moved to the beginning of the next
|
||||
# channel buffer.
|
||||
set f [open $path(test1) w]
|
||||
chan configure $f -encoding jis0208 -buffersize 17
|
||||
chan configure $f -encoding jis0208 -buffersize 17
|
||||
chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
|
||||
set x [list [contents $path(test1)]]
|
||||
chan close $f
|
||||
@@ -353,7 +350,7 @@ test chan-io-4.5 {TranslateOutputEOL: crlf} {
|
||||
|
||||
test chan-io-5.1 {CheckFlush: not full} {
|
||||
set f [open $path(test1) w]
|
||||
chan configure $f
|
||||
chan configure $f
|
||||
chan puts -nonewline $f "12345678901234567890"
|
||||
set x [list [contents $path(test1)]]
|
||||
chan close $f
|
||||
@@ -441,7 +438,7 @@ set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
|
||||
append a $a
|
||||
append a $a
|
||||
test chan-io-6.6 {Tcl_GetsObj: loop test} -body {
|
||||
# if (dst >= dstEnd)
|
||||
# if (dst >= dstEnd)
|
||||
set f [open $path(test1) w]
|
||||
chan puts $f $a
|
||||
chan puts $f hi
|
||||
@@ -750,7 +747,7 @@ test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} -body {
|
||||
chan close $f
|
||||
} -result [list 16 "123456789012345\r" 1]
|
||||
test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} -body {
|
||||
# not (*eol == '\n')
|
||||
# not (*eol == '\n')
|
||||
set f [open $path(test1) w]
|
||||
chan configure $f -translation lf
|
||||
chan puts -nonewline $f "123456789012345\rabcd\r\nefg"
|
||||
@@ -860,7 +857,7 @@ test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup {
|
||||
chan configure $f -buffersize 16
|
||||
lappend x [chan gets $f]
|
||||
chan configure $f -blocking 0
|
||||
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
|
||||
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
|
||||
chan configure $f -blocking 1
|
||||
chan puts -nonewline $f "\nabcd\refg\x1a"
|
||||
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
|
||||
@@ -871,14 +868,14 @@ test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup {
|
||||
test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup {
|
||||
set x ""
|
||||
} -constraints {stdio testchannel openpipe fileevent} -body {
|
||||
# not (*eol == '\n')
|
||||
# not (*eol == '\n')
|
||||
set f [openpipe w+ $path(cat)]
|
||||
chan configure $f -translation {auto lf} -buffering none
|
||||
chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
|
||||
chan configure $f -buffersize 16
|
||||
lappend x [chan gets $f]
|
||||
chan configure $f -blocking 0
|
||||
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
|
||||
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
|
||||
chan configure $f -blocking 1
|
||||
chan puts -nonewline $f "abcd\refg\x1a"
|
||||
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
|
||||
@@ -957,7 +954,7 @@ test chan-io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} -constraints {test
|
||||
chan close $f
|
||||
} -result {123456 0 8 78901}
|
||||
test chan-io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} -constraints {testchannel} -body {
|
||||
# not (*eol == '\n')
|
||||
# not (*eol == '\n')
|
||||
set f [open $path(test1) w]
|
||||
chan configure $f -translation lf
|
||||
chan puts -nonewline $f "123456\r78901"
|
||||
@@ -1183,7 +1180,7 @@ test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {st
|
||||
chan close $f
|
||||
} -result {15 abcdefghijklmno 1}
|
||||
test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel openpipe fileevent} -body {
|
||||
# ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
|
||||
# ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
|
||||
set f [openpipe w+ $path(cat)]
|
||||
chan configure $f -translation {auto binary} -buffersize 16
|
||||
chan puts -nonewline $f "abcdefghijklmno\r"
|
||||
@@ -1423,7 +1420,7 @@ test chan-io-13.2 {TranslateInputEOL: crlf mode} -body {
|
||||
chan close $f
|
||||
} -result "abcd\ndef\n"
|
||||
test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} -body {
|
||||
# (src >= srcMax)
|
||||
# (src >= srcMax)
|
||||
set f [open $path(test1) w]
|
||||
chan configure $f -translation lf
|
||||
chan puts -nonewline $f "abcd\r\ndef\r"
|
||||
@@ -1435,7 +1432,7 @@ test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} -body {
|
||||
chan close $f
|
||||
} -result "abcd\ndef\r"
|
||||
test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} -body {
|
||||
# (src >= srcMax)
|
||||
# (src >= srcMax)
|
||||
set f [open $path(test1) w]
|
||||
chan configure $f -translation lf
|
||||
chan puts -nonewline $f "abcd\r\ndef\rfgh"
|
||||
@@ -1447,7 +1444,7 @@ test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} -body {
|
||||
chan close $f
|
||||
} -result "abcd\ndef\rfgh"
|
||||
test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} -body {
|
||||
# (src >= srcMax)
|
||||
# (src >= srcMax)
|
||||
set f [open $path(test1) w]
|
||||
chan configure $f -translation lf
|
||||
chan puts -nonewline $f "abcd\r\ndef\nfgh"
|
||||
@@ -1515,7 +1512,7 @@ test chan-io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} -body {
|
||||
chan close $f
|
||||
} -result "abcd\ndef"
|
||||
test chan-io-13.10 {TranslateInputEOL: auto mode: \n} -body {
|
||||
# not (*src == '\r')
|
||||
# not (*src == '\r')
|
||||
set f [open $path(test1) w]
|
||||
chan configure $f -translation lf
|
||||
chan puts -nonewline $f "abcd\ndef"
|
||||
@@ -1884,7 +1881,7 @@ test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -bod
|
||||
} -result {{{} {}} {auto lf}}
|
||||
test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup {
|
||||
set path(stdout) [makeFile {} stdout]
|
||||
} -constraints {stdio openpipe} -body {
|
||||
} -constraints {stdio openpipe knownMsvcBug} -body {
|
||||
set f [open $path(script) w]
|
||||
chan puts -nonewline $f {
|
||||
chan close stdout
|
||||
@@ -2028,7 +2025,7 @@ test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} -setup {
|
||||
test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup {
|
||||
file delete $path(test1)
|
||||
set l ""
|
||||
} -constraints {unixOrPc} -body {
|
||||
} -constraints {unixOrWin} -body {
|
||||
set f [open $path(test1) w]
|
||||
chan configure $f -translation lf -buffersize 60 -eofchar {}
|
||||
lappend l [file size $path(test1)]
|
||||
@@ -2794,7 +2791,7 @@ test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} -s
|
||||
chan puts $s $l
|
||||
}
|
||||
}
|
||||
} -constraints {socket tempNotMac fileevent} -body {
|
||||
} -constraints {socket tempNotMac fileevent knownMsvcBug} -body {
|
||||
proc accept {s a p} {
|
||||
variable x
|
||||
chan event $s readable [namespace code [list readit $s]]
|
||||
@@ -2820,7 +2817,7 @@ test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} -s
|
||||
chan close $cs
|
||||
chan close $ss
|
||||
vwait [namespace which -variable x]
|
||||
return $c
|
||||
set c
|
||||
} -result 2000
|
||||
test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} -setup {
|
||||
catch {interp delete x}
|
||||
@@ -3901,7 +3898,7 @@ test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} -setup {
|
||||
}
|
||||
chan close $f
|
||||
set f [open $path(test1) r]
|
||||
chan configure $f -translation crlf
|
||||
chan configure $f -translation crlf
|
||||
while {[chan gets $f line] >= 0} {
|
||||
append c $line\n
|
||||
}
|
||||
@@ -5163,7 +5160,7 @@ test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup {
|
||||
file delete $path(test1)
|
||||
} -body {
|
||||
set f [open $path(test1) w]
|
||||
chan configure $f -encoding {}
|
||||
chan configure $f -encoding {}
|
||||
chan puts -nonewline $f \xe7\x89\xa6
|
||||
chan close $f
|
||||
set f [open $path(test1) r]
|
||||
@@ -5308,7 +5305,7 @@ test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or\
|
||||
test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\
|
||||
writable so we can't change -eofchar or -translation} -setup {
|
||||
set l [list]
|
||||
} -body {
|
||||
} -body {
|
||||
set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
|
||||
chan configure $sock -eofchar D -translation lf
|
||||
lappend l [chan configure $sock -eofchar] \
|
||||
@@ -5461,7 +5458,7 @@ test chan-io-40.13 {POSIX open access modes: WRONLY} -body {
|
||||
set x [list [catch {chan gets $f} msg] $msg]
|
||||
chan close $f
|
||||
lappend x [viewFile test3]
|
||||
} -match glob -result {1 {channel "*" wasn't opened for reading} abzzy}
|
||||
} -match glob -result {1 {channel "*" wasn't opened for reading} abzzy}
|
||||
test chan-io-40.14 {POSIX open access modes: RDWR} -match regexp -body {
|
||||
file delete $path(test3)
|
||||
open $path(test3) RDWR
|
||||
@@ -5866,6 +5863,8 @@ test chan-io-47.6 {file events on shared files, deleting file events} -setup {
|
||||
testfevent delete
|
||||
chan close $f
|
||||
} -result {{script 1} {}}
|
||||
unset path(foo)
|
||||
removeFile foo
|
||||
|
||||
set path(bar) [makeFile {} bar]
|
||||
|
||||
@@ -5961,6 +5960,9 @@ test chan-io-48.3 {testing readability conditions} -setup {
|
||||
} -cleanup {
|
||||
chan close $f
|
||||
} -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
|
||||
unset path(bar)
|
||||
removeFile bar
|
||||
|
||||
test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup {
|
||||
file delete $path(test1)
|
||||
set c 0
|
||||
@@ -7031,7 +7033,7 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se
|
||||
vwait ::forever
|
||||
catch {after cancel $token}
|
||||
# Report
|
||||
return $::RES
|
||||
set ::RES
|
||||
} -cleanup {
|
||||
chan close $f
|
||||
chan close $g
|
||||
@@ -7231,7 +7233,7 @@ test chan-io-54.1 {Recursive channel events} {socket fileevent} {
|
||||
for {set i 0} {$i < 10} {incr i} {
|
||||
if {![catch {
|
||||
set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]
|
||||
}]} then {
|
||||
}]} {
|
||||
set done 1
|
||||
break
|
||||
}
|
||||
@@ -7303,7 +7305,7 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} -setup {
|
||||
chan close $writer
|
||||
chan close $s
|
||||
after cancel $after
|
||||
return $counter
|
||||
set counter
|
||||
} -cleanup {
|
||||
if {$accept ne {}} {chan close $accept}
|
||||
} -result 1
|
||||
@@ -7330,7 +7332,7 @@ test chan-io-55.1 {ChannelEventScriptInvoker: deletion} -constraints {
|
||||
chan event $f writable [namespace code [list eventScript $f]]
|
||||
variable x not_done
|
||||
vwait [namespace which -variable x]
|
||||
return $x
|
||||
set x
|
||||
} -cleanup {
|
||||
interp bgerror {} $handler
|
||||
} -result {got_error}
|
||||
@@ -7375,7 +7377,7 @@ test chan-io-57.1 {buffered data and file events, gets} -setup {
|
||||
vwait [namespace which -variable result]
|
||||
lappend result [chan gets $s2]
|
||||
vwait [namespace which -variable result]
|
||||
return $result
|
||||
set result
|
||||
} -cleanup {
|
||||
chan close $s
|
||||
chan close $s2
|
||||
@@ -7400,14 +7402,14 @@ test chan-io-57.2 {buffered data and file events, read} -setup {
|
||||
vwait [namespace which -variable result]
|
||||
lappend result [chan read $s2 9]
|
||||
vwait [namespace which -variable result]
|
||||
return $result
|
||||
set result
|
||||
} -cleanup {
|
||||
chan close $s
|
||||
chan close $s2
|
||||
chan close $server
|
||||
} -result {1 readable 234567890 timer}
|
||||
|
||||
test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} {
|
||||
test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin openpipe fileevent} {
|
||||
set out [open $path(script) w]
|
||||
chan puts $out {
|
||||
chan puts "normal message from pipe"
|
||||
@@ -7448,6 +7450,7 @@ test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} {
|
||||
test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} {
|
||||
# This test will hang in older revisions of the core.
|
||||
set out [open $path(script) w]
|
||||
chan puts $out "catch {load $::tcltestlib Tcltest}"
|
||||
chan puts $out {
|
||||
chan puts [testbytestring \xe2]
|
||||
exit 1
|
||||
|
||||
102
tests/clock.test
102
tests/clock.test
@@ -250,6 +250,18 @@ proc ::testClock::registry { cmd path key } {
|
||||
return [dict get $reg $path $key]
|
||||
}
|
||||
|
||||
proc timeWithinDuration {duration start end} {
|
||||
regexp {([\d.]+)(s|ms|us)} $duration -> duration unit
|
||||
if {[llength $start] > 1} { set start [expr "([join $start +])/[llength $start]"] }
|
||||
if {[llength $end] > 1} { set end [expr "([join $end +])/[llength $end]"] }
|
||||
set delta [expr {$end - $start}]
|
||||
expr {
|
||||
($delta > 0) && ($delta <= $duration) ?
|
||||
"ok" :
|
||||
"test should have taken 0-$duration $unit, actually took $delta"}
|
||||
}
|
||||
|
||||
|
||||
# Test some of the basics of [clock format]
|
||||
|
||||
test clock-1.0 "clock format - wrong # args" {
|
||||
@@ -35425,7 +35437,7 @@ test clock-33.2 {clock clicks tests} {
|
||||
set start [clock clicks]
|
||||
after 10
|
||||
set end [clock clicks]
|
||||
expr "$end > $start"
|
||||
expr {$end > $start}
|
||||
} {1}
|
||||
test clock-33.3 {clock clicks tests} {
|
||||
list [catch {clock clicks foo} msg] $msg
|
||||
@@ -35439,28 +35451,22 @@ test clock-33.4a {clock milliseconds} {
|
||||
concat {}
|
||||
} {}
|
||||
test clock-33.5 {clock clicks tests, millisecond timing test} {
|
||||
# This test can fail on a system that is so heavily loaded that
|
||||
# the test takes >60 ms to run.
|
||||
set start [clock clicks -milli]
|
||||
after 10
|
||||
set end [clock clicks -milli]
|
||||
# 60 msecs seems to be the max time slice under Windows 95/98
|
||||
expr {
|
||||
($end > $start) && (($end - $start) <= 60) ?
|
||||
"ok" :
|
||||
"test should have taken 0-60 ms, actually took [expr $end - $start]"}
|
||||
set start [set end {}]
|
||||
lassign [time {
|
||||
lappend start [clock clicks -milli]
|
||||
after 1 {lappend end [clock clicks -milli]}
|
||||
vwait end
|
||||
} 5] tm
|
||||
timeWithinDuration [expr {int($tm/1000 + 1)}]ms $start $end
|
||||
} {ok}
|
||||
test clock-33.5a {clock tests, millisecond timing test} {
|
||||
# This test can fail on a system that is so heavily loaded that
|
||||
# the test takes >60 ms to run.
|
||||
set start [clock milliseconds]
|
||||
after 10
|
||||
set end [clock milliseconds]
|
||||
# 60 msecs seems to be the max time slice under Windows 95/98
|
||||
expr {
|
||||
($end > $start) && (($end - $start) <= 60) ?
|
||||
"ok" :
|
||||
"test should have taken 0-60 ms, actually took [expr $end - $start]"}
|
||||
set start [set end {}]
|
||||
lassign [time {
|
||||
lappend start [clock milliseconds]
|
||||
after 1 {lappend end [clock milliseconds]}
|
||||
vwait end
|
||||
} 5] tm
|
||||
timeWithinDuration [expr {int($tm/1000 + 1)}]ms $start $end
|
||||
} {ok}
|
||||
test clock-33.6 {clock clicks, milli with too much abbreviation} {
|
||||
list [catch { clock clicks ? } msg] $msg
|
||||
@@ -35470,21 +35476,23 @@ test clock-33.7 {clock clicks, milli with too much abbreviation} {
|
||||
} {1 {ambiguous option "-": must be -milliseconds or -microseconds}}
|
||||
|
||||
test clock-33.8 {clock clicks test, microsecond timing test} {
|
||||
# This test can fail on a system that is so heavily loaded that
|
||||
# the test takes >60 ms to run.
|
||||
set start [clock clicks -micro]
|
||||
after 10
|
||||
set end [clock clicks -micro]
|
||||
expr {($end > $start) && (($end - $start) <= 60000)}
|
||||
} {1}
|
||||
set start [set end {}]
|
||||
lassign [time {
|
||||
lappend start [clock clicks -micro]
|
||||
after 1 {lappend end [clock clicks -micro]}
|
||||
vwait end
|
||||
} 5] tm
|
||||
timeWithinDuration [expr {int($tm + 10)}]us $start $end
|
||||
} {ok}
|
||||
test clock-33.8a {clock test, microsecond timing test} {
|
||||
# This test can fail on a system that is so heavily loaded that
|
||||
# the test takes >60 ms to run.
|
||||
set start [clock microseconds]
|
||||
after 10
|
||||
set end [clock microseconds]
|
||||
expr {($end > $start) && (($end - $start) <= 60000)}
|
||||
} {1}
|
||||
set start [set end {}]
|
||||
lassign [time {
|
||||
lappend start [clock microseconds]
|
||||
after 1 {lappend end [clock microseconds]}
|
||||
vwait end
|
||||
} 5] tm
|
||||
timeWithinDuration [expr {int($tm + 10)}]us $start $end
|
||||
} {ok}
|
||||
|
||||
test clock-33.9 {clock clicks test, millis align with seconds} {
|
||||
set t1 [clock seconds]
|
||||
@@ -35826,7 +35834,7 @@ test clock-35.3 {clock seconds tests} {
|
||||
set start [clock seconds]
|
||||
after 2000
|
||||
set end [clock seconds]
|
||||
expr "$end > $start"
|
||||
expr {$end > $start}
|
||||
} {1}
|
||||
|
||||
|
||||
@@ -36699,16 +36707,18 @@ test clock-58.1 {clock l10n - Japanese localisation} {*}{
|
||||
}
|
||||
-body {
|
||||
set trouble {}
|
||||
foreach {date jdate} [list \
|
||||
1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 \
|
||||
1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 \
|
||||
1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 \
|
||||
1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 \
|
||||
1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 \
|
||||
1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 \
|
||||
1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 \
|
||||
1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 \
|
||||
] {
|
||||
foreach {date jdate} {
|
||||
1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5
|
||||
1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5
|
||||
1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5
|
||||
1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5
|
||||
1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5
|
||||
1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5
|
||||
1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5
|
||||
1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5
|
||||
2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5
|
||||
2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5
|
||||
} {
|
||||
set status [catch {
|
||||
set secs [clock scan $date \
|
||||
-timezone +0900 \
|
||||
|
||||
@@ -21,9 +21,13 @@ catch [list package require -exact Tcltest [info patchlevel]]
|
||||
testConstraint testchmod [llength [info commands testchmod]]
|
||||
testConstraint testsetplatform [llength [info commands testsetplatform]]
|
||||
testConstraint testvolumetype [llength [info commands testvolumetype]]
|
||||
testConstraint time64bit [expr {
|
||||
$::tcl_platform(pointerSize) >= 8 ||
|
||||
[llength [info command testsize]] && [testsize st_mtime] >= 8
|
||||
}]
|
||||
testConstraint linkDirectory [expr {
|
||||
![testConstraint win] ||
|
||||
([string index $tcl_platform(osVersion) 0] >= 5
|
||||
($::tcl_platform(osVersion) >= 5.0
|
||||
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
|
||||
}]
|
||||
|
||||
@@ -566,6 +570,13 @@ test cmdAH-9.51 {Tcl_FileObjCmd: tail} testsetplatform {
|
||||
testsetplatform windows
|
||||
file tail {foo\bar}
|
||||
} bar
|
||||
test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} {
|
||||
list \
|
||||
[file tail {~/~foo}] \
|
||||
[file tail {~/test/~foo}] \
|
||||
[file tail [file normalize {~/~foo}]] \
|
||||
[file tail [file normalize {~/test/~foo}]]
|
||||
} [lrepeat 4 ./~foo]
|
||||
|
||||
# rootname
|
||||
test cmdAH-10.1 {Tcl_FileObjCmd: rootname} -returnCodes error -body {
|
||||
@@ -881,7 +892,7 @@ test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} {
|
||||
file exe $gorpfile
|
||||
} 1
|
||||
test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body {
|
||||
# On pc, must be a .exe, .com, etc.
|
||||
# On windows, must be a .exe, .com, etc.
|
||||
set x {}
|
||||
set gorpexes {}
|
||||
foreach ext {exe com cmd bat} {
|
||||
@@ -1040,7 +1051,7 @@ test cmdAH-20.7.1 {
|
||||
Tcl_FileObjCmd: atime (built-in Windows names with dir path and extension)
|
||||
} -constraints {win} -body {
|
||||
file atime [file join [temporaryDirectory] CON.txt]
|
||||
} -result "could not get access time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error
|
||||
} -match regexp -result {could not (?:get access time|read)} -returnCodes error
|
||||
|
||||
if {[testConstraint unix] && [file exists /tmp]} {
|
||||
removeFile touch.me /tmp
|
||||
@@ -1281,14 +1292,50 @@ test cmdAH-24.14.1 {
|
||||
Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension)
|
||||
} -constraints {win} -body {
|
||||
file mtime [file join [temporaryDirectory] CON.txt]
|
||||
} -result "could not get modification time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error
|
||||
} -match regexp -result {could not (?:get modification time|read)} -returnCodes error
|
||||
|
||||
# 3155760000 is 64-bit unix time, Wed Jan 01 00:00:00 GMT 2070:
|
||||
test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup {
|
||||
set filename [makeFile "" foo.text]
|
||||
} -body {
|
||||
list [file atime $filename 3155760000] [file atime $filename]
|
||||
} -cleanup {
|
||||
removeFile $filename
|
||||
} -result {3155760000 3155760000}
|
||||
test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup {
|
||||
set filename [makeFile "" foo.text]
|
||||
} -body {
|
||||
list [file mtime $filename 3155760000] [file mtime $filename]
|
||||
} -cleanup {
|
||||
file delete -force $filename
|
||||
} -result {3155760000 3155760000}
|
||||
|
||||
# owned
|
||||
test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body {
|
||||
file owned a b
|
||||
} -result {wrong # args: should be "file owned name"}
|
||||
test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -body {
|
||||
file owned $gorpfile
|
||||
test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -setup {
|
||||
set fn $gorpfile
|
||||
# prefer temp file to check owner (try to avoid bug [7de2d722bd]):
|
||||
if {
|
||||
[info exists ::env(TEMP)] && [file isdirectory $::env(TEMP)] &&
|
||||
[file dirname $fn] ne [file normalize $::env(TEMP)]
|
||||
} {
|
||||
set fn [file join $::env(TEMP)/test-owner-from-tcl.txt]
|
||||
set fn [makeFile "data" test-owner-from-tcl.txt $::env(TEMP)]
|
||||
}
|
||||
# be sure we have really owned this file before trying to check that
|
||||
# (avoid dependency on admin with UAC and the setting "System objects:
|
||||
# Default owner for objects created by members of the Administrators group"):
|
||||
catch {
|
||||
exec takeown /F [file nativename $fn]
|
||||
}
|
||||
} -body {
|
||||
file owned $fn
|
||||
} -cleanup {
|
||||
if {$fn ne $gorpfile} {
|
||||
removeFile $fn
|
||||
}
|
||||
} -result 1
|
||||
test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup {
|
||||
# Avoid problems with AFS
|
||||
@@ -1302,7 +1349,11 @@ test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} {
|
||||
file owned /
|
||||
} 0
|
||||
test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints win -body {
|
||||
file owned $env(windir)
|
||||
if {[info exists env(SystemRoot)]} {
|
||||
file owned $env(SystemRoot)
|
||||
} else {
|
||||
file owned $env(windir)
|
||||
}
|
||||
} -result 0
|
||||
test cmdAH-25.4 {Tcl_FileObjCmd: owned} -body {
|
||||
file owned nosuchfile
|
||||
@@ -1345,7 +1396,12 @@ test cmdAH-27.4 {
|
||||
test cmdAH-27.4.1 {
|
||||
Tcl_FileObjCmd: size (built-in Windows names with dir path and extension)
|
||||
} -constraints {win} -body {
|
||||
file size [file join [temporaryDirectory] con.txt]
|
||||
try {
|
||||
set res [file size [file join [temporaryDirectory] con.txt]]
|
||||
} trap {POSIX ENOENT} {} {
|
||||
set res 0
|
||||
}
|
||||
set res
|
||||
} -result 0
|
||||
|
||||
catch {testsetplatform $platform}
|
||||
@@ -1447,8 +1503,13 @@ test cmdAH-28.13 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {w
|
||||
test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup {
|
||||
unset -nocomplain stat
|
||||
} -body {
|
||||
file stat [file join [temporaryDirectory] CON.txt] stat
|
||||
lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)}
|
||||
try {
|
||||
file stat [file join [temporaryDirectory] CON.txt] stat
|
||||
set res [lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)}]
|
||||
} trap {POSIX ENOENT} {} {
|
||||
set res {0 0 -1 0 0 8630 0 0 0 characterSpecial 0}
|
||||
}
|
||||
set res
|
||||
} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0}
|
||||
unset -nocomplain stat
|
||||
|
||||
@@ -1498,7 +1559,12 @@ test cmdAH-29.6 {
|
||||
test cmdAH-29.6.1 {
|
||||
Tcl_FileObjCmd: type (built-in Windows names, with dir path and extension)
|
||||
} -constraints {win} -body {
|
||||
file type [file join [temporaryDirectory] CON.txt]
|
||||
try {
|
||||
set res [file type [file join [temporaryDirectory] CON.txt]]
|
||||
} trap {POSIX ENOENT} {} {
|
||||
set res {characterSpecial}
|
||||
}
|
||||
set res
|
||||
} -result "characterSpecial"
|
||||
|
||||
# Error conditions
|
||||
|
||||
@@ -147,6 +147,12 @@ test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} {
|
||||
{{b i g} 12345} {{d e m o} 34512}
|
||||
}
|
||||
} {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}}
|
||||
test cmdIL-1.41 {lsort -stride and -index} -body {
|
||||
lsort -stride 2 -index -2 {a 2 b 1}
|
||||
} -returnCodes error -result {index "-2" cannot select an element from any list}
|
||||
test cmdIL-1.42 {lsort -stride and-index} -body {
|
||||
lsort -stride 2 -index -1-1 {a 2 b 1}
|
||||
} -returnCodes error -result {index "-1-1" cannot select an element from any list}
|
||||
|
||||
# Can't think of any good tests for the MergeSort and MergeLists procedures,
|
||||
# except a bunch of random lists to sort.
|
||||
@@ -203,6 +209,33 @@ test cmdIL-3.4.1 {SortCompare procedure, -index option} -body {
|
||||
test cmdIL-3.5 {SortCompare procedure, -index option} -body {
|
||||
lsort -integer -index 2 {{20 10 13} {15}}
|
||||
} -returnCodes error -result {element 2 missing from sublist "15"}
|
||||
test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated index)} -body {
|
||||
lsort -index 1+3 {{1 . c} {2 . b} {3 . a}}
|
||||
} -returnCodes error -result {element 4 missing from sublist "1 . c"}
|
||||
test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body {
|
||||
lsort -index -1-1 {{1 . c} {2 . b} {3 . a}}
|
||||
} -returnCodes error -result {index "-1-1" cannot select an element from any list}
|
||||
test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body {
|
||||
lsort -index -2 {{1 . c} {2 . b} {3 . a}}
|
||||
} -returnCodes error -result {index "-2" cannot select an element from any list}
|
||||
test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body {
|
||||
lsort -index end-4 {{1 . c} {2 . b} {3 . a}}
|
||||
} -returnCodes error -result {element -2 missing from sublist "1 . c"}
|
||||
test cmdIL-3.5.5 {SortCompare procedure, -index option} {
|
||||
lsort -index {} {a b}
|
||||
} {a b}
|
||||
test cmdIL-3.5.6 {SortCompare procedure, -index option} {
|
||||
lsort -index {} [list a \{]
|
||||
} {a \{}
|
||||
test cmdIL-3.5.7 {SortCompare procedure, -index option (out of range, calculated index)} -body {
|
||||
lsort -index end--1 {{1 . c} {2 . b} {3 . a}}
|
||||
} -returnCodes error -result {index "end--1" cannot select an element from any list}
|
||||
test cmdIL-3.5.8 {SortCompare procedure, -index option (out of range, calculated index)} -body {
|
||||
lsort -index end+1 {{1 . c} {2 . b} {3 . a}}
|
||||
} -returnCodes error -result {index "end+1" cannot select an element from any list}
|
||||
test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body {
|
||||
lsort -index end+2 {{1 . c} {2 . b} {3 . a}}
|
||||
} -returnCodes error -result {index "end+2" cannot select an element from any list}
|
||||
test cmdIL-3.6 {SortCompare procedure, -index option} {
|
||||
lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}}
|
||||
} {{3 25 20} {2 5 25} {1 15 30}}
|
||||
|
||||
151
tests/cmdMZ.test
151
tests/cmdMZ.test
@@ -22,8 +22,13 @@ namespace eval ::tcl::test::cmdMZ {
|
||||
namespace import ::tcltest::makeFile
|
||||
namespace import ::tcltest::removeFile
|
||||
namespace import ::tcltest::temporaryDirectory
|
||||
namespace import ::tcltest::testConstraint
|
||||
namespace import ::tcltest::test
|
||||
|
||||
if {[namespace which -command ::tcl::unsupported::timerate] ne ""} {
|
||||
namespace import ::tcl::unsupported::timerate
|
||||
}
|
||||
|
||||
proc ListGlobMatch {expected actual} {
|
||||
if {[llength $expected] != [llength $actual]} {
|
||||
return 0
|
||||
@@ -227,12 +232,12 @@ foreach {testid script} {
|
||||
# More tests of Tcl_SourceObjCmd are in source.test
|
||||
|
||||
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints {
|
||||
unixOrPc
|
||||
unixOrWin
|
||||
} -returnCodes error -body {
|
||||
source
|
||||
} -match glob -result {wrong # args: should be "source*fileName"}
|
||||
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints {
|
||||
unixOrPc
|
||||
unixOrWin
|
||||
} -returnCodes error -body {
|
||||
source a b
|
||||
} -match glob -result {wrong # args: should be "source*fileName"}
|
||||
@@ -316,6 +321,18 @@ test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} {
|
||||
# The tests for Tcl_SubstObjCmd are in subst.test
|
||||
# The tests for Tcl_SwitchObjCmd are in switch.test
|
||||
|
||||
# todo: rewrite this if monotonic clock is provided resp. command "after"
|
||||
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
|
||||
proc _nrt_sleep {msec} {
|
||||
set usec [expr {$msec * 1000}]
|
||||
set stime [clock microseconds]
|
||||
while {abs([clock microseconds] - $stime) < $usec} {
|
||||
# don't use after 0 unless it's NRT-capable, so yes - busy-wait (but it's more precise):
|
||||
# after 0
|
||||
}
|
||||
}
|
||||
_nrt_sleep 0; # warm up (clock, compile, etc)
|
||||
|
||||
test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body {
|
||||
time
|
||||
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
|
||||
@@ -331,9 +348,13 @@ test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts}
|
||||
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body {
|
||||
time {format 1}
|
||||
} -match regexp -result {^\d+ microseconds per iteration}
|
||||
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
|
||||
expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]}
|
||||
} 1
|
||||
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} -body {
|
||||
set m1 [lindex [time {_nrt_sleep 0.01}] 0]
|
||||
set m2 [lindex [time {_nrt_sleep 10.0}] 0]
|
||||
list \
|
||||
[expr {$m1 < $m2}] \
|
||||
$m1 $m2; # interesting only in error case.
|
||||
} -match glob -result [list 1 *]
|
||||
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
|
||||
list [catch {time {error foo}} msg] $msg $::errorInfo
|
||||
} {1 foo {foo
|
||||
@@ -341,6 +362,126 @@ test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
|
||||
"error foo"
|
||||
invoked from within
|
||||
"time {error foo}"}}
|
||||
test cmdMZ-5.7.1 {Tcl_TimeObjCmd: return from time} {
|
||||
set x 0
|
||||
proc r1 {} {upvar x x; time {incr x; return "r1"; incr x} 10}
|
||||
list [r1] $x
|
||||
} {r1 1}
|
||||
test cmdMZ-5.8 {Tcl_TimeObjCmd: done optimization: nested call of self inside time (if compiled)} {
|
||||
set x [set y 0]
|
||||
set m1 {
|
||||
if {[incr x] <= 5} {
|
||||
# nested call should return result, so covering that:
|
||||
if {![string is integer -strict [eval $m1]]} {error unexpected}
|
||||
}
|
||||
# increase again (no "continue" from nested call):
|
||||
incr x
|
||||
}
|
||||
time {incr y; eval $m1} 5
|
||||
list $y $x
|
||||
} {5 20}
|
||||
|
||||
test cmdMZ-6.1 {Tcl_TimeRateObjCmd: basic format of command} {
|
||||
list [catch {timerate} msg] $msg
|
||||
} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}}
|
||||
test cmdMZ-6.2.1 {Tcl_TimeRateObjCmd: basic format of command} {
|
||||
list [catch {timerate a b c d} msg] $msg
|
||||
} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}}
|
||||
test cmdMZ-6.2.2 {Tcl_TimeRateObjCmd: basic format of command} {
|
||||
list [catch {timerate a b c} msg] $msg
|
||||
} {1 {expected integer but got "b"}}
|
||||
test cmdMZ-6.2.3 {Tcl_TimeRateObjCmd: basic format of command} {
|
||||
list [catch {timerate a b} msg] $msg
|
||||
} {1 {expected integer but got "b"}}
|
||||
test cmdMZ-6.3 {Tcl_TimeRateObjCmd: basic format of command} {
|
||||
list [catch {timerate -overhead b {} a b} msg] $msg
|
||||
} {1 {expected floating-point number but got "b"}}
|
||||
test cmdMZ-6.4 {Tcl_TimeRateObjCmd: compile of script happens even with negative iteration counts} {
|
||||
list [catch {timerate "foreach a {c d e} \{" -12456} msg] $msg
|
||||
} {1 {missing close-brace}}
|
||||
test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
|
||||
regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0]
|
||||
} 1
|
||||
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
|
||||
regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0]
|
||||
} 1
|
||||
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} -body {
|
||||
set m1 [timerate {_nrt_sleep 0.01} 50]
|
||||
set m2 [timerate {_nrt_sleep 1.00} 50]
|
||||
list [list \
|
||||
[expr {[lindex $m1 0] < [lindex $m2 0]}] \
|
||||
[expr {[lindex $m1 0] < 100}] \
|
||||
[expr {[lindex $m2 0] > 100}] \
|
||||
[expr {[lindex $m1 2] > 500}] \
|
||||
[expr {[lindex $m2 2] < 500}] \
|
||||
[expr {[lindex $m1 4] > 10000}] \
|
||||
[expr {[lindex $m2 4] < 10000}] \
|
||||
[expr {[lindex $m1 6] > 5 && [lindex $m1 6] < 100}] \
|
||||
[expr {[lindex $m2 6] > 5 && [lindex $m2 6] < 100}] \
|
||||
] $m1 $m2; # interesting only in error case.
|
||||
} -match glob -result [list [lrepeat 9 1] *]
|
||||
test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} {
|
||||
list [catch {timerate {error foo} 1} msg] $msg $::errorInfo
|
||||
} {1 foo {foo
|
||||
while executing
|
||||
"error foo"
|
||||
invoked from within
|
||||
"timerate {error foo} 1"}}
|
||||
test cmdMZ-6.7.1 {Tcl_TimeRateObjCmd: return from timerate} {
|
||||
set x 0
|
||||
proc r1 {} {upvar x x; timerate {incr x; return "r1"; incr x} 1000 10}
|
||||
list [r1] $x
|
||||
} {r1 1}
|
||||
test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} -body {
|
||||
set m1 [timerate {break}]
|
||||
list [list \
|
||||
[expr {[lindex $m1 0] < 1000}] \
|
||||
[expr {[lindex $m1 2] == 1}] \
|
||||
[expr {[lindex $m1 4] > 1000}] \
|
||||
[expr {[lindex $m1 6] < 10}] \
|
||||
] $m1; # interesting only in error case.
|
||||
} -match glob -result [list {1 1 1 1} *]
|
||||
test cmdMZ-6.8.1 {Tcl_TimeRateObjCmd: allow (conditional) continue in timerate} -body {
|
||||
set m1 [timerate {continue; return -code error "unexpected"} 1000 10]
|
||||
list [list \
|
||||
[expr {[lindex $m1 0] < 1000}] \
|
||||
[expr {[lindex $m1 2] == 10}] \
|
||||
[expr {[lindex $m1 4] > 1000}] \
|
||||
[expr {[lindex $m1 6] < 100}] \
|
||||
] $m1; # interesting only in error case.
|
||||
} -match glob -result [list {1 1 1 1} *]
|
||||
test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} {
|
||||
set m1 [timerate {} 1000 5]; # max-count wins
|
||||
set m2 [timerate {_nrt_sleep 20} 1 5]; # max-time wins
|
||||
list [lindex $m1 2] [lindex $m2 2]
|
||||
} {5 1}
|
||||
test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} -body {
|
||||
set m1 [timerate -overhead 1e6 {_nrt_sleep 10} 100 1]
|
||||
list [list \
|
||||
[expr {[lindex $m1 0] == 0.0}] \
|
||||
[expr {[lindex $m1 2] == 1}] \
|
||||
[expr {[lindex $m1 4] == 1000000}] \
|
||||
[expr {[lindex $m1 6] <= 0.001}] \
|
||||
] $m1; # interesting only in error case.
|
||||
} -match glob -result [list {1 1 1 1} *]
|
||||
test cmdMZ-6.11 {Tcl_TimeRateObjCmd: done/continue optimization rollback} {
|
||||
set m1 {set m2 ok}
|
||||
if 1 $m1
|
||||
timerate $m1 1000 10
|
||||
if 1 $m1; # if rollback is missing throws an error: invoked "continue" outside of a loop
|
||||
} ok
|
||||
test cmdMZ-6.12 {Tcl_TimeRateObjCmd: done optimization: nested call of self inside timerate} {
|
||||
set x 0
|
||||
set m1 {
|
||||
if {[incr x] <= 5} {
|
||||
# nested call should return result, so covering that:
|
||||
if {![string is integer -strict [eval $m1]]} {error unexpected}
|
||||
}
|
||||
# increase again (no "continue" from nested call):
|
||||
incr x
|
||||
}
|
||||
list [lindex [timerate $m1 1000 5] 2] $x
|
||||
} {5 20}
|
||||
|
||||
# The tests for Tcl_WhileObjCmd are in while.test
|
||||
|
||||
|
||||
@@ -466,6 +466,67 @@ test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
|
||||
list [catch {exec [interpreter] << $script} msg] $msg
|
||||
} {0 OK}
|
||||
|
||||
# Tests of nested compile (body in body compilation), should not generate stack overflow
|
||||
# (with abnormal program termination), bug [fec0c17d39]:
|
||||
proc _ti_gencode {} {
|
||||
# creates test interpreter on demand with [gencode] generator:
|
||||
if {[interp exists ti]} {
|
||||
return
|
||||
}
|
||||
interp create ti
|
||||
ti eval {proc gencode {nr {cmd eval} {nl 0}} {
|
||||
set code ""
|
||||
set e ""; if {$nl} {set e "\n"}
|
||||
for {set i 0} {$i < $nr} {incr i} {
|
||||
append code "$cmd \{$e"
|
||||
}
|
||||
append code "lappend result 1$e"
|
||||
for {set i 0} {$i < $nr} {incr i} {
|
||||
append code "\}$e"
|
||||
}
|
||||
#puts [format "%% %.40s ... %d bytes" $code [string length $code]]
|
||||
return $code
|
||||
}}
|
||||
}
|
||||
test compile-13.2 {TclCompileScript: testing expected nested scripts compilation} -setup {
|
||||
_ti_gencode
|
||||
interp recursionlimit ti [expr {10000+50}]
|
||||
ti eval {set result {}}
|
||||
} -body {
|
||||
# Test different compilation variants (instructions evalStk, invokeStk, etc),
|
||||
# with 1500 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack
|
||||
# boxes or systems, please don't decrease it (either provide a constraint)
|
||||
ti eval {foreach cmd {eval "if 1" try catch} {
|
||||
set c [gencode [expr {![::tcl::pkgconfig get debug] ? 1500 : 1000}] $cmd]
|
||||
if 1 $c
|
||||
}}
|
||||
ti eval {set result}
|
||||
} -result {1 1 1 1}
|
||||
test compile-13.3 {TclCompileScript: testing check of max depth by nested scripts compilation} -setup {
|
||||
_ti_gencode
|
||||
interp recursionlimit ti 100
|
||||
ti eval {set result {}}
|
||||
} -body {
|
||||
# Test different compilation variants (instructions evalStk, invokeStk, etc),
|
||||
# with 500 nested scripts (bodies). It must generate "too many nested compilations"
|
||||
# error for any variant we're testing here:
|
||||
ti eval {foreach cmd {eval "if 1" try catch} {
|
||||
set c [gencode 500 $cmd]
|
||||
lappend errors [catch $c e] $e
|
||||
}}
|
||||
#puts $errors
|
||||
# all of nested calls exceed the limit, so must end with "too many nested compilations"
|
||||
# (or evaluations, depending on compile method/instruction and "mixed" compile within
|
||||
# evaliation), so no one succeeds, the result must be empty:
|
||||
ti eval {set result}
|
||||
} -result {}
|
||||
#
|
||||
# clean up:
|
||||
if {[interp exists ti]} {
|
||||
interp delete ti
|
||||
}
|
||||
rename _ti_gencode {}
|
||||
|
||||
# Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342]
|
||||
test compile-14.1 {testing errors in element name; segfault?} {} {
|
||||
catch {set a([error])} msg1
|
||||
|
||||
@@ -626,19 +626,31 @@ test coroutine-7.5 {return codes} {
|
||||
}
|
||||
set result
|
||||
} {0 1 2 3 4 5}
|
||||
test coroutine-7.6 {Early yield crashes} {
|
||||
proc foo args {}
|
||||
trace add execution foo enter {catch yield}
|
||||
coroutine demo foo
|
||||
rename foo {}
|
||||
} {}
|
||||
test coroutine-7.7 {Bug 2486550} -setup {
|
||||
interp hide {} yield
|
||||
test coroutine-7.6 {Early yield crashes} -setup {
|
||||
set i [interp create]
|
||||
} -body {
|
||||
coroutine demo interp invokehidden {} yield ok
|
||||
# Force into a child interpreter [bug 60559fd4a6]
|
||||
$i eval {
|
||||
proc foo args {}
|
||||
trace add execution foo enter {catch yield}
|
||||
coroutine demo foo
|
||||
rename foo {}
|
||||
return ok
|
||||
}
|
||||
} -cleanup {
|
||||
demo
|
||||
interp expose {} yield
|
||||
interp delete $i
|
||||
} -result ok
|
||||
test coroutine-7.7 {Bug 2486550} -setup {
|
||||
set i [interp create]
|
||||
$i hide yield
|
||||
} -body {
|
||||
# Force into a child interpreter [bug 60559fd4a6]
|
||||
$i eval {
|
||||
coroutine demo interp invokehidden {} yield ok
|
||||
}
|
||||
} -cleanup {
|
||||
$i eval demo
|
||||
interp delete $i
|
||||
} -result ok
|
||||
test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup {
|
||||
namespace eval cotest {}
|
||||
@@ -739,6 +751,8 @@ test coroutine-7.12 {coro floor above street level #3008307} -body {
|
||||
}
|
||||
boom ; # does not crash: the coro floor is a good insulator
|
||||
list
|
||||
} -cleanup {
|
||||
rename boom {}; rename cc {}; rename c {}
|
||||
} -result {}
|
||||
|
||||
test coroutine-8.0.0 {coro inject executed} -body {
|
||||
@@ -779,7 +793,80 @@ test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body {
|
||||
set result
|
||||
} -result {inject-executed}
|
||||
|
||||
test coroutine-9.1 {coro type} {
|
||||
coroutine demo eval {
|
||||
yield
|
||||
yield "PHASE 1"
|
||||
yieldto string cat "PHASE 2"
|
||||
::tcl::unsupported::corotype [info coroutine]
|
||||
}
|
||||
list [demo] [::tcl::unsupported::corotype demo] \
|
||||
[demo] [::tcl::unsupported::corotype demo] [demo]
|
||||
} {{PHASE 1} yield {PHASE 2} yieldto active}
|
||||
test coroutine-9.2 {coro type} -setup {
|
||||
catch {rename nosuchcommand ""}
|
||||
} -returnCodes error -body {
|
||||
::tcl::unsupported::corotype nosuchcommand
|
||||
} -result {can only get coroutine type of a coroutine}
|
||||
test coroutine-9.3 {coro type} -returnCodes error -body {
|
||||
proc notacoroutine {} {}
|
||||
::tcl::unsupported::corotype notacoroutine
|
||||
} -returnCodes error -cleanup {
|
||||
rename notacoroutine {}
|
||||
} -result {can only get coroutine type of a coroutine}
|
||||
|
||||
test coroutine-10.1 {coroutine general introspection} -setup {
|
||||
set i [interp create]
|
||||
} -body {
|
||||
$i eval {
|
||||
# Make the introspection code
|
||||
namespace path tcl::unsupported
|
||||
proc probe {type var} {
|
||||
upvar 1 $var v
|
||||
set f [info frame]
|
||||
incr f -1
|
||||
set result [list $v [dict get [info frame $f] proc]]
|
||||
if {$type eq "yield"} {
|
||||
tailcall yield $result
|
||||
} else {
|
||||
tailcall yieldto string cat $result
|
||||
}
|
||||
}
|
||||
proc pokecoro {c var} {
|
||||
inject $c probe [corotype $c] $var
|
||||
$c
|
||||
}
|
||||
|
||||
# Coroutine implementations
|
||||
proc cbody1 {} {
|
||||
set val [info coroutine]
|
||||
set accum {}
|
||||
while {[set val [yield $val]] ne ""} {
|
||||
lappend accum $val
|
||||
set val ok
|
||||
}
|
||||
return $accum
|
||||
}
|
||||
proc cbody2 {} {
|
||||
set val [info coroutine]
|
||||
set accum {}
|
||||
while {[llength [set val [yieldto string cat $val]]]} {
|
||||
lappend accum {*}$val
|
||||
set val ok
|
||||
}
|
||||
return $accum
|
||||
}
|
||||
|
||||
# Make the coroutines
|
||||
coroutine c1 cbody1
|
||||
coroutine c2 cbody2
|
||||
list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \
|
||||
[c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \
|
||||
[c1] [c2]
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete $i
|
||||
} -result {ok ok {abc ::cbody1} {{1 2 3} ::cbody2} ok ok {{abc def} ::cbody1} {{1 2 3 4 5 6} ::cbody2} {abc def} {1 2 3 4 5 6}}
|
||||
|
||||
# cleanup
|
||||
unset lambda
|
||||
|
||||
@@ -328,6 +328,40 @@ test encoding-15.3 {UtfToUtfProc null character input} {
|
||||
binary scan [encoding convertto identity $y] H* z
|
||||
list [string bytelength $x] [string bytelength $y] $z
|
||||
} {1 2 c080}
|
||||
test encoding-15.4 {UtfToUtfProc emoji character input} {
|
||||
set x \xED\xA0\xBD\xED\xB8\x82
|
||||
set y [encoding convertfrom utf-8 \xED\xA0\xBD\xED\xB8\x82]
|
||||
list [string length $x] [string length $y] $y
|
||||
} "6 2 \uD83D\uDE02"
|
||||
test encoding-15.5 {UtfToUtfProc emoji character input} {
|
||||
set x \xF0\x9F\x98\x82
|
||||
set y [encoding convertfrom utf-8 \xF0\x9F\x98\x82]
|
||||
list [string length $x] [string length $y] $y
|
||||
} "4 2 \uD83D\uDE02"
|
||||
test encoding-15.6 {UtfToUtfProc emoji character output} {
|
||||
set x \uDE02\uD83D\uDE02\uD83D
|
||||
set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D]
|
||||
binary scan $y H* z
|
||||
list [string length $x] [string length $y] $z
|
||||
} {4 10 edb882f09f9882eda0bd}
|
||||
test encoding-15.7 {UtfToUtfProc emoji character output} {
|
||||
set x \uDE02\uD83D\uD83D
|
||||
set y [encoding convertto utf-8 \uDE02\uD83D\uD83D]
|
||||
binary scan $y H* z
|
||||
list [string length $x] [string length $y] $z
|
||||
} {3 9 edb882eda0bdeda0bd}
|
||||
test encoding-15.8 {UtfToUtfProc emoji character output} {
|
||||
set x \uDE02\uD83D\xE9
|
||||
set y [encoding convertto utf-8 \uDE02\uD83D\xE9]
|
||||
binary scan $y H* z
|
||||
list [string length $x] [string length $y] $z
|
||||
} {3 8 edb882eda0bdc3a9}
|
||||
test encoding-15.9 {UtfToUtfProc emoji character output} {
|
||||
set x \uDE02\uD83DX
|
||||
set y [encoding convertto utf-8 \uDE02\uD83DX]
|
||||
binary scan $y H* z
|
||||
list [string length $x] [string length $y] $z
|
||||
} {3 7 edb882eda0bd58}
|
||||
|
||||
test encoding-16.1 {UnicodeToUtfProc} {
|
||||
set val [encoding convertfrom unicode NN]
|
||||
|
||||
405
tests/env.test
405
tests/env.test
@@ -16,49 +16,96 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# Some tests require the "exec" command.
|
||||
# Skip them if exec is not defined.
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
|
||||
#
|
||||
# These tests will run on any platform (and indeed crashed on the Mac). So put
|
||||
# them before you test for the existance of exec.
|
||||
#
|
||||
test env-1.1 {propagation of env values to child interpreters} -setup {
|
||||
catch {interp delete child}
|
||||
catch {unset env(test)}
|
||||
} -body {
|
||||
interp create child
|
||||
set env(test) garbage
|
||||
child eval {set env(test)}
|
||||
} -cleanup {
|
||||
interp delete child
|
||||
unset env(test)
|
||||
} -result {garbage}
|
||||
#
|
||||
# This one crashed on Solaris under Tcl8.0, so we only want to make sure it
|
||||
# runs.
|
||||
#
|
||||
test env-1.2 {lappend to env value} -setup {
|
||||
catch {unset env(test)}
|
||||
} -body {
|
||||
set env(test) aaaaaaaaaaaaaaaa
|
||||
append env(test) bbbbbbbbbbbbbb
|
||||
unset env(test)
|
||||
}
|
||||
test env-1.3 {reflection of env by "array names"} -setup {
|
||||
catch {interp delete child}
|
||||
catch {unset env(test)}
|
||||
} -body {
|
||||
interp create child
|
||||
child eval {set env(test) garbage}
|
||||
expr {"test" in [array names env]}
|
||||
} -cleanup {
|
||||
interp delete child
|
||||
catch {unset env(test)}
|
||||
} -result {1}
|
||||
package require tcltests
|
||||
|
||||
set printenvScript [makeFile {
|
||||
# [exec] is required here to see the actual environment received by child
|
||||
# processes.
|
||||
proc getenv {} {
|
||||
global printenvScript
|
||||
catch {exec [interpreter] $printenvScript} out
|
||||
if {$out eq "child process exited abnormally"} {
|
||||
set out {}
|
||||
}
|
||||
return $out
|
||||
}
|
||||
|
||||
|
||||
proc envrestore {} {
|
||||
# Restore the environment variables at the end of the test.
|
||||
global env
|
||||
variable env2
|
||||
|
||||
foreach name [array names env] {
|
||||
unset env($name)
|
||||
}
|
||||
array set env $env2
|
||||
return
|
||||
}
|
||||
|
||||
|
||||
proc envprep {} {
|
||||
# Save the current environment variables at the start of the test.
|
||||
global env
|
||||
variable keep
|
||||
variable env2
|
||||
|
||||
set env2 [array get env]
|
||||
foreach name [array names env] {
|
||||
# Keep some environment variables that support operation of the tcltest
|
||||
# package.
|
||||
if {[string toupper $name] ni [string toupper $keep]} {
|
||||
unset env($name)
|
||||
}
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
|
||||
proc encodingrestore {} {
|
||||
variable sysenc
|
||||
encoding system $sysenc
|
||||
return
|
||||
}
|
||||
|
||||
|
||||
proc encodingswitch encoding {
|
||||
variable sysenc
|
||||
# Need to run [getenv] in known encoding, so save the current one here...
|
||||
set sysenc [encoding system]
|
||||
encoding system $encoding
|
||||
return
|
||||
}
|
||||
|
||||
|
||||
proc setup1 {} {
|
||||
global env
|
||||
envprep
|
||||
encodingswitch iso8859-1
|
||||
}
|
||||
|
||||
proc setup2 {} {
|
||||
global env
|
||||
setup1
|
||||
set env(NAME1) {test string}
|
||||
set env(NAME2) {new value}
|
||||
set env(XYZZY) {garbage}
|
||||
}
|
||||
|
||||
|
||||
proc cleanup1 {} {
|
||||
encodingrestore
|
||||
envrestore
|
||||
}
|
||||
|
||||
variable keep {
|
||||
TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
|
||||
SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
|
||||
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
|
||||
__CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM
|
||||
CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432
|
||||
}
|
||||
|
||||
variable printenvScript [makeFile [string map [list @keep@ [list $keep]] {
|
||||
encoding system iso8859-1
|
||||
proc lrem {listname name} {
|
||||
upvar $listname list
|
||||
@@ -70,7 +117,7 @@ set printenvScript [makeFile {
|
||||
}
|
||||
proc mangle s {
|
||||
regsub -all {\[|\\|\]} $s {\\&} s
|
||||
regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar &]} s
|
||||
regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar {&}]} s
|
||||
return [subst -novariables $s]
|
||||
}
|
||||
proc manglechar c {
|
||||
@@ -84,161 +131,154 @@ set printenvScript [makeFile {
|
||||
lrem names ComSpec
|
||||
lrem names ""
|
||||
}
|
||||
foreach name {
|
||||
TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
|
||||
SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
|
||||
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
|
||||
__CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM
|
||||
CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432
|
||||
} {
|
||||
foreach name @keep@ {
|
||||
lrem names $name
|
||||
}
|
||||
foreach p $names {
|
||||
puts "[mangle $p]=[mangle $env($p)]"
|
||||
puts [mangle $p]=[mangle $env($p)]
|
||||
}
|
||||
exit
|
||||
} printenv]
|
||||
}] printenv]
|
||||
|
||||
# [exec] is required here to see the actual environment received by child
|
||||
# processes.
|
||||
proc getenv {} {
|
||||
global printenvScript tcltest
|
||||
catch {exec [interpreter] $printenvScript} out
|
||||
if {$out eq "child process exited abnormally"} {
|
||||
set out {}
|
||||
}
|
||||
return $out
|
||||
|
||||
test env-1.1 {propagation of env values to child interpreters} -setup {
|
||||
catch {interp delete child}
|
||||
catch {unset env(test)}
|
||||
} -body {
|
||||
interp create child
|
||||
set env(test) garbage
|
||||
child eval {set env(test)}
|
||||
} -cleanup {
|
||||
interp delete child
|
||||
unset env(test)
|
||||
} -result {garbage}
|
||||
|
||||
|
||||
# This one crashed on Solaris under Tcl8.0, so we only want to make sure it
|
||||
# runs.
|
||||
test env-1.2 {lappend to env value} -setup {
|
||||
catch {unset env(test)}
|
||||
} -body {
|
||||
set env(test) aaaaaaaaaaaaaaaa
|
||||
append env(test) bbbbbbbbbbbbbb
|
||||
unset env(test)
|
||||
}
|
||||
|
||||
# Save the current environment variables at the start of the test.
|
||||
|
||||
set env2 [array get env]
|
||||
foreach name [array names env] {
|
||||
# Keep some environment variables that support operation of the tcltest
|
||||
# package.
|
||||
if {[string toupper $name] ni {
|
||||
TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH
|
||||
SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
|
||||
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
|
||||
SECURITYSESSIONID LANG WINDIR TERM
|
||||
CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432
|
||||
}} {
|
||||
unset env($name)
|
||||
}
|
||||
}
|
||||
|
||||
# Need to run 'getenv' in known encoding, so save the current one here...
|
||||
set sysenc [encoding system]
|
||||
|
||||
test env-2.1 {adding environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
getenv
|
||||
test env-1.3 {reflection of env by "array names"} -setup {
|
||||
catch {interp delete child}
|
||||
catch {unset env(test)}
|
||||
} -body {
|
||||
interp create child
|
||||
child eval {set env(test) garbage}
|
||||
expr {"test" in [array names env]}
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {}
|
||||
test env-2.2 {adding environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
interp delete child
|
||||
catch {unset env(test)}
|
||||
} -result 1
|
||||
|
||||
|
||||
test env-2.1 {
|
||||
adding environment variables
|
||||
} -constraints exec -setup setup1 -body {
|
||||
getenv
|
||||
} -cleanup cleanup1 -result {}
|
||||
|
||||
|
||||
test env-2.2 {
|
||||
adding environment variables
|
||||
} -constraints exec -setup setup1 -body {
|
||||
set env(NAME1) "test string"
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {NAME1=test string}
|
||||
test env-2.3 {adding environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -cleanup cleanup1 -result {NAME1=test string}
|
||||
|
||||
|
||||
test env-2.3 {adding environment variables} -constraints exec -setup {
|
||||
setup1
|
||||
set env(NAME1) "test string"
|
||||
} -constraints {exec} -body {
|
||||
} -body {
|
||||
set env(NAME2) "more"
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {NAME1=test string
|
||||
} -cleanup cleanup1 -result {NAME1=test string
|
||||
NAME2=more}
|
||||
test env-2.4 {adding environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
|
||||
|
||||
test env-2.4 {
|
||||
adding environment variables
|
||||
} -constraints exec -setup {
|
||||
setup1
|
||||
set env(NAME1) "test string"
|
||||
set env(NAME2) "more"
|
||||
} -constraints {exec} -body {
|
||||
} -body {
|
||||
set env(XYZZY) "garbage"
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -cleanup { cleanup1
|
||||
} -result {NAME1=test string
|
||||
NAME2=more
|
||||
XYZZY=garbage}
|
||||
|
||||
set env(NAME1) "test string"
|
||||
set env(NAME2) "new value"
|
||||
set env(XYZZY) "garbage"
|
||||
test env-3.1 {changing environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
|
||||
test env-3.1 {
|
||||
changing environment variables
|
||||
} -constraints exec -setup setup2 -body {
|
||||
set result [getenv]
|
||||
unset env(NAME2)
|
||||
set result
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
cleanup1
|
||||
} -result {NAME1=test string
|
||||
NAME2=new value
|
||||
XYZZY=garbage}
|
||||
unset -nocomplain env(NAME2)
|
||||
|
||||
test env-4.1 {unsetting environment variables: default} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
|
||||
test env-4.1 {
|
||||
unsetting environment variables
|
||||
} -constraints exec -setup setup2 -body {
|
||||
unset -nocomplain env(NAME2)
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {NAME1=test string
|
||||
} -cleanup cleanup1 -result {NAME1=test string
|
||||
XYZZY=garbage}
|
||||
test env-4.2 {unsetting environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
unset env(NAME1)
|
||||
getenv
|
||||
} -cleanup {
|
||||
unset env(XYZZY)
|
||||
encoding system $sysenc
|
||||
} -result {XYZZY=garbage}
|
||||
unset -nocomplain env(NAME1) env(XYZZY)
|
||||
test env-4.3 {setting international environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
|
||||
# env-4.2 is deleted
|
||||
|
||||
test env-4.3 {
|
||||
setting international environment variables
|
||||
} -constraints exec -setup setup1 -body {
|
||||
set env(\ua7) \ub6
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {\u00a7=\u00b6}
|
||||
test env-4.4 {changing international environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -constraints {exec} -body {
|
||||
} -cleanup cleanup1 -result {\u00a7=\u00b6}
|
||||
|
||||
|
||||
test env-4.4 {
|
||||
changing international environment variables
|
||||
} -constraints exec -setup setup1 -body {
|
||||
set env(\ua7) \ua7
|
||||
getenv
|
||||
} -cleanup {
|
||||
encoding system $sysenc
|
||||
} -result {\u00a7=\u00a7}
|
||||
test env-4.5 {unsetting international environment variables} -setup {
|
||||
encoding system iso8859-1
|
||||
} -cleanup cleanup1 -result {\u00a7=\u00a7}
|
||||
|
||||
|
||||
test env-4.5 {
|
||||
unsetting international environment variables
|
||||
} -constraints exec -setup {
|
||||
setup1
|
||||
set env(\ua7) \ua7
|
||||
} -body {
|
||||
set env(\ub6) \ua7
|
||||
unset env(\ua7)
|
||||
getenv
|
||||
} -constraints {exec} -cleanup {
|
||||
unset env(\ub6)
|
||||
encoding system $sysenc
|
||||
} -result {\u00b6=\u00a7}
|
||||
} -cleanup cleanup1 -result {\u00b6=\u00a7}
|
||||
|
||||
test env-5.0 {corner cases - set a value, it should exist} -body {
|
||||
test env-5.0 {
|
||||
corner cases - set a value, it should exist
|
||||
} -setup setup1 -body {
|
||||
set env(temp) a
|
||||
set env(temp)
|
||||
} -cleanup {
|
||||
unset env(temp)
|
||||
} -result {a}
|
||||
test env-5.1 {corner cases - remove one elem at a time} -setup {
|
||||
set x [array get env]
|
||||
} -body {
|
||||
} -cleanup cleanup1 -result a
|
||||
|
||||
|
||||
test env-5.1 {
|
||||
corner cases - remove one elem at a time
|
||||
} -setup setup1 -body {
|
||||
# When no environment variables exist, the env var will contain no
|
||||
# entries. The "array names" call synchs up the C-level environ array with
|
||||
# the Tcl level env array. Make sure an empty Tcl array is created.
|
||||
@@ -246,9 +286,9 @@ test env-5.1 {corner cases - remove one elem at a time} -setup {
|
||||
unset env($e)
|
||||
}
|
||||
array size env
|
||||
} -cleanup {
|
||||
array set env $x
|
||||
} -result {0}
|
||||
} -cleanup cleanup1 -result 0
|
||||
|
||||
|
||||
test env-5.2 {corner cases - unset the env array} -setup {
|
||||
interp create i
|
||||
} -body {
|
||||
@@ -262,42 +302,54 @@ test env-5.2 {corner cases - unset the env array} -setup {
|
||||
} -cleanup {
|
||||
interp delete i
|
||||
} -result {0}
|
||||
|
||||
|
||||
test env-5.3 {corner cases: unset the env in master should unset child} -setup {
|
||||
setup1
|
||||
interp create i
|
||||
} -body {
|
||||
# Variables deleted in a master interp should be deleted in child interp
|
||||
# too.
|
||||
i eval { set env(THIS_SHOULD_EXIST) a}
|
||||
i eval {set env(THIS_SHOULD_EXIST) a}
|
||||
set result [set env(THIS_SHOULD_EXIST)]
|
||||
unset env(THIS_SHOULD_EXIST)
|
||||
lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}]
|
||||
} -cleanup {
|
||||
cleanup1
|
||||
interp delete i
|
||||
} -result {a 1}
|
||||
|
||||
|
||||
test env-5.4 {corner cases - unset the env array} -setup {
|
||||
setup1
|
||||
interp create i
|
||||
} -body {
|
||||
# The info exists command should be in synch with the env array.
|
||||
# Know Bug: 1737
|
||||
i eval { set env(THIS_SHOULD_EXIST) a}
|
||||
i eval {set env(THIS_SHOULD_EXIST) a}
|
||||
set result [info exists env(THIS_SHOULD_EXIST)]
|
||||
lappend result [set env(THIS_SHOULD_EXIST)]
|
||||
lappend result [info exists env(THIS_SHOULD_EXIST)]
|
||||
} -cleanup {
|
||||
cleanup1
|
||||
interp delete i
|
||||
} -result {1 a 1}
|
||||
test env-5.5 {corner cases - cannot have null entries on Windows} -constraints win -body {
|
||||
|
||||
|
||||
test env-5.5 {
|
||||
corner cases - cannot have null entries on Windows
|
||||
} -constraints win -body {
|
||||
set env() a
|
||||
catch {set env()}
|
||||
} -result 1
|
||||
} -cleanup cleanup1 -result 1
|
||||
|
||||
test env-6.1 {corner cases - add lots of env variables} -body {
|
||||
test env-6.1 {corner cases - add lots of env variables} -setup setup1 -body {
|
||||
set size [array size env]
|
||||
for {set i 0} {$i < 100} {incr i} {
|
||||
set env(BOGUS$i) $i
|
||||
}
|
||||
expr {[array size env] - $size}
|
||||
} -result 100
|
||||
} -cleanup cleanup1 -result 100
|
||||
|
||||
test env-7.1 {[219226]: whole env array should not be unset by read} -body {
|
||||
set n [array size env]
|
||||
@@ -310,16 +362,20 @@ test env-7.1 {[219226]: whole env array should not be unset by read} -body {
|
||||
return $n
|
||||
} -result 0
|
||||
|
||||
test env-7.2 {[219226]: links to env elements should not be removed by read} -body {
|
||||
test env-7.2 {
|
||||
[219226]: links to env elements should not be removed by read
|
||||
} -setup setup1 -body {
|
||||
apply {{} {
|
||||
set ::env(test7_2) ok
|
||||
upvar env(test7_2) elem
|
||||
set ::env(PATH)
|
||||
return $elem
|
||||
}}
|
||||
} -result ok
|
||||
} -cleanup cleanup1 -result ok
|
||||
|
||||
test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy trace} -body {
|
||||
test env-7.3 {
|
||||
[9b4702]: testing existence of env(some_thing) should not destroy trace
|
||||
} -setup setup1 -body {
|
||||
apply {{} {
|
||||
catch {unset ::env(test7_3)}
|
||||
proc foo args {
|
||||
@@ -330,16 +386,25 @@ test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy
|
||||
set ::env(not_yet_existent) "Now I'm here";
|
||||
return [info exists ::env(test7_3)]
|
||||
}}
|
||||
} -result 1
|
||||
} -cleanup cleanup1 -result 1
|
||||
|
||||
# Restore the environment variables at the end of the test.
|
||||
test env-8.0 {
|
||||
memory usage - valgrind does not report reachable memory
|
||||
} -body {
|
||||
set res [set env(__DUMMY__) {i'm with dummy}]
|
||||
unset env(__DUMMY__)
|
||||
return $res
|
||||
} -result {i'm with dummy}
|
||||
|
||||
|
||||
foreach name [array names env] {
|
||||
unset env($name)
|
||||
}
|
||||
array set env $env2
|
||||
|
||||
# cleanup
|
||||
rename getenv {}
|
||||
rename envrestore {}
|
||||
rename envprep {}
|
||||
rename encodingrestore {}
|
||||
rename encodingswitch {}
|
||||
|
||||
removeFile $printenvScript
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
@@ -527,7 +527,7 @@ test event-11.4 {Tcl_VwaitCmd procedure} -setup {
|
||||
} -body {
|
||||
after 100 {set x x-done}
|
||||
after 200 {set y y-done}
|
||||
after 300 {set z z-done}
|
||||
after 400 {set z z-done}
|
||||
after idle {set q q-done}
|
||||
set x before
|
||||
set y before
|
||||
|
||||
@@ -11,9 +11,14 @@
|
||||
# See the file "license.terms" for information on usage and redistribution of
|
||||
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
# There is no point in running Valgrind on cases where [exec] forks but then
|
||||
# fails and the child process doesn't go through full cleanup.
|
||||
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
|
||||
package require tcltests
|
||||
|
||||
# All tests require the "exec" command.
|
||||
# Skip them if exec is not defined.
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
@@ -300,7 +305,6 @@ test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} {
|
||||
# I/O redirection: combinations.
|
||||
|
||||
set path(gorp.file2) [makeFile {} gorp.file2]
|
||||
file delete $path(gorp.file2)
|
||||
|
||||
test exec-7.1 {multiple I/O redirections} {exec} {
|
||||
exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file)
|
||||
@@ -326,11 +330,11 @@ test exec-8.2 {long input and output} {exec} {
|
||||
|
||||
# Commands that return errors.
|
||||
|
||||
test exec-9.1 {commands returning errors} {exec} {
|
||||
test exec-9.1 {commands returning errors} {exec notValgrind} {
|
||||
set x [catch {exec gorp456} msg]
|
||||
list $x [string tolower $msg] [string tolower $errorCode]
|
||||
} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
test exec-9.2 {commands returning errors} {exec} {
|
||||
test exec-9.2 {commands returning errors} {exec notValgrind} {
|
||||
string tolower [list [catch {exec [interpreter] echo foo | foo123} msg] $msg $errorCode]
|
||||
} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}}
|
||||
test exec-9.3 {commands returning errors} -constraints {exec stdio} -body {
|
||||
@@ -340,7 +344,7 @@ test exec-9.4 {commands returning errors} -constraints {exec stdio} -body {
|
||||
exec [interpreter] $path(exit) 43 | [interpreter] $path(echo) "foo bar"
|
||||
} -returnCodes error -result {foo bar
|
||||
child process exited abnormally}
|
||||
test exec-9.5 {commands returning errors} -constraints {exec stdio} -body {
|
||||
test exec-9.5 {commands returning errors} -constraints {exec stdio notValgrind} -body {
|
||||
exec gorp456 | [interpreter] echo a b c
|
||||
} -returnCodes error -result {couldn't execute "gorp456": no such file or directory}
|
||||
test exec-9.6 {commands returning errors} -constraints {exec} -body {
|
||||
@@ -429,13 +433,13 @@ test exec-10.19 {errors in exec invocation} -constraints {exec} -body {
|
||||
exec cat >@ $f
|
||||
} -returnCodes error -result "channel \"$f\" wasn't opened for writing"
|
||||
close $f
|
||||
test exec-10.20 {errors in exec invocation} -constraints {exec} -body {
|
||||
test exec-10.20 {errors in exec invocation} -constraints {exec notValgrind} -body {
|
||||
exec ~non_existent_user/foo/bar
|
||||
} -returnCodes error -result {user "non_existent_user" doesn't exist}
|
||||
test exec-10.21 {errors in exec invocation} -constraints {exec} -body {
|
||||
test exec-10.21 {errors in exec invocation} -constraints {exec notValgrind} -body {
|
||||
exec [interpreter] true | ~xyzzy_bad_user/x | false
|
||||
} -returnCodes error -result {user "xyzzy_bad_user" doesn't exist}
|
||||
test exec-10.22 {errors in exec invocation} -constraints exec -body {
|
||||
test exec-10.22 {errors in exec invocation} -constraints {exec notValgrind} -body {
|
||||
exec echo test > ~non_existent_user/foo/bar
|
||||
} -returnCodes error -result {user "non_existent_user" doesn't exist}
|
||||
# Commands in background.
|
||||
@@ -511,7 +515,7 @@ test exec-13.1 {setting errorCode variable} {exec} {
|
||||
test exec-13.2 {setting errorCode variable} {exec} {
|
||||
list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode]
|
||||
} {1 {posix enoent {no such file or directory}}}
|
||||
test exec-13.3 {setting errorCode variable} {exec} {
|
||||
test exec-13.3 {setting errorCode variable} {exec notValgrind} {
|
||||
set x [catch {exec _weird_cmd_} msg]
|
||||
list $x [string tolower $msg] [lindex $errorCode 0] \
|
||||
[string tolower [lrange $errorCode 2 end]]
|
||||
@@ -549,7 +553,7 @@ test exec-14.2 {-keepnewline switch} -constraints {exec} -body {
|
||||
test exec-14.3 {unknown switch} -constraints {exec} -body {
|
||||
exec -gorp
|
||||
} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --}
|
||||
test exec-14.4 {-- switch} -constraints {exec} -body {
|
||||
test exec-14.4 {-- switch} -constraints {exec notValgrind} -body {
|
||||
exec -- -gorp
|
||||
} -returnCodes error -result {couldn't execute "-gorp": no such file or directory}
|
||||
test exec-14.5 {-ignorestderr switch} {exec} {
|
||||
@@ -663,7 +667,7 @@ test exec-18.2 {exec cat deals with weird file names} -body {
|
||||
# Note that this test cannot be adapted to work on Windows; that platform has
|
||||
# no kernel support for an analog of O_APPEND. OTOH, that means we can assume
|
||||
# that there is a POSIX shell...
|
||||
test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup {
|
||||
test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind} -setup {
|
||||
set tmpfile [makeFile {0} tmpfile.exec-19.1]
|
||||
} -body {
|
||||
# Note that we have to allow for the current contents of the temporary
|
||||
@@ -676,7 +680,7 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup {
|
||||
{for a in a b c; do sleep 1; echo $a; done} >>$tmpfile &
|
||||
exec /bin/sh -c \
|
||||
{for a in d e f; do sleep 1; echo $a >&2; done} 2>>$tmpfile &
|
||||
# The above four shell invokations take about 3 seconds to finish, so allow
|
||||
# The above four shell invocations take about 3 seconds to finish, so allow
|
||||
# 5s (in case the machine is busy)
|
||||
after 5000
|
||||
# Check that no bytes have got lost through mixups with overlapping
|
||||
|
||||
@@ -37,6 +37,11 @@ testConstraint testobj [expr {
|
||||
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
|
||||
testConstraint testexprlongobj [llength [info commands testexprlongobj]]
|
||||
|
||||
|
||||
if {[namespace which -command testbumpinterpepoch] eq ""} {
|
||||
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
|
||||
}
|
||||
|
||||
# Tests for the omnibus TclExecuteByteCode function:
|
||||
|
||||
# INST_DONE not tested
|
||||
@@ -933,8 +938,7 @@ test execute-8.3 {Stack restoration} -setup {
|
||||
proc f {args} "f $arglst"
|
||||
proc run {} {
|
||||
# bump the interp's epoch
|
||||
rename ::set ::dummy
|
||||
rename ::dummy ::set
|
||||
testbumpinterpepoch
|
||||
catch f msg
|
||||
set msg
|
||||
}
|
||||
@@ -948,8 +952,7 @@ test execute-8.4 {Compile epoch bump effect on stack trace} -setup {
|
||||
}
|
||||
proc FOO {} {
|
||||
catch {error bar} m o
|
||||
rename ::set ::dummy
|
||||
rename ::dummy ::set
|
||||
testbumpinterpepoch
|
||||
return -options $o $m
|
||||
}
|
||||
} -body {
|
||||
@@ -978,10 +981,80 @@ test execute-8.5 {Bug 2038069} -setup {
|
||||
invoked from within
|
||||
"catch \[list error FOO\] m o"} -errorline 2}
|
||||
|
||||
test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup {
|
||||
interp create slave
|
||||
slave eval {
|
||||
package require tcltest
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
::tcltest::loadTestedCommands
|
||||
if {[namespace which -command testbumpinterpepoch] eq ""} {
|
||||
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
|
||||
}
|
||||
}
|
||||
} -body {
|
||||
slave eval {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
|
||||
}
|
||||
slave eval {
|
||||
set i 0; while {[incr i] < 3} {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
|
||||
}
|
||||
}
|
||||
slave eval {
|
||||
set i 0; while {[incr i] < 3} {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
|
||||
}
|
||||
}
|
||||
slave eval {
|
||||
catch {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
|
||||
}
|
||||
}
|
||||
slave eval {set res}
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
} -result [lrepeat 4 A B]
|
||||
test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup {
|
||||
interp create slave
|
||||
slave eval {
|
||||
package require tcltest
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
::tcltest::loadTestedCommands
|
||||
if {[namespace which -command testbumpinterpepoch] eq ""} {
|
||||
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
|
||||
}
|
||||
}
|
||||
} -body {
|
||||
set res {}
|
||||
lappend res [catch {
|
||||
slave eval {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C;
|
||||
}
|
||||
} e] $e
|
||||
lappend res [catch {
|
||||
slave eval {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
|
||||
}
|
||||
} e] $e
|
||||
lappend res [catch {
|
||||
slave eval {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C;
|
||||
}
|
||||
} e] $e
|
||||
lappend res [catch {
|
||||
slave eval {
|
||||
lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
|
||||
}
|
||||
} e] $e
|
||||
list $res [slave eval {set res}]
|
||||
} -cleanup {
|
||||
interp delete slave
|
||||
} -result [list {1 test 1 test 2 test 3 {}} [lrepeat 4 A B]]
|
||||
|
||||
test execute-9.1 {Interp result resetting [Bug 1522803]} {
|
||||
set c 0
|
||||
catch {
|
||||
catch {set foo}
|
||||
catch {error foo}
|
||||
expr {1/$c}
|
||||
}
|
||||
if {[string match *foo* $::errorInfo]} {
|
||||
@@ -1016,6 +1089,7 @@ test execute-10.3 {Bug 3072640} -setup {
|
||||
proc t {args} {
|
||||
incr ::foo
|
||||
}
|
||||
set ::foo 0
|
||||
trace add execution ::generate enterstep ::t
|
||||
} -body {
|
||||
coroutine coro generate 5
|
||||
@@ -1066,6 +1140,45 @@ test execute-11.3 {Bug a0ece9d6d4} -setup {
|
||||
trace remove execution crash enterstep {apply {args {info frame -2}}}
|
||||
rename crash {}
|
||||
} -result 1
|
||||
|
||||
test execute-12.1 {failing multi-lappend to unshared} -setup {
|
||||
unset -nocomplain x y
|
||||
} -body {
|
||||
set x 1
|
||||
lappend x 2 3
|
||||
trace add variable x write {apply {args {error boo}}}
|
||||
lappend x 4 5
|
||||
} -cleanup {
|
||||
unset -nocomplain x y
|
||||
} -returnCodes error -result {can't set "x": boo}
|
||||
test execute-12.2 {failing multi-lappend to shared} -setup {
|
||||
unset -nocomplain x y
|
||||
} -body {
|
||||
set x 1
|
||||
lappend x 2 3
|
||||
set y $x
|
||||
trace add variable x write {apply {args {error boo}}}
|
||||
lappend x 4 5
|
||||
} -cleanup {
|
||||
unset -nocomplain x y
|
||||
} -returnCodes error -result {can't set "x": boo}
|
||||
test execute-12.3 {failing multi-lappend to unshared: LVT} -body {
|
||||
apply {{} {
|
||||
set x 1
|
||||
lappend x 2 3
|
||||
trace add variable x write {apply {args {error boo}}}
|
||||
lappend x 4 5
|
||||
}}
|
||||
} -returnCodes error -result {can't set "x": boo}
|
||||
test execute-12.4 {failing multi-lappend to shared: LVT} -body {
|
||||
apply {{} {
|
||||
set x 1
|
||||
lappend x 2 3
|
||||
set y $x
|
||||
trace add variable x write {apply {args {error boo}}}
|
||||
lappend x 4 5
|
||||
}}
|
||||
} -returnCodes error -result {can't set "x": boo}
|
||||
|
||||
# cleanup
|
||||
if {[info commands testobj] != {}} {
|
||||
|
||||
@@ -1150,7 +1150,7 @@ test expr-23.54.11 {INST_EXPON: Bug 2798543} {
|
||||
expr {3**9 == 3**131081}
|
||||
} 0
|
||||
test expr-23.54.12 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {3**9 == 3**268435465}
|
||||
expr {3**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.54.13 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-3)**9 == (-3)**65545}
|
||||
@@ -1165,7 +1165,7 @@ test expr-23.55.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {4**9 == 4**131081}
|
||||
} 0
|
||||
test expr-23.55.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {4**9 == 4**268435465}
|
||||
expr {4**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.55.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-4)**9 == (-4)**65545}
|
||||
@@ -1180,7 +1180,7 @@ test expr-23.56.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {5**9 == 5**131081}
|
||||
} 0
|
||||
test expr-23.56.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {5**9 == 5**268435465}
|
||||
expr {5**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.56.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-5)**9 == (-5)**65545}
|
||||
@@ -1195,7 +1195,7 @@ test expr-23.57.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {6**9 == 6**131081}
|
||||
} 0
|
||||
test expr-23.57.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {6**9 == 6**268435465}
|
||||
expr {6**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.57.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-6)**9 == (-6)**65545}
|
||||
@@ -1210,7 +1210,7 @@ test expr-23.58.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {7**9 == 7**131081}
|
||||
} 0
|
||||
test expr-23.58.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {7**9 == 7**268435465}
|
||||
expr {7**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.58.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-7)**9 == (-7)**65545}
|
||||
@@ -1225,7 +1225,7 @@ test expr-23.59.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {8**9 == 8**131081}
|
||||
} 0
|
||||
test expr-23.59.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {8**9 == 8**268435465}
|
||||
expr {8**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.59.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-8)**9 == (-8)**65545}
|
||||
@@ -1237,7 +1237,7 @@ test expr-23.60.1 {INST_EXPON: Bug 2798543} {
|
||||
expr {9**9 == 9**131081}
|
||||
} 0
|
||||
test expr-23.60.2 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {9**9 == 9**268435465}
|
||||
expr {9**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.60.3 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-9)**9 == (-9)**65545}
|
||||
@@ -1249,7 +1249,7 @@ test expr-23.61.1 {INST_EXPON: Bug 2798543} {
|
||||
expr {10**9 == 10**131081}
|
||||
} 0
|
||||
test expr-23.61.2 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {10**9 == 10**268435465}
|
||||
expr {10**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.61.3 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-10)**9 == (-10)**65545}
|
||||
@@ -1261,7 +1261,7 @@ test expr-23.62.1 {INST_EXPON: Bug 2798543} {
|
||||
expr {11**9 == 11**131081}
|
||||
} 0
|
||||
test expr-23.62.2 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {11**9 == 11**268435465}
|
||||
expr {11**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.62.3 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-11)**9 == (-11)**65545}
|
||||
@@ -1276,7 +1276,7 @@ test expr-23.63.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {3**20 == 3**131092}
|
||||
} 0
|
||||
test expr-23.63.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {3**20 == 3**268435476}
|
||||
expr {3**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.63.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-3)**20 == (-3)**65556}
|
||||
@@ -1291,7 +1291,7 @@ test expr-23.64.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {4**17 == 4**131089}
|
||||
} 0
|
||||
test expr-23.64.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {4**17 == 4**268435473}
|
||||
expr {4**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.64.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-4)**17 == (-4)**65553}
|
||||
@@ -1306,7 +1306,7 @@ test expr-23.65.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {5**17 == 5**131089}
|
||||
} 0
|
||||
test expr-23.65.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {5**17 == 5**268435473}
|
||||
expr {5**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.65.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-5)**17 == (-5)**65553}
|
||||
@@ -1321,7 +1321,7 @@ test expr-23.66.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {6**17 == 6**131089}
|
||||
} 0
|
||||
test expr-23.66.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {6**17 == 6**268435473}
|
||||
expr {6**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.66.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-6)**17 == (-6)**65553}
|
||||
@@ -1336,7 +1336,7 @@ test expr-23.67.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {7**17 == 7**131089}
|
||||
} 0
|
||||
test expr-23.67.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {7**17 == 7**268435473}
|
||||
expr {7**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.67.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-7)**17 == (-7)**65553}
|
||||
@@ -1351,7 +1351,7 @@ test expr-23.68.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {8**17 == 8**131089}
|
||||
} 0
|
||||
test expr-23.68.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {8**17 == 8**268435473}
|
||||
expr {8**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.68.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-8)**17 == (-8)**65553}
|
||||
@@ -1366,7 +1366,7 @@ test expr-23.69.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {9**17 == 9**131089}
|
||||
} 0
|
||||
test expr-23.69.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {9**17 == 9**268435473}
|
||||
expr {9**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.69.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-9)**17 == (-9)**65553}
|
||||
@@ -1381,7 +1381,7 @@ test expr-23.70.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {10**17 == 10**131089}
|
||||
} 0
|
||||
test expr-23.70.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {10**17 == 10**268435473}
|
||||
expr {10**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.70.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-10)**17 == (-10)**65553}
|
||||
@@ -1396,7 +1396,7 @@ test expr-23.71.2 {INST_EXPON: Bug 2798543} {
|
||||
expr {11**17 == 11**131089}
|
||||
} 0
|
||||
test expr-23.71.3 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {11**17 == 11**268435473}
|
||||
expr {11**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.71.4 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-11)**17 == (-11)**65553}
|
||||
@@ -1408,7 +1408,7 @@ test expr-23.72.1 {INST_EXPON: Bug 2798543} {
|
||||
expr {12**17 == 12**131089}
|
||||
} 0
|
||||
test expr-23.72.2 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {12**17 == 12**268435473}
|
||||
expr {12**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.72.3 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-12)**17 == (-12)**65553}
|
||||
@@ -1420,7 +1420,7 @@ test expr-23.73.1 {INST_EXPON: Bug 2798543} {
|
||||
expr {13**17 == 13**131089}
|
||||
} 0
|
||||
test expr-23.73.2 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {13**17 == 13**268435473}
|
||||
expr {13**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.73.3 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-13)**17 == (-13)**65553}
|
||||
@@ -1432,7 +1432,7 @@ test expr-23.74.1 {INST_EXPON: Bug 2798543} {
|
||||
expr {14**17 == 14**131089}
|
||||
} 0
|
||||
test expr-23.74.2 {INST_EXPON: Bug 2798543} -body {
|
||||
expr {14**17 == 14**268435473}
|
||||
expr {14**268435456}
|
||||
} -returnCodes error -result {exponent too large}
|
||||
test expr-23.74.3 {INST_EXPON: Bug 2798543} {
|
||||
expr {(-14)**17 == (-14)**65553}
|
||||
@@ -5838,6 +5838,15 @@ test expr-32.5 {Bug 1585704} {
|
||||
test expr-32.6 {Bug 1585704} {
|
||||
expr -(1<<32)%(1<<63)
|
||||
} [expr (1<<63)-(1<<32)]
|
||||
test expr-32.7 {bignum regression} {
|
||||
expr {0%(1<<63)}
|
||||
} 0
|
||||
test expr-32.8 {bignum regression} {
|
||||
expr {0%-(1<<63)}
|
||||
} 0
|
||||
test expr-32.9 {bignum regression} {
|
||||
expr {0%-(1+(1<<63))}
|
||||
} 0
|
||||
|
||||
test expr-33.1 {parse largest long value} longIs32bit {
|
||||
set max_long_str 2147483647
|
||||
@@ -7187,6 +7196,15 @@ test expr-51.1 {test round-to-even on input} {
|
||||
expr 6.9294956446009195e15
|
||||
} 6929495644600920.0
|
||||
|
||||
test expr-52.1 {
|
||||
comparison with empty string does not generate string representation
|
||||
} {
|
||||
set a [list one two three]
|
||||
list [expr {$a eq {}}] [expr {$a < {}}] [expr {$a > {}}] [
|
||||
string match {*no string representation*} [
|
||||
::tcl::unsupported::representation $a]]
|
||||
} {0 0 1 1}
|
||||
|
||||
|
||||
|
||||
# cleanup
|
||||
|
||||
@@ -65,11 +65,10 @@ if {[testConstraint unix]} {
|
||||
|
||||
# Also used in winFCmd...
|
||||
if {[testConstraint win]} {
|
||||
set major [string index $tcl_platform(osVersion) 0]
|
||||
if {[testConstraint nt] && $major > 4} {
|
||||
if {$major > 5} {
|
||||
if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} {
|
||||
if {$::tcl_platform(osVersion) >= 6.0} {
|
||||
testConstraint winVista 1
|
||||
} elseif {$major == 5} {
|
||||
} else {
|
||||
testConstraint win2000orXP 1
|
||||
}
|
||||
}
|
||||
@@ -78,7 +77,7 @@ if {[testConstraint win]} {
|
||||
testConstraint darwin9 [expr {
|
||||
[testConstraint unix]
|
||||
&& $tcl_platform(os) eq "Darwin"
|
||||
&& [package vsatisfies 1.$tcl_platform(osVersion) 1.9]
|
||||
&& [package vsatisfies 1.$::tcl_platform(osVersion) 1.9]
|
||||
}]
|
||||
testConstraint notDarwin9 [expr {![testConstraint darwin9]}]
|
||||
|
||||
@@ -279,7 +278,7 @@ test fCmd-3.14 {FileCopyRename: FileBasename fails} -setup {
|
||||
} -result {user "_totally_bogus_user" doesn't exist}
|
||||
test fCmd-3.15 {FileCopyRename: source[0] == '\0'} -setup {
|
||||
cleanup
|
||||
} -constraints {notRoot unixOrPc} -returnCodes error -body {
|
||||
} -constraints {notRoot unixOrWin} -returnCodes error -body {
|
||||
file mkdir td1
|
||||
file rename / td1
|
||||
} -result {error renaming "/" to "td1": file already exists}
|
||||
@@ -419,7 +418,7 @@ test fCmd-5.4 {TclFileDeleteCmd: multiple files} -constraints notRoot -setup {
|
||||
} -cleanup {cleanup} -result {1 1 1 0 0 0}
|
||||
test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup {
|
||||
cleanup
|
||||
} -constraints {notRoot unixOrPc} -body {
|
||||
} -constraints {notRoot unixOrWin} -body {
|
||||
createfile tf1
|
||||
createfile tf2
|
||||
file mkdir td1
|
||||
@@ -1119,7 +1118,7 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup {
|
||||
} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]
|
||||
test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup {
|
||||
cleanup
|
||||
} -constraints {notRoot unixOrPc testchmod} -body {
|
||||
} -constraints {notRoot unixOrWin testchmod} -body {
|
||||
file mkdir tds1
|
||||
file mkdir tds2
|
||||
file mkdir [file join tdd1 tds1 xxx]
|
||||
@@ -2309,7 +2308,7 @@ test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} -setup {
|
||||
|
||||
if {
|
||||
[testConstraint win] &&
|
||||
([string index $tcl_platform(osVersion) 0] < 5
|
||||
($::tcl_platform(osVersion) < 5.0
|
||||
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS")
|
||||
} then {
|
||||
testConstraint linkDirectory 0
|
||||
|
||||
@@ -23,7 +23,7 @@ testConstraint testtranslatefilename [llength [info commands testtranslatefilena
|
||||
testConstraint linkDirectory 1
|
||||
testConstraint symbolicLinkFile 1
|
||||
if {[testConstraint win]} {
|
||||
if {[string index $tcl_platform(osVersion) 0] < 5 \
|
||||
if {$::tcl_platform(osVersion) < 5.0 \
|
||||
|| [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} {
|
||||
testConstraint linkDirectory 0
|
||||
}
|
||||
@@ -778,6 +778,8 @@ test filename-11.16 {Tcl_GlobCmd} {
|
||||
} {globTest}
|
||||
set globname "globTest"
|
||||
set horribleglobname "glob\[\{Test"
|
||||
set tildeglobname "./~test.txt"
|
||||
|
||||
test filename-11.17 {Tcl_GlobCmd} {unix} {
|
||||
lsort [glob -directory $globname *]
|
||||
} [lsort [list [file join $globname a1] [file join $globname a2]\
|
||||
@@ -917,11 +919,12 @@ test filename-11.21.1 {Tcl_GlobCmd} -body {
|
||||
} -result {{[tcl].testremains}}
|
||||
# Get rid of file/dir if it exists, since it will have been left behind by a
|
||||
# previous failed run.
|
||||
if {[file exists $horribleglobname]} {
|
||||
file delete -force $horribleglobname
|
||||
}
|
||||
file delete -force $horribleglobname
|
||||
file rename globTest $horribleglobname
|
||||
set globname $horribleglobname
|
||||
file delete -force $tildeglobname
|
||||
close [open $tildeglobname w]
|
||||
|
||||
test filename-11.22 {Tcl_GlobCmd} {unix} {
|
||||
lsort [glob -dir $globname *]
|
||||
} [lsort [list [file join $globname a1] [file join $globname a2]\
|
||||
@@ -1040,7 +1043,9 @@ test filename-11.41 {Tcl_GlobCmd} -body {
|
||||
test filename-11.42 {Tcl_GlobCmd} -body {
|
||||
set res [list]
|
||||
foreach f [glob -dir [pwd] *] {
|
||||
lappend res [file tail $f]
|
||||
set f [file tail $f]
|
||||
regsub {^./} $f {} f; # until glob bug [2511011fff] don't fixed (tilde expansion prevention).
|
||||
lappend res $f
|
||||
}
|
||||
list $res [glob *]
|
||||
} -match compareWords -result equal
|
||||
@@ -1080,16 +1085,17 @@ test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body {
|
||||
} -result {bad argument to "-types": abcde}
|
||||
|
||||
file rename $horribleglobname globTest
|
||||
file delete -force $tildeglobname
|
||||
set globname globTest
|
||||
unset horribleglobname
|
||||
unset horribleglobname tildeglobname
|
||||
|
||||
test filename-12.1 {simple globbing} {unixOrPc} {
|
||||
test filename-12.1 {simple globbing} {unixOrWin} {
|
||||
glob {}
|
||||
} {.}
|
||||
test filename-12.1.1 {simple globbing} -constraints {unixOrPc} -body {
|
||||
test filename-12.1.1 {simple globbing} -constraints {unixOrWin} -body {
|
||||
glob -types f {}
|
||||
} -returnCodes error -result {no files matched glob pattern ""}
|
||||
test filename-12.1.2 {simple globbing} {unixOrPc} {
|
||||
test filename-12.1.2 {simple globbing} {unixOrWin} {
|
||||
glob -types d {}
|
||||
} {.}
|
||||
test filename-12.1.3 {simple globbing} {unix} {
|
||||
@@ -1110,7 +1116,7 @@ test filename-12.3 {simple globbing} {
|
||||
set globPreResult globTest/
|
||||
set x1 x1.c
|
||||
set y1 y1.c
|
||||
test filename-12.4 {simple globbing} {unixOrPc} {
|
||||
test filename-12.4 {simple globbing} {unixOrWin} {
|
||||
lsort [glob globTest/x1.c globTest/y1.c globTest/foo]
|
||||
} "$globPreResult$x1 $globPreResult$y1"
|
||||
test filename-12.5 {simple globbing} {
|
||||
@@ -1172,32 +1178,32 @@ test filename-13.9 {globbing with brace substitution} {
|
||||
test filename-13.10 {globbing with brace substitution} {
|
||||
lsort [glob globTest/\{x,,y\}1.c]
|
||||
} [list $globPreResult$x1 $globPreResult$y1]
|
||||
test filename-13.11 {globbing with brace substitution} {unixOrPc} {
|
||||
test filename-13.11 {globbing with brace substitution} {unixOrWin} {
|
||||
lsort [glob globTest/\{x,x\\,z,z\}1.c]
|
||||
} [lsort {globTest/x1.c globTest/x,z1.c globTest/z1.c}]
|
||||
test filename-13.13 {globbing with brace substitution} {
|
||||
lsort [glob globTest/{a,b,x,y}1.c]
|
||||
} [list $globPreResult$x1 $globPreResult$y1]
|
||||
test filename-13.14 {globbing with brace substitution} {unixOrPc} {
|
||||
test filename-13.14 {globbing with brace substitution} {unixOrWin} {
|
||||
lsort [glob {globTest/{x1,y2,weird name}.c}]
|
||||
} {{globTest/weird name.c} globTest/x1.c}
|
||||
test filename-13.16 {globbing with brace substitution} {unixOrPc} {
|
||||
test filename-13.16 {globbing with brace substitution} {unixOrWin} {
|
||||
lsort [glob globTest/{x1.c,a1/*}]
|
||||
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
|
||||
test filename-13.18 {globbing with brace substitution} {unixOrPc} {
|
||||
test filename-13.18 {globbing with brace substitution} {unixOrWin} {
|
||||
lsort [glob globTest/{x1.c,{a},a1/*}]
|
||||
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
|
||||
test filename-13.20 {globbing with brace substitution} {unixOrPc} {
|
||||
test filename-13.20 {globbing with brace substitution} {unixOrWin} {
|
||||
lsort [glob globTest/{a,x}1/*/{x,y}*]
|
||||
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
|
||||
test filename-13.22 {globbing with brace substitution} -body {
|
||||
glob globTest/\{a,x\}1/*/\{
|
||||
} -returnCodes error -result {unmatched open-brace in file name}
|
||||
|
||||
test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc} {
|
||||
test filename-14.1 {asterisks, question marks, and brackets} {unixOrWin} {
|
||||
lsort [glob glo*/*.c]
|
||||
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
|
||||
test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
|
||||
test filename-14.3 {asterisks, question marks, and brackets} {unixOrWin} {
|
||||
lsort [glob globTest/?1.c]
|
||||
} {globTest/x1.c globTest/y1.c globTest/z1.c}
|
||||
test filename-14.5 {asterisks, question marks, and brackets} -setup {
|
||||
@@ -1207,7 +1213,7 @@ test filename-14.5 {asterisks, question marks, and brackets} -setup {
|
||||
file rename globTest [file join globTestContext globTest]
|
||||
set savepwd [pwd]
|
||||
cd globTestContext
|
||||
} -constraints {unixOrPc} -body {
|
||||
} -constraints {unixOrWin} -body {
|
||||
lsort [glob */*/*/*.c]
|
||||
} -cleanup {
|
||||
# Reset to where we were
|
||||
@@ -1221,16 +1227,16 @@ test filename-14.7 {asterisks, question marks, and brackets} {unix} {
|
||||
test filename-14.7.1 {asterisks, question marks, and brackets} {win} {
|
||||
lsort [glob globTest/*]
|
||||
} {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
|
||||
test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc} {
|
||||
test filename-14.9 {asterisks, question marks, and brackets} {unixOrWin} {
|
||||
lsort [glob globTest/.*]
|
||||
} {globTest/. globTest/.. globTest/.1}
|
||||
test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} {
|
||||
test filename-14.11 {asterisks, question marks, and brackets} {unixOrWin} {
|
||||
lsort [glob globTest/*/*]
|
||||
} {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3}
|
||||
test filename-14.13 {asterisks, question marks, and brackets} {unixOrPc} {
|
||||
test filename-14.13 {asterisks, question marks, and brackets} {unixOrWin} {
|
||||
lsort [glob {globTest/[xyab]1.*}]
|
||||
} {globTest/x1.c globTest/y1.c}
|
||||
test filename-14.15 {asterisks, question marks, and brackets} {unixOrPc} {
|
||||
test filename-14.15 {asterisks, question marks, and brackets} {unixOrWin} {
|
||||
lsort [glob globTest/*/]
|
||||
} {globTest/a1/ globTest/a2/ globTest/a3/}
|
||||
test filename-14.17 {asterisks, question marks, and brackets} -setup {
|
||||
@@ -1242,7 +1248,7 @@ test filename-14.17 {asterisks, question marks, and brackets} -setup {
|
||||
} -cleanup {
|
||||
set env(HOME) $temp
|
||||
} -result [list [file join $env(HOME) globTest z1.c]]
|
||||
test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc} {
|
||||
test filename-14.18 {asterisks, question marks, and brackets} {unixOrWin} {
|
||||
lsort [glob globTest/*.c goo/*]
|
||||
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
|
||||
test filename-14.20 {asterisks, question marks, and brackets} {
|
||||
@@ -1281,16 +1287,16 @@ test filename-14.25.1 {type specific globbing} {win} {
|
||||
test filename-14.26 {type specific globbing} {
|
||||
glob -nocomplain -dir globTest -types {readonly} *
|
||||
} {}
|
||||
test filename-14.27 {Bug 2710920} {unixOrPc} {
|
||||
test filename-14.27 {Bug 2710920} {unixOrWin} {
|
||||
file tail [lindex [lsort [glob globTest/*/]] 0]
|
||||
} a1
|
||||
test filename-14.28 {Bug 2710920} {unixOrPc} {
|
||||
test filename-14.28 {Bug 2710920} {unixOrWin} {
|
||||
file dirname [lindex [lsort [glob globTest/*/]] 0]
|
||||
} globTest
|
||||
test filename-14.29 {Bug 2710920} {unixOrPc} {
|
||||
test filename-14.29 {Bug 2710920} {unixOrWin} {
|
||||
file extension [lindex [lsort [glob globTest/*/]] 0]
|
||||
} {}
|
||||
test filename-14.30 {Bug 2710920} {unixOrPc} {
|
||||
test filename-14.30 {Bug 2710920} {unixOrWin} {
|
||||
file rootname [lindex [lsort [glob globTest/*/]] 0]
|
||||
} globTest/a1/
|
||||
|
||||
|
||||
@@ -34,6 +34,7 @@ catch {
|
||||
testConstraint testfilesystem [llength [info commands ::testfilesystem]]
|
||||
testConstraint testsetplatform [llength [info commands ::testsetplatform]]
|
||||
testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]]
|
||||
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
|
||||
|
||||
cd [tcltest::temporaryDirectory]
|
||||
makeFile "test file" gorp.file
|
||||
@@ -264,6 +265,12 @@ removeDirectory dir.dir
|
||||
test filesystem-1.30 {normalisation of nonexistent user} -body {
|
||||
file normalize ~noonewiththisname
|
||||
} -returnCodes error -result {user "noonewiththisname" doesn't exist}
|
||||
test filesystem-1.30.1 {normalisation of existing user} -body {
|
||||
catch {file normalize ~$::tcl_platform(user)}
|
||||
} -result {0}
|
||||
test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body {
|
||||
file normalize ~nonexistentuser@nonexistentdomain
|
||||
} -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist}
|
||||
test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} {
|
||||
testsetplatform unix
|
||||
file normalize /foo/../bar
|
||||
@@ -306,7 +313,7 @@ test filesystem-1.37 {file normalisation with '/./'} -body {
|
||||
} -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$}
|
||||
test filesystem-1.38 {file normalisation with volume relative} -setup {
|
||||
set dir [pwd]
|
||||
} -constraints {win moreThanOneDrive} -body {
|
||||
} -constraints {win moreThanOneDrive knownMsvcBug} -body {
|
||||
set path "[string range [lindex $drives 0] 0 1]foo"
|
||||
cd [lindex $drives 1]
|
||||
file norm $path
|
||||
|
||||
52
tests/fileSystemEncoding.test
Normal file
52
tests/fileSystemEncoding.test
Normal file
@@ -0,0 +1,52 @@
|
||||
#! /usr/bin/env tclsh
|
||||
|
||||
# Copyright (c) 2019 Poor Yorick
|
||||
|
||||
if {[string equal $::tcl_platform(os) "Windows NT"]} {
|
||||
return
|
||||
}
|
||||
|
||||
namespace eval ::tcl::test::fileSystemEncoding {
|
||||
package require tcltest 2
|
||||
namespace import ::tcltest::*
|
||||
|
||||
variable fname1 \u767b\u9e1b\u9d72\u6a13
|
||||
|
||||
proc autopath {} {
|
||||
global auto_path
|
||||
set scriptpath [info script]
|
||||
set scriptpathnorm [file dirname [file normalize $scriptpath/...]]
|
||||
set dirnorm [file dirname $scriptpathnorm]
|
||||
set idx [lsearch -exact $auto_path $dirnorm]
|
||||
if {$idx >= 0} {
|
||||
set auto_path [lreplace $auto_path[set auto_path {}] $idx $idx {}]
|
||||
}
|
||||
set auto_path [linsert $auto_path[set auto_path {}] 0 0 $dirnorm]
|
||||
}
|
||||
autopath
|
||||
|
||||
package require tcltests
|
||||
|
||||
test filesystemEncoding-1.0 {
|
||||
issue bcd100410465
|
||||
} -body {
|
||||
set dir [tcltests::tempdir]
|
||||
set saved [encoding system]
|
||||
encoding system iso8859-1
|
||||
set fname1a $dir/$fname1
|
||||
set utf8name [encoding convertto utf-8 $fname1a]
|
||||
makeFile {} $utf8name
|
||||
set globbed [lindex [glob -directory $dir *] 0]
|
||||
encoding system utf-8
|
||||
set res [file exists $globbed]
|
||||
encoding system iso8859-1
|
||||
lappend res [file exists $globbed]
|
||||
return $res
|
||||
} -cleanup {
|
||||
removeFile $utf8name
|
||||
file delete -force $dir
|
||||
encoding system $saved
|
||||
} -result {0 1}
|
||||
|
||||
cleanupTests
|
||||
}
|
||||
@@ -212,14 +212,16 @@ test foreach-6.4 {break tests} {
|
||||
set msg
|
||||
} {wrong # args: should be "break"}
|
||||
# Check for bug #406709
|
||||
test foreach-6.5 {break tests} {
|
||||
test foreach-6.5 {break tests} -body {
|
||||
proc a {} {
|
||||
set a 1
|
||||
foreach b b {list [concat a; break]; incr a}
|
||||
incr a
|
||||
}
|
||||
a
|
||||
} {2}
|
||||
} -cleanup {
|
||||
rename a {}
|
||||
} -result {2}
|
||||
|
||||
# Test for incorrect "double evaluation" semantics
|
||||
test foreach-7.1 {delayed substitution of body} {
|
||||
|
||||
@@ -21,6 +21,7 @@ testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
|
||||
testConstraint wideIs64bit \
|
||||
[expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
|
||||
testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
|
||||
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
|
||||
|
||||
test format-1.1 {integer formatting} {
|
||||
format "%*d %d %d %d" 6 34 16923 -12 -1
|
||||
@@ -273,13 +274,13 @@ test format-6.1 {floating-point zeroes} {eformat} {
|
||||
test format-6.2 {floating-point zeroes} {eformat} {
|
||||
format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0
|
||||
} {0.0000e+00 0.0000 0}
|
||||
test format-6.3 {floating-point zeroes} {eformat} {
|
||||
test format-6.3 {floating-point zeroes} {eformat knownMsvcBug} {
|
||||
format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0
|
||||
} {0.0000e+00 0.0000 0.000}
|
||||
test format-6.4 {floating-point zeroes} {eformat} {
|
||||
format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0
|
||||
} {0e+00 0 0}
|
||||
test format-6.5 {floating-point zeroes} {eformat} {
|
||||
test format-6.5 {floating-point zeroes} {eformat knownMsvcBug} {
|
||||
format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0
|
||||
} {0.e+00 0. 0.}
|
||||
test format-6.6 {floating-point zeroes} {
|
||||
@@ -585,6 +586,20 @@ test format-19.3 {Bug 2830354} {
|
||||
string length [format %340f 0]
|
||||
} 340
|
||||
|
||||
test format-19.4.1 {Bug d498578df4: width overflow should cause limit exceeded} \
|
||||
-constraints {longIs32bit} -body {
|
||||
# in case of overflow into negative, it produces width -2 (and limit exceeded),
|
||||
# in case of width will be unsigned, it will be outside limit (2GB for 32bit)...
|
||||
# and it don't throw an error in case the bug is not fixed (and probably no segfault).
|
||||
format %[expr {0xffffffff - 1}]g 0
|
||||
} -returnCodes error -result "max size for a Tcl value exceeded"
|
||||
|
||||
test format-19.4.2 {Bug d498578df4: width overflow should cause limit exceeded} -body {
|
||||
# limit should exceeds in any case,
|
||||
# and it don't throw an error in case the bug is not fixed (and probably no segfault).
|
||||
format %[expr {0xffffffffffffffff - 1}]g 0
|
||||
} -returnCodes error -result "max size for a Tcl value exceeded"
|
||||
|
||||
# Note that this test may fail in future versions
|
||||
test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
|
||||
set x [dict create a b c d]
|
||||
|
||||
@@ -86,7 +86,7 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
|
||||
test http-1.1 {http::config} {
|
||||
http::config -useragent UserAgent
|
||||
http::config
|
||||
} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"]
|
||||
} [list -accept */* -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1]
|
||||
test http-1.2 {http::config} {
|
||||
http::config -proxyfilter
|
||||
} http::ProxyRequired
|
||||
@@ -101,10 +101,10 @@ test http-1.4 {http::config} {
|
||||
set x [http::config]
|
||||
http::config {*}$savedconf
|
||||
set x
|
||||
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}}
|
||||
} {-accept */* -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1}
|
||||
test http-1.5 {http::config} -returnCodes error -body {
|
||||
http::config -proxyhost {} -junk 8080
|
||||
} -result {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}
|
||||
} -result {Unknown option -junk, must be: -accept, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip}
|
||||
test http-1.6 {http::config} -setup {
|
||||
set oldenc [http::config -urlencoding]
|
||||
} -body {
|
||||
@@ -190,7 +190,7 @@ test http-3.7 {http::geturl} -body {
|
||||
<h2>GET $tail</h2>
|
||||
</body></html>"
|
||||
test http-3.8 {http::geturl} -body {
|
||||
set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000]
|
||||
set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 3000]
|
||||
http::data $token
|
||||
} -cleanup {
|
||||
http::cleanup $token
|
||||
@@ -356,7 +356,7 @@ test http-3.24 {http::geturl parse failures} -body {
|
||||
test http-3.25 {http::meta} -setup {
|
||||
unset -nocomplain m token
|
||||
} -body {
|
||||
set token [http::geturl $url -timeout 2000]
|
||||
set token [http::geturl $url -timeout 3000]
|
||||
array set m [http::meta $token]
|
||||
lsort [array names m]
|
||||
} -cleanup {
|
||||
@@ -366,7 +366,7 @@ test http-3.25 {http::meta} -setup {
|
||||
test http-3.26 {http::meta} -setup {
|
||||
unset -nocomplain m token
|
||||
} -body {
|
||||
set token [http::geturl $url -headers {X-Check 1} -timeout 2000]
|
||||
set token [http::geturl $url -headers {X-Check 1} -timeout 3000]
|
||||
array set m [http::meta $token]
|
||||
lsort [array names m]
|
||||
} -cleanup {
|
||||
@@ -592,7 +592,7 @@ test http-4.14 {http::Event} -body {
|
||||
test http-4.15 {http::Event} -body {
|
||||
# This test may fail if you use a proxy server. That is to be
|
||||
# expected and is not a problem with Tcl.
|
||||
set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command \#]
|
||||
set token [http::geturl //not_a_host.tcl.tk -timeout 3000 -command \#]
|
||||
http::wait $token
|
||||
http::status $token
|
||||
# error codes vary among platforms.
|
||||
|
||||
@@ -515,10 +515,7 @@ proc handler {var sock token} {
|
||||
set chunk [read $sock]
|
||||
append data $chunk
|
||||
#::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])"
|
||||
if {[eof $sock]} {
|
||||
#::http::Log "handler eof $sock"
|
||||
chan event $sock readable {}
|
||||
}
|
||||
return [string length $chunk]
|
||||
}
|
||||
|
||||
test http11-3.0 "-handler,close,identity" -setup {
|
||||
@@ -666,6 +663,13 @@ test http11-4.3 "normal post request, check channel query length" -setup {
|
||||
|
||||
# -------------------------------------------------------------------------
|
||||
|
||||
# Eliminate valgrind "still reachable" reports on outstanding "Detached"
|
||||
# structures in the detached list which stem from PipeClose2Proc not waiting
|
||||
# around for background processes to complete, meaning that previous calls to
|
||||
# Tcl_ReapDetachedProcs might not have had a chance to reap all processes.
|
||||
after 10
|
||||
exec [info nameofexecutable] << {}
|
||||
|
||||
foreach p {create_httpd httpd_read halt_httpd meta check_crc} {
|
||||
if {[llength [info proc $p]]} {rename $p {}}
|
||||
}
|
||||
|
||||
866
tests/httpPipeline.test
Normal file
866
tests/httpPipeline.test
Normal file
@@ -0,0 +1,866 @@
|
||||
# httpPipeline.test
|
||||
#
|
||||
# Test HTTP/1.1 concurrent requests including
|
||||
# queueing, pipelining and retries.
|
||||
#
|
||||
# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
|
||||
package require http 2.8
|
||||
|
||||
set sourcedir [file normalize [file dirname [info script]]]
|
||||
source [file join $sourcedir httpTest.tcl]
|
||||
source [file join $sourcedir httpTestScript.tcl]
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# (1) Define the test scripts that will be used to generate logs for analysis -
|
||||
# and also define the "correct" results.
|
||||
# ------------------------------------------------------------------------------
|
||||
|
||||
proc ReturnTestScriptAndResult {ca cb delay te} {
|
||||
|
||||
switch -- $ca {
|
||||
1 {set start {
|
||||
START
|
||||
KEEPALIVE 0
|
||||
PIPELINE 0
|
||||
}}
|
||||
|
||||
2 {set start {
|
||||
START
|
||||
KEEPALIVE 0
|
||||
PIPELINE 1
|
||||
}}
|
||||
|
||||
3 {set start {
|
||||
START
|
||||
KEEPALIVE 1
|
||||
PIPELINE 0
|
||||
}}
|
||||
|
||||
4 {set start {
|
||||
START
|
||||
KEEPALIVE 1
|
||||
PIPELINE 1
|
||||
}}
|
||||
|
||||
default {
|
||||
return -code error {no matching script}
|
||||
}
|
||||
}
|
||||
|
||||
set middle "
|
||||
[list DELAY $delay]
|
||||
"
|
||||
|
||||
switch -- $cb {
|
||||
1 {set end {
|
||||
GET a
|
||||
GET b
|
||||
GET c
|
||||
GET a
|
||||
STOP
|
||||
}
|
||||
set resShort {1 ? ? ?}
|
||||
set resLong {1 2 3 4}
|
||||
}
|
||||
|
||||
2 {set end {
|
||||
GET a
|
||||
HEAD b
|
||||
GET c
|
||||
HEAD a
|
||||
HEAD c
|
||||
STOP
|
||||
}
|
||||
set resShort {1 ? ? ? ?}
|
||||
set resLong {1 2 3 4 5}
|
||||
}
|
||||
|
||||
3 {set end {
|
||||
HEAD a
|
||||
GET b
|
||||
HEAD c
|
||||
HEAD b
|
||||
GET a
|
||||
GET b
|
||||
STOP
|
||||
}
|
||||
set resShort {1 ? ? ? ? ?}
|
||||
set resLong {1 2 3 4 5 6}
|
||||
}
|
||||
|
||||
4 {set end {
|
||||
GET a
|
||||
GET b
|
||||
GET c
|
||||
GET a
|
||||
POST b address=home code=brief paid=yes
|
||||
GET c
|
||||
GET a
|
||||
GET b
|
||||
GET c
|
||||
STOP
|
||||
}
|
||||
set resShort {1 ? ? ? 5 ? ? ? ?}
|
||||
set resLong {1 2 3 4 5 6 7 8 9}
|
||||
}
|
||||
|
||||
5 {set end {
|
||||
POST a address=home code=brief paid=yes
|
||||
POST b address=home code=brief paid=yes
|
||||
POST c address=home code=brief paid=yes
|
||||
POST a address=home code=brief paid=yes
|
||||
POST b address=home code=brief paid=yes
|
||||
POST c address=home code=brief paid=yes
|
||||
POST a address=home code=brief paid=yes
|
||||
POST b address=home code=brief paid=yes
|
||||
POST c address=home code=brief paid=yes
|
||||
STOP
|
||||
}
|
||||
set resShort {1 2 3 4 5 6 7 8 9}
|
||||
set resLong {1 2 3 4 5 6 7 8 9}
|
||||
}
|
||||
|
||||
6 {set end {
|
||||
POST a address=home code=brief paid=yes
|
||||
GET b address=home code=brief paid=yes
|
||||
POST c address=home code=brief paid=yes
|
||||
GET a address=home code=brief paid=yes
|
||||
GET b address=home code=brief paid=yes
|
||||
POST c address=home code=brief paid=yes
|
||||
POST a address=home code=brief paid=yes
|
||||
HEAD b address=home code=brief paid=yes
|
||||
GET c address=home code=brief paid=yes
|
||||
STOP
|
||||
}
|
||||
set resShort {1 ? 3 ? ? 6 7 ? ?}
|
||||
set resLong {1 2 3 4 5 6 7 8 9}
|
||||
}
|
||||
|
||||
7 {set end {
|
||||
GET b address=home code=brief paid=yes
|
||||
POST a address=home code=brief paid=yes
|
||||
GET a address=home code=brief paid=yes
|
||||
POST c address=home code=brief paid=yes
|
||||
GET b address=home code=brief paid=yes
|
||||
HEAD b address=home code=brief paid=yes
|
||||
POST c address=home code=brief paid=yes
|
||||
POST a address=home code=brief paid=yes
|
||||
GET c address=home code=brief paid=yes
|
||||
STOP
|
||||
}
|
||||
set resShort {1 2 ? 4 ? ? 7 8 ?}
|
||||
set resLong {1 2 3 4 5 6 7 8 9}
|
||||
}
|
||||
|
||||
8 {set end {
|
||||
# Telling the server to close the connection.
|
||||
GET a
|
||||
GET b close=y
|
||||
GET c
|
||||
GET a
|
||||
GET b
|
||||
GET c
|
||||
GET a
|
||||
GET b
|
||||
GET c
|
||||
STOP
|
||||
}
|
||||
set resShort {1 ? 3 ? ? ? ? ? ?}
|
||||
set resLong {1 2 3 4 5 6 7 8 9}
|
||||
}
|
||||
|
||||
9 {set end {
|
||||
# Telling the server to close the connection.
|
||||
GET a
|
||||
POST b close=y address=home code=brief paid=yes
|
||||
GET c
|
||||
GET a
|
||||
GET b
|
||||
GET c
|
||||
GET a
|
||||
GET b
|
||||
GET c
|
||||
STOP
|
||||
}
|
||||
set resShort {1 2 3 ? ? ? ? ? ?}
|
||||
set resLong {1 2 3 4 5 6 7 8 9}
|
||||
}
|
||||
|
||||
10 {set end {
|
||||
# Telling the server to close the connection.
|
||||
GET a
|
||||
GET b close=y
|
||||
POST c address=home code=brief paid=yes
|
||||
GET a
|
||||
GET b
|
||||
GET c
|
||||
GET a
|
||||
GET b
|
||||
GET c
|
||||
STOP
|
||||
}
|
||||
set resShort {1 ? 3 ? ? ? ? ? ?}
|
||||
set resLong {1 2 3 4 5 6 7 8 9}
|
||||
}
|
||||
|
||||
11 {set end {
|
||||
# Telling the server to close the connection twice.
|
||||
GET a
|
||||
GET b close=y
|
||||
GET c
|
||||
GET a
|
||||
GET b close=y
|
||||
GET c
|
||||
GET a
|
||||
GET b
|
||||
GET c
|
||||
STOP
|
||||
}
|
||||
set resShort {1 ? 3 ? ? 6 ? ? ?}
|
||||
set resLong {1 2 3 4 5 6 7 8 9}
|
||||
}
|
||||
|
||||
12 {set end {
|
||||
# Telling the server to delay before sending the response.
|
||||
GET a
|
||||
GET b delay=1
|
||||
GET c
|
||||
GET a
|
||||
GET b
|
||||
STOP
|
||||
}
|
||||
set resShort {1 ? ? ? ?}
|
||||
set resLong {1 2 3 4 5}
|
||||
}
|
||||
|
||||
13 {set end {
|
||||
# Making the server close the connection (time out).
|
||||
GET a
|
||||
WAIT 2000
|
||||
GET b
|
||||
GET c
|
||||
GET a
|
||||
GET b
|
||||
STOP
|
||||
}
|
||||
set resShort {1 2 ? ? ?}
|
||||
set resLong {1 2 3 4 5}
|
||||
}
|
||||
|
||||
14 {set end {
|
||||
# Making the server close the connection (time out) twice.
|
||||
GET a
|
||||
WAIT 2000
|
||||
GET b
|
||||
GET c
|
||||
GET a
|
||||
WAIT 2000
|
||||
GET b
|
||||
GET c
|
||||
GET a
|
||||
GET b
|
||||
GET c
|
||||
STOP
|
||||
}
|
||||
set resShort {1 2 ? ? 5 ? ? ? ?}
|
||||
set resLong {1 2 3 4 5 6 7 8 9}
|
||||
}
|
||||
|
||||
15 {set end {
|
||||
POST a address=home code=brief paid=yes
|
||||
POST b address=home code=brief paid=yes close=y delay=1
|
||||
POST c address=home code=brief paid=yes delay=1
|
||||
POST a address=home code=brief paid=yes close=y
|
||||
WAIT 2000
|
||||
POST b address=home code=brief paid=yes delay=1
|
||||
POST c address=home code=brief paid=yes close=y
|
||||
POST a address=home code=brief paid=yes
|
||||
POST b address=home code=brief paid=yes close=y
|
||||
POST c address=home code=brief paid=yes
|
||||
STOP
|
||||
}
|
||||
set resShort {1 2 3 4 5 6 7 8 9}
|
||||
set resLong {1 2 3 4 5 6 7 8 9}
|
||||
}
|
||||
|
||||
16 {set end {
|
||||
POST a address=home code=brief paid=yes
|
||||
GET b address=home code=brief paid=yes
|
||||
POST c address=home code=brief paid=yes close=y
|
||||
GET a address=home code=brief paid=yes
|
||||
GET b address=home code=brief paid=yes close=y
|
||||
POST c address=home code=brief paid=yes
|
||||
WAIT 2000
|
||||
POST a address=home code=brief paid=yes
|
||||
HEAD b address=home code=brief paid=yes close=y
|
||||
GET c address=home code=brief paid=yes
|
||||
STOP
|
||||
}
|
||||
set resShort {1 ? 3 4 ? 6 7 ? 9}
|
||||
set resLong {1 2 3 4 5 6 7 8 9}
|
||||
}
|
||||
|
||||
17 {set end {
|
||||
GET b address=home code=brief paid=yes
|
||||
POST a address=home code=brief paid=yes
|
||||
GET a address=home code=brief paid=yes
|
||||
POST c address=home code=brief paid=yes close=y
|
||||
GET b address=home code=brief paid=yes
|
||||
HEAD b address=home code=brief paid=yes close=y
|
||||
POST c address=home code=brief paid=yes
|
||||
WAIT 2000
|
||||
POST a address=home code=brief paid=yes
|
||||
WAIT 2000
|
||||
GET c address=home code=brief paid=yes
|
||||
STOP
|
||||
}
|
||||
set resShort {1 2 3 4 5 ? 7 8 9}
|
||||
set resLong {1 2 3 4 5 6 7 8 9}
|
||||
}
|
||||
|
||||
|
||||
18 {set end {
|
||||
REPOST 0
|
||||
GET a
|
||||
WAIT 2000
|
||||
POST b address=home code=brief paid=yes
|
||||
GET c
|
||||
GET a
|
||||
STOP
|
||||
}
|
||||
set resShort {1 2 ? ?}
|
||||
set resLong {1 2 3 4}
|
||||
# resShort is overwritten below for the case ($te == 1).
|
||||
}
|
||||
|
||||
|
||||
19 {set end {
|
||||
REPOST 0
|
||||
GET a
|
||||
WAIT 2000
|
||||
GET b address=home code=brief paid=yes
|
||||
GET c
|
||||
GET a
|
||||
STOP
|
||||
}
|
||||
set resShort {1 2 ? ?}
|
||||
set resLong {1 2 3 4}
|
||||
}
|
||||
|
||||
|
||||
20 {set end {
|
||||
POSTFRESH 1
|
||||
GET a
|
||||
WAIT 2000
|
||||
POST b address=home code=brief paid=yes
|
||||
GET c
|
||||
GET a
|
||||
STOP
|
||||
}
|
||||
set resShort {1 3 ?}
|
||||
set resLong {1 3 4}
|
||||
}
|
||||
|
||||
|
||||
21 {set end {
|
||||
POSTFRESH 1
|
||||
GET a
|
||||
WAIT 2000
|
||||
GET b address=home code=brief paid=yes
|
||||
GET c
|
||||
GET a
|
||||
STOP
|
||||
}
|
||||
set resShort {1 2 ? ?}
|
||||
set resLong {1 2 3 4}
|
||||
}
|
||||
|
||||
22 {set end {
|
||||
GET a
|
||||
WAIT 2000
|
||||
KEEPALIVE 0
|
||||
POST b address=home code=brief paid=yes
|
||||
KEEPALIVE 1
|
||||
GET c
|
||||
GET a
|
||||
STOP
|
||||
}
|
||||
set resShort {1 3 ?}
|
||||
set resLong {1 3 4}
|
||||
}
|
||||
|
||||
|
||||
23 {set end {
|
||||
GET a
|
||||
WAIT 2000
|
||||
KEEPALIVE 0
|
||||
GET b address=home code=brief paid=yes
|
||||
KEEPALIVE 1
|
||||
GET c
|
||||
GET a
|
||||
STOP
|
||||
}
|
||||
set resShort {1 3 ?}
|
||||
set resLong {1 3 4}
|
||||
}
|
||||
|
||||
24 {set end {
|
||||
GET a
|
||||
KEEPALIVE 0
|
||||
POST b address=home code=brief paid=yes
|
||||
KEEPALIVE 1
|
||||
GET c
|
||||
GET a
|
||||
STOP
|
||||
}
|
||||
set resShort {1 ? ?}
|
||||
set resLong {1 3 4}
|
||||
}
|
||||
|
||||
|
||||
25 {set end {
|
||||
GET a
|
||||
KEEPALIVE 0
|
||||
GET b address=home code=brief paid=yes
|
||||
KEEPALIVE 1
|
||||
GET c
|
||||
GET a
|
||||
STOP
|
||||
}
|
||||
set resShort {1 ? ?}
|
||||
set resLong {1 3 4}
|
||||
}
|
||||
|
||||
default {
|
||||
return -code error {no matching script}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if {$ca < 3} {
|
||||
# Not Keep-Alive.
|
||||
set result "Passed all sanity checks."
|
||||
|
||||
} elseif {$ca == 3} {
|
||||
# Keep-Alive, not pipelined.
|
||||
set result {}
|
||||
append result "Passed all sanity checks.\n"
|
||||
append result "Have overlaps including response body:\n"
|
||||
|
||||
} else {
|
||||
# Keep-Alive, pipelined: ($ca == 4)
|
||||
set result {}
|
||||
append result "Passed all sanity checks.\n"
|
||||
append result "Overlap-free without response body:\n"
|
||||
append result "$resShort"
|
||||
}
|
||||
|
||||
# - The special case of test *.18*-testEof needs test results to be
|
||||
# individually written.
|
||||
# - These test -repost 0 when there is a POST to apply it to, and the server
|
||||
# timeout has not been detected.
|
||||
if {($cb == 18) && ($te == 1)} {
|
||||
if {$ca < 3} {
|
||||
# Not Keep-Alive.
|
||||
set result "Passed all sanity checks."
|
||||
|
||||
} elseif {$ca == 3 && $delay == 0} {
|
||||
# Keep-Alive, not pipelined.
|
||||
set result [MakeMessage {
|
||||
|Problems with sanity checks:
|
||||
|Wrong sequence for token ::http::2 - {A B C D X X X}
|
||||
|- and error(s) X
|
||||
|Wrong sequence for token ::http::3 - {A X X}
|
||||
|- and error(s) X
|
||||
|Wrong sequence for token ::http::4 - {A X X X}
|
||||
|- and error(s) X
|
||||
|
|
||||
|Have overlaps including response body:
|
||||
|
|
||||
}]
|
||||
|
||||
} elseif {$ca == 3} {
|
||||
# Keep-Alive, not pipelined.
|
||||
set result [MakeMessage {
|
||||
|Problems with sanity checks:
|
||||
|Wrong sequence for token ::http::2 - {A B C D X X X}
|
||||
|- and error(s) X
|
||||
|
|
||||
|Have overlaps including response body:
|
||||
|
|
||||
}]
|
||||
|
||||
} elseif {$delay == 0} {
|
||||
# Keep-Alive, pipelined: ($ca == 4)
|
||||
set result [MakeMessage {
|
||||
|Problems with sanity checks:
|
||||
|Wrong sequence for token ::http::2 - {A B C D X X X}
|
||||
|- and error(s) X
|
||||
|Wrong sequence for token ::http::3 - {A X X}
|
||||
|- and error(s) X
|
||||
|Wrong sequence for token ::http::4 - {A X X X}
|
||||
|- and error(s) X
|
||||
|
|
||||
|Overlap-free without response body:
|
||||
|
|
||||
}]
|
||||
|
||||
} else {
|
||||
set result [MakeMessage {
|
||||
|Problems with sanity checks:
|
||||
|Wrong sequence for token ::http::2 - {A B C D X X X}
|
||||
|- and error(s) X
|
||||
|
|
||||
|Overlap-free without response body:
|
||||
|
|
||||
}]
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
return [list "$start$middle$end" $result]
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# Proc MakeMessage
|
||||
# ------------------------------------------------------------------------------
|
||||
# WHD's one-line command to generate multi-line strings from readable code.
|
||||
#
|
||||
# Example:
|
||||
# set blurb [MakeMessage {
|
||||
# |This command allows multi-line strings to be created with readable
|
||||
# |code, and without breaking the rules for indentation.
|
||||
# |
|
||||
# |The command shifts the entire block of text to the left, omitting
|
||||
# |the pipe character and the spaces to its left.
|
||||
# }]
|
||||
# ------------------------------------------------------------------------------
|
||||
|
||||
proc MakeMessage {in} {
|
||||
regsub -all -line {^\s*\|} [string trim $in] {}
|
||||
# N.B. Implicit Return.
|
||||
}
|
||||
|
||||
|
||||
proc ReturnTestScript {ca cb delay te} {
|
||||
lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result
|
||||
return $script
|
||||
}
|
||||
|
||||
proc ReturnTestResult {ca cb delay te} {
|
||||
lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result
|
||||
return $result
|
||||
}
|
||||
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# (2) Command to run a test script and use httpTest to analyse the logs.
|
||||
# ------------------------------------------------------------------------------
|
||||
|
||||
namespace import httpTestScript::runHttpTestScript
|
||||
namespace import httpTestScript::cleanupHttpTestScript
|
||||
namespace import httpTest::cleanupHttpTest
|
||||
namespace import httpTest::logAnalyse
|
||||
namespace import httpTest::setHttpTestOptions
|
||||
|
||||
proc RunTest {header footer delay te} {
|
||||
set num [runHttpTestScript [ReturnTestScript $header $footer $delay $te]]
|
||||
set skipOverlaps 0
|
||||
set notPiped {}
|
||||
set notIncluded {}
|
||||
|
||||
# --------------------------------------------------------------------------
|
||||
# Custom code for specific tests
|
||||
# --------------------------------------------------------------------------
|
||||
if {$header < 3} {
|
||||
set skipOverlaps 1
|
||||
for {set i 1} {$i <= $num} {incr i} {
|
||||
lappend notPiped $i
|
||||
}
|
||||
} elseif {$header > 2 && $footer == 18 && $te == 1} {
|
||||
set skipOverlaps 1
|
||||
if {$delay == 0} {
|
||||
# Transaction 1 is conventional.
|
||||
# Check that transactions 2,3,4 are cancelled.
|
||||
set notPiped {1}
|
||||
set notIncluded $notPiped
|
||||
} else {
|
||||
# Transaction 1 is conventional.
|
||||
# Check that transaction 2 is cancelled.
|
||||
# The timing of transactions 3 and 4 is uncertain.
|
||||
set notPiped {1 3 4}
|
||||
set notIncluded $notPiped
|
||||
}
|
||||
} elseif {$footer in {20 22 23 24 25}} {
|
||||
# Transaction 2 uses its own socket.
|
||||
set notPiped 2
|
||||
set notIncluded $notPiped
|
||||
} else {
|
||||
}
|
||||
# --------------------------------------------------------------------------
|
||||
# End of custom code for specific tests
|
||||
# --------------------------------------------------------------------------
|
||||
|
||||
|
||||
set Results [logAnalyse $num $skipOverlaps $notIncluded $notPiped]
|
||||
lassign $Results msg cleanE cleanF dirtyE dirtyF
|
||||
if {$msg eq {}} {
|
||||
set msg "Passed all sanity checks."
|
||||
} else {
|
||||
set msg "Problems with sanity checks:\n$msg"
|
||||
}
|
||||
|
||||
if 0 {
|
||||
puts $msg
|
||||
puts "Overlap-free including response body:\n$cleanF"
|
||||
puts "Have overlaps including response body:\n$dirtyF"
|
||||
puts "Overlap-free without response body:\n$cleanE"
|
||||
puts "Have overlaps without response body:\n$dirtyE"
|
||||
}
|
||||
|
||||
if {$header < 3} {
|
||||
# No ordering, just check that transactions all finish
|
||||
set result $msg
|
||||
} elseif {$header == 3} {
|
||||
# Not pipelined - check overlaps with response body.
|
||||
set result "$msg\nHave overlaps including response body:\n$dirtyF"
|
||||
} else {
|
||||
# Pipelined - check overlaps without response body. Check that the
|
||||
# first request, the first requests after replay, and POSTs are clean.
|
||||
set result "$msg\nOverlap-free without response body:\n$cleanE"
|
||||
}
|
||||
set ::nTokens $num
|
||||
return $result
|
||||
}
|
||||
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# (3) VERBOSITY CONTROL
|
||||
# ------------------------------------------------------------------------------
|
||||
# If tests fail, run an individual test with -verbose 1 or 2 for diagnosis.
|
||||
# If still obscure, uncomment #Log and ##Log lines in the http package.
|
||||
# ------------------------------------------------------------------------------
|
||||
|
||||
setHttpTestOptions -verbose 0
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# (4) Define the base URLs used for testing. Each must have a query string.
|
||||
# ------------------------------------------------------------------------------
|
||||
# - A HTTP/1.1 server is required. It should be configured to provide
|
||||
# persistent connections when requested to do so, and to close these
|
||||
# connections if they are idle for one second.
|
||||
# - The resource must be served with status 200 in response to a valid GET or
|
||||
# POST.
|
||||
# - The value of "page" is always specified in the query-string. Different
|
||||
# resources for the three values of "page" allow testing of both chunked and
|
||||
# unchunked transfer encoding.
|
||||
# - The variables "close" and "delay" may be specified in the query-string (for
|
||||
# a GET) or the request body (for a POST).
|
||||
# - "delay" is a numerical value in seconds, and causes the server to delay
|
||||
# the response, including headers.
|
||||
# - "close", if it has the value "y", instructs the server to close the
|
||||
# connection ater the current request.
|
||||
# - Any other variables should be ignored.
|
||||
# ------------------------------------------------------------------------------
|
||||
|
||||
namespace eval ::httpTestScript {
|
||||
variable URL
|
||||
array set URL {
|
||||
a http://test-tcl-http.kerlin.org/index.html?page=privacy
|
||||
b http://test-tcl-http.kerlin.org/index.html?page=conditions
|
||||
c http://test-tcl-http.kerlin.org/index.html?page=welcome
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# (5) Define the tests
|
||||
# ------------------------------------------------------------------------------
|
||||
# Constraints:
|
||||
# - serverNeeded - the URLs defined at (4) must be available, and must have the
|
||||
# properties specified there.
|
||||
# - duplicate - the value of -pipeline does not matter if -keepalive 0
|
||||
# - timeout1s - tests that work correctly only if the server closes
|
||||
# persistent connections after one second.
|
||||
#
|
||||
# Server timeout of persistent connections should be 1s. Delays of 2s are
|
||||
# intended to cause timeout.
|
||||
# Servers are usually configured to use a longer timeout: this will cause the
|
||||
# tests to fail. The "2000" could be replaced with a larger number, but the
|
||||
# tests will then be inconveniently slow.
|
||||
# ------------------------------------------------------------------------------
|
||||
|
||||
#testConstraint serverNeeded 1
|
||||
#testConstraint timeout1s 1
|
||||
#testConstraint duplicate 1
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# Proc SetTestEof - to edit the command ::http::KeepSocket
|
||||
# ------------------------------------------------------------------------------
|
||||
# The usual line in command ::http::KeepSocket is " set TEST_EOF 0".
|
||||
# Whether the value set in the file is 0 or 1, change it here to the value
|
||||
# specified by the argument.
|
||||
#
|
||||
# It is worth doing all tests for both values of the argument.
|
||||
#
|
||||
# test 0 - ::http::KeepSocket is unchanged, detects server eof where possible
|
||||
# and closes the connection.
|
||||
# test 1 - ::http::KeepSocket is edited, does not detect server eof, so the
|
||||
# reaction to finding server eof can be tested without the difficulty
|
||||
# of testing in the few milliseconds of an asynchronous close event.
|
||||
# ------------------------------------------------------------------------------
|
||||
|
||||
proc SetTestEof {test} {
|
||||
set body [info body ::http::KeepSocket]
|
||||
set subs " set TEST_EOF $test"
|
||||
set count [regsub -line -all -- {^\s*set TEST_EOF .*$} $body $subs newBody]
|
||||
if {$count != 1} {
|
||||
return -code error {proc ::http::KeepSocket has unexpected form}
|
||||
}
|
||||
proc ::http::KeepSocket {token} $newBody
|
||||
return
|
||||
}
|
||||
|
||||
for {set header 1} {$header <= 4} {incr header} {
|
||||
if {$header == 4} {
|
||||
setHttpTestOptions -dotted 1
|
||||
set match glob
|
||||
} else {
|
||||
setHttpTestOptions -dotted 0
|
||||
set match exact
|
||||
}
|
||||
|
||||
if {$header == 2} {
|
||||
set cons0 {serverNeeded duplicate}
|
||||
} else {
|
||||
set cons0 serverNeeded
|
||||
}
|
||||
|
||||
for {set footer 1} {$footer <= 25} {incr footer} {
|
||||
foreach {delay label} {
|
||||
0 a
|
||||
1 b
|
||||
2 c
|
||||
3 d
|
||||
5 e
|
||||
8 f
|
||||
12 g
|
||||
100 h
|
||||
500 i
|
||||
2000 j
|
||||
} {
|
||||
foreach te {0 1} {
|
||||
if {$te} {
|
||||
set tag testEof
|
||||
} else {
|
||||
set tag normal
|
||||
}
|
||||
set suffix {}
|
||||
set cons $cons0
|
||||
|
||||
# ------------------------------------------------------------------
|
||||
# Custom code for individual tests
|
||||
# ------------------------------------------------------------------
|
||||
if {$footer in {18}} {
|
||||
# Custom code:
|
||||
if {($label eq "j") && ($te == 1)} {
|
||||
continue
|
||||
}
|
||||
if {$te == 1} {
|
||||
# The test (of REPOST 0) is useful if tag is "testEof"
|
||||
# (server timeout without client reaction). The same test
|
||||
# has a different result if tag is "normal".
|
||||
|
||||
set suffix " - extra test for -repost 0 - ::http::2 must be"
|
||||
append suffix " cancelled"
|
||||
if {($delay == 0)} {
|
||||
append suffix ", along with ::http::3 ::http::4 if"
|
||||
append suffix " the test creates these before ::http::2"
|
||||
append suffix " is cancelled"
|
||||
}
|
||||
} else {
|
||||
}
|
||||
} elseif {$footer in {19}} {
|
||||
set suffix " - extra test for -repost 0"
|
||||
} elseif {$footer in {20 21}} {
|
||||
set suffix " - extra test for -postfresh 1"
|
||||
if {($footer == 20)} {
|
||||
append suffix " - ::http::2 uses a separate socket"
|
||||
append suffix ", other requests use a persistent connection"
|
||||
}
|
||||
} elseif {$footer in {22 23 24 25}} {
|
||||
append suffix " - ::http::2 uses a separate socket"
|
||||
append suffix ", other requests use a persistent connection"
|
||||
} else {
|
||||
}
|
||||
|
||||
if {($footer >= 13 && $footer <= 23)} {
|
||||
# Test use WAIT and depend on server timeout before this time.
|
||||
lappend cons timeout1s
|
||||
}
|
||||
# ------------------------------------------------------------------
|
||||
# End of custom code.
|
||||
# ------------------------------------------------------------------
|
||||
|
||||
set name "pipeline test header $header footer $footer delay $delay $tag$suffix"
|
||||
|
||||
|
||||
# Here's the test:
|
||||
test httpPipeline-${header}.${footer}${label}-${tag} $name \
|
||||
-constraints $cons \
|
||||
-setup [string map [list TE $te] {
|
||||
# Restore default values for tests:
|
||||
http::config -pipeline 1 -postfresh 0 -repost 1
|
||||
http::init
|
||||
set http::http(uid) 0
|
||||
SetTestEof {TE}
|
||||
}] -body [list RunTest $header $footer $delay $te] -cleanup {
|
||||
# Restore default values for tests:
|
||||
http::config -pipeline 1 -postfresh 0 -repost 1
|
||||
cleanupHttpTestScript
|
||||
SetTestEof 0
|
||||
cleanupHttpTest
|
||||
after 2000
|
||||
# Wait for persistent sockets on the server to time out.
|
||||
} -result [ReturnTestResult $header $footer $delay $te] -match $match
|
||||
|
||||
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# (*) Notes on tests *.18*-testEof, *.19*-testEof - these test -repost 0
|
||||
# ------------------------------------------------------------------------------
|
||||
# These tests are a bit awkward because the main test kit analyses whether all
|
||||
# requests are satisfied, with retries if necessary, and it has result analysis
|
||||
# for processing retry logs.
|
||||
# - *.18*-testEof tests that certain requests are NOT satisfied, so the analysis
|
||||
# is a one-off.
|
||||
# - Tests *.18a-testEof depend on client/server timing - the test needs to call
|
||||
# http::geturl for all requests before the POST (request 2) is cancelled.
|
||||
# We test that requests 2, 3, 4 are all cancelled.
|
||||
# - Other tests *.18*-testEof may not request 3 and 4 in time for the to be
|
||||
# added to the write queue before request 2 is completed. We simply check that
|
||||
# request 2 is cancelled.
|
||||
# - The behaviour is different if all connections are allowed to time out
|
||||
# (label "j"). This case is not needed to test -repost 0, and is omitted.
|
||||
# - Tests *.18*-normal and *.19* are conventional (-repost 0 should have no
|
||||
# effect).
|
||||
# ------------------------------------------------------------------------------
|
||||
|
||||
|
||||
unset header footer delay label suffix match cons name te
|
||||
namespace delete ::httpTest
|
||||
namespace delete ::httpTestScript
|
||||
|
||||
::tcltest::cleanupTests
|
||||
505
tests/httpTest.tcl
Normal file
505
tests/httpTest.tcl
Normal file
@@ -0,0 +1,505 @@
|
||||
# httpTest.tcl
|
||||
#
|
||||
# Test HTTP/1.1 concurrent requests including
|
||||
# queueing, pipelining and retries.
|
||||
#
|
||||
# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# "Package" httpTest for analysis of Log output of http requests.
|
||||
# ------------------------------------------------------------------------------
|
||||
# This is a specialised test kit for examining the presence, ordering, and
|
||||
# overlap of multiple HTTP transactions over a persistent ("Keep-Alive")
|
||||
# connection; and also for testing reconnection in accordance with RFC 7230 when
|
||||
# the connection is lost.
|
||||
#
|
||||
# This kit is probably not useful for other purposes. It depends on the
|
||||
# presence of specific Log commands in the http library, and it interprets the
|
||||
# logs that these commands create.
|
||||
# ------------------------------------------------------------------------------
|
||||
|
||||
package require http
|
||||
|
||||
namespace eval ::http {
|
||||
variable TestStartTimeInMs [clock milliseconds]
|
||||
# catch {puts stdout "Start time (zero ms) is $TestStartTimeInMs"}
|
||||
}
|
||||
|
||||
namespace eval ::httpTest {
|
||||
variable testResults {}
|
||||
variable testOptions
|
||||
array set testOptions {
|
||||
-verbose 0
|
||||
-dotted 1
|
||||
}
|
||||
# -verbose - 0 quiet 1 write to stdout 2 write more
|
||||
# -dotted - (boolean) use dots for absences in lists of transactions
|
||||
}
|
||||
|
||||
proc httpTest::Puts {txt} {
|
||||
variable testOptions
|
||||
if {$testOptions(-verbose) > 0} {
|
||||
puts stdout $txt
|
||||
flush stdout
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
# http::Log
|
||||
#
|
||||
# A special-purpose logger used for running tests.
|
||||
# - Processes Log calls that have "^" in their arguments, and records them in
|
||||
# variable ::httpTest::testResults.
|
||||
# - Also writes them to stdout (using Puts) if ($testOptions(-verbose) > 0).
|
||||
# - Also writes Log calls that do not have "^", if ($testOptions(-verbose) > 1).
|
||||
|
||||
proc http::Log {args} {
|
||||
variable TestStartTimeInMs
|
||||
set time [expr {[clock milliseconds] - $TestStartTimeInMs}]
|
||||
set txt [list $time {*}$args]
|
||||
if {[string first ^ $txt] != -1} {
|
||||
::httpTest::LogRecord $txt
|
||||
::httpTest::Puts $txt
|
||||
} elseif {$::httpTest::testOptions(-verbose) > 1} {
|
||||
::httpTest::Puts $txt
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
|
||||
# Called by http::Log (the "testing" version) to record logs for later analysis.
|
||||
|
||||
proc httpTest::LogRecord {txt} {
|
||||
variable testResults
|
||||
|
||||
set pos [string first ^ $txt]
|
||||
set len [string length $txt]
|
||||
if {$pos > $len - 3} {
|
||||
puts stdout "Logging Error: $txt"
|
||||
puts stdout "Fix this call to Log in http-*.tm so it has ^ then\
|
||||
a letter then a numeral."
|
||||
flush stdout
|
||||
} elseif {$pos == -1} {
|
||||
# Called by mistake.
|
||||
} else {
|
||||
set letter [string index $txt [incr pos]]
|
||||
set number [string index $txt [incr pos]]
|
||||
# Max 9 requests!
|
||||
lappend testResults [list $letter $number]
|
||||
}
|
||||
|
||||
return
|
||||
}
|
||||
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# Commands for analysing the logs recorded when calling http::geturl.
|
||||
# ------------------------------------------------------------------------------
|
||||
|
||||
# httpTest::TestOverlaps --
|
||||
#
|
||||
# The main test for correct behaviour of pipelined and sequential
|
||||
# (non-pipelined) transactions. Other tests should be run first to detect
|
||||
# any inconsistencies in the data (e.g. absence of the elements that are
|
||||
# examined here).
|
||||
#
|
||||
# Examine the sequence $someResults for each transaction from 1 to $n,
|
||||
# ignoring any that are listed in $badTrans.
|
||||
# Determine whether the elements "B" to $term for one transaction overlap
|
||||
# elements "B" to $term for the previous and following transactions.
|
||||
#
|
||||
# Transactions in the list $badTrans are not included in "clean" or
|
||||
# "dirty", but their possible overlap with other transactions is noted.
|
||||
# Transactions in the list $notPiped are a subset of $badTrans, and
|
||||
# their possible overlap with other transactions is NOT noted.
|
||||
#
|
||||
# Arguments:
|
||||
# someResults - list of results, each of the form {letter numeral}
|
||||
# n - number of HTTP transactions
|
||||
# term - letter that indicated end of search range. "E" for testing
|
||||
# overlaps from start of request to end of response headers.
|
||||
# "F" to extend to the end of the response body.
|
||||
# msg - the cumulative message from sanity checks. Append to it only
|
||||
# to report a test failure.
|
||||
# badTrans - list of transaction numbers not to be assessed as "clean" or
|
||||
# "dirty"
|
||||
# notPiped - subset of badTrans. List of transaction numbers that cannot
|
||||
# taint another transaction by overlapping with it, because it
|
||||
# used a different socket.
|
||||
#
|
||||
# Return value: [list $msg $clean $dirty]
|
||||
# msg - warning messages: nothing will be appended to argument $msg if there
|
||||
# is an error with the test.
|
||||
# clean - list of transactions that have no overlap with other transactions
|
||||
# dirty - list of transactions that have YES overlap with other transactions
|
||||
|
||||
proc httpTest::TestOverlaps {someResults n term msg badTrans notPiped} {
|
||||
variable testOptions
|
||||
|
||||
# Check whether transactions overlap:
|
||||
set clean {}
|
||||
set dirty {}
|
||||
for {set i 1} {$i <= $n} {incr i} {
|
||||
if {$i in $badTrans} {
|
||||
continue
|
||||
}
|
||||
set myStart [lsearch -exact $someResults [list B $i]]
|
||||
set myEnd [lsearch -exact $someResults [list $term $i]]
|
||||
|
||||
if {($myStart == -1 || $myEnd == -1)} {
|
||||
set res "Cannot find positions of transaction $i"
|
||||
append msg $res \n
|
||||
Puts $res
|
||||
}
|
||||
|
||||
set overlaps {}
|
||||
for {set j $myStart} {$j <= $myEnd} {incr j} {
|
||||
lassign [lindex $someResults $j] letter number
|
||||
if {$number != $i && $letter ne "A" && $number ni $notPiped} {
|
||||
lappend overlaps $number
|
||||
}
|
||||
}
|
||||
|
||||
if {[llength $overlaps] == 0} {
|
||||
set res "Transaction $i has no overlaps"
|
||||
Puts $res
|
||||
lappend clean $i
|
||||
if {$testOptions(-dotted)} {
|
||||
# N.B. results from different segments are concatenated.
|
||||
lappend dirty .
|
||||
} else {
|
||||
}
|
||||
} else {
|
||||
set res "Transaction $i overlaps with [join $overlaps { }]"
|
||||
Puts $res
|
||||
lappend dirty $i
|
||||
if {$testOptions(-dotted)} {
|
||||
# N.B. results from different segments are concatenated.
|
||||
lappend clean .
|
||||
} else {
|
||||
}
|
||||
}
|
||||
}
|
||||
return [list $msg $clean $dirty]
|
||||
}
|
||||
|
||||
# httpTest::PipelineNext --
|
||||
#
|
||||
# Test whether prevPair, pair are valid as consecutive elements of a pipelined
|
||||
# sequence (Start 1), (End 1), (Start 2), (End 2) ...
|
||||
# Numbers are integers increasing (by 1 if argument "any" is false), and need
|
||||
# not begin with 1.
|
||||
# The first element of the sequence has prevPair {} and is always passed as
|
||||
# valid.
|
||||
#
|
||||
# Arguments;
|
||||
# Start - string that labels the start of a segment
|
||||
# End - string that labels the end of a segment
|
||||
# prevPair - previous "pair" (list of string and number) element of a
|
||||
# sequence, or {} if argument "pair" is the first in the
|
||||
# sequence.
|
||||
# pair - current "pair" (list of string and number) element of a
|
||||
# sequence
|
||||
# any - (boolean) iff true, accept any increasing sequence of integers.
|
||||
# If false, integers must increase by 1.
|
||||
#
|
||||
# Return value - boolean, true iff the two pairs are valid consecutive elements.
|
||||
|
||||
proc httpTest::PipelineNext {Start End prevPair pair any} {
|
||||
if {$prevPair eq {}} {
|
||||
return 1
|
||||
}
|
||||
|
||||
lassign $prevPair letter number
|
||||
lassign $pair newLetter newNumber
|
||||
if {$letter eq $Start} {
|
||||
return [expr {($newLetter eq $End) && ($newNumber == $number)}]
|
||||
} elseif {$any} {
|
||||
set nxt [list $Start [expr {$number + 1}]]
|
||||
return [expr {($newLetter eq $Start) && ($newNumber > $number)}]
|
||||
} else {
|
||||
set nxt [list $Start [expr {$number + 1}]]
|
||||
return [expr {($newLetter eq $Start) && ($newNumber == $number + 1)}]
|
||||
}
|
||||
}
|
||||
|
||||
# httpTest::TestPipeline --
|
||||
#
|
||||
# Given a sequence of "pair" elements, check that the elements whose string is
|
||||
# $Start or $End form a valid pipeline. Ignore other elements.
|
||||
#
|
||||
# Return value: {} if valid pipeline, otherwise a non-empty error message.
|
||||
|
||||
proc httpTest::TestPipeline {someResults n Start End msg desc badTrans} {
|
||||
set sequence {}
|
||||
set prevPair {}
|
||||
set ok 1
|
||||
set any [llength $badTrans]
|
||||
foreach pair $someResults {
|
||||
lassign $pair letter number
|
||||
if {($letter in [list $Start $End]) && ($number ni $badTrans)} {
|
||||
lappend sequence $pair
|
||||
if {![PipelineNext $Start $End $prevPair $pair $any]} {
|
||||
set ok 0
|
||||
break
|
||||
}
|
||||
set prevPair $pair
|
||||
}
|
||||
}
|
||||
|
||||
if {!$ok} {
|
||||
set res "$desc are not pipelined: {$sequence}"
|
||||
append msg $res \n
|
||||
Puts $res
|
||||
}
|
||||
return $msg
|
||||
}
|
||||
|
||||
# httpTest::TestSequence --
|
||||
#
|
||||
# Examine each transaction from 1 to $n, ignoring any that are listed
|
||||
# in $badTrans.
|
||||
# Check that each transaction has elements A to F, in alphabetical order.
|
||||
|
||||
proc httpTest::TestSequence {someResults n msg badTrans} {
|
||||
variable testOptions
|
||||
|
||||
for {set i 1} {$i <= $n} {incr i} {
|
||||
if {$i in $badTrans} {
|
||||
continue
|
||||
}
|
||||
set sequence {}
|
||||
foreach pair $someResults {
|
||||
lassign $pair letter number
|
||||
if {$number == $i} {
|
||||
lappend sequence $letter
|
||||
}
|
||||
}
|
||||
if {$sequence eq {A B C D E F}} {
|
||||
} else {
|
||||
set res "Wrong sequence for token ::http::$i - {$sequence}"
|
||||
append msg $res \n
|
||||
Puts $res
|
||||
if {"X" in $sequence} {
|
||||
set res "- and error(s) X"
|
||||
append msg $res \n
|
||||
Puts $res
|
||||
}
|
||||
if {"Y" in $sequence} {
|
||||
set res "- and warnings(s) Y"
|
||||
append msg $res \n
|
||||
Puts $res
|
||||
}
|
||||
}
|
||||
}
|
||||
return $msg
|
||||
}
|
||||
|
||||
#
|
||||
# Arguments:
|
||||
# someResults - list of elements, each a list of a letter and a number
|
||||
# n - (positive integer) the number of HTTP requests
|
||||
# msg - accumulated warning messages
|
||||
# skipOverlaps - (boolean) whether to skip testing of transaction overlaps
|
||||
# badTrans - list of transaction numbers not to be assessed as "clean" or
|
||||
# "dirty" by their overlaps
|
||||
# for 1/2 includes all transactions
|
||||
# for 3/4 includes an increasing (with recursion) set that will not be included in the list because they are already handled.
|
||||
# notPiped - subset of badTrans. List of transaction numbers that cannot
|
||||
# taint another transaction by overlapping with it, because it
|
||||
# used a different socket.
|
||||
#
|
||||
# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF]
|
||||
# msg - warning messages: nothing will be appended to argument $msg if there
|
||||
# is no error with the test.
|
||||
# cleanE - list of transactions that have no overlap with other transactions
|
||||
# (not considering response body)
|
||||
# dirtyE - list of transactions that have YES overlap with other transactions
|
||||
# (not considering response body)
|
||||
# cleanF - list of transactions that have no overlap with other transactions
|
||||
# (including response body)
|
||||
# dirtyF - list of transactions that have YES overlap with other transactions
|
||||
# (including response body)
|
||||
|
||||
proc httpTest::MostAnalysis {someResults n msg skipOverlaps badTrans notPiped} {
|
||||
variable testOptions
|
||||
|
||||
# Check that stages for "good" transactions are all present and correct:
|
||||
set msg [TestSequence $someResults $n $msg $badTrans]
|
||||
|
||||
# Check that requests are pipelined:
|
||||
set msg [TestPipeline $someResults $n B C $msg Requests $notPiped]
|
||||
|
||||
# Check that responses are pipelined:
|
||||
set msg [TestPipeline $someResults $n D F $msg Responses $notPiped]
|
||||
|
||||
if {$skipOverlaps} {
|
||||
set cleanE {}
|
||||
set dirtyE {}
|
||||
set cleanF {}
|
||||
set dirtyF {}
|
||||
} else {
|
||||
Puts "Overlaps including response body (test for non-pipelined case)"
|
||||
lassign [TestOverlaps $someResults $n F $msg $badTrans $notPiped] msg cleanF dirtyF
|
||||
|
||||
Puts "Overlaps without response body (test for pipelined case)"
|
||||
lassign [TestOverlaps $someResults $n E $msg $badTrans $notPiped] msg cleanE dirtyE
|
||||
}
|
||||
|
||||
return [list $msg $cleanE $cleanF $dirtyE $dirtyF]
|
||||
}
|
||||
|
||||
# httpTest::ProcessRetries --
|
||||
#
|
||||
# Command to examine results for socket-changing records [PQR],
|
||||
# divide the results into segments for each connection, and analyse each segment
|
||||
# individually.
|
||||
# (Could add $sock to the logging to simplify this, but never mind.)
|
||||
#
|
||||
# In each segment, identify any transactions that are not included, and
|
||||
# any that are aborted, to assist subsequent testing.
|
||||
#
|
||||
# Prepend A records (socket-independent) to each segment for transactions that
|
||||
# were scheduled (by A) but not completed (by F). Pass each segment to
|
||||
# MostAnalysis for processing.
|
||||
|
||||
proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} {
|
||||
variable testOptions
|
||||
|
||||
set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}]
|
||||
if {$nextRetry == -1} {
|
||||
return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped]
|
||||
}
|
||||
set badTrans $notIncluded
|
||||
set tryCount 0
|
||||
set try $nextRetry
|
||||
incr tryCount
|
||||
lassign [lindex $someResults $try] letter number
|
||||
Puts "Processing retry [lindex $someResults $try]"
|
||||
set beforeTry [lrange $someResults 0 $try-1]
|
||||
Puts [join $beforeTry \n]
|
||||
set afterTry [lrange $someResults $try+1 end]
|
||||
|
||||
set dummyTry {}
|
||||
for {set i 1} {$i <= $n} {incr i} {
|
||||
set first [lsearch -exact $beforeTry [list A $i]]
|
||||
set last [lsearch -exact $beforeTry [list F $i]]
|
||||
if {$first == -1} {
|
||||
set res "Transaction $i was not started in connection number $tryCount"
|
||||
# So lappend it to badTrans and don't include it in the call below of MostAnalysis.
|
||||
# append msg $res \n
|
||||
Puts $res
|
||||
if {$i ni $badTrans} {
|
||||
lappend badTrans $i
|
||||
} else {
|
||||
}
|
||||
} elseif {$last == -1} {
|
||||
set res "Transaction $i was started but unfinished in connection number $tryCount"
|
||||
# So lappend it to badTrans and don't include it in the call below of MostAnalysis.
|
||||
# append msg $res \n
|
||||
Puts $res
|
||||
lappend badTrans $i
|
||||
lappend dummyTry [list A $i]
|
||||
} else {
|
||||
set res "Transaction $i was started and finished in connection number $tryCount"
|
||||
# So include it in the call below of MostAnalysis.
|
||||
# So lappend it to notIncluded and don't include it in the recursive call of
|
||||
# ProcessRetries which handles the later connections.
|
||||
# append msg $res \n
|
||||
Puts $res
|
||||
lappend notIncluded $i
|
||||
}
|
||||
}
|
||||
|
||||
# Analyse the part of the results before the first replay:
|
||||
set HeadResults [MostAnalysis $beforeTry $n $msg $skipOverlaps $badTrans $notPiped]
|
||||
lassign $HeadResults msg cleanE1 cleanF1 dirtyE1 dirtyF1
|
||||
|
||||
# Pass the rest of the results to be processed recursively.
|
||||
set afterTry [concat $dummyTry $afterTry]
|
||||
set TailResults [ProcessRetries $afterTry $n $msg $skipOverlaps $notIncluded $notPiped]
|
||||
lassign $TailResults msg cleanE2 cleanF2 dirtyE2 dirtyF2
|
||||
|
||||
set cleanE [concat $cleanE1 $cleanE2]
|
||||
set cleanF [concat $cleanF1 $cleanF2]
|
||||
set dirtyE [concat $dirtyE1 $dirtyE2]
|
||||
set dirtyF [concat $dirtyF1 $dirtyF2]
|
||||
return [list $msg $cleanE $cleanF $dirtyE $dirtyF]
|
||||
}
|
||||
|
||||
# httpTest::logAnalyse --
|
||||
#
|
||||
# The main command called to analyse logs for a single test.
|
||||
#
|
||||
# Arguments:
|
||||
# n - (positive integer) the number of HTTP requests
|
||||
# skipOverlaps - (boolean) whether to skip testing of transaction overlaps
|
||||
# notIncluded - list of transaction numbers not to be assessed as "clean" or
|
||||
# "dirty" by their overlaps
|
||||
# notPiped - subset of notIncluded. List of transaction numbers that cannot
|
||||
# taint another transaction by overlapping with it, because it
|
||||
# used a different socket.
|
||||
#
|
||||
# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF]
|
||||
# msg - warning messages: {} if there is no error with the test.
|
||||
# cleanE - list of transactions that have no overlap with other transactions
|
||||
# (not considering response body)
|
||||
# dirtyE - list of transactions that have YES overlap with other transactions
|
||||
# (not considering response body)
|
||||
# cleanF - list of transactions that have no overlap with other transactions
|
||||
# (including response body)
|
||||
# dirtyF - list of transactions that have YES overlap with other transactions
|
||||
# (including response body)
|
||||
|
||||
proc httpTest::logAnalyse {n skipOverlaps notIncluded notPiped} {
|
||||
variable testResults
|
||||
variable testOptions
|
||||
|
||||
# Check that each data item has the correct form {letter numeral}.
|
||||
set ii 0
|
||||
set ok 1
|
||||
foreach pair $testResults {
|
||||
lassign $pair letter number
|
||||
if { [string match {[A-Z]} $letter]
|
||||
&& [string match {[0-9]} $number]
|
||||
} {
|
||||
# OK
|
||||
} else {
|
||||
set ok 0
|
||||
set res "Error: testResults has bad element {$pair} at position $ii"
|
||||
append msg $res \n
|
||||
Puts $res
|
||||
}
|
||||
incr ii
|
||||
}
|
||||
|
||||
if {!$ok} {
|
||||
return $msg
|
||||
}
|
||||
set msg {}
|
||||
|
||||
Puts [join $testResults \n]
|
||||
ProcessRetries $testResults $n $msg $skipOverlaps $notIncluded $notPiped
|
||||
# N.B. Implicit Return.
|
||||
}
|
||||
|
||||
proc httpTest::cleanupHttpTest {} {
|
||||
variable testResults
|
||||
set testResults {}
|
||||
return
|
||||
}
|
||||
|
||||
proc httpTest::setHttpTestOptions {key args} {
|
||||
variable testOptions
|
||||
if {$key ni {-dotted -verbose}} {
|
||||
return -code error {valid options are -dotted, -verbose}
|
||||
}
|
||||
set testOptions($key) {*}$args
|
||||
}
|
||||
|
||||
namespace eval httpTest {
|
||||
namespace export cleanupHttpTest logAnalyse setHttpTestOptions
|
||||
}
|
||||
509
tests/httpTestScript.tcl
Normal file
509
tests/httpTestScript.tcl
Normal file
@@ -0,0 +1,509 @@
|
||||
# httpTestScript.tcl
|
||||
#
|
||||
# Test HTTP/1.1 concurrent requests including
|
||||
# queueing, pipelining and retries.
|
||||
#
|
||||
# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net>
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# "Package" httpTestScript for executing test scripts written in a convenient
|
||||
# shorthand.
|
||||
# ------------------------------------------------------------------------------
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# Documentation for "package" httpTestScript.
|
||||
# ------------------------------------------------------------------------------
|
||||
# To use the package:
|
||||
# (a) define URLs as the values of elements in the array ::httpTestScript
|
||||
# (b) define a script in terms of the commands
|
||||
# START STOP DELAY KEEPALIVE WAIT PIPELINE GET HEAD POST
|
||||
# referring to URLs by the name of the corresponding array element. The
|
||||
# script can include any other Tcl commands, and evaluates in the
|
||||
# httpTestScript namespace.
|
||||
# (c) Use the command httpTestScript::runHttpTestScript to evaluate the script.
|
||||
# (d) For tcltest tests, wrap the runHttpTestScript call in a suitable "test"
|
||||
# command.
|
||||
# ------------------------------------------------------------------------------
|
||||
# START
|
||||
# Must be the first command of the script.
|
||||
#
|
||||
# STOP
|
||||
# Must be present in the script to avoid waiting for client timeout.
|
||||
# Usually the last command, but can be elsewhere to end a script prematurely.
|
||||
# Subsequent httpTestScript commands will have no effect.
|
||||
#
|
||||
# DELAY ms
|
||||
# If there are no WAIT commands, this sets the delay in ms between subsequent
|
||||
# calls to http::geturl. Default 500ms.
|
||||
#
|
||||
# KEEPALIVE
|
||||
# Set the value passed to http::geturl for the -keepalive option. The command
|
||||
# applies to subsequent requests in the script. Default 1.
|
||||
#
|
||||
# WAIT ms
|
||||
# Pause for a time in ms before sending subsequent requests.
|
||||
#
|
||||
# PIPELINE boolean
|
||||
# Set the value of -pipeline using http::config. The last PIPELINE command
|
||||
# in the script applies to every request. Default 1.
|
||||
#
|
||||
# POSTFRESH boolean
|
||||
# Set the value of -postfresh using http::config. The last POSTFRESH command
|
||||
# in the script applies to every request. Default 0.
|
||||
#
|
||||
# REPOST boolean
|
||||
# Set the value of -repost using http::config. The last REPOST command
|
||||
# in the script applies to every request. Default 1 for httpTestScript.
|
||||
# (Default value in http is 0).
|
||||
#
|
||||
# GET uriCode ?arg ...?
|
||||
# Send a HTTP request using the GET method.
|
||||
# Arguments:
|
||||
# uriCode - the code for the base URI - the value must be stored in
|
||||
# ::httpTestScript::URL($uriCode).
|
||||
# args - strings that will be joined by "&" and appended to the query
|
||||
# string with a preceding "&".
|
||||
#
|
||||
# HEAD uriCode ?arg ...?
|
||||
# Send a HTTP request using the HEAD method.
|
||||
# Arguments: as for GET
|
||||
#
|
||||
# POST uriCode ?arg ...?
|
||||
# Send a HTTP request using the POST method.
|
||||
# Arguments:
|
||||
# uriCode - the code for the base URI - the value must be stored in
|
||||
# ::httpTestScript::URL($uriCode).
|
||||
# args - strings that will be joined by "&" and used as the request body.
|
||||
# ------------------------------------------------------------------------------
|
||||
|
||||
namespace eval ::httpTestScript {
|
||||
namespace export runHttpTestScript cleanupHttpTestScript
|
||||
}
|
||||
|
||||
# httpTestScript::START --
|
||||
# Initialise, and create a long-stop timeout.
|
||||
|
||||
proc httpTestScript::START {} {
|
||||
variable CountRequestedSoFar
|
||||
variable RequestsWhenStopped
|
||||
variable KeepAlive
|
||||
variable Delay
|
||||
variable TimeOutCode
|
||||
variable TimeOutDone
|
||||
variable StartDone
|
||||
variable StopDone
|
||||
variable CountFinishedSoFar
|
||||
variable RequestList
|
||||
variable RequestsMade
|
||||
variable ExtraTime
|
||||
variable ActualKeepAlive
|
||||
|
||||
if {[info exists StartDone] && ($StartDone == 1)} {
|
||||
set msg {START has been called twice without an intervening STOP}
|
||||
return -code error $msg
|
||||
}
|
||||
|
||||
set StartDone 1
|
||||
set StopDone 0
|
||||
set TimeOutDone 0
|
||||
set CountFinishedSoFar 0
|
||||
set CountRequestedSoFar 0
|
||||
set RequestList {}
|
||||
set RequestsMade {}
|
||||
set ExtraTime 0
|
||||
set ActualKeepAlive 1
|
||||
|
||||
# Undefined until a STOP command:
|
||||
unset -nocomplain RequestsWhenStopped
|
||||
|
||||
# Default values:
|
||||
set KeepAlive 1
|
||||
set Delay 500
|
||||
|
||||
# Default values for tests:
|
||||
KEEPALIVE 1
|
||||
PIPELINE 1
|
||||
POSTFRESH 0
|
||||
REPOST 1
|
||||
|
||||
set TimeOutCode [after 30000 httpTestScript::TimeOutNow]
|
||||
# set TimeOutCode [after 4000 httpTestScript::TimeOutNow]
|
||||
return
|
||||
}
|
||||
|
||||
# httpTestScript::STOP --
|
||||
# Do not process any more commands. The commands will be executed but will
|
||||
# silently do nothing.
|
||||
|
||||
proc httpTestScript::STOP {} {
|
||||
variable CountRequestedSoFar
|
||||
variable CountFinishedSoFar
|
||||
variable RequestsWhenStopped
|
||||
variable TimeOutCode
|
||||
variable StartDone
|
||||
variable StopDone
|
||||
variable RequestsMade
|
||||
|
||||
if {$StopDone} {
|
||||
# Don't do anything on a second call.
|
||||
return
|
||||
}
|
||||
|
||||
if {![info exists StartDone]} {
|
||||
return -code error {initialise the script by calling command START}
|
||||
}
|
||||
|
||||
set StopDone 1
|
||||
set StartDone 0
|
||||
set RequestsWhenStopped $CountRequestedSoFar
|
||||
unset -nocomplain StartDone
|
||||
|
||||
if {$CountFinishedSoFar == $RequestsWhenStopped} {
|
||||
if {[info exists TimeOutCode]} {
|
||||
after cancel $TimeOutCode
|
||||
}
|
||||
set ::httpTestScript::FOREVER 0
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
# httpTestScript::DELAY --
|
||||
# If there are no WAIT commands, this sets the delay in ms between subsequent
|
||||
# calls to http::geturl. Default 500ms.
|
||||
|
||||
proc httpTestScript::DELAY {t} {
|
||||
variable StartDone
|
||||
variable StopDone
|
||||
|
||||
if {$StopDone} {
|
||||
return
|
||||
}
|
||||
|
||||
if {![info exists StartDone]} {
|
||||
return -code error {initialise the script by calling command START}
|
||||
}
|
||||
|
||||
variable Delay
|
||||
|
||||
set Delay $t
|
||||
return
|
||||
}
|
||||
|
||||
# httpTestScript::KEEPALIVE --
|
||||
# Set the value passed to http::geturl for the -keepalive option. Default 1.
|
||||
|
||||
proc httpTestScript::KEEPALIVE {b} {
|
||||
variable StartDone
|
||||
variable StopDone
|
||||
|
||||
if {$StopDone} {
|
||||
return
|
||||
}
|
||||
|
||||
if {![info exists StartDone]} {
|
||||
return -code error {initialise the script by calling command START}
|
||||
}
|
||||
|
||||
variable KeepAlive
|
||||
set KeepAlive $b
|
||||
return
|
||||
}
|
||||
|
||||
# httpTestScript::WAIT --
|
||||
# Pause for a time in ms before processing any more commands.
|
||||
|
||||
proc httpTestScript::WAIT {t} {
|
||||
variable StartDone
|
||||
variable StopDone
|
||||
variable ExtraTime
|
||||
|
||||
if {$StopDone} {
|
||||
return
|
||||
}
|
||||
|
||||
if {![info exists StartDone]} {
|
||||
return -code error {initialise the script by calling command START}
|
||||
}
|
||||
|
||||
if {(![string is integer -strict $t]) || $t < 0} {
|
||||
return -code error {argument to WAIT must be a non-negative integer}
|
||||
}
|
||||
|
||||
incr ExtraTime $t
|
||||
|
||||
return
|
||||
}
|
||||
|
||||
# httpTestScript::PIPELINE --
|
||||
# Pass a value to http::config -pipeline.
|
||||
|
||||
proc httpTestScript::PIPELINE {b} {
|
||||
variable StartDone
|
||||
variable StopDone
|
||||
|
||||
if {$StopDone} {
|
||||
return
|
||||
}
|
||||
|
||||
if {![info exists StartDone]} {
|
||||
return -code error {initialise the script by calling command START}
|
||||
}
|
||||
|
||||
::http::config -pipeline $b
|
||||
##::http::Log http(-pipeline) is now [::http::config -pipeline]
|
||||
return
|
||||
}
|
||||
|
||||
# httpTestScript::POSTFRESH --
|
||||
# Pass a value to http::config -postfresh.
|
||||
|
||||
proc httpTestScript::POSTFRESH {b} {
|
||||
variable StartDone
|
||||
variable StopDone
|
||||
|
||||
if {$StopDone} {
|
||||
return
|
||||
}
|
||||
|
||||
if {![info exists StartDone]} {
|
||||
return -code error {initialise the script by calling command START}
|
||||
}
|
||||
|
||||
::http::config -postfresh $b
|
||||
##::http::Log http(-postfresh) is now [::http::config -postfresh]
|
||||
return
|
||||
}
|
||||
|
||||
# httpTestScript::REPOST --
|
||||
# Pass a value to http::config -repost.
|
||||
|
||||
proc httpTestScript::REPOST {b} {
|
||||
variable StartDone
|
||||
variable StopDone
|
||||
|
||||
if {$StopDone} {
|
||||
return
|
||||
}
|
||||
|
||||
if {![info exists StartDone]} {
|
||||
return -code error {initialise the script by calling command START}
|
||||
}
|
||||
|
||||
::http::config -repost $b
|
||||
##::http::Log http(-repost) is now [::http::config -repost]
|
||||
return
|
||||
}
|
||||
|
||||
# httpTestScript::GET --
|
||||
# Send a HTTP request using the GET method.
|
||||
# Arguments:
|
||||
# uriCode - the code for the base URI - the value must be stored in
|
||||
# ::httpTestScript::URL($uriCode).
|
||||
# args - strings that will each be preceded by "&" and appended to the query
|
||||
# string.
|
||||
|
||||
proc httpTestScript::GET {uriCode args} {
|
||||
variable RequestList
|
||||
lappend RequestList GET
|
||||
RequestAfter $uriCode 0 {} {*}$args
|
||||
return
|
||||
}
|
||||
|
||||
# httpTestScript::HEAD --
|
||||
# Send a HTTP request using the HEAD method.
|
||||
# Arguments: as for GET
|
||||
|
||||
proc httpTestScript::HEAD {uriCode args} {
|
||||
variable RequestList
|
||||
lappend RequestList HEAD
|
||||
RequestAfter $uriCode 1 {} {*}$args
|
||||
return
|
||||
}
|
||||
|
||||
# httpTestScript::POST --
|
||||
# Send a HTTP request using the POST method.
|
||||
# Arguments:
|
||||
# uriCode - the code for the base URI - the value must be stored in
|
||||
# ::httpTestScript::URL($uriCode).
|
||||
# args - strings that will be joined by "&" and used as the request body.
|
||||
|
||||
proc httpTestScript::POST {uriCode args} {
|
||||
variable RequestList
|
||||
lappend RequestList POST
|
||||
RequestAfter $uriCode 0 {use} {*}$args
|
||||
return
|
||||
}
|
||||
|
||||
|
||||
proc httpTestScript::RequestAfter {uriCode validate query args} {
|
||||
variable CountRequestedSoFar
|
||||
variable Delay
|
||||
variable ExtraTime
|
||||
variable StartDone
|
||||
variable StopDone
|
||||
variable KeepAlive
|
||||
|
||||
if {$StopDone} {
|
||||
return
|
||||
}
|
||||
|
||||
if {![info exists StartDone]} {
|
||||
return -code error {initialise the script by calling command START}
|
||||
}
|
||||
|
||||
incr CountRequestedSoFar
|
||||
set idelay [expr {($CountRequestedSoFar - 1) * $Delay + 10 + $ExtraTime}]
|
||||
|
||||
# Could pass values of -pipeline, -postfresh, -repost if it were
|
||||
# useful to change these mid-script.
|
||||
after $idelay [list httpTestScript::Requester $uriCode $KeepAlive $validate $query {*}$args]
|
||||
return
|
||||
}
|
||||
|
||||
proc httpTestScript::Requester {uriCode keepAlive validate query args} {
|
||||
variable URL
|
||||
|
||||
::http::config -accept {*/*}
|
||||
|
||||
set absUrl $URL($uriCode)
|
||||
if {$query eq {}} {
|
||||
if {$args ne {}} {
|
||||
append absUrl & [join $args &]
|
||||
}
|
||||
set queryArgs {}
|
||||
} elseif {$validate} {
|
||||
return -code error {cannot have both -validate (HEAD) and -query (POST)}
|
||||
} else {
|
||||
set queryArgs [list -query [join $args &]]
|
||||
}
|
||||
|
||||
if {[catch {
|
||||
::http::geturl $absUrl \
|
||||
-validate $validate \
|
||||
-timeout 10000 \
|
||||
{*}$queryArgs \
|
||||
-keepalive $keepAlive \
|
||||
-command ::httpTestScript::WhenFinished
|
||||
} token]} {
|
||||
set msg $token
|
||||
catch {puts stdout "Error: $msg"}
|
||||
return
|
||||
} else {
|
||||
# Request will begin.
|
||||
}
|
||||
|
||||
return
|
||||
|
||||
}
|
||||
|
||||
proc httpTestScript::TimeOutNow {} {
|
||||
variable TimeOutDone
|
||||
|
||||
set TimeOutDone 1
|
||||
set ::httpTestScript::FOREVER 0
|
||||
return
|
||||
}
|
||||
|
||||
proc httpTestScript::WhenFinished {hToken} {
|
||||
variable CountFinishedSoFar
|
||||
variable RequestsWhenStopped
|
||||
variable TimeOutCode
|
||||
variable StopDone
|
||||
variable RequestList
|
||||
variable RequestsMade
|
||||
variable ActualKeepAlive
|
||||
|
||||
upvar #0 $hToken state
|
||||
|
||||
if {[catch {
|
||||
if { [info exists state(transfer)]
|
||||
&& ($state(transfer) eq "chunked")
|
||||
} {
|
||||
set Trans chunked
|
||||
} else {
|
||||
set Trans unchunked
|
||||
}
|
||||
|
||||
if { [info exists ::httpTest::testOptions(-verbose)]
|
||||
&& ($::httpTest::testOptions(-verbose) > 0)
|
||||
} {
|
||||
puts "Token $hToken
|
||||
Response $state(http)
|
||||
Status $state(status)
|
||||
Method $state(method)
|
||||
Transfer $Trans
|
||||
Size $state(currentsize)
|
||||
URL $state(url)
|
||||
"
|
||||
}
|
||||
|
||||
if {!$state(-keepalive)} {
|
||||
set ActualKeepAlive 0
|
||||
}
|
||||
|
||||
if {[info exists state(method)]} {
|
||||
lappend RequestsMade $state(method)
|
||||
} else {
|
||||
lappend RequestsMade UNKNOWN
|
||||
}
|
||||
set tk [namespace tail $hToken]
|
||||
|
||||
if { ($state(http) != {HTTP/1.1 200 OK})
|
||||
|| ($state(status) != {ok})
|
||||
|| (($state(currentsize) == 0) && ($state(method) ne "HEAD"))
|
||||
} {
|
||||
::http::Log ^X$tk unexpected result Response $state(http) Status $state(status) Size $state(currentsize) - token $hToken
|
||||
}
|
||||
} err]} {
|
||||
::http::Log ^X$tk httpTestScript::WhenFinished failed with error status: $err - token $hToken
|
||||
}
|
||||
|
||||
incr CountFinishedSoFar
|
||||
if {$StopDone && ($CountFinishedSoFar == $RequestsWhenStopped)} {
|
||||
if {[info exists TimeOutCode]} {
|
||||
after cancel $TimeOutCode
|
||||
}
|
||||
if {$RequestsMade ne $RequestList && $ActualKeepAlive} {
|
||||
::http::Log ^X$tk unexpected result - Script asked for "{$RequestList}" but got "{$RequestsMade}" - token $hToken
|
||||
}
|
||||
set ::httpTestScript::FOREVER 0
|
||||
}
|
||||
|
||||
return
|
||||
}
|
||||
|
||||
|
||||
proc httpTestScript::runHttpTestScript {scr} {
|
||||
variable TimeOutDone
|
||||
variable RequestsWhenStopped
|
||||
|
||||
after idle [list namespace eval ::httpTestScript $scr]
|
||||
vwait ::httpTestScript::FOREVER
|
||||
# N.B. does not automatically execute in this namespace, unlike some other events.
|
||||
# Release when all requests have been served or have timed out.
|
||||
|
||||
if {$TimeOutDone} {
|
||||
return -code error {test script timed out}
|
||||
}
|
||||
|
||||
return $RequestsWhenStopped
|
||||
}
|
||||
|
||||
|
||||
proc httpTestScript::cleanupHttpTestScript {} {
|
||||
variable TimeOutDone
|
||||
variable RequestsWhenStopped
|
||||
|
||||
if {![info exists RequestsWhenStopped]} {
|
||||
return -code error {Cleanup Failed: RequestsWhenStopped is undefined}
|
||||
}
|
||||
|
||||
for {set i 1} {$i <= $RequestsWhenStopped} {incr i} {
|
||||
http::cleanup ::http::$i
|
||||
}
|
||||
|
||||
return
|
||||
}
|
||||
@@ -768,26 +768,26 @@ test info-22.8 {info frame, basic trace} -match glob -body {
|
||||
* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
|
||||
unset -nocomplain msg
|
||||
|
||||
test info-23.0.0 {eval'd info frame} {!singleTestInterp} {
|
||||
eval {info frame}
|
||||
} 8
|
||||
test info-23.0.1 {eval'd info frame} -constraints {singleTestInterp} -match glob -body {
|
||||
eval {info frame}
|
||||
} -result {1[12]} ;# SingleTestInterp results changes depending on running the whole suite, or info.test alone.
|
||||
test info-23.1.0 {eval'd info frame, semi-dynamic} {!singleTestInterp} {
|
||||
eval info frame
|
||||
} 8
|
||||
test info-23.1.1 {eval'd info frame, semi-dynamic} -constraints {singleTestInterp} -match glob -body {
|
||||
eval info frame
|
||||
} -result {1[12]}
|
||||
test info-23.2.0 {eval'd info frame, dynamic} -constraints {!singleTestInterp} -body {
|
||||
set script {info frame}
|
||||
eval $script
|
||||
} -cleanup {unset script} -result 8
|
||||
test info-23.2.1 {eval'd info frame, dynamic} -constraints {singleTestInterp} -match glob -body {
|
||||
set script {info frame}
|
||||
eval $script
|
||||
} -cleanup {unset script} -result {1[12]}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0
|
||||
test info-23.0 {eval'd info frame} -constraints {!singleTestInterp} -body {
|
||||
list [i eval {info frame}] [i eval {eval {info frame}}]
|
||||
} -setup {interp create i} -cleanup {interp delete i} -result {1 2}
|
||||
test info-23.1 {eval'd info frame, semi-dynamic} -constraints {!singleTestInterp} -body {
|
||||
i eval {eval info frame}
|
||||
} -setup {interp create i} -cleanup {interp delete i} -result 2
|
||||
test info-23.2 {eval'd info frame, dynamic} -constraints {!singleTestInterp} -body {
|
||||
i eval { set script {info frame}
|
||||
eval $script}
|
||||
} -setup {interp create i} -cleanup {interp delete i} -result 2
|
||||
test info-23.3 {eval'd info frame, literal} -match glob -body {
|
||||
eval {
|
||||
info frame 0
|
||||
@@ -2398,7 +2398,7 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body {
|
||||
# -------------------------------------------------------------------------
|
||||
unset -nocomplain res
|
||||
|
||||
test info-39.1 {Bug 4b61afd660} -setup {
|
||||
test info-39.2 {Bug 4b61afd660} -setup {
|
||||
proc probe {} {
|
||||
return [dict get [info frame -1] line]
|
||||
}
|
||||
|
||||
@@ -1836,7 +1836,7 @@ test interp-23.1 {testing hiding vs aliases: unsafe interp} -setup {
|
||||
test interp-23.2 {testing hiding vs aliases: safe interp} -setup {
|
||||
catch {interp delete a}
|
||||
set l ""
|
||||
} -constraints {unixOrPc} -body {
|
||||
} -constraints {unixOrWin} -body {
|
||||
interp create a -safe
|
||||
lappend l [lsort [interp hidden a]]
|
||||
a alias bar bar
|
||||
|
||||
@@ -15,14 +15,8 @@
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testbytestring [llength [info commands testbytestring]]
|
||||
|
||||
namespace eval ::tcl::test::io {
|
||||
namespace import ::tcltest::*
|
||||
|
||||
@@ -35,16 +29,21 @@ namespace eval ::tcl::test::io {
|
||||
variable msg
|
||||
variable expected
|
||||
|
||||
catch {
|
||||
::tcltest::loadTestedCommands
|
||||
package require -exact Tcltest [info patchlevel]
|
||||
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
|
||||
}
|
||||
package require tcltests
|
||||
|
||||
testConstraint testbytestring [llength [info commands testbytestring]]
|
||||
testConstraint testchannel [llength [info commands testchannel]]
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
testConstraint openpipe 1
|
||||
testConstraint fileevent [llength [info commands fileevent]]
|
||||
testConstraint fcopy [llength [info commands fcopy]]
|
||||
testConstraint testfevent [llength [info commands testfevent]]
|
||||
testConstraint testchannelevent [llength [info commands testchannelevent]]
|
||||
testConstraint testmainthread [llength [info commands testmainthread]]
|
||||
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
|
||||
testConstraint testobj [llength [info commands testobj]]
|
||||
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
|
||||
|
||||
# You need a *very* special environment to do some tests. In
|
||||
# particular, many file systems do not support large-files...
|
||||
@@ -2213,7 +2212,7 @@ test io-27.4 {FlushChannel, implicit flush when buffer fills} {
|
||||
set l
|
||||
} {0 60 72}
|
||||
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
|
||||
{unixOrPc} {
|
||||
{unixOrWin} {
|
||||
file delete $path(test1)
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation lf -buffersize 60 -eofchar {}
|
||||
@@ -2230,7 +2229,7 @@ test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
|
||||
set path(pipe) [makeFile {} pipe]
|
||||
set path(output) [makeFile {} output]
|
||||
test io-27.6 {FlushChannel, async flushing, async close} \
|
||||
{stdio asyncPipeClose openpipe} {
|
||||
{stdio asyncPipeClose openpipe knownMsvcBug} {
|
||||
# This test may fail on old Unix systems (seen on IRIX64 6.5) with
|
||||
# obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
|
||||
file delete $path(pipe)
|
||||
@@ -2834,7 +2833,7 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
|
||||
set result
|
||||
} ok
|
||||
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
|
||||
{stdio asyncPipeClose openpipe} {
|
||||
{stdio asyncPipeClose openpipe knownMsvcBug} {
|
||||
# This test may fail on old Unix systems (seen on IRIX64 6.5) with
|
||||
# obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197.
|
||||
file delete $path(pipe)
|
||||
@@ -6163,6 +6162,8 @@ test io-47.6 {file events on shared files, deleting file events} {testfevent fil
|
||||
close $f
|
||||
set x
|
||||
} {{script 1} {}}
|
||||
unset path(foo)
|
||||
removeFile foo
|
||||
|
||||
set path(bar) [makeFile {} bar]
|
||||
|
||||
@@ -6265,6 +6266,9 @@ test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe
|
||||
close $f
|
||||
list $x $l
|
||||
} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
|
||||
unset path(bar)
|
||||
removeFile bar
|
||||
|
||||
test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} {
|
||||
file delete $path(test1)
|
||||
set f [open $path(test1) w]
|
||||
@@ -7379,7 +7383,7 @@ test io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} {
|
||||
close $f
|
||||
set result
|
||||
} "ready line1 line2 {done\n}"
|
||||
test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileevent fcopy} {
|
||||
test io-53.4 {CopyData: background write overflow} {stdio openpipe fileevent fcopy} {
|
||||
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
|
||||
variable x
|
||||
for {set x 0} {$x < 12} {incr x} {
|
||||
@@ -8017,7 +8021,7 @@ test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup {
|
||||
removeFile out
|
||||
} -result {line 100 line}
|
||||
|
||||
test io-54.1 {Recursive channel events} {socket fileevent} {
|
||||
test io-54.1 {Recursive channel events} {socket fileevent knownMsvcBug} {
|
||||
# This test checks to see if file events are delivered during recursive
|
||||
# event loops when there is buffered data on the channel.
|
||||
|
||||
@@ -8226,7 +8230,7 @@ test io-57.2 {buffered data and file events, read} {fileevent} {
|
||||
set result
|
||||
} {1 readable 234567890 timer}
|
||||
|
||||
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} {
|
||||
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin openpipe fileevent} {
|
||||
set out [open $path(script) w]
|
||||
puts $out {
|
||||
puts "normal message from pipe"
|
||||
@@ -8270,6 +8274,7 @@ test io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring}
|
||||
# This test will hang in older revisions of the core.
|
||||
|
||||
set out [open $path(script) w]
|
||||
puts $out "catch {load $::tcltestlib Tcltest}"
|
||||
puts $out {
|
||||
puts [testbytestring \xe2]
|
||||
exit 1
|
||||
|
||||
@@ -21,10 +21,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
package require tcltests
|
||||
|
||||
# Custom constraints used in this file
|
||||
testConstraint fcopy [llength [info commands fcopy]]
|
||||
testConstraint testchannel [llength [info commands testchannel]]
|
||||
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
@@ -282,7 +282,7 @@ removeFile fconfigure.dummy
|
||||
test iocmd-8.14 {fconfigure command} {
|
||||
fconfigure stdin -buffers
|
||||
} 4096
|
||||
test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrPc} -setup {
|
||||
test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup {
|
||||
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
|
||||
set port [lindex [fconfigure $srv -sockname] 2]
|
||||
proc iocmdSRV {sock ip port} {close $sock}
|
||||
@@ -384,19 +384,18 @@ test iocmd-10.5 {fblocked command} {
|
||||
set path(test4) [makeFile {} test4]
|
||||
set path(test5) [makeFile {} test5]
|
||||
|
||||
file delete $path(test5)
|
||||
test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
|
||||
test iocmd-11.1 {I/O to command pipelines} {unixOrWin unixExecs} {
|
||||
set f [open $path(test4) w]
|
||||
close $f
|
||||
list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode
|
||||
} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}}
|
||||
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
|
||||
test iocmd-11.2 {I/O to command pipelines} {unixOrWin unixExecs} {
|
||||
list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode
|
||||
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
|
||||
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
|
||||
test iocmd-11.3 {I/O to command pipelines} {unixOrWin unixExecs} {
|
||||
list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode
|
||||
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
|
||||
test iocmd-11.4 {I/O to command pipelines} unixOrPc {
|
||||
test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrWin} {
|
||||
list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode
|
||||
} {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}}
|
||||
|
||||
@@ -807,11 +806,11 @@ test iocmd-21.20 {Bug 88aef05cda} -setup {
|
||||
}
|
||||
set ch [chan create {read write} foo]
|
||||
} -body {
|
||||
list [catch {chan configure $ch -blocking 0} m] $m
|
||||
chan configure $ch -blocking 0
|
||||
} -cleanup {
|
||||
close $ch
|
||||
rename foo {}
|
||||
} -match glob -result {1 {*nested eval*}}
|
||||
} -match glob -returnCodes 1 -result {*(infinite loop?)*}
|
||||
test iocmd-21.21 {[close] in [read] segfaults} -setup {
|
||||
proc foo {method chan args} {
|
||||
switch -- $method initialize {
|
||||
@@ -1986,7 +1985,7 @@ test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body {
|
||||
proc foo {args} {oninit; onfinal; track; return}
|
||||
set c [chan create {r w} foo]
|
||||
note [fileevent $c readable {note TOCK}]
|
||||
set stop [after 10000 {note TIMEOUT}]
|
||||
set stop [after 15000 {note TIMEOUT}]
|
||||
after 1000 {note [chan postevent $c r]}
|
||||
vwait ::res
|
||||
catch {after cancel $stop}
|
||||
@@ -1999,7 +1998,7 @@ test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
|
||||
proc foo {args} {oninit; onfinal; track; return}
|
||||
set c [chan create {r w} foo]
|
||||
note [fileevent $c writable {note TOCK}]
|
||||
set stop [after 10000 {note TIMEOUT}]
|
||||
set stop [after 15000 {note TIMEOUT}]
|
||||
after 1000 {note [chan postevent $c w]}
|
||||
vwait ::res
|
||||
catch {after cancel $stop}
|
||||
@@ -2058,6 +2057,8 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body {
|
||||
lappend res [catch {interp eval $idb [list close $chan]} msg] $msg
|
||||
set res
|
||||
|
||||
} -cleanup {
|
||||
interp delete $idb
|
||||
} -constraints {testchannel} \
|
||||
-result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
|
||||
|
||||
@@ -2100,6 +2101,8 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
|
||||
set res
|
||||
}]
|
||||
set res
|
||||
} -cleanup {
|
||||
interp delete $idb
|
||||
} -constraints {testchannel} -result {Owner lost}
|
||||
|
||||
test iocmd-32.2 {delete interp of reflected chan} {
|
||||
@@ -3778,7 +3781,6 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body {
|
||||
# Use constraints to skip this test while valgrinding so this expected leak
|
||||
# doesn't prevent a finding of "leak-free".
|
||||
#
|
||||
testConstraint notValgrind [expr {![testConstraint valgrind]}]
|
||||
test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body {
|
||||
|
||||
#puts <<$tcltest::mainThread>>main
|
||||
@@ -3831,13 +3833,21 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat
|
||||
|
||||
rename track {}
|
||||
# cleanup
|
||||
|
||||
|
||||
# Eliminate valgrind "still reachable" reports on outstanding "Detached"
|
||||
# structures in the detached list which stem from PipeClose2Proc not waiting
|
||||
# around for background processes to complete, meaning that previous calls to
|
||||
# Tcl_ReapDetachedProcs might not have had a chance to reap all processes.
|
||||
after 10
|
||||
exec [info nameofexecutable] << {}
|
||||
|
||||
|
||||
foreach file [list test1 test2 test3 test4] {
|
||||
removeFile $file
|
||||
}
|
||||
# delay long enough for background processes to finish
|
||||
after 500
|
||||
foreach file [list test5] {
|
||||
removeFile $file
|
||||
}
|
||||
removeFile test5
|
||||
cleanupTests
|
||||
return
|
||||
|
||||
@@ -1200,6 +1200,7 @@ test iortrans-11.0 {origin interpreter of moved transform gone} -setup {
|
||||
# without invoking the transform handler.
|
||||
} -cleanup {
|
||||
tempdone
|
||||
interp delete $idb
|
||||
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
|
||||
test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup {
|
||||
set ida [interp create]; #puts <<$ida>>
|
||||
@@ -1239,6 +1240,7 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces
|
||||
set res
|
||||
}]
|
||||
} -cleanup {
|
||||
interp delete $idb
|
||||
tempdone
|
||||
} -result {Owner lost}
|
||||
test iortrans-11.2 {delete interp of reflected transform} -setup {
|
||||
|
||||
@@ -608,7 +608,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
|
||||
variable copy 1
|
||||
}
|
||||
} -constraints {testchannel knownBug} -body {
|
||||
# This test to check the validity of aquired Tcl_Channel references is not
|
||||
# This test to check the validity of acquired Tcl_Channel references is not
|
||||
# possible because even a backgrounded fcopy will immediately start to
|
||||
# copy data, without waiting for the event loop. This is done only in case
|
||||
# of an underflow on the read size!. So stacking transforms after the
|
||||
|
||||
@@ -45,6 +45,11 @@ test join-3.1 {joinString is binary ok} {
|
||||
test join-3.2 {join is binary ok} {
|
||||
string length [join "a\0b a\0b a\0b"]
|
||||
} 11
|
||||
|
||||
test join-4.1 {shimmer segfault prevention} {
|
||||
set l {0 0}
|
||||
join $l $l
|
||||
} {00 00}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
|
||||
@@ -79,6 +79,15 @@ test lindex-3.7 {indexes don't shimmer wide ints} {
|
||||
set x [expr {(wide(1)<<31) - 2}]
|
||||
list $x [lindex {1 2 3} $x] [incr x] [incr x]
|
||||
} {2147483646 {} 2147483647 2147483648}
|
||||
test lindex-3.8 {compiled with static indices out of range, negative} {
|
||||
list [lindex {a b c} -1] [lindex {a b c} -2] [lindex {a b c} -3]
|
||||
} [lrepeat 3 {}]
|
||||
test lindex-3.9 {compiled with calculated indices out of range, negative constant} {
|
||||
list [lindex {a b c} -1-1] [lindex {a b c} -2+0] [lindex {a b c} -2+1]
|
||||
} [lrepeat 3 {}]
|
||||
test lindex-3.10 {compiled with calculated indices out of range, after end} {
|
||||
list [lindex {a b c} end+1] [lindex {a b c} end+2] [lindex {a b c} end+3]
|
||||
} [lrepeat 3 {}]
|
||||
|
||||
# Indices relative to end
|
||||
|
||||
|
||||
@@ -25,6 +25,16 @@ foreach i {int real bool string} {
|
||||
unset -nocomplain $i
|
||||
}
|
||||
|
||||
test link-0.1 {leak test} {testlink} {
|
||||
interp create i
|
||||
load {} Tcltest i
|
||||
i eval {
|
||||
testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||
namespace delete ::
|
||||
}
|
||||
interp delete i
|
||||
} {}
|
||||
|
||||
test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup {
|
||||
testlink delete
|
||||
} -body {
|
||||
|
||||
@@ -128,6 +128,24 @@ test list-3.1 {SetListFromAny and lrange/concat results} {
|
||||
test list-4.1 {Bug 3173086} {
|
||||
string is list "{[list \\\\\}]}"
|
||||
} 1
|
||||
test list-4.2 {Bug 35a8f1c04a, check correct str-rep} {
|
||||
set result {}
|
||||
foreach i {
|
||||
{#"} {#"""} {#"""""""""""""""}
|
||||
"#\"{" "#\"\"\"{" "#\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\{"
|
||||
"#\"}" "#\"\"\"}" "#\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\}"
|
||||
} {
|
||||
set list [list $i]
|
||||
set list [string trim " $list "]
|
||||
if {[llength $list] > 1 || $i ne [lindex $list 0]} {
|
||||
lappend result "wrong string-representation of list by '$i', length: [llength $list], list: '$list'"
|
||||
}
|
||||
}
|
||||
set result [join $result \n]
|
||||
} {}
|
||||
test list-4.3 {Bug 35a8f1c04a, check correct string length} {
|
||||
string length [list #""]
|
||||
} 5
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
|
||||
@@ -15,6 +15,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testpurebytesobj [llength [info commands testpurebytesobj]]
|
||||
|
||||
|
||||
test lrange-1.1 {range of list elements} {
|
||||
lrange {a b c d} 1 2
|
||||
@@ -90,6 +96,58 @@ test lrange-3.1 {Bug 3588366: end-offsets before start} {
|
||||
lrange $l 0 end-5
|
||||
}} {1 2 3 4 5}
|
||||
} {}
|
||||
|
||||
test lrange-3.2 {compiled with static indices out of range, negative} {
|
||||
list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3]
|
||||
} [lrepeat 4 {}]
|
||||
test lrange-3.3 {compiled with calculated indices out of range, negative constant} {
|
||||
list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1]
|
||||
} [lrepeat 4 {}]
|
||||
test lrange-3.4 {compiled with calculated indices out of range, after end} {
|
||||
list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2]
|
||||
} [lrepeat 4 {}]
|
||||
|
||||
test lrange-3.5 {compiled with calculated indices, start out of range (negative)} {
|
||||
list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1]
|
||||
} [lrepeat 4 {a b}]
|
||||
test lrange-3.6 {compiled with calculated indices, end out of range (after end)} {
|
||||
list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1]
|
||||
} [lrepeat 4 {b c}]
|
||||
|
||||
test lrange-3.7a {compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} {
|
||||
list [lrange { } 0 1] [lrange [format %c 32] 0 1] [lrange [set a { }] 0 1] \
|
||||
[lrange { } 0-1 end+1] [lrange [format %c 32] 0-1 end+1] [lrange $a 0-1 end+1]
|
||||
} [lrepeat 6 {}]
|
||||
test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} {
|
||||
set cmd lrange
|
||||
list [$cmd { } 0 1] [$cmd [format %c 32] 0 1] [$cmd [set a { }] 0 1] \
|
||||
[$cmd { } 0-1 end+1] [$cmd [format %c 32] 0-1 end+1] [$cmd $a 0-1 end+1]
|
||||
} [lrepeat 6 {}]
|
||||
# following 4 tests could cause a segfault on empty non-lists with tclEmptyStringRep
|
||||
# (as before the fix [58c46e74b931d3a1]):
|
||||
test lrange-3.7a.2 {compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
|
||||
list [lrange {} 0 1] [lrange [lindex a -1] 0 1] [lrange [set a {}] 0 1] \
|
||||
[lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1]
|
||||
} [lrepeat 6 {}]
|
||||
test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
|
||||
set cmd lrange
|
||||
list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \
|
||||
[$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1]
|
||||
} [lrepeat 6 {}]
|
||||
test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
|
||||
testpurebytesobj
|
||||
} -body {
|
||||
list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \
|
||||
[lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1]
|
||||
} -result [lrepeat 6 {}]
|
||||
test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
|
||||
testpurebytesobj
|
||||
} -body {
|
||||
set cmd lrange
|
||||
list [$cmd [testpurebytesobj] 0 1] [$cmd [testpurebytesobj { }] 0 1] [$cmd [set a [testpurebytesobj {}]] 0 1] \
|
||||
[$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1]
|
||||
} -result [lrepeat 6 {}]
|
||||
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
|
||||
@@ -98,12 +98,18 @@ test lreplace-1.26 {lreplace command} {
|
||||
[set foo [lreplace $foo end end]] \
|
||||
[set foo [lreplace $foo end end]]
|
||||
} {a {} {}}
|
||||
test lreplace-1.27 {lreplace command} {
|
||||
test lreplace-1.27 {lreplace command} -body {
|
||||
lreplace x 1 1
|
||||
} x
|
||||
test lreplace-1.28 {lreplace command} {
|
||||
} -result x
|
||||
test lreplace-1.28 {lreplace command} -body {
|
||||
lreplace x 1 1 y
|
||||
} {x y}
|
||||
} -result {x y}
|
||||
test lreplace-1.29 {lreplace command} -body {
|
||||
lreplace x 1 1 [error foo]
|
||||
} -returnCodes 1 -result {foo}
|
||||
test lreplace-1.30 {lreplace command} -body {
|
||||
lreplace {not {}alist} 0 0 [error foo]
|
||||
} -returnCodes 1 -result {foo}
|
||||
|
||||
test lreplace-2.1 {lreplace errors} {
|
||||
list [catch lreplace msg] $msg
|
||||
@@ -122,10 +128,10 @@ test lreplace-2.5 {lreplace errors} {
|
||||
} {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
|
||||
test lreplace-2.6 {lreplace errors} {
|
||||
list [catch {lreplace x 3 2} msg] $msg
|
||||
} {1 {list doesn't contain element 3}}
|
||||
} {0 x}
|
||||
test lreplace-2.7 {lreplace errors} {
|
||||
list [catch {lreplace x 2 2} msg] $msg
|
||||
} {1 {list doesn't contain element 2}}
|
||||
} {0 x}
|
||||
|
||||
test lreplace-3.1 {lreplace won't modify shared argument objects} {
|
||||
proc p {} {
|
||||
|
||||
@@ -418,6 +418,34 @@ test lsearch-17.6 {lsearch -index option, basic functionality} {
|
||||
test lsearch-17.7 {lsearch -index option, basic functionality} {
|
||||
lsearch -all -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b}
|
||||
} {0 1}
|
||||
test lsearch-17.8 {lsearch -index option, empty argument} {
|
||||
lsearch -index {} a a
|
||||
} 0
|
||||
test lsearch-17.9 {lsearch -index option, empty argument} {
|
||||
lsearch -index {} a a
|
||||
} [lsearch a a]
|
||||
test lsearch-17.10 {lsearch -index option, empty argument} {
|
||||
lsearch -index {} [list \{] \{
|
||||
} 0
|
||||
test lsearch-17.11 {lsearch -index option, empty argument} {
|
||||
lsearch -index {} [list \{] \{
|
||||
} [lsearch [list \{] \{]
|
||||
test lsearch-17.12 {lsearch -index option, encoding aliasing} -body {
|
||||
lsearch -index -2 a a
|
||||
} -returnCodes error -result {index "-2" cannot select an element from any list}
|
||||
test lsearch-17.13 {lsearch -index option, encoding aliasing} -body {
|
||||
lsearch -index -1-1 a a
|
||||
} -returnCodes error -result {index "-1-1" cannot select an element from any list}
|
||||
test lsearch-17.14 {lsearch -index option, encoding aliasing} -body {
|
||||
lsearch -index end--1 a a
|
||||
} -returnCodes error -result {index "end--1" cannot select an element from any list}
|
||||
test lsearch-17.15 {lsearch -index option, encoding aliasing} -body {
|
||||
lsearch -index end+1 a a
|
||||
} -returnCodes error -result {index "end+1" cannot select an element from any list}
|
||||
test lsearch-17.16 {lsearch -index option, encoding aliasing} -body {
|
||||
lsearch -index end+2 a a
|
||||
} -returnCodes error -result {index "end+2" cannot select an element from any list}
|
||||
|
||||
|
||||
test lsearch-18.1 {lsearch -index option, list as index basic functionality} {
|
||||
lsearch -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
|
||||
@@ -435,21 +463,27 @@ test lsearch-18.5 {lsearch -index option, list as index basic functionality} {
|
||||
lsearch -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
|
||||
} {0 1}
|
||||
|
||||
test lsearch-19.1 {lsearch -sunindices option} {
|
||||
test lsearch-19.1 {lsearch -subindices option} {
|
||||
lsearch -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
|
||||
} {1 0 0}
|
||||
test lsearch-19.2 {lsearch -sunindices option} {
|
||||
test lsearch-19.2 {lsearch -subindices option} {
|
||||
lsearch -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
|
||||
} {0 2 0}
|
||||
test lsearch-19.3 {lsearch -sunindices option} {
|
||||
test lsearch-19.3 {lsearch -subindices option} {
|
||||
lsearch -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b*
|
||||
} {0 1 1}
|
||||
test lsearch-19.4 {lsearch -sunindices option} {
|
||||
test lsearch-19.4 {lsearch -subindices option} {
|
||||
lsearch -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b}
|
||||
} {0 0 1}
|
||||
test lsearch-19.5 {lsearch -sunindices option} {
|
||||
test lsearch-19.5 {lsearch -subindices option} {
|
||||
lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
|
||||
} {{0 0 0} {1 0 0}}
|
||||
test lsearch-19.7 {lsearch -subindices option} {
|
||||
lsearch -subindices -index end {{1 a}} a
|
||||
} {0 1}
|
||||
test lsearch-19.8 {lsearch -subindices option} {
|
||||
lsearch -subindices -all -index end {{1 a}} a
|
||||
} {{0 1}}
|
||||
|
||||
test lsearch-20.1 {lsearch -index option, index larger than sublists} -body {
|
||||
lsearch -index 2 {{a c} {a b} {a a}} a
|
||||
|
||||
@@ -99,7 +99,7 @@ test macOSXFCmd-2.6 {MacOSXSetFileAttribute - hidden} {macosxFileAttr notRoot} {
|
||||
[catch {file attributes foo.test -hidden} msg] $msg \
|
||||
[file delete -force -- foo.test]
|
||||
} {0 {} 0 1 {}}
|
||||
test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot} {
|
||||
test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot nonPortable} {
|
||||
catch {file delete -force -- foo.test}
|
||||
close [open foo.test w]
|
||||
catch {
|
||||
@@ -151,16 +151,16 @@ test macOSXFCmd-4.1 {TclMacOSXMatchType} {macosxFileAttr notRoot} {
|
||||
file attributes dir.test -hidden 1
|
||||
}
|
||||
set res [list \
|
||||
[catch {glob *.test} msg] $msg \
|
||||
[catch {glob -types FOOT *.test} msg] $msg \
|
||||
[catch {glob -types {{macintosh type FOOT}} *.test} msg] $msg \
|
||||
[catch {glob -types FOOTT *.test} msg] $msg \
|
||||
[catch {glob -types {{macintosh type FOOTT}} *.test} msg] $msg \
|
||||
[catch {glob -types {{macintosh type {}}} *.test} msg] $msg \
|
||||
[catch {glob -types {{macintosh creator FOOC}} *.test} msg] $msg \
|
||||
[catch {glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test} msg] $msg \
|
||||
[catch {glob -types hidden *.test} msg] $msg \
|
||||
[catch {glob -types {hidden FOOT} *.test} msg] $msg \
|
||||
[catch {lsort [glob *.test]} msg] $msg \
|
||||
[catch {lsort [glob -types FOOT *.test]} msg] $msg \
|
||||
[catch {lsort [glob -types {{macintosh type FOOT}} *.test]} msg] $msg \
|
||||
[catch {lsort [glob -types FOOTT *.test]} msg] $msg \
|
||||
[catch {lsort [glob -types {{macintosh type FOOTT}} *.test]} msg] $msg \
|
||||
[catch {lsort [glob -types {{macintosh type {}}} *.test]} msg] $msg \
|
||||
[catch {lsort [glob -types {{macintosh creator FOOC}} *.test]} msg] $msg \
|
||||
[catch {lsort [glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test]} msg] $msg \
|
||||
[catch {lsort [glob -types hidden *.test]} msg] $msg \
|
||||
[catch {lsort [glob -types {hidden FOOT} *.test]} msg] $msg \
|
||||
]
|
||||
cd ..
|
||||
file delete -force globtest
|
||||
|
||||
@@ -1210,8 +1210,6 @@ namespace eval ::tcl::test::main {
|
||||
Bug 1775878
|
||||
} -constraints {
|
||||
exec Tcltest
|
||||
} -setup {
|
||||
catch {set f [open "|[list [interpreter]]" w+]}
|
||||
} -body {
|
||||
exec [interpreter] << "testsetmainloop\nputs \\\npwd\ntestexitmainloop" >& result
|
||||
set f [open result]
|
||||
|
||||
@@ -1206,6 +1206,8 @@ test mathop-25.5 { exp operator } {TestOp ** 1 5} 1
|
||||
test mathop-25.6 { exp operator } {TestOp ** 5 1} 5
|
||||
test mathop-25.7 { exp operator } {TestOp ** 4 3 2 1} 262144
|
||||
test mathop-25.8 { exp operator } {TestOp ** 5.5 4} 915.0625
|
||||
test mathop-25.8a { exp operator } {TestOp ** 4.0 -1} 0.25
|
||||
test mathop-25.8b { exp operator } {TestOp ** 2.0 -2} 0.25
|
||||
test mathop-25.9 { exp operator } {TestOp ** 16 3.5} 16384.0
|
||||
test mathop-25.10 { exp operator } {TestOp ** 3.5 0} 1.0
|
||||
test mathop-25.11 { exp operator } {TestOp ** 378 0} 1
|
||||
@@ -1219,8 +1221,32 @@ test mathop-25.18 { exp operator } {TestOp ** -1 -2} 1
|
||||
test mathop-25.19 { exp operator } {TestOp ** -1 3} -1
|
||||
test mathop-25.20 { exp operator } {TestOp ** -1 4} 1
|
||||
test mathop-25.21 { exp operator } {TestOp ** 2 63} 9223372036854775808
|
||||
test mathop-25.22 { exp operator } {TestOp ** 83756485763458746358734658473567847567473 2} 7015148907444467657897585474493757781161998914521537835809623408157343003287605729
|
||||
test mathop-25.23 { exp operator errors } {
|
||||
test mathop-25.22 { exp operator } {TestOp ** 2 256} 115792089237316195423570985008687907853269984665640564039457584007913129639936
|
||||
set big 83756485763458746358734658473567847567473
|
||||
test mathop-25.23 { exp operator } {TestOp ** $big 2} 7015148907444467657897585474493757781161998914521537835809623408157343003287605729
|
||||
test mathop-25.24 { exp operator } {TestOp ** $big 0} 1
|
||||
test mathop-25.25 { exp operator } {TestOp ** $big 1} $big
|
||||
test mathop-25.26 { exp operator } {TestOp ** $big -1} 0
|
||||
test mathop-25.27 { exp operator } {TestOp ** $big -2} 0
|
||||
test mathop-25.28 { exp operator } {TestOp ** $big -$big} 0
|
||||
test mathop-25.29 { exp operator } {expr {[set res [TestOp ** $big -1.0]] > 0 && $res < 1.2e-41}} 1
|
||||
test mathop-25.30 { exp operator } {expr {[set res [TestOp ** $big -1e-18]] > 0 && $res < 1}} 1
|
||||
test mathop-25.31 { exp operator } {expr {[set res [TestOp ** -$big -1.0]] > -1 && $res < 0}} 1
|
||||
test mathop-25.32 { exp operator } {expr {[set res [TestOp ** -$big -2.0]] > 0 && $res < 1}} 1
|
||||
test mathop-25.33 { exp operator } {expr {[set res [TestOp ** -$big -3.0]] > -1 && $res < 0}} 1
|
||||
test mathop-25.34 { exp operator } {TestOp ** $big -1e-30} 1.0
|
||||
test mathop-25.35 { exp operator } {TestOp ** $big -1e+30} 0.0
|
||||
test mathop-25.36 { exp operator } {TestOp ** 0 $big} 0
|
||||
test mathop-25.37 { exp operator } {TestOp ** 1 $big} 1
|
||||
test mathop-25.38 { exp operator } {TestOp ** -1 $big} -1
|
||||
test mathop-25.39 { exp operator } {TestOp ** -1 [expr {$big+1}]} 1
|
||||
test mathop-25.40 { exp operator (small exponent power helper and its boundaries) } {
|
||||
set pwr 0
|
||||
set res 1
|
||||
while {[incr pwr] <= 17 && [set i [TestOp ** 15 $pwr]] == [set res [expr {$res * 15}]]} {}
|
||||
list [incr pwr -1] $res
|
||||
} {17 98526125335693359375}
|
||||
test mathop-25.41 { exp operator errors } {
|
||||
set res {}
|
||||
set exp {}
|
||||
|
||||
|
||||
@@ -196,6 +196,19 @@ test namespace-7.7 {Bug 1655305} -setup {
|
||||
interp delete slave
|
||||
} -result {}
|
||||
|
||||
test namespace-7.8 {Bug ba1419303b4c} -setup {
|
||||
namespace eval ns1 {
|
||||
namespace ensemble create
|
||||
}
|
||||
|
||||
trace add command ns1 delete {
|
||||
namespace delete ns1
|
||||
}
|
||||
} -body {
|
||||
# No segmentation fault given --enable-symbols=mem.
|
||||
namespace delete ns1
|
||||
} -result {}
|
||||
|
||||
test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
|
||||
catch {interp delete test_interp}
|
||||
interp create test_interp
|
||||
@@ -1951,7 +1964,7 @@ test namespace-44.5 {ensemble: errors} -setup {
|
||||
foobar foobarcon
|
||||
} -cleanup {
|
||||
rename foobar {}
|
||||
} -returnCodes error -result {invalid command name "::foobarconfigure"}
|
||||
} -returnCodes error -result {invalid command name "foobarconfigure"}
|
||||
test namespace-44.6 {ensemble: errors} -returnCodes error -body {
|
||||
namespace ensemble create gorp
|
||||
} -result {wrong # args: should be "namespace ensemble create ?option value ...?"}
|
||||
@@ -2611,6 +2624,7 @@ test namespace-51.6 {name resolution path control} -body {
|
||||
namespace delete ::test_ns_1
|
||||
catch {rename ::pathtestB {}}
|
||||
catch {rename ::pathtestD {}}
|
||||
catch {rename ::pathtestC {}}
|
||||
}
|
||||
test namespace-51.7 {name resolution path control} -body {
|
||||
namespace eval ::test_ns_1 {
|
||||
@@ -3298,6 +3312,31 @@ test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} {
|
||||
}
|
||||
}
|
||||
} {::testing::abc::def ::testing::abc::ghi}
|
||||
|
||||
test namespace-56.4 {bug 16fe1b5807: names starting with ":"} knownBug {
|
||||
namespace eval : {
|
||||
namespace ensemble create
|
||||
namespace export *
|
||||
proc p1 {} {
|
||||
return 16fe1b5807
|
||||
}
|
||||
}
|
||||
|
||||
: p1
|
||||
} 16fe1b5807
|
||||
|
||||
test namespace-56.5 {Bug 8b9854c3d8} -setup {
|
||||
namespace eval namespace-56.5 {
|
||||
proc cmd {} {string match ::* [lindex [[string cat info] level 0] 0]}
|
||||
namespace export *
|
||||
namespace ensemble create
|
||||
}
|
||||
} -body {
|
||||
namespace-56.5 cmd
|
||||
} -cleanup {
|
||||
namespace delete namespace-56.5
|
||||
} -result 1
|
||||
|
||||
|
||||
# cleanup
|
||||
catch {rename cmd1 {}}
|
||||
|
||||
445
tests/oo.test
445
tests/oo.test
@@ -13,6 +13,13 @@ if {"::tcltest" in [namespace children]} {
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
|
||||
# The foundational objects oo::object and oo::class are sensitive to reference
|
||||
# counting errors and are deallocated only when an interp is deleted, so in
|
||||
# this test suite, interp creation and interp deletion are often used in
|
||||
# leaktests in order to leverage this sensitivity.
|
||||
|
||||
|
||||
testConstraint memory [llength [info commands memory]]
|
||||
if {[testConstraint memory]} {
|
||||
proc getbytes {} {
|
||||
@@ -47,7 +54,7 @@ test oo-0.2 {basic test of OO's ability to clean up its initial state} {
|
||||
} {}
|
||||
test oo-0.3 {basic test of OO's ability to clean up its initial state} -body {
|
||||
leaktest {
|
||||
[oo::object new] destroy
|
||||
[oo::object new] destroy
|
||||
}
|
||||
} -constraints memory -result 0
|
||||
test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
|
||||
@@ -57,7 +64,13 @@ test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
|
||||
foo destroy
|
||||
}
|
||||
} -constraints memory -result 0
|
||||
test oo-0.5 {testing literal leak on interp delete} memory {
|
||||
test oo-0.5.1 {testing object foundation cleanup} memory {
|
||||
leaktest {
|
||||
interp create foo
|
||||
interp delete foo
|
||||
}
|
||||
} 0
|
||||
test oo-0.5.2 {testing literal leak on interp delete} memory {
|
||||
leaktest {
|
||||
interp create foo
|
||||
foo eval {oo::object new}
|
||||
@@ -128,6 +141,13 @@ test oo-1.3 {basic test of OO functionality: no classes} {
|
||||
test oo-1.4 {basic test of OO functionality} -body {
|
||||
oo::object create {}
|
||||
} -returnCodes 1 -result {object name must not be empty}
|
||||
test oo-1.4.1 {fully-qualified nested name} -body {
|
||||
oo::object create ::one::two::three
|
||||
} -result {::one::two::three}
|
||||
test oo-1.4.2 {automatic command name has same name as namespace} -body {
|
||||
set obj [oo::object new]
|
||||
expr {[info object namespace $obj] == $obj}
|
||||
} -result 1
|
||||
test oo-1.5 {basic test of OO functionality} -body {
|
||||
oo::object doesnotexist
|
||||
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
|
||||
@@ -258,7 +278,21 @@ test oo-1.18 {OO: create object in NS with same name as global cmd} -setup {
|
||||
rename test-oo-1.18 {}
|
||||
A destroy
|
||||
} -result ::C
|
||||
test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
|
||||
test oo-1.18.1 {no memory leak: superclass} -setup {
|
||||
} -constraints memory -body {
|
||||
|
||||
leaktest {
|
||||
interp create t
|
||||
t eval {
|
||||
oo::class create A {
|
||||
superclass oo::class
|
||||
}
|
||||
}
|
||||
interp delete t
|
||||
}
|
||||
} -cleanup {
|
||||
} -result 0
|
||||
test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup {
|
||||
proc test-oo-1.18 {} return
|
||||
} -constraints memory -body {
|
||||
leaktest {
|
||||
@@ -271,7 +305,7 @@ test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
|
||||
} -cleanup {
|
||||
rename test-oo-1.18 {}
|
||||
} -result 0
|
||||
test oo-1.18.2 {Bug 21c144f0f5} -setup {
|
||||
test oo-1.18.3 {Bug 21c144f0f5} -setup {
|
||||
interp create slave
|
||||
} -body {
|
||||
slave eval {
|
||||
@@ -1319,6 +1353,35 @@ test oo-7.9 {OO: defining inheritance in namespaces} -setup {
|
||||
return
|
||||
}
|
||||
} -result {}
|
||||
test oo-7.10 {OO: next after object deletion, bug [135804138e]} -setup {
|
||||
set ::result ""
|
||||
oo::class create c1 {
|
||||
method m1 {} {
|
||||
lappend ::result c1::m1
|
||||
}
|
||||
}
|
||||
oo::class create c2 {
|
||||
superclass c1
|
||||
destructor {
|
||||
lappend ::result c2::destructor
|
||||
my m1
|
||||
lappend ::result /c2::destructor
|
||||
}
|
||||
method m1 {} {
|
||||
lappend ::result c2::m1
|
||||
rename [self] {}
|
||||
lappend ::result no-self
|
||||
next
|
||||
lappend ::result /c2::m1
|
||||
}
|
||||
}
|
||||
} -body {
|
||||
c2 create o
|
||||
lappend ::result [catch {o m1} msg] $msg
|
||||
} -cleanup {
|
||||
c1 destroy
|
||||
unset ::result
|
||||
} -result {c2::m1 c2::destructor c2::m1 no-self c1::m1 /c2::m1 /c2::destructor no-self 1 {no next method implementation}}
|
||||
|
||||
test oo-8.1 {OO: global must work in methods} {
|
||||
oo::object create foo
|
||||
@@ -1446,6 +1509,30 @@ test oo-10.3 {OO: invoke and modify} -setup {
|
||||
oo::define B deletemethod b c
|
||||
lappend result [C a] [C b] [C c]
|
||||
} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}
|
||||
test oo-10.4 {OO: invoke and modify} -setup {
|
||||
oo::class create A {
|
||||
method a {} {return A.a}
|
||||
method b {} {return A.b}
|
||||
method c {} {return A.c}
|
||||
}
|
||||
A create B
|
||||
oo::objdefine B {
|
||||
method a {} {return [next],B.a}
|
||||
method b {} {return [next],B.b}
|
||||
method c {} {return [next],B.c}
|
||||
}
|
||||
set result {}
|
||||
} -cleanup {
|
||||
A destroy
|
||||
} -body {
|
||||
lappend result [B a] [B b] [B c] -
|
||||
oo::objdefine B deletemethod b
|
||||
lappend result [B a] [B b] [B c] -
|
||||
oo::objdefine B renamemethod a b
|
||||
lappend result [B a] [B b] [B c] -
|
||||
oo::objdefine B deletemethod b c
|
||||
lappend result [B a] [B b] [B c]
|
||||
} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c}
|
||||
|
||||
test oo-11.1 {OO: cleanup} {
|
||||
oo::object create foo
|
||||
@@ -1482,6 +1569,87 @@ test oo-11.4 {OO: cleanup} {
|
||||
lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \
|
||||
[oo::object create bar2] [bar2 destroy]
|
||||
} {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}}
|
||||
test oo-11.5 {OO: cleanup} {
|
||||
oo::class create obj1
|
||||
|
||||
trace add command obj1 delete {apply {{name1 name2 action} {
|
||||
set namespace [info object namespace $name1]
|
||||
namespace delete $namespace
|
||||
}}}
|
||||
|
||||
rename obj1 {}
|
||||
# No segmentation fault
|
||||
return done
|
||||
} done
|
||||
|
||||
test oo-11.6.1 {
|
||||
OO: cleanup of when an class is mixed into itself
|
||||
} -constraints memory -body {
|
||||
leaktest {
|
||||
interp create interp1
|
||||
oo::class create obj1
|
||||
::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
|
||||
rename obj1 {}
|
||||
interp delete interp1
|
||||
}
|
||||
} -result 0 -cleanup {
|
||||
}
|
||||
|
||||
test oo-11.6.2 {
|
||||
OO: cleanup ReleaseClassContents() where class is mixed into one of its
|
||||
instances
|
||||
} -constraints memory -body {
|
||||
leaktest {
|
||||
interp create interp1
|
||||
interp1 eval {
|
||||
oo::class create obj1
|
||||
::oo::copy obj1 obj2
|
||||
rename obj2 {}
|
||||
rename obj1 {}
|
||||
}
|
||||
interp delete interp1
|
||||
}
|
||||
} -result 0 -cleanup {
|
||||
}
|
||||
|
||||
test oo-11.6.3 {
|
||||
OO: cleanup ReleaseClassContents() where class is mixed into one of its
|
||||
instances
|
||||
} -constraints memory -body {
|
||||
leaktest {
|
||||
interp create interp1
|
||||
interp1 eval {
|
||||
oo::class create obj1
|
||||
::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
|
||||
|
||||
::oo::copy obj1 obj2
|
||||
rename obj2 {}
|
||||
rename obj1 {}
|
||||
}
|
||||
interp delete interp1
|
||||
}
|
||||
} -result 0 -cleanup {
|
||||
}
|
||||
|
||||
test oo-11.6.4 {
|
||||
OO: cleanup ReleaseClassContents() where class is mixed into one of its
|
||||
instances
|
||||
} -body {
|
||||
oo::class create obj1
|
||||
::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
|
||||
|
||||
::oo::copy obj1 obj2
|
||||
::oo::objdefine obj2 {mixin [uplevel 1 {namespace which obj2}]}
|
||||
|
||||
::oo::copy obj2 obj3
|
||||
rename obj3 {}
|
||||
rename obj2 {}
|
||||
|
||||
# No segmentation fault
|
||||
return done
|
||||
} -result done -cleanup {
|
||||
rename obj1 {}
|
||||
}
|
||||
|
||||
test oo-12.1 {OO: filters} {
|
||||
oo::class create Aclass
|
||||
@@ -1668,13 +1836,13 @@ test oo-13.2 {OO: changing an object's class} -body {
|
||||
oo::objdefine foo class oo::class
|
||||
} -cleanup {
|
||||
foo destroy
|
||||
} -returnCodes 1 -result {may not change a non-class object into a class object}
|
||||
} -result {}
|
||||
test oo-13.3 {OO: changing an object's class} -body {
|
||||
oo::class create foo
|
||||
oo::objdefine foo class oo::object
|
||||
} -cleanup {
|
||||
foo destroy
|
||||
} -returnCodes 1 -result {may not change a class object into a non-class object}
|
||||
} -result {}
|
||||
test oo-13.4 {OO: changing an object's class} -body {
|
||||
oo::class create foo {
|
||||
method m {} {
|
||||
@@ -1689,6 +1857,106 @@ test oo-13.4 {OO: changing an object's class} -body {
|
||||
foo destroy
|
||||
bar destroy
|
||||
} -result {::foo ::foo ::foo ::bar}
|
||||
test oo-13.5 {OO: changing an object's class: non-class to class} -setup {
|
||||
oo::object create fooObj
|
||||
} -body {
|
||||
oo::objdefine fooObj {
|
||||
class oo::class
|
||||
}
|
||||
oo::define fooObj {
|
||||
method x {} {expr 1+2+3}
|
||||
}
|
||||
[fooObj new] x
|
||||
} -cleanup {
|
||||
fooObj destroy
|
||||
} -result 6
|
||||
test oo-13.6 {OO: changing an object's class: class to non-class} -setup {
|
||||
oo::class create foo
|
||||
unset -nocomplain ::result
|
||||
} -body {
|
||||
set result dangling
|
||||
oo::define foo {
|
||||
method x {} {expr 1+2+3}
|
||||
}
|
||||
oo::class create boo {
|
||||
superclass foo
|
||||
destructor {set ::result "ok"}
|
||||
}
|
||||
boo new
|
||||
foo create bar
|
||||
oo::objdefine foo {
|
||||
class oo::object
|
||||
}
|
||||
list $result [catch {bar x} msg] $msg
|
||||
} -cleanup {
|
||||
catch {bar destroy}
|
||||
foo destroy
|
||||
} -result {ok 1 {invalid command name "bar"}}
|
||||
test oo-13.7 {OO: changing an object's class} -setup {
|
||||
oo::class create foo
|
||||
oo::class create bar
|
||||
unset -nocomplain result
|
||||
} -body {
|
||||
oo::define bar method x {} {return ok}
|
||||
oo::define foo {
|
||||
method x {} {expr 1+2+3}
|
||||
self mixin foo
|
||||
}
|
||||
lappend result [foo x]
|
||||
oo::objdefine foo class bar
|
||||
lappend result [foo x]
|
||||
} -cleanup {
|
||||
foo destroy
|
||||
bar destroy
|
||||
} -result {6 ok}
|
||||
test oo-13.8 {OO: changing an object's class to itself} -setup {
|
||||
oo::class create foo
|
||||
} -body {
|
||||
oo::define foo {
|
||||
method x {} {expr 1+2+3}
|
||||
}
|
||||
oo::objdefine foo class foo
|
||||
} -cleanup {
|
||||
foo destroy
|
||||
} -returnCodes error -result {may not change classes into an instance of themselves}
|
||||
test oo-13.9 {OO: changing an object's class: roots are special} -setup {
|
||||
set i [interp create]
|
||||
} -body {
|
||||
$i eval {
|
||||
oo::objdefine oo::object {
|
||||
class oo::class
|
||||
}
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete $i
|
||||
} -returnCodes error -result {may not modify the class of the root object class}
|
||||
test oo-13.10 {OO: changing an object's class: roots are special} -setup {
|
||||
set i [interp create]
|
||||
} -body {
|
||||
$i eval {
|
||||
oo::objdefine oo::class {
|
||||
class oo::object
|
||||
}
|
||||
}
|
||||
} -cleanup {
|
||||
interp delete $i
|
||||
} -returnCodes error -result {may not modify the class of the class of classes}
|
||||
test oo-13.11 {OO: changing an object's class in a tricky place} -setup {
|
||||
oo::class create cls
|
||||
unset -nocomplain result
|
||||
} -body {
|
||||
set result gorp
|
||||
list [catch {
|
||||
oo::define cls {
|
||||
method x {} {return}
|
||||
self class oo::object
|
||||
::set ::result ok
|
||||
method y {} {return}; # I'm sorry, Dave. I'm afraid I can't do that.
|
||||
}
|
||||
} msg] $msg $result
|
||||
} -cleanup {
|
||||
cls destroy
|
||||
} -result {1 {attempt to misuse API} ok}
|
||||
# todo: changing a class subtype (metaclass) to another class subtype
|
||||
|
||||
test oo-14.1 {OO: mixins} {
|
||||
@@ -2026,7 +2294,20 @@ test oo-15.12 {OO: object cloning with target NS} -setup {
|
||||
Super destroy
|
||||
catch {namespace delete ::existing}
|
||||
} -result {::existing refers to an existing namespace}
|
||||
test oo-15.13 {OO: object cloning with target NS} -setup {
|
||||
test oo-15.13.1 {
|
||||
OO: object cloning with target NS
|
||||
Valgrind will report a leak if the reference count of the namespace isn't
|
||||
properly incremented.
|
||||
} -setup {
|
||||
oo::class create Cls {}
|
||||
} -body {
|
||||
oo::copy Cls Cls2 ::dupens
|
||||
return done
|
||||
} -cleanup {
|
||||
Cls destroy
|
||||
Cls2 destroy
|
||||
} -result done
|
||||
test oo-15.13.2 {OO: object cloning with target NS} -setup {
|
||||
oo::class create Super
|
||||
oo::class create Cls {superclass Super}
|
||||
} -body {
|
||||
@@ -3621,99 +3902,110 @@ test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup {
|
||||
cls destroy
|
||||
} -result {0 {}}
|
||||
|
||||
oo::class create SampleSlot {
|
||||
superclass oo::Slot
|
||||
constructor {} {
|
||||
variable contents {a b c} ops {}
|
||||
}
|
||||
method contents {} {variable contents; return $contents}
|
||||
method ops {} {variable ops; return $ops}
|
||||
method Get {} {
|
||||
variable contents
|
||||
variable ops
|
||||
lappend ops [info level] Get
|
||||
return $contents
|
||||
}
|
||||
method Set {lst} {
|
||||
variable contents $lst
|
||||
variable ops
|
||||
lappend ops [info level] Set $lst
|
||||
return
|
||||
proc SampleSlotSetup script {
|
||||
set script0 {
|
||||
oo::class create SampleSlot {
|
||||
superclass oo::Slot
|
||||
constructor {} {
|
||||
variable contents {a b c} ops {}
|
||||
}
|
||||
method contents {} {variable contents; return $contents}
|
||||
method ops {} {variable ops; return $ops}
|
||||
method Get {} {
|
||||
variable contents
|
||||
variable ops
|
||||
lappend ops [info level] Get
|
||||
return $contents
|
||||
}
|
||||
method Set {lst} {
|
||||
variable contents $lst
|
||||
variable ops
|
||||
lappend ops [info level] Set $lst
|
||||
return
|
||||
}
|
||||
}
|
||||
}
|
||||
append script0 \n$script
|
||||
}
|
||||
|
||||
test oo-32.1 {TIP 380: slots - class test} -setup {
|
||||
proc SampleSlotCleanup script {
|
||||
set script0 {
|
||||
SampleSlot destroy
|
||||
}
|
||||
append script \n$script0
|
||||
}
|
||||
|
||||
test oo-32.1 {TIP 380: slots - class test} -setup [SampleSlotSetup {
|
||||
SampleSlot create sampleSlot
|
||||
} -body {
|
||||
}] -body {
|
||||
list [info level] [sampleSlot contents] [sampleSlot ops]
|
||||
} -cleanup {
|
||||
} -cleanup [SampleSlotCleanup {
|
||||
rename sampleSlot {}
|
||||
} -result {0 {a b c} {}}
|
||||
test oo-32.2 {TIP 380: slots - class test} -setup {
|
||||
}] -result {0 {a b c} {}}
|
||||
test oo-32.2 {TIP 380: slots - class test} -setup [SampleSlotSetup {
|
||||
SampleSlot create sampleSlot
|
||||
} -body {
|
||||
}] -body {
|
||||
list [info level] [sampleSlot -clear] \
|
||||
[sampleSlot contents] [sampleSlot ops]
|
||||
} -cleanup {
|
||||
} -cleanup [SampleSlotCleanup {
|
||||
rename sampleSlot {}
|
||||
} -result {0 {} {} {1 Set {}}}
|
||||
test oo-32.3 {TIP 380: slots - class test} -setup {
|
||||
}] -result {0 {} {} {1 Set {}}}
|
||||
test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
|
||||
SampleSlot create sampleSlot
|
||||
} -body {
|
||||
}] -body {
|
||||
list [info level] [sampleSlot -append g h i] \
|
||||
[sampleSlot contents] [sampleSlot ops]
|
||||
} -cleanup {
|
||||
} -cleanup [SampleSlotCleanup {
|
||||
rename sampleSlot {}
|
||||
} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
|
||||
test oo-32.4 {TIP 380: slots - class test} -setup {
|
||||
}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
|
||||
test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
|
||||
SampleSlot create sampleSlot
|
||||
} -body {
|
||||
}] -body {
|
||||
list [info level] [sampleSlot -set d e f] \
|
||||
[sampleSlot contents] [sampleSlot ops]
|
||||
} -cleanup {
|
||||
} -cleanup [SampleSlotCleanup {
|
||||
rename sampleSlot {}
|
||||
} -result {0 {} {d e f} {1 Set {d e f}}}
|
||||
test oo-32.5 {TIP 380: slots - class test} -setup {
|
||||
}] -result {0 {} {d e f} {1 Set {d e f}}}
|
||||
test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
|
||||
SampleSlot create sampleSlot
|
||||
} -body {
|
||||
}] -body {
|
||||
list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
|
||||
[sampleSlot contents] [sampleSlot ops]
|
||||
} -cleanup {
|
||||
} -cleanup [SampleSlotCleanup {
|
||||
rename sampleSlot {}
|
||||
} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
|
||||
}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
|
||||
|
||||
test oo-33.1 {TIP 380: slots - defaulting} -setup {
|
||||
test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
|
||||
set s [SampleSlot new]
|
||||
} -body {
|
||||
}] -body {
|
||||
list [$s x y] [$s contents]
|
||||
} -cleanup {
|
||||
} -cleanup [SampleSlotCleanup {
|
||||
rename $s {}
|
||||
} -result {{} {a b c x y}}
|
||||
test oo-33.2 {TIP 380: slots - defaulting} -setup {
|
||||
}] -result {{} {a b c x y}}
|
||||
test oo-33.2 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
|
||||
set s [SampleSlot new]
|
||||
} -body {
|
||||
}] -body {
|
||||
list [$s destroy; $s unknown] [$s contents]
|
||||
} -cleanup {
|
||||
} -cleanup [SampleSlotCleanup {
|
||||
rename $s {}
|
||||
} -result {{} {a b c destroy unknown}}
|
||||
test oo-33.3 {TIP 380: slots - defaulting} -setup {
|
||||
}] -result {{} {a b c destroy unknown}}
|
||||
test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
|
||||
set s [SampleSlot new]
|
||||
} -body {
|
||||
}] -body {
|
||||
oo::objdefine $s forward --default-operation my -set
|
||||
list [$s destroy; $s unknown] [$s contents] [$s ops]
|
||||
} -cleanup {
|
||||
} -cleanup [SampleSlotCleanup {
|
||||
rename $s {}
|
||||
} -result {{} unknown {1 Set destroy 1 Set unknown}}
|
||||
test oo-33.4 {TIP 380: slots - errors} -setup {
|
||||
}] -result {{} unknown {1 Set destroy 1 Set unknown}}
|
||||
test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
|
||||
set s [SampleSlot new]
|
||||
} -body {
|
||||
}] -body {
|
||||
# Method names beginning with "-" are special to slots
|
||||
$s -grill q
|
||||
} -returnCodes error -cleanup {
|
||||
} -returnCodes error -cleanup [SampleSlotCleanup {
|
||||
rename $s {}
|
||||
} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}
|
||||
|
||||
SampleSlot destroy
|
||||
}] -result \
|
||||
{unknown method "-grill": must be -append, -clear, -set, contents or ops}
|
||||
|
||||
test oo-34.1 {TIP 380: slots - presence} -setup {
|
||||
set obj [oo::object new]
|
||||
@@ -3833,10 +4125,35 @@ test oo-35.5 {Bug 1a56550e96: introspectors must traverse mixin links correctly}
|
||||
} -cleanup {
|
||||
base destroy
|
||||
} -result {{c d e} {c d e}}
|
||||
|
||||
|
||||
test oo-35.6 {
|
||||
Bug : teardown of an object that is a class that is an instance of itself
|
||||
} -setup {
|
||||
oo::class create obj
|
||||
|
||||
oo::copy obj obj1 obj1
|
||||
oo::objdefine obj1 {
|
||||
mixin obj1 obj
|
||||
}
|
||||
oo::copy obj1 obj2
|
||||
oo::objdefine obj2 {
|
||||
mixin obj2 obj1
|
||||
}
|
||||
} -body {
|
||||
rename obj2 {}
|
||||
rename obj1 {}
|
||||
# doesn't crash
|
||||
return done
|
||||
} -cleanup {
|
||||
rename obj {}
|
||||
} -result done
|
||||
|
||||
|
||||
|
||||
cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# MODE: Tcl
|
||||
# End:
|
||||
|
||||
@@ -608,6 +608,18 @@ test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} {
|
||||
package require t
|
||||
set x
|
||||
} {1.1}
|
||||
test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup {
|
||||
package forget t
|
||||
} -body {
|
||||
coroutine coro1 apply {{} {
|
||||
package ifneeded t 2.1 {
|
||||
yield
|
||||
package provide t 2.1
|
||||
}
|
||||
package require t 2.1
|
||||
}}
|
||||
list [catch {coro1} msg] $msg
|
||||
} -match glob -result {0 2.1}
|
||||
|
||||
|
||||
test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body {
|
||||
|
||||
@@ -21,7 +21,7 @@ testConstraint pidDefined [llength [info commands pid]]
|
||||
test pid-1.1 {pid command} pidDefined {
|
||||
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
|
||||
} 1
|
||||
test pid-1.2 {pid command} -constraints {unixOrPc unixExecs pidDefined} -setup {
|
||||
test pid-1.2 {pid command} -constraints {unixOrWin unixExecs pidDefined} -setup {
|
||||
set path(test1) [makeFile {} test1]
|
||||
file delete $path(test1)
|
||||
} -body {
|
||||
|
||||
3
tests/pkgIndex.tcl
Normal file
3
tests/pkgIndex.tcl
Normal file
@@ -0,0 +1,3 @@
|
||||
#! /usr/bin/env tclsh
|
||||
|
||||
package ifneeded tcltests 0.1 [list source $dir/tcltests.tcl]
|
||||
@@ -10,6 +10,7 @@
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
package require tcltest 2
|
||||
package require tcltests
|
||||
|
||||
namespace eval ::tcl::test::platform {
|
||||
namespace import ::tcltest::testConstraint
|
||||
@@ -67,7 +68,10 @@ test platform-3.1 {CPU ID on Windows/UNIX} \
|
||||
# format of string it produces consists of two non-empty words separated by a
|
||||
# hyphen.
|
||||
package require platform
|
||||
test platform-4.1 {format of platform::identify result} -match regexp -body {
|
||||
test platform-4.1 {format of platform::identify result} -constraints notValgrind -match regexp -body {
|
||||
# [identify] may attempt to [exec] dpkg-architecture, which may not exist,
|
||||
# in which case fork will not be followed by exec, and valgrind will issue
|
||||
# "still reachable" reports.
|
||||
platform::identify
|
||||
} -result {^([^-]+-)+[^-]+$}
|
||||
test platform-4.2 {format of platform::generic result} -match regexp -body {
|
||||
|
||||
@@ -110,6 +110,14 @@ test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple name
|
||||
proc p {b:a b::a} {
|
||||
}
|
||||
} -returnCodes error -result {formal parameter "b::a" is not a simple name}
|
||||
test proc-1.9 {Tcl_ProcObjCmd, arguments via canonical list (string-representation bug [631b4c45df])} -body {
|
||||
set v 2
|
||||
binary scan AB cc a b
|
||||
proc p [list [list a $a] [list b $b] [list v [expr {$v + 2}]]] {expr {$a + $b + $v}}
|
||||
p
|
||||
} -result [expr {65+66+4}] -cleanup {
|
||||
rename p {}
|
||||
}
|
||||
|
||||
test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} -setup {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
@@ -313,6 +321,9 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set
|
||||
rename getbytes {}
|
||||
unset -nocomplain end i tmp leakedBytes
|
||||
} -result 0
|
||||
test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} procbodytest {
|
||||
procbodytest::check
|
||||
} 1
|
||||
|
||||
test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body {
|
||||
proc p args {} ; # this will be bytecompiled into t
|
||||
@@ -383,6 +394,14 @@ test proc-7.4 {Proc struct outlives its interp: Bug 3532959} {
|
||||
interp delete slave
|
||||
unset lambda
|
||||
} {}
|
||||
|
||||
test proc-7.5 {[631b4c45df] Crash in argument processing} {
|
||||
binary scan A c val
|
||||
proc foo [list [list from $val]] {}
|
||||
rename foo {}
|
||||
unset -nocomplain val
|
||||
} {}
|
||||
|
||||
|
||||
# cleanup
|
||||
catch {rename p ""}
|
||||
|
||||
@@ -19,7 +19,7 @@ testConstraint reg 0
|
||||
if {[testConstraint win]} {
|
||||
if {![catch {
|
||||
::tcltest::loadTestedCommands
|
||||
set ::regver [package require registry 1.3.2]
|
||||
set ::regver [package require registry 1.3.4]
|
||||
}]} {
|
||||
testConstraint reg 1
|
||||
}
|
||||
@@ -33,7 +33,7 @@ testConstraint english [expr {
|
||||
|
||||
test registry-1.0 {check if we are testing the right dll} {win reg} {
|
||||
set ::regver
|
||||
} {1.3.2}
|
||||
} {1.3.4}
|
||||
test registry-1.1 {argument parsing for registry command} {win reg} {
|
||||
list [catch {registry} msg] $msg
|
||||
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
|
||||
@@ -283,7 +283,7 @@ test registry-4.7 {GetKeyNames: Unicode} {win reg english} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} "baz\u00c7bar blat"
|
||||
test registry-4.8 {GetKeyNames: Unicode} {win reg nt} {
|
||||
test registry-4.8 {GetKeyNames: Unicode} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u30b7bar
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar\\blat
|
||||
@@ -487,7 +487,7 @@ test registry-6.17 {GetValue: Unicode value names} {win reg} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} foobar
|
||||
test registry-6.18 {GetValue: values with Unicode strings} {win reg nt} {
|
||||
test registry-6.18 {GetValue: values with Unicode strings} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar val1]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
@@ -505,7 +505,7 @@ test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} {
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
set result
|
||||
} "foo ba r baz"
|
||||
test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} {
|
||||
test registry-6.21 {GetValue: very long value names and values} {win reg} {
|
||||
registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz
|
||||
set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]]
|
||||
registry delete HKEY_CURRENT_USER\\TclFoobar
|
||||
@@ -604,7 +604,7 @@ test registry-9.3 {ParseKeyName: bad keys} -constraints {win reg} -body {
|
||||
test registry-9.4 {ParseKeyName: bad keys} -constraints {win reg} -body {
|
||||
registry values \\\\\\
|
||||
} -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA}
|
||||
test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english nt} -body {
|
||||
test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english} -body {
|
||||
registry values \\\\\\HKEY_CLASSES_ROOT
|
||||
} -returnCodes error -result {unable to open key: The network address is invalid.}
|
||||
test registry-9.6 {ParseKeyName: bad keys} -constraints {win reg} -body {
|
||||
|
||||
@@ -180,17 +180,17 @@ test safe-6.3 {test safe interpreters knowledge of the world} {
|
||||
# leaking infos, but they still do...
|
||||
|
||||
# high level general test
|
||||
test safe-7.1 {tests that everything works at high level} {
|
||||
test safe-7.1 {tests that everything works at high level} -body {
|
||||
set i [safe::interpCreate]
|
||||
# no error shall occur:
|
||||
# (because the default access_path shall include 1st level sub dirs so
|
||||
# package require in a slave works like in the master)
|
||||
set v [interp eval $i {package require http 1}]
|
||||
set v [interp eval $i {package require http 2}]
|
||||
# no error shall occur:
|
||||
interp eval $i {http_config}
|
||||
interp eval $i {http::config}
|
||||
safe::interpDelete $i
|
||||
set v
|
||||
} 1.0
|
||||
} -match glob -result 2.*
|
||||
test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body {
|
||||
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
|
||||
# should not add anything (p0)
|
||||
@@ -308,14 +308,10 @@ test safe-8.7 {safe source control on file} -setup {
|
||||
unset log
|
||||
safe::interpDelete $i
|
||||
} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]]
|
||||
test safe-8.8 {safe source forbids -rsrc} -setup {
|
||||
catch {safe::interpDelete $i}
|
||||
safe::interpCreate $i
|
||||
} -body {
|
||||
$i eval {source -rsrc Init}
|
||||
} -returnCodes error -cleanup {
|
||||
safe::interpDelete $i
|
||||
} -result {wrong # args: should be "source ?-encoding E? fileName"}
|
||||
test safe-8.8 {safe source forbids -rsrc} emptyTest {
|
||||
# Disabled this test. It was only useful for long unsupported
|
||||
# Mac OS 9 systems. [Bug 860a9f1945]
|
||||
} {}
|
||||
test safe-8.9 {safe source and return} -setup {
|
||||
set returnScript [makeFile {return "ok"} return.tcl]
|
||||
catch {safe::interpDelete $i}
|
||||
|
||||
1048
tests/socket.test
1048
tests/socket.test
File diff suppressed because it is too large
Load Diff
@@ -24,6 +24,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testobj [expr {[info commands testobj] != {}}]
|
||||
testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
|
||||
testConstraint tip389 [expr {[string length \U010000] == 2}]
|
||||
|
||||
# Used for constraining memory leak tests
|
||||
testConstraint memory [llength [info commands memory]]
|
||||
@@ -224,6 +225,24 @@ test string-4.15 {string first, ability to two-byte encoded utf-8 chars} {
|
||||
set uchar \u057e ;# character with two-byte encoding in utf-8
|
||||
string first % %#$uchar$uchar#$uchar$uchar#% 3
|
||||
} 8
|
||||
test string-4.17 {string first, corner case} {
|
||||
string first a aaa 4294967295
|
||||
} {0}
|
||||
test string-4.18 {string first, corner case} {
|
||||
string first a aaa -1
|
||||
} {0}
|
||||
test string-4.19 {string first, corner case} {
|
||||
string first a aaa end-5
|
||||
} {0}
|
||||
test string-4.20 {string last, corner case} {
|
||||
string last a aaa 4294967295
|
||||
} {-1}
|
||||
test string-4.21 {string last, corner case} {
|
||||
string last a aaa -1
|
||||
} {-1}
|
||||
test string-4.22 {string last, corner case} {
|
||||
string last a aaa end-5
|
||||
} {-1}
|
||||
|
||||
test string-5.1 {string index} {
|
||||
list [catch {string index} msg] $msg
|
||||
@@ -290,6 +309,9 @@ test string-5.19 {string index, bytearray object out of bounds} {
|
||||
test string-5.20 {string index, bytearray object out of bounds} {
|
||||
string index [binary format I* {0x50515253 0x52}] 20
|
||||
} {}
|
||||
test string-5.21 {string index, surrogates, bug [11ae2be95dac9417]} tip389 {
|
||||
list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]
|
||||
} [list \U100000 {} b]
|
||||
|
||||
|
||||
proc largest_int {} {
|
||||
@@ -1191,6 +1213,9 @@ test string-11.54 {string match, failure} {
|
||||
[string match *a*l*\u0000*cba* $longString] \
|
||||
[string match *===* $longString]
|
||||
} {0 1 1 1 0 0}
|
||||
test string-11.55 {string match, invalid binary optimization} {
|
||||
[format string] match \u0141 [binary format c 65]
|
||||
} 0
|
||||
|
||||
test string-12.1 {string range} {
|
||||
list [catch {string range} msg] $msg
|
||||
@@ -1276,6 +1301,9 @@ test string-12.22 {string range, shimmering binary/index} {
|
||||
binary scan $s a* x
|
||||
string range $s $s end
|
||||
} 000000001
|
||||
test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} tip389 {
|
||||
list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]
|
||||
} [list \U100000 {} b]
|
||||
|
||||
test string-13.1 {string repeat} {
|
||||
list [catch {string repeat} msg] $msg
|
||||
@@ -1371,6 +1399,12 @@ test string-14.16 {string replace} {
|
||||
test string-14.17 {string replace} {
|
||||
string replace abcdefghijklmnop end end-1
|
||||
} {abcdefghijklmnop}
|
||||
test string-14.18 {string replace} {
|
||||
string replace abcdefghijklmnop 10 9 XXX
|
||||
} {abcdefghijklmnop}
|
||||
test string-14.19 {string replace} {
|
||||
string replace {} -1 0 A
|
||||
} A
|
||||
|
||||
test string-15.1 {string tolower too few args} {
|
||||
list [catch {string tolower} msg] $msg
|
||||
@@ -1464,6 +1498,10 @@ test string-17.7 {string totitle, unicode} {
|
||||
test string-17.8 {string totitle, compiled} {
|
||||
lindex [string totitle [list aa bb [list cc]]] 0
|
||||
} Aa
|
||||
test string-17.9 {string totitle, surrogates, bug [11ae2be95dac9417]} tip389 {
|
||||
list [string totitle a\U118c0c 1 1] [string totitle a\U118c0c 2 2] \
|
||||
[string totitle a\U118c0c 3 3]
|
||||
} [list a\U118a0c a\U118c0C a\U118c0C]
|
||||
|
||||
test string-18.1 {string trim} {
|
||||
list [catch {string trim} msg] $msg
|
||||
@@ -1995,6 +2033,12 @@ test string-29.4 {string cat, many args} {
|
||||
list $r1 $r2
|
||||
} {0 0}
|
||||
|
||||
test string-30.1.1 {[Bug ba921a8d98]: string cat} {
|
||||
string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]
|
||||
} hellohello
|
||||
test string-30.1.2 {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} {
|
||||
set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"
|
||||
} hellohello
|
||||
|
||||
|
||||
# cleanup
|
||||
|
||||
@@ -688,6 +688,26 @@ if {[testConstraint testnrelevels]} {
|
||||
namespace delete testnre
|
||||
}
|
||||
|
||||
test tailcall-14.1 {in a deleted namespace} -body {
|
||||
namespace eval ns {
|
||||
proc p args {
|
||||
tailcall [namespace current] $args
|
||||
}
|
||||
namespace delete [namespace current]
|
||||
p
|
||||
}
|
||||
} -returnCodes 1 -result {namespace "::ns" not found}
|
||||
|
||||
test tailcall-14.1-bc {{in a deleted namespace} {byte compiled}} -body {
|
||||
namespace eval ns {
|
||||
proc p args {
|
||||
tailcall [namespace current] {*}$args
|
||||
}
|
||||
namespace delete [namespace current]
|
||||
p
|
||||
}
|
||||
} -returnCodes 1 -result {namespace "::ns" not found}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
|
||||
|
||||
@@ -98,44 +98,44 @@ proc slave {msgVar args} {
|
||||
}
|
||||
return $code
|
||||
}
|
||||
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
|
||||
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} {
|
||||
set result [slave msg test.tcl]
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 1 0 0 1}
|
||||
test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} {
|
||||
test tcltest-2.1 {tcltest -verbose 'b'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -verbose 'b']
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 1 0 0 1}
|
||||
test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} {
|
||||
test tcltest-2.2 {tcltest -verbose 'p'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -verbose 'p']
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 0 1 0 1}
|
||||
test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} {
|
||||
test tcltest-2.3 {tcltest -verbose 's'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -verbose 's']
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 0 0 1 1}
|
||||
test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} {
|
||||
test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -verbose 'ps']
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 0 1 1 1}
|
||||
test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} {
|
||||
test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -verbose 'psb']
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 1 1 1 1}
|
||||
|
||||
test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
|
||||
test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -verbose "pass skip body"]
|
||||
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
|
||||
[regexp c-1.0 $msg] \
|
||||
@@ -143,7 +143,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
|
||||
} {0 1 1 1 1}
|
||||
|
||||
test tcltest-2.6 {tcltest -verbose 't'} {
|
||||
-constraints {unixOrPc}
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
set result [slave msg test.tcl -verbose 't']
|
||||
list $result $msg
|
||||
@@ -153,7 +153,7 @@ test tcltest-2.6 {tcltest -verbose 't'} {
|
||||
}
|
||||
|
||||
test tcltest-2.6a {tcltest -verbose 'start'} {
|
||||
-constraints {unixOrPc}
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
set result [slave msg test.tcl -verbose start]
|
||||
list $result $msg
|
||||
@@ -176,7 +176,7 @@ test tcltest-2.7 {tcltest::verbose} {
|
||||
}
|
||||
|
||||
test tcltest-2.8 {tcltest -verbose 'error'} {
|
||||
-constraints {unixOrPc}
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
set result [slave msg test.tcl -verbose error]
|
||||
list $result $msg
|
||||
@@ -185,22 +185,22 @@ test tcltest-2.8 {tcltest -verbose 'error'} {
|
||||
-match regexp
|
||||
}
|
||||
# -match, [match]
|
||||
test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} {
|
||||
test tcltest-3.1 {tcltest -match 'a*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -match a* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
|
||||
} {0 1 0 0 1}
|
||||
test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} {
|
||||
test tcltest-3.2 {tcltest -match 'b*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -match b* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
|
||||
} {0 0 1 0 1}
|
||||
test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} {
|
||||
test tcltest-3.3 {tcltest -match 'c*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -match c* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
|
||||
} {0 0 0 1 1}
|
||||
test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} {
|
||||
test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -match {a* b*} -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
|
||||
@@ -220,27 +220,27 @@ test tcltest-3.5 {tcltest::match} {
|
||||
}
|
||||
|
||||
# -skip, [skip]
|
||||
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
|
||||
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -skip a* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
|
||||
} {0 0 1 1 1}
|
||||
test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} {
|
||||
test tcltest-4.2 {tcltest -skip 'b*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -skip b* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
|
||||
} {0 1 0 1 1}
|
||||
test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} {
|
||||
test tcltest-4.3 {tcltest -skip 'c*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -skip c* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
|
||||
} {0 1 1 0 1}
|
||||
test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} {
|
||||
test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -skip {a* b*} -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
|
||||
} {0 0 0 1 1}
|
||||
test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} {
|
||||
test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
|
||||
@@ -261,12 +261,12 @@ test tcltest-4.6 {tcltest::skip} {
|
||||
|
||||
# -constraints, -limitconstraints, [testConstraint],
|
||||
# $constraintsSpecified, [limitConstraints]
|
||||
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
|
||||
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrWin} {
|
||||
set result [slave msg test.tcl -constraints knownBug -verbose 'ps']
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
|
||||
} {0 1 1 1 1}
|
||||
test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} {
|
||||
test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrWin} {
|
||||
set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
|
||||
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
|
||||
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
|
||||
@@ -355,7 +355,7 @@ set printerror [makeFile {
|
||||
} printerror.tcl]
|
||||
|
||||
test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
|
||||
-constraints unixOrPc
|
||||
-constraints unixOrWin
|
||||
-body {
|
||||
slave msg $printerror
|
||||
return $msg
|
||||
@@ -363,21 +363,21 @@ test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
|
||||
-result {a test.*a really}
|
||||
-match regexp
|
||||
}
|
||||
test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} {
|
||||
test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} {
|
||||
slave msg $printerror -outfile a.tmp
|
||||
set result1 [catch {exec grep "a test" a.tmp}]
|
||||
set result2 [catch {exec grep "a really" a.tmp}]
|
||||
list [regexp "a test" $msg] [regexp "a really" $msg] \
|
||||
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
|
||||
} {0 1 0 1 1 {}}
|
||||
test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} {
|
||||
test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrWin unixExecs} {
|
||||
slave msg $printerror -errfile a.tmp
|
||||
set result1 [catch {exec grep "a test" a.tmp}]
|
||||
set result2 [catch {exec grep "a really" a.tmp}]
|
||||
list [regexp "a test" $msg] [regexp "a really" $msg] \
|
||||
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
|
||||
} {1 0 1 0 1 {}}
|
||||
test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} {
|
||||
test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrWin unixExecs} {
|
||||
slave msg $printerror -outfile a.tmp -errfile b.tmp
|
||||
set result1 [catch {exec grep "a test" a.tmp}]
|
||||
set result2 [catch {exec grep "a really" b.tmp}]
|
||||
@@ -464,25 +464,25 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
|
||||
# Must use child processes to test -debug because it always writes
|
||||
# messages to stdout, and we have no way to capture stdout of a
|
||||
# slave interp
|
||||
test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} {
|
||||
test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrWin} {
|
||||
catch {exec [interpreter] test.tcl -debug 0} msg
|
||||
regexp "Flags passed into tcltest" $msg
|
||||
} {0}
|
||||
test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} {
|
||||
test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrWin} {
|
||||
catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
|
||||
list [regexp userSpecifiedSkip $msg] \
|
||||
[regexp "Flags passed into tcltest" $msg]
|
||||
} {1 0}
|
||||
test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} {
|
||||
test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrWin} {
|
||||
catch {exec [interpreter] test.tcl -debug 1 -match b*} msg
|
||||
list [regexp userSpecifiedNonMatch $msg] \
|
||||
[regexp "Flags passed into tcltest" $msg]
|
||||
} {1 0}
|
||||
test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} {
|
||||
test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrWin} {
|
||||
catch {exec [interpreter] test.tcl -debug 2} msg
|
||||
list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
|
||||
} {1 0}
|
||||
test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} {
|
||||
test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrWin} {
|
||||
catch {exec [interpreter] test.tcl -debug 3} msg
|
||||
list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
|
||||
} {1 1}
|
||||
@@ -522,7 +522,7 @@ set normaldirectory [makeDirectory normaldirectory]
|
||||
normalizePath normaldirectory
|
||||
|
||||
# -tmpdir, [temporaryDirectory]
|
||||
test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrPc -setup {
|
||||
test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup {
|
||||
file delete -force thisdirectorydoesnotexist
|
||||
} -body {
|
||||
slave msg $a -tmpdir thisdirectorydoesnotexist
|
||||
@@ -531,7 +531,7 @@ test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrPc -setup {
|
||||
file delete -force thisdirectorydoesnotexist
|
||||
} -result 1
|
||||
test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
|
||||
-constraints unixOrPc
|
||||
-constraints unixOrWin
|
||||
-body {
|
||||
slave msg $a -tmpdir $tdiaf
|
||||
return $msg
|
||||
@@ -550,6 +550,7 @@ switch -- $::tcl_platform(platform) {
|
||||
file attributes $notWriteableDir -permissions 00555
|
||||
}
|
||||
default {
|
||||
# note in FAT/NTFS we won't be able to protect directory with read-only attribute...
|
||||
catch {file attributes $notWriteableDir -readonly 1}
|
||||
catch {testchmod 0 $notWriteableDir}
|
||||
}
|
||||
@@ -566,11 +567,12 @@ test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
|
||||
# This constraint doesn't go at the top of the file so that it doesn't
|
||||
# interfere with tcltest-5.5
|
||||
testConstraint notFAT [expr {
|
||||
![string match "FAT*" [lindex [file system $notWriteableDir] 1]]
|
||||
![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]]
|
||||
|| $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]]
|
||||
}]
|
||||
# FAT permissions are fairly hopeless; ignore this test if that FS is used
|
||||
# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used
|
||||
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
|
||||
-constraints {unixOrPc notRoot notFAT}
|
||||
-constraints {unixOrWin notRoot notFAT}
|
||||
-body {
|
||||
slave msg $a -tmpdir $notWriteableDir
|
||||
return $msg
|
||||
@@ -579,7 +581,7 @@ test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
|
||||
-match glob
|
||||
}
|
||||
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {
|
||||
-constraints unixOrPc
|
||||
-constraints unixOrWin
|
||||
-body {
|
||||
slave msg $a -tmpdir $normaldirectory
|
||||
# The join is necessary because the message can be split on multiple
|
||||
@@ -622,7 +624,7 @@ test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
|
||||
cd [temporaryDirectory]
|
||||
# -testdir, [testsDirectory]
|
||||
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
|
||||
-constraints unixOrPc
|
||||
-constraints unixOrWin
|
||||
-setup {
|
||||
file delete -force thisdirectorydoesnotexist
|
||||
}
|
||||
@@ -634,7 +636,7 @@ test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
|
||||
-result {*does not exist*}
|
||||
}
|
||||
test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {
|
||||
-constraints unixOrPc
|
||||
-constraints unixOrWin
|
||||
-body {
|
||||
slave msg $a -testdir $tdiaf
|
||||
return $msg
|
||||
@@ -652,7 +654,7 @@ test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {
|
||||
-result {*not readable*}
|
||||
}
|
||||
test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {
|
||||
-constraints unixOrPc
|
||||
-constraints unixOrWin
|
||||
-body {
|
||||
slave msg $a -testdir $normaldirectory
|
||||
# The join is necessary because the message can be split on multiple
|
||||
@@ -729,7 +731,7 @@ removeFile thisdirectoryisafile
|
||||
removeDirectory normaldirectory
|
||||
|
||||
# -file, -notfile, [matchFiles], [skipFiles]
|
||||
test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup {
|
||||
test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup {
|
||||
set old [testsDirectory]
|
||||
testsDirectory [file dirname [info script]]
|
||||
} -body {
|
||||
@@ -739,7 +741,7 @@ test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup {
|
||||
testsDirectory $old
|
||||
} -match regexp -result {dstring\.test}
|
||||
|
||||
test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup {
|
||||
test tcltest-9.2 {-file d*.tcl} -constraints {unixOrWin} -setup {
|
||||
set old [testsDirectory]
|
||||
testsDirectory [file dirname [info script]]
|
||||
} -body {
|
||||
@@ -804,23 +806,23 @@ set mc [makeFile {
|
||||
} makecore.tcl]
|
||||
|
||||
cd [temporaryDirectory]
|
||||
test tcltest-10.1 {-preservecore 0} {unixOrPc} {
|
||||
test tcltest-10.1 {-preservecore 0} {unixOrWin} {
|
||||
slave msg $mc -preservecore 0
|
||||
file delete core
|
||||
regexp "Core file produced" $msg
|
||||
} {0}
|
||||
test tcltest-10.2 {-preservecore 1} {unixOrPc} {
|
||||
test tcltest-10.2 {-preservecore 1} {unixOrWin} {
|
||||
slave msg $mc -preservecore 1
|
||||
file delete core
|
||||
regexp "Core file produced" $msg
|
||||
} {1}
|
||||
test tcltest-10.3 {-preservecore 2} {unixOrPc} {
|
||||
test tcltest-10.3 {-preservecore 2} {unixOrWin} {
|
||||
slave msg $mc -preservecore 2
|
||||
file delete core
|
||||
list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
|
||||
[regexp "core-" $msg] [file delete core-makecore]
|
||||
} {1 1 1 {}}
|
||||
test tcltest-10.4 {-preservecore 3} {unixOrPc} {
|
||||
test tcltest-10.4 {-preservecore 3} {unixOrWin} {
|
||||
slave msg $mc -preservecore 3
|
||||
file delete core
|
||||
list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
|
||||
@@ -851,13 +853,13 @@ set contents {
|
||||
}
|
||||
set loadfile [makeFile $contents load.tcl]
|
||||
|
||||
test tcltest-12.1 {-load xxx} {unixOrPc} {
|
||||
test tcltest-12.1 {-load xxx} {unixOrWin} {
|
||||
slave msg $loadfile -load xxx
|
||||
return $msg
|
||||
} {xxx}
|
||||
|
||||
# Using child process because of -debug usage.
|
||||
test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} {
|
||||
test tcltest-12.2 {-loadfile load.tcl} {unixOrWin} {
|
||||
catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg
|
||||
list \
|
||||
[regexp {tcltest} [join [list $msg] [split $msg \n]]] \
|
||||
@@ -906,7 +908,9 @@ removeFile load.tcl
|
||||
|
||||
# [interpreter]
|
||||
test tcltest-13.1 {interpreter} {
|
||||
-constraints notValgrind
|
||||
-setup {
|
||||
#to do: Why is $::tcltest::tcltest being saved and restored here?
|
||||
set old $::tcltest::tcltest
|
||||
set ::tcltest::tcltest tcltest
|
||||
}
|
||||
@@ -918,6 +922,11 @@ test tcltest-13.1 {interpreter} {
|
||||
}
|
||||
-result {tcltest tclsh tclsh}
|
||||
-cleanup {
|
||||
# writing ::tcltest::tcltest triggers a trace that sets up the stdio
|
||||
# constraint, which involves a call to [exec] that might fail after
|
||||
# "fork" and before "exec", in which case the forked process will not
|
||||
# have a chance to clean itself up before exiting, which causes
|
||||
# valgrind to issue numerous "still reachable" reports.
|
||||
set ::tcltest::tcltest $old
|
||||
}
|
||||
}
|
||||
@@ -941,7 +950,7 @@ set allfile [makeFile {
|
||||
cd [workingDirectory]
|
||||
|
||||
test tcltest-14.1 {-singleproc - single process} {
|
||||
-constraints {unixOrPc}
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
|
||||
return $msg
|
||||
@@ -951,7 +960,7 @@ test tcltest-14.1 {-singleproc - single process} {
|
||||
}
|
||||
|
||||
test tcltest-14.2 {-singleproc - multiple process} {
|
||||
-constraints {unixOrPc}
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
|
||||
return $msg
|
||||
@@ -1015,7 +1024,7 @@ makeFile {
|
||||
} all.tcl $dtd3
|
||||
|
||||
test tcltest-15.1 {basic directory walking} {
|
||||
-constraints {unixOrPc}
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
if {[slave msg \
|
||||
[file join $dtd all.tcl] \
|
||||
@@ -1029,7 +1038,7 @@ test tcltest-15.1 {basic directory walking} {
|
||||
}
|
||||
|
||||
test tcltest-15.2 {-asidefromdir} {
|
||||
-constraints {unixOrPc}
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
if {[slave msg \
|
||||
[file join $dtd all.tcl] \
|
||||
@@ -1047,7 +1056,7 @@ Error: No test files remain after applying your match and skip patterns!$}
|
||||
}
|
||||
|
||||
test tcltest-15.3 {-relateddir, non-existent dir} {
|
||||
-constraints {unixOrPc}
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
if {[slave msg \
|
||||
[file join $dtd all.tcl] \
|
||||
@@ -1062,7 +1071,7 @@ test tcltest-15.3 {-relateddir, non-existent dir} {
|
||||
}
|
||||
|
||||
test tcltest-15.4 {-relateddir, subdir} {
|
||||
-constraints {unixOrPc}
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
if {[slave msg \
|
||||
[file join $dtd all.tcl] \
|
||||
@@ -1075,7 +1084,7 @@ test tcltest-15.4 {-relateddir, subdir} {
|
||||
-result {Tests located in:.*dirtestdir2.[^23]}
|
||||
}
|
||||
test tcltest-15.5 {-relateddir, -asidefromdir} {
|
||||
-constraints {unixOrPc}
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
if {[slave msg \
|
||||
[file join $dtd all.tcl] \
|
||||
@@ -1164,7 +1173,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
|
||||
|
||||
cd [temporaryDirectory]
|
||||
# PrintError
|
||||
test tcltest-20.1 {PrintError} {unixOrPc} {
|
||||
test tcltest-20.1 {PrintError} {unixOrWin} {
|
||||
set result [slave msg $printerror]
|
||||
list $result [regexp "Error: a really short string" $msg] \
|
||||
[regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \
|
||||
@@ -1198,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} {
|
||||
} {1}
|
||||
}
|
||||
-returnCodes 1
|
||||
-result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
|
||||
-result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
|
||||
}
|
||||
|
||||
test tcltest-21.3 {test command with setup} {
|
||||
@@ -1291,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} {
|
||||
}
|
||||
}
|
||||
-returnCodes 1
|
||||
-result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
|
||||
-result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
|
||||
}
|
||||
|
||||
# alternate test command format (these are the same as 21.1-21.6, with the
|
||||
@@ -1311,7 +1320,7 @@ test tcltest-21.8 {force a test command failure} \
|
||||
} \
|
||||
-returnCodes 1 \
|
||||
-cleanup {set ::tcltest::currentFailure $fail} \
|
||||
-result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
|
||||
-result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
|
||||
|
||||
test tcltest-21.9 {test command with setup} \
|
||||
-setup {set foo 1} \
|
||||
@@ -1400,7 +1409,7 @@ makeFile {
|
||||
# Must use a child process because stdout/stderr parsing can't be
|
||||
# duplicated in slave interp.
|
||||
test tcltest-22.1 {runAllTests} {
|
||||
-constraints {unixOrPc}
|
||||
-constraints {unixOrWin}
|
||||
-body {
|
||||
exec [interpreter] \
|
||||
[file join $atd all.tcl] \
|
||||
|
||||
46
tests/tcltests.tcl
Normal file
46
tests/tcltests.tcl
Normal file
@@ -0,0 +1,46 @@
|
||||
#! /usr/bin/env tclsh
|
||||
|
||||
package require tcltest 2.2
|
||||
namespace import ::tcltest::*
|
||||
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
testConstraint fcopy [llength [info commands fcopy]]
|
||||
testConstraint fileevent [llength [info commands fileevent]]
|
||||
testConstraint thread [
|
||||
expr {0 == [catch {package require Thread 2.7-}]}]
|
||||
testConstraint notValgrind [expr {![testConstraint valgrind]}]
|
||||
|
||||
namespace eval ::tcltests {
|
||||
|
||||
|
||||
proc init {} {
|
||||
if {[namespace which ::tcl::file::tempdir] eq {}} {
|
||||
interp alias {} [namespace current]::tempdir {} [
|
||||
namespace current]::tempdir_alternate
|
||||
} else {
|
||||
interp alias {} [namespace current]::tempdir {} ::tcl::file::tempdir
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
proc tempdir_alternate {} {
|
||||
close [file tempfile tempfile]
|
||||
set tmpdir [file dirname $tempfile]
|
||||
set execname [info nameofexecutable]
|
||||
regsub -all {[^[:alpha:][:digit:]]} $execname _ execname
|
||||
for {set i 0} {$i < 10000} {incr i} {
|
||||
set time [clock milliseconds]
|
||||
set name $tmpdir/${execname}_${time}_$i
|
||||
if {![file exists $name]} {
|
||||
file mkdir $name
|
||||
return $name
|
||||
}
|
||||
}
|
||||
error [list {could not create temporary directory}]
|
||||
}
|
||||
|
||||
init
|
||||
|
||||
package provide tcltests 0.1
|
||||
|
||||
}
|
||||
@@ -11,25 +11,19 @@
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
|
||||
if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
package require tcltest 2.2
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
# when thread::release is used, -wait is passed in order allow the thread to
|
||||
# be fully finalized, which avoids valgrind "still reachable" reports.
|
||||
|
||||
package require tcltests
|
||||
|
||||
::tcltest::loadTestedCommands
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
# Some tests require the testthread command
|
||||
|
||||
testConstraint testthread [expr {[info commands testthread] != {}}]
|
||||
testConstraint testthread [expr {[info commands testthread] ne {}}]
|
||||
|
||||
# Some tests require the Thread package
|
||||
|
||||
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
|
||||
|
||||
# Some tests may not work under valgrind
|
||||
|
||||
testConstraint notValgrind [expr {![testConstraint valgrind]}]
|
||||
|
||||
set threadSuperKillScript {
|
||||
rename catch ""
|
||||
@@ -72,6 +66,17 @@ proc ThreadError {id info} {
|
||||
set threadSawError($id) true; # signal main thread to exit [vwait].
|
||||
}
|
||||
|
||||
proc threadSuperKill id {
|
||||
variable threadSuperKillScript
|
||||
try {
|
||||
thread::send $id $::threadSuperKillScript
|
||||
} on error {tres topts} {
|
||||
if {$tres ne {target thread died}} {
|
||||
return -options $topts $tres
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if {[testConstraint thread]} {
|
||||
thread::errorproc ThreadError
|
||||
}
|
||||
@@ -96,22 +101,22 @@ test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} {
|
||||
test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} {
|
||||
set serverthread [thread::create -preserved]
|
||||
set numthreads [llength [thread::names]]
|
||||
thread::release $serverthread
|
||||
thread::release -wait $serverthread
|
||||
set numthreads
|
||||
} {2}
|
||||
} 2
|
||||
test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} {
|
||||
thread::create {set x 5}
|
||||
foreach try {0 1 2 4 5 6} {
|
||||
# Try various ways to yield
|
||||
update
|
||||
after 10
|
||||
set l [llength [thread::names]]
|
||||
if {$l == 1} {
|
||||
break
|
||||
}
|
||||
# Try various ways to yield
|
||||
update
|
||||
after 10
|
||||
set l [llength [thread::names]]
|
||||
if {$l == 1} {
|
||||
break
|
||||
}
|
||||
}
|
||||
set l
|
||||
} {1}
|
||||
} 1
|
||||
test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} {
|
||||
thread::create {{*}{}}
|
||||
update
|
||||
@@ -121,13 +126,13 @@ test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} {
|
||||
test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} {
|
||||
set serverthread [thread::create -preserved]
|
||||
set five [thread::send $serverthread {set x 5}]
|
||||
thread::release $serverthread
|
||||
thread::release -wait $serverthread
|
||||
set five
|
||||
} 5
|
||||
test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} {
|
||||
set serverthread [thread::create -preserved {set z 5 ; thread::wait}]
|
||||
set five [thread::send $serverthread {set z}]
|
||||
thread::release $serverthread
|
||||
thread::release -wait $serverthread
|
||||
set five
|
||||
} 5
|
||||
|
||||
@@ -159,7 +164,7 @@ test thread-3.1 {TclThreadList} {thread} {
|
||||
set l2 [thread::names]
|
||||
set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]]
|
||||
foreach t $l1 {
|
||||
thread::release $t
|
||||
thread::release -wait $t
|
||||
}
|
||||
list $len $c
|
||||
} {1 0}
|
||||
@@ -887,7 +892,7 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread drainE
|
||||
# wait for other thread to signal "ready to cancel"
|
||||
vwait ::threadIdStarted; after 1000
|
||||
set res [thread::cancel $serverthread]
|
||||
thread::send $serverthread $::threadSuperKillScript
|
||||
threadSuperKill $serverthread
|
||||
vwait ::threadSawError($serverthread)
|
||||
thread::join $serverthread; drainEventQueue
|
||||
list $res [expr {[info exists ::threadIdStarted] ? \
|
||||
@@ -929,7 +934,7 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread
|
||||
# wait for other thread to signal "ready to cancel"
|
||||
vwait ::threadIdStarted; after 1000
|
||||
set res [thread::cancel $serverthread]
|
||||
thread::send $serverthread $::threadSuperKillScript
|
||||
threadSuperKill $serverthread
|
||||
vwait ::threadSawError($serverthread)
|
||||
thread::join $serverthread; drainEventQueue
|
||||
list $res [expr {[info exists ::threadIdStarted] ? \
|
||||
@@ -1029,7 +1034,7 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo
|
||||
# wait for other thread to signal "ready to cancel"
|
||||
vwait ::threadIdStarted; after 1000
|
||||
set res [thread::send -async $serverthread {interp cancel}]
|
||||
thread::send $serverthread $::threadSuperKillScript
|
||||
threadSuperKill $serverthread
|
||||
vwait ::threadSawError($serverthread)
|
||||
thread::join $serverthread; drainEventQueue
|
||||
list $res [expr {[info exists ::threadIdStarted] ? \
|
||||
@@ -1071,7 +1076,7 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo
|
||||
# wait for other thread to signal "ready to cancel"
|
||||
vwait ::threadIdStarted; after 1000
|
||||
set res [thread::send -async $serverthread {interp cancel}]
|
||||
thread::send $serverthread $::threadSuperKillScript
|
||||
threadSuperKill $serverthread
|
||||
vwait ::threadSawError($serverthread)
|
||||
thread::join $serverthread; drainEventQueue
|
||||
list $res [expr {[info exists ::threadIdStarted] ? \
|
||||
@@ -1111,7 +1116,7 @@ test thread-7.30 {cancel: send async thread cancel nested catch inside pure byte
|
||||
# wait for other thread to signal "ready to cancel"
|
||||
vwait ::threadIdStarted; after 1000
|
||||
set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
|
||||
thread::send $serverthread $::threadSuperKillScript
|
||||
threadSuperKill $serverthread
|
||||
vwait ::threadSawError($serverthread)
|
||||
thread::join $serverthread; drainEventQueue
|
||||
list $res [expr {[info exists ::threadIdStarted] ? \
|
||||
@@ -1153,7 +1158,7 @@ test thread-7.31 {cancel: send async thread cancel nested catch pure inside-comm
|
||||
# wait for other thread to signal "ready to cancel"
|
||||
vwait ::threadIdStarted; after 1000
|
||||
set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
|
||||
thread::send $serverthread $::threadSuperKillScript
|
||||
threadSuperKill $serverthread
|
||||
vwait ::threadSawError($serverthread)
|
||||
thread::join $serverthread; drainEventQueue
|
||||
list $res [expr {[info exists ::threadIdStarted] ? \
|
||||
|
||||
@@ -205,11 +205,11 @@ test timer-6.4 {Tcl_AfterCmd procedure, ms argument} {
|
||||
} {before after}
|
||||
test timer-6.5 {Tcl_AfterCmd procedure, ms argument} {
|
||||
set x before
|
||||
after 300 set x after
|
||||
after 400 set x after
|
||||
after 200
|
||||
update
|
||||
set y $x
|
||||
after 200
|
||||
after 400
|
||||
update
|
||||
list $y $x
|
||||
} {before after}
|
||||
|
||||
@@ -200,7 +200,7 @@ test tm-3.11 {tm: module path management, remove ignores unknown path} -setup {
|
||||
proc genpaths {base} {
|
||||
# Normalizing picks up drive letters on windows [Bug 1053568]
|
||||
set base [file normalize $base]
|
||||
lassign [split [package present Tcl] .] major minor
|
||||
regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
|
||||
set results {}
|
||||
set base [file join $base tcl$major]
|
||||
lappend results [file join $base site-tcl]
|
||||
|
||||
@@ -333,11 +333,10 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
|
||||
puts $f {puts [encoding system]; exit}
|
||||
set enc [gets $f]
|
||||
close $f
|
||||
return $enc
|
||||
set enc
|
||||
} -cleanup {
|
||||
unset -nocomplain env(LANG)
|
||||
} -match regexp -result [expr {
|
||||
($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}]
|
||||
} -match regexp -result {^(iso8859-15?|utf-8)$}
|
||||
test unixInit-3.2 {TclpSetInitialEncodings} -setup {
|
||||
catch {set oldlc_all $env(LC_ALL)}
|
||||
} -constraints {unix stdio} -body {
|
||||
|
||||
@@ -83,6 +83,16 @@ test uplevel-3.4 {uplevel to same level} {
|
||||
a1
|
||||
} 55
|
||||
|
||||
test uplevel-4.0.1 {error: non-existent level} -body {
|
||||
uplevel #0 { uplevel { set y 222 } }
|
||||
} -returnCodes error -result {bad level "1"}
|
||||
test uplevel-4.0.2 {error: non-existent level} -setup {
|
||||
interp create i
|
||||
} -body {
|
||||
i eval { uplevel { set y 222 } }
|
||||
} -returnCodes error -result {bad level "1"} -cleanup {
|
||||
interp delete i
|
||||
}
|
||||
test uplevel-4.1 {error: non-existent level} -returnCodes error -body {
|
||||
apply {{} {
|
||||
uplevel #2 {set y 222}
|
||||
|
||||
@@ -304,6 +304,17 @@ test upvar-8.3 {errors in upvar command} -returnCodes error -body {
|
||||
proc p1 {} {upvar a b c}
|
||||
p1
|
||||
} -result {bad level "a"}
|
||||
test upvar-8.3.1 {bad level for upvar (upvar at top-level, bug [775ee88560])} -body {
|
||||
proc p1 {} { uplevel { upvar b b; lappend b UNEXPECTED } }
|
||||
uplevel #0 { p1 }
|
||||
} -returnCodes error -result {bad level "1"}
|
||||
test upvar-8.3.2 {bad level for upvar (upvar at top-level, bug [775ee88560])} -setup {
|
||||
interp create i
|
||||
} -body {
|
||||
i eval { upvar b b; lappend b UNEXPECTED }
|
||||
} -returnCodes error -result {bad level "1"} -cleanup {
|
||||
interp delete i
|
||||
}
|
||||
test upvar-8.4 {errors in upvar command} -returnCodes error -body {
|
||||
proc p1 {} {upvar 0 b b}
|
||||
p1
|
||||
@@ -355,7 +366,11 @@ test upvar-8.11 {upvar will not create a variable that looks like an array} -set
|
||||
|
||||
test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
|
||||
list [catch {testupvar xyz a {} x global} msg] $msg
|
||||
} {1 {bad level "xyz"}}
|
||||
} {1 {bad level "1"}}
|
||||
test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar {
|
||||
apply {{} {testupvar xyz a {} x local; set x foo}}
|
||||
set a
|
||||
} foo
|
||||
test upvar-9.2 {Tcl_UpVar2 procedure} testupvar {
|
||||
catch {unset a}
|
||||
catch {unset x}
|
||||
|
||||
@@ -201,6 +201,28 @@ test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array:
|
||||
test var-1.19 {TclLookupVar, right error message when parsing variable name} -body {
|
||||
[format set] thisvar(doesntexist)
|
||||
} -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable}
|
||||
test var-1.20 {TclLookupVar, regression on utf-8 variable names} -setup {
|
||||
proc p [list \u20ac \xe4] {info vars}
|
||||
} -body {
|
||||
# test variable with non-ascii name is available (euro and a-uml chars here):
|
||||
list \
|
||||
[p 1 2] \
|
||||
[apply [list [list \u20ac \xe4] {info vars}] 1 2] \
|
||||
[apply [list [list [list \u20ac \u20ac] [list \xe4 \xe4]] {info vars}]] \
|
||||
} -cleanup {
|
||||
rename p {}
|
||||
} -result [lrepeat 3 [list \u20ac \xe4]]
|
||||
test var-1.21 {TclLookupVar, regression on utf-8 variable names} -setup {
|
||||
proc p [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}
|
||||
} -body {
|
||||
# test variable with non-ascii name (and default) is resolvable (euro and a-uml chars here):
|
||||
list \
|
||||
[p] \
|
||||
[apply [list [list \u20ac \xe4] {list [set \u20ac] [set \xe4]}] v\u20ac v\xe4] \
|
||||
[apply [list [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}]] \
|
||||
} -cleanup {
|
||||
rename p {}
|
||||
} -result [lrepeat 3 [list v\u20ac v\xe4]]
|
||||
|
||||
test var-2.1 {Tcl_LappendObjCmd, create var if new} {
|
||||
catch {unset x}
|
||||
@@ -776,6 +798,22 @@ test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup {
|
||||
}
|
||||
set x "If you see this, it worked"
|
||||
} -result "If you see this, it worked"
|
||||
test var-13.2 {unset array with search, bug 46a2410650} -body {
|
||||
apply {{} {
|
||||
array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66}
|
||||
set s [array startsearch a]
|
||||
unset a([array nextelement a $s])
|
||||
array nextelement a $s
|
||||
}}
|
||||
} -returnCodes error -result {couldn't find search "s-1-a"}
|
||||
test var-13.3 {unset array with search, SIGSEGV, bug 46a2410650} -body {
|
||||
apply {{} {
|
||||
array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66}
|
||||
set s [array startsearch a]
|
||||
unset a(ff)
|
||||
array nextelement a $s
|
||||
}}
|
||||
} -returnCodes error -result {couldn't find search "s-1-a"}
|
||||
|
||||
test var-14.1 {array names syntax} -body {
|
||||
array names foo bar baz snafu
|
||||
@@ -819,6 +857,18 @@ test var-17.1 {TclArraySet [Bug 1669489]} -setup {
|
||||
} -cleanup {
|
||||
unset -nocomplain ::a ::elements
|
||||
} -result {}
|
||||
test var-17.2 {TclArraySet Dict shortcut only on pure value} -setup {
|
||||
unset -nocomplain a d
|
||||
set d {p 1 p 2}
|
||||
dict get $d p
|
||||
set foo 0
|
||||
} -body {
|
||||
trace add variable a write "[list incr [namespace which -variable foo]];#"
|
||||
array set a $d
|
||||
set foo
|
||||
} -cleanup {
|
||||
unset -nocomplain a d foo
|
||||
} -result 2
|
||||
|
||||
test var-18.1 {array unset and unset traces: Bug 2939073} -setup {
|
||||
set already 0
|
||||
@@ -930,6 +980,28 @@ test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup {
|
||||
test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body {
|
||||
apply {{} {set name foo(bar); array set $name {a 1}}}
|
||||
} -returnCodes error -match glob -result *
|
||||
test var-20.11 {array set don't compile bad initializer} -setup {
|
||||
unset -nocomplain foo
|
||||
trace add variable foo array {set foo(bar) baz;#}
|
||||
} -body {
|
||||
catch {array set foo bad}
|
||||
set foo(bar)
|
||||
} -cleanup {
|
||||
unset -nocomplain foo
|
||||
} -result baz
|
||||
test var-20.12 {array set don't compile bad initializer} -setup {
|
||||
unset -nocomplain ::foo
|
||||
trace add variable ::foo array {set ::foo(bar) baz;#}
|
||||
} -body {
|
||||
catch {apply {{} {
|
||||
set value bad
|
||||
array set ::foo $value
|
||||
|
||||
}}}
|
||||
set ::foo(bar)
|
||||
} -cleanup {
|
||||
unset -nocomplain ::foo
|
||||
} -result baz
|
||||
|
||||
test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
|
||||
proc linenumber {} {dict get [info frame -1] line}
|
||||
|
||||
@@ -20,7 +20,7 @@ testConstraint dde 0
|
||||
if {[testConstraint win]} {
|
||||
if {![catch {
|
||||
::tcltest::loadTestedCommands
|
||||
set ::ddever [package require dde 1.4.0]
|
||||
set ::ddever [package require dde 1.4.2]
|
||||
set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} {
|
||||
testConstraint dde 1
|
||||
}
|
||||
@@ -104,7 +104,7 @@ proc createChildProcess {ddeServerName args} {
|
||||
# -------------------------------------------------------------------------
|
||||
test winDde-1.0 {check if we are testing the right dll} {win dde} {
|
||||
set ::ddever
|
||||
} {1.4.0}
|
||||
} {1.4.2}
|
||||
|
||||
test winDde-1.1 {Settings the server's topic name} -constraints dde -body {
|
||||
list [dde servername foobar] [dde servername] [dde servername self]
|
||||
|
||||
@@ -29,6 +29,7 @@ testConstraint testchmod [llength [info commands testchmod]]
|
||||
testConstraint cdrom 0
|
||||
testConstraint exdev 0
|
||||
testConstraint longFileNames 0
|
||||
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
|
||||
|
||||
proc createfile {file {string a}} {
|
||||
set f [open $file w]
|
||||
@@ -57,11 +58,10 @@ proc cleanup {args} {
|
||||
}
|
||||
|
||||
if {[testConstraint winOnly]} {
|
||||
set major [string index $tcl_platform(osVersion) 0]
|
||||
if {[testConstraint nt] && $major > 4} {
|
||||
if {$major > 5} {
|
||||
if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} {
|
||||
if {$::tcl_platform(osVersion) >= 6.0} {
|
||||
testConstraint winVista 1
|
||||
} elseif {$major == 5} {
|
||||
} else {
|
||||
testConstraint win2000orXP 1
|
||||
}
|
||||
} else {
|
||||
@@ -98,8 +98,13 @@ if {[testConstraint testvolumetype]} {
|
||||
# NB: filename is chosen to be short but unlikely to clash with other apps
|
||||
if {[file exists c:/] && [file exists d:/]} {
|
||||
catch {file delete d:/TclTmpF.1}
|
||||
if {[catch {createfile d:/TclTmpF.1 {}}] == 0} {
|
||||
file delete d:/TclTmpF.1
|
||||
catch {file delete d:/TclTmpD.1}
|
||||
catch {file delete c:/TclTmpC.1}
|
||||
if {![catch {createfile d:/TclTmpF.1 {}}] && [file isfile d:/TclTmpF.1]
|
||||
&& ![catch {file mkdir d:/TclTmpD.1}] && [file isdirectory d:/TclTmpD.1]
|
||||
&& ![catch {file mkdir c:/TclTmpC.1}] && [file isdirectory c:/TclTmpC.1]
|
||||
} {
|
||||
file delete d:/TclTmpF.1 d:/TclTmpD.1 c:/TclTmpC.1
|
||||
testConstraint exdev 1
|
||||
}
|
||||
}
|
||||
@@ -179,12 +184,12 @@ test winFCmd-1.9 {TclpRenameFile: errno: ENOTDIR} -setup {
|
||||
testfile mv td1 tf1
|
||||
} -returnCodes error -result ENOTDIR
|
||||
test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} -setup {
|
||||
file delete -force d:/tf1
|
||||
file delete -force d:/TclTmpD.1
|
||||
} -constraints {win exdev testfile} -body {
|
||||
file mkdir c:/tf1
|
||||
testfile mv c:/tf1 d:/tf1
|
||||
file mkdir c:/TclTmpC.1
|
||||
testfile mv c:/TclTmpC.1 d:/TclTmpD.1
|
||||
} -cleanup {
|
||||
file delete -force c:/tf1
|
||||
file delete -force c:/TclTmpC.1
|
||||
} -returnCodes error -result EXDEV
|
||||
test winFCmd-1.11 {TclpRenameFile: errno: EACCES} -setup {
|
||||
cleanup
|
||||
@@ -334,15 +339,15 @@ test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} -setup {
|
||||
} -result {0 1 1}
|
||||
test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \
|
||||
-constraints {win exdev testfile testchmod} -body {
|
||||
file mkdir d:/td1
|
||||
testchmod 0 d:/td1
|
||||
file mkdir c:/tf1
|
||||
catch {testfile mv c:/tf1 d:/td1} msg
|
||||
list $msg [file writable d:/td1]
|
||||
file mkdir d:/TclTmpD.1
|
||||
testchmod 0 d:/TclTmpD.1
|
||||
file mkdir c:/TclTmpC.1
|
||||
catch {testfile mv c:/TclTmpC.1 d:/TclTmpD.1} msg
|
||||
list $msg [file writable d:/TclTmpD.1]
|
||||
} -cleanup {
|
||||
catch {testchmod 0o666 d:/td1}
|
||||
file delete d:/td1
|
||||
file delete -force c:/tf1
|
||||
catch {testchmod 0o666 d:/TclTmpD.1}
|
||||
file delete d:/TclTmpD.1
|
||||
file delete -force c:/TclTmpC.1
|
||||
} -result {EXDEV 0}
|
||||
test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} -setup {
|
||||
cleanup
|
||||
@@ -406,7 +411,7 @@ proc MakeFiles {dirname} {
|
||||
|
||||
test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup {
|
||||
cleanup
|
||||
} -constraints {win winNonZeroInodes} -body {
|
||||
} -constraints {win winNonZeroInodes knownMsvcBug} -body {
|
||||
file mkdir td1
|
||||
foreach {a b} [MakeFiles td1] break
|
||||
file rename -force $a $b
|
||||
@@ -656,7 +661,7 @@ test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} -setup {
|
||||
|
||||
test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup {
|
||||
cleanup
|
||||
} -constraints {winVista testfile testchmod} -body {
|
||||
} -constraints {winVista testfile testchmod knownMsvcBug} -body {
|
||||
file mkdir td1
|
||||
testchmod 0 td1
|
||||
testfile rmdir td1
|
||||
@@ -710,7 +715,7 @@ test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} -setup {
|
||||
} -result {1 {tf1 ENOTDIR}}
|
||||
test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup {
|
||||
cleanup
|
||||
} -constraints {winVista testfile testchmod} -body {
|
||||
} -constraints {winVista testfile testchmod knownMsvcBug} -body {
|
||||
file mkdir td1
|
||||
testchmod 0 td1
|
||||
testfile rmdir td1
|
||||
@@ -728,7 +733,7 @@ test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup {
|
||||
} -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$}
|
||||
test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup {
|
||||
cleanup
|
||||
} -constraints {winVista testfile testchmod} -body {
|
||||
} -constraints {winVista testfile testchmod knownMsvcBug} -body {
|
||||
file mkdir td1
|
||||
testchmod 0 td1
|
||||
testfile rmdir td1
|
||||
@@ -957,7 +962,7 @@ test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup {
|
||||
} -result {}
|
||||
test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup {
|
||||
cleanup
|
||||
} -constraints {winVista testfile testchmod} -body {
|
||||
} -constraints {winVista testfile testchmod knownMsvcBug} -body {
|
||||
file mkdir td1/td2
|
||||
testchmod 0 td1
|
||||
testfile rmdir -force td1
|
||||
@@ -1071,13 +1076,22 @@ test winFCmd-12.5 {ConvertFileNameFormat: absolute path} -body {
|
||||
list [file attributes / -longname] [file attributes \\ -longname]
|
||||
} -constraints {win} -result {/ /}
|
||||
test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup {
|
||||
catch {file delete -force -- c:/td1}
|
||||
catch {file delete -force -- c:/TclTmpC.1}
|
||||
} -constraints {win win2000orXP} -body {
|
||||
createfile c:/td1 {}
|
||||
string tolower [file attributes c:/td1 -longname]
|
||||
createfile c:/TclTmpC.1 {}
|
||||
string tolower [file attributes c:/TclTmpC.1 -longname]
|
||||
} -cleanup {
|
||||
file delete -force -- c:/td1
|
||||
} -result {c:/td1}
|
||||
file delete -force -- c:/TclTmpC.1
|
||||
} -result [string tolower {c:/TclTmpC.1}]
|
||||
test winFCmd-12.6.2 {ConvertFileNameFormat: absolute path with drive (in temp folder)} -setup {
|
||||
catch {file delete -force -- $::env(TEMP)/td1}
|
||||
} -constraints {win} -body {
|
||||
createfile $::env(TEMP)/td1 {}
|
||||
string equal [string tolower [file attributes $::env(TEMP)/td1 -longname]] \
|
||||
[string tolower [file normalize $::env(TEMP)]/td1]
|
||||
} -cleanup {
|
||||
file delete -force -- $::env(TEMP)/td1
|
||||
} -result 1
|
||||
test winFCmd-12.7 {ConvertFileNameFormat} -body {
|
||||
string tolower [file attributes //bisque/tcl/ws -longname]
|
||||
} -constraints {nonPortable win} -result {//bisque/tcl/ws}
|
||||
|
||||
@@ -43,13 +43,14 @@ test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} {
|
||||
|
||||
test winFile-2.1 {TclpMatchFiles: case sensitivity} -constraints {win} -body {
|
||||
makeFile {} GlobCapS
|
||||
list [glob -nocomplain GlobC*] [glob -nocomplain globc*]
|
||||
} -cleanup {
|
||||
set args [list -nocomplain -tails -directory [temporaryDirectory]]
|
||||
list [glob {*}$args GlobC*] [glob {*}$args globc*]} -cleanup {
|
||||
removeFile GlobCapS
|
||||
} -result {GlobCapS GlobCapS}
|
||||
test winFile-2.2 {TclpMatchFiles: case sensitivity} -constraints {win} -body {
|
||||
makeFile {} globlower
|
||||
list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]
|
||||
set args [list -nocomplain -tails -directory [temporaryDirectory]]
|
||||
list [glob {*}$args globl*] [glob {*}$args gLOBl*]
|
||||
} -cleanup {
|
||||
removeFile globlower
|
||||
} -result {globlower globlower}
|
||||
|
||||
@@ -22,14 +22,19 @@ catch {
|
||||
set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1]
|
||||
}
|
||||
|
||||
set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
|
||||
set org_pwd [pwd]
|
||||
set bindir [file join $org_pwd [file dirname [info nameofexecutable]]]
|
||||
set cat32 [file join $bindir cat32.exe]
|
||||
|
||||
# several test-cases here expect current directory == [temporaryDirectory]:
|
||||
cd [temporaryDirectory]
|
||||
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
testConstraint cat32 [file exists $cat32]
|
||||
testConstraint AllocConsole [catch {puts console1 ""}]
|
||||
testConstraint RealConsole [expr {![testConstraint AllocConsole]}]
|
||||
testConstraint testexcept [llength [info commands testexcept]]
|
||||
testConstraint slowTest 0
|
||||
|
||||
|
||||
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
|
||||
@@ -41,7 +46,7 @@ append big $big
|
||||
append big $big
|
||||
|
||||
set path(little) [makeFile {} little]
|
||||
set f [open $path(little) w]
|
||||
set f [open $path(little) w]
|
||||
puts -nonewline $f "little"
|
||||
close $f
|
||||
|
||||
@@ -308,9 +313,54 @@ test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \
|
||||
lappend x [catch {close $f} msg] $msg
|
||||
} {writable timeout 0 {}}
|
||||
|
||||
set path(echoArgs.tcl) [makeFile {
|
||||
puts "[list $argv0 $argv]"
|
||||
} echoArgs.tcl]
|
||||
proc _testExecArgs {single args} {
|
||||
variable path
|
||||
if {![info exists path(echoArgs.tcl)] || ![file exists $path(echoArgs.tcl)]} {
|
||||
set path(echoArgs.tcl) [makeFile {
|
||||
puts "[list [file tail $argv0] {*}$argv]"
|
||||
} echoArgs.tcl]
|
||||
}
|
||||
if {![info exists path(echoArgs.bat)] || ![file exists $path(echoArgs.bat)]} {
|
||||
set path(echoArgs.bat) [makeFile "@[file native [interpreter]] $path(echoArgs.tcl) %*" "echoArgs.bat"]
|
||||
}
|
||||
set cmds [list [list [interpreter] $path(echoArgs.tcl)]]
|
||||
if {!($single & 2)} {
|
||||
lappend cmds [list $path(echoArgs.bat)]
|
||||
} else {
|
||||
if {![info exists path(echoArgs2.bat)] || ![file exists $path(echoArgs2.bat)]} {
|
||||
set path(echoArgs2.bat) [makeFile \
|
||||
"@[file native [interpreter]] $path(echoArgs.tcl) %*" \
|
||||
"echo(Cmd)Test Args & Batch.bat" [makeDirectory test(Dir)Check]]
|
||||
}
|
||||
lappend cmds [list $path(echoArgs2.bat)]
|
||||
}
|
||||
set broken {}
|
||||
foreach args $args {
|
||||
if {$single & 1} {
|
||||
# enclose single test-arg between 1st/3rd to be sure nothing is truncated
|
||||
# (e. g. to cover unexpected trim by nts-zero case, and args don't recombined):
|
||||
set args [list "1st" $args "3rd"]
|
||||
}
|
||||
set args [list {*}$args]; # normalized canonical list
|
||||
foreach cmd $cmds {
|
||||
set e [linsert $args 0 [file tail $path(echoArgs.tcl)]]
|
||||
tcltest::DebugPuts 4 " ## test exec [file extension [lindex $cmd 0]] ($cmd) for\n ## $args"
|
||||
if {[catch {
|
||||
exec {*}$cmd {*}$args
|
||||
} r]} {
|
||||
set r "ERROR: $r"
|
||||
}
|
||||
if {$r ne $e} {
|
||||
append broken "\[ERROR\]: exec [file extension [lindex $cmd 0]] on $args\n -- result:\n$r\n -- expected:\n$e\n"
|
||||
}
|
||||
if {$single & 8} {
|
||||
# if test exe only:
|
||||
break
|
||||
}
|
||||
}
|
||||
}
|
||||
return $broken
|
||||
}
|
||||
|
||||
### validate the raw output of BuildCommandLine().
|
||||
###
|
||||
@@ -369,65 +419,178 @@ test winpipe-7.18 {BuildCommandLine: special chars #5} {win exec} {
|
||||
exec $env(COMSPEC) /c echo foo \} bar
|
||||
} "foo \} bar"
|
||||
|
||||
set injectList {
|
||||
{test"whoami} {test""whoami}
|
||||
{test"""whoami} {test""""whoami}
|
||||
|
||||
"test\"whoami\\" "test\"\"whoami\\"
|
||||
"test\"\"\"whoami\\" "test\"\"\"\"whoami\\"
|
||||
|
||||
{test\\&\\test} {test"\\&\\test}
|
||||
{"test\\&\\test} {"test"\\&\\"test"}
|
||||
{test\\"&"\\test} {test"\\"&"\\test}
|
||||
{"test\\"&"\\test} {"test"\\"&"\\"test"}
|
||||
|
||||
{test\"&whoami} {test"\"&whoami}
|
||||
{test""\"&whoami} {test"""\"&whoami}
|
||||
{test\"\&whoami} {test"\"\&whoami}
|
||||
{test""\"\&whoami} {test"""\"\&whoami}
|
||||
|
||||
{test&whoami} {test|whoami}
|
||||
{"test&whoami} {"test|whoami}
|
||||
{test"&whoami} {test"|whoami}
|
||||
{"test"&whoami} {"test"|whoami}
|
||||
{""test"&whoami} {""test"|whoami}
|
||||
|
||||
{test&echo "} {test|echo "}
|
||||
{"test&echo "} {"test|echo "}
|
||||
{test"&echo "} {test"|echo "}
|
||||
{"test"&echo "} {"test"|echo "}
|
||||
{""test"&echo "} {""test"|echo "}
|
||||
|
||||
{test&echo ""} {test|echo ""}
|
||||
{"test&echo ""} {"test|echo ""}
|
||||
{test"&echo ""} {test"|echo ""}
|
||||
{"test"&echo ""} {"test"|echo ""}
|
||||
{""test"&echo ""} {""test"|echo ""}
|
||||
|
||||
{test>whoami} {test<whoami}
|
||||
{"test>whoami} {"test<whoami}
|
||||
{test">whoami} {test"<whoami}
|
||||
{"test">whoami} {"test"<whoami}
|
||||
{""test">whoami} {""test"<whoami}
|
||||
{test(whoami)} {test(whoami)}
|
||||
{test"(whoami)} {test"(whoami)}
|
||||
{test^whoami} {test^^echo ^^^}
|
||||
{test"^whoami} {test"^^echo ^^^}
|
||||
{test"^echo ^^^"} {test""^echo" ^^^"}
|
||||
|
||||
{test%USERDOMAIN%\%USERNAME%}
|
||||
{test" %USERDOMAIN%\%USERNAME%}
|
||||
{test%USERDOMAIN%\\%USERNAME%}
|
||||
{test" %USERDOMAIN%\\%USERNAME%}
|
||||
{test%USERDOMAIN%&%USERNAME%}
|
||||
{test" %USERDOMAIN%&%USERNAME%}
|
||||
{test%USERDOMAIN%\&\%USERNAME%}
|
||||
{test" %USERDOMAIN%\&\%USERNAME%}
|
||||
|
||||
{test%USERDOMAIN%\&\test}
|
||||
{test" %USERDOMAIN%\&\test}
|
||||
{test%USERDOMAIN%\\&\\test}
|
||||
{test" %USERDOMAIN%\\&\\test}
|
||||
|
||||
{test%USERDOMAIN%\&\"test}
|
||||
{test" %USERDOMAIN%\&\"test}
|
||||
{test%USERDOMAIN%\\&\\"test}
|
||||
{test" %USERDOMAIN%\\&\\"test}
|
||||
}
|
||||
|
||||
### validate the pass-thru from BuildCommandLine() to the crt's parse_cmdline().
|
||||
###
|
||||
test winpipe-8.1 {BuildCommandLine/parse_cmdline pass-thru: null arguments} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo "" bar
|
||||
} [list $path(echoArgs.tcl) [list foo {} bar]]
|
||||
test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: null arguments} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo {} bar
|
||||
} [list $path(echoArgs.tcl) [list foo {} bar]]
|
||||
test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #1} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo "\"" bar
|
||||
} [list $path(echoArgs.tcl) [list foo "\"" bar]]
|
||||
test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #2} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo {""} bar
|
||||
} [list $path(echoArgs.tcl) [list foo {""} bar]]
|
||||
test winpipe-8.5 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #3} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo "\" " bar
|
||||
} [list $path(echoArgs.tcl) [list foo "\" " bar]]
|
||||
test winpipe-8.6 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #4} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo {a="b"} bar
|
||||
} [list $path(echoArgs.tcl) [list foo {a="b"} bar]]
|
||||
test winpipe-8.7 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #5} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo {a = "b"} bar
|
||||
} [list $path(echoArgs.tcl) [list foo {a = "b"} bar]]
|
||||
test winpipe-8.8 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #6} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo}
|
||||
} [list $path(echoArgs.tcl) [list {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo}]]
|
||||
test winpipe-8.9 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #1} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo \\ bar
|
||||
} [list $path(echoArgs.tcl) [list foo \\ bar]]
|
||||
test winpipe-8.10 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #2} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo \\\\ bar
|
||||
} [list $path(echoArgs.tcl) [list foo \\\\ bar]]
|
||||
test winpipe-8.11 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #3} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\ bar
|
||||
} [list $path(echoArgs.tcl) [list foo \\\ \\ bar]]
|
||||
test winpipe-8.12 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #4} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\ bar
|
||||
} [list $path(echoArgs.tcl) [list foo \\\ \\\\ bar]]
|
||||
test winpipe-8.13 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #5} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\\\ bar
|
||||
} [list $path(echoArgs.tcl) [list foo \\\ \\\\\\ bar]]
|
||||
test winpipe-8.14 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #6} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\" bar
|
||||
} [list $path(echoArgs.tcl) [list foo \\\ \\\" bar]]
|
||||
test winpipe-8.15 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #7} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\\" bar
|
||||
} [list $path(echoArgs.tcl) [list foo \\\ \\\\\" bar]]
|
||||
test winpipe-8.16 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #8} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\\\\" bar
|
||||
} [list $path(echoArgs.tcl) [list foo \\\ \\\\\\\" bar]]
|
||||
test winpipe-8.17 {BuildCommandLine/parse_cmdline pass-thru: special chars #1} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo \{ bar
|
||||
} [list $path(echoArgs.tcl) [list foo \{ bar]]
|
||||
test winpipe-8.18 {BuildCommandLine/parse_cmdline pass-thru: special chars #2} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo \} bar
|
||||
} [list $path(echoArgs.tcl) [list foo \} bar]]
|
||||
test winpipe-8.19 {ensure parse_cmdline isn't doing wildcard replacement} {win exec} {
|
||||
exec [interpreter] $path(echoArgs.tcl) foo * makefile.?c bar
|
||||
} [list $path(echoArgs.tcl) [list foo * makefile.?c bar]]
|
||||
test winpipe-8.1 {BuildCommandLine/parse_cmdline pass-thru: dumped arguments are equal original} \
|
||||
-constraints {win exec} -body {
|
||||
_testExecArgs 0 \
|
||||
[list foo "" bar] \
|
||||
[list foo {} bar] \
|
||||
[list foo "\"" bar] \
|
||||
[list foo {""} bar] \
|
||||
[list foo "\" " bar] \
|
||||
[list foo {a="b"} bar] \
|
||||
[list foo {a = "b"} bar] \
|
||||
[list {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo}] \
|
||||
[list foo \\ bar] \
|
||||
[list foo \\\\ bar] \
|
||||
[list foo \\\ \\ bar] \
|
||||
[list foo \\\ \\\\ bar] \
|
||||
[list foo \\\ \\\\\\ bar] \
|
||||
[list foo \\\ \\\" bar] \
|
||||
[list foo \\\ \\\\\" bar] \
|
||||
[list foo \\\ \\\\\\\" bar] \
|
||||
[list foo \{ bar] \
|
||||
[list foo \} bar] \
|
||||
[list foo * makefile.?c bar]
|
||||
} -result {}
|
||||
|
||||
test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (particular)} \
|
||||
-constraints {win exec slowTest} -body {
|
||||
_testExecArgs 1 {*}$injectList
|
||||
} -result {}
|
||||
|
||||
test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (jointly)} \
|
||||
-constraints {win exec} -body {
|
||||
_testExecArgs 0 \
|
||||
[list START {*}$injectList END] \
|
||||
[list "START\"" {*}$injectList END] \
|
||||
[list START {*}$injectList "\"END"] \
|
||||
[list "START\"" {*}$injectList "\"END"]
|
||||
} -result {}
|
||||
|
||||
test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (command/jointly args)} \
|
||||
-constraints {win exec} -body {
|
||||
_testExecArgs 2 \
|
||||
[list START {*}$injectList END] \
|
||||
[list "START\"" {*}$injectList END] \
|
||||
[list START {*}$injectList "\"END"] \
|
||||
[list "START\"" {*}$injectList "\"END"]
|
||||
} -result {}
|
||||
|
||||
test winpipe-8.5 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (random mix)} \
|
||||
-constraints {win exec} -body {
|
||||
set lst {}
|
||||
set maps {
|
||||
{\&|^<>!()%}
|
||||
{\&|^<>!()% }
|
||||
{"\&|^<>!()%}
|
||||
{"\&|^<>!()% }
|
||||
{"""""\\\\\&|^<>!()%}
|
||||
{"""""\\\\\&|^<>!()% }
|
||||
}
|
||||
set i 0
|
||||
time {
|
||||
set args {[incr i].}
|
||||
time {
|
||||
set map [lindex $maps [expr {int(rand()*[llength $maps])}]]
|
||||
# be sure arg has some prefix (avoid special handling, like |& etc)
|
||||
set a {x}
|
||||
while {[string length $a] < 50} {
|
||||
append a [string index $map [expr {int(rand()*[string length $map])}]]
|
||||
}
|
||||
lappend args $a
|
||||
} 20
|
||||
lappend lst $args
|
||||
} 10
|
||||
_testExecArgs 0 {*}$lst
|
||||
} -result {} -cleanup {
|
||||
unset -nocomplain lst args a map maps
|
||||
}
|
||||
|
||||
set injectList {
|
||||
"test\"\nwhoami" "test\"\"\nwhoami"
|
||||
"test\"\"\"\nwhoami" "test\"\"\"\"\nwhoami"
|
||||
"test;\n&echo \"" "\"test;\n&echo \""
|
||||
"test\";\n&echo \"" "\"test\";\n&echo \""
|
||||
"\"\"test\";\n&echo \""
|
||||
}
|
||||
|
||||
test winpipe-8.6 {BuildCommandLine/parse_cmdline pass-thru: check new-line quoted in args} \
|
||||
-constraints {win exec} -body {
|
||||
# test exe only, because currently there is no proper way to escape a new-line char resp.
|
||||
# to supply a new-line to the batch-files within arguments (command line is truncated).
|
||||
_testExecArgs 8 \
|
||||
[list START {*}$injectList END] \
|
||||
[list "START\"" {*}$injectList END] \
|
||||
[list START {*}$injectList "\"END"] \
|
||||
[list "START\"" {*}$injectList "\"END"]
|
||||
} -result {}
|
||||
|
||||
test winpipe-8.7 {BuildCommandLine/parse_cmdline pass-thru: check new-line quoted in args (batch)} \
|
||||
-constraints {win exec knownBug} -body {
|
||||
# this will fail if executed batch-file, because currently there is no proper way to escape a new-line char.
|
||||
_testExecArgs 0 $injectList
|
||||
} -result {}
|
||||
|
||||
|
||||
rename _testExecArgs {}
|
||||
|
||||
# restore old values for env(TMP) and env(TEMP)
|
||||
|
||||
@@ -445,8 +608,12 @@ removeFile more
|
||||
removeFile stdout
|
||||
removeFile stderr
|
||||
removeFile nothing
|
||||
removeFile echoArgs.tcl
|
||||
if {[info exists path(echoArgs.tcl)]} { removeFile echoArgs.tcl }
|
||||
if {[info exists path(echoArgs.bat)]} { removeFile echoArgs.bat }
|
||||
if {[info exists path(echoArgs2.bat)]} { removeDirectory test(Dir)Check }
|
||||
::tcltest::cleanupTests
|
||||
# back to original directory:
|
||||
cd $org_pwd; unset org_pwd
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
|
||||
@@ -19,6 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
catch [list package require -exact Tcltest [info patchlevel]]
|
||||
|
||||
testConstraint testwinclock [llength [info commands testwinclock]]
|
||||
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
|
||||
|
||||
# The next two tests will crash on Windows if the check for negative
|
||||
# clock values is not done properly.
|
||||
@@ -40,7 +41,7 @@ test winTime-1.2 {TclpGetDate} {win} {
|
||||
# with the Windows clock. 30 sec really isn't enough,
|
||||
# but how much time does a tester have patience for?
|
||||
|
||||
test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock} {
|
||||
test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock knownMsvcBug} {
|
||||
# May fail due to OS/hardware discrepancies. See:
|
||||
# http://support.microsoft.com/default.aspx?scid=kb;en-us;274323
|
||||
set failed {}
|
||||
@@ -50,7 +51,7 @@ test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock} {
|
||||
foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] break
|
||||
set diff [expr { $tcl_sec - $sys_sec
|
||||
+ 1.0e-6 * ( $tcl_usec - $sys_usec ) }]
|
||||
if { abs($diff) > 0.06 } {
|
||||
if { abs($diff) > 0.1 } {
|
||||
set failed "Tcl clock differs from system clock by $diff sec"
|
||||
break
|
||||
} else {
|
||||
|
||||
Reference in New Issue
Block a user