Update to 8.5.19
This commit is contained in:
Zachary Ware
@@ -41,7 +41,7 @@ namespace eval ::tcl::test::io {
|
||||
|
||||
# You need a *very* special environment to do some tests. In
|
||||
# particular, many file systems do not support large-files...
|
||||
testConstraint largefileSupport 0
|
||||
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
|
||||
|
||||
# some tests can only be run is umask is 2
|
||||
# if "umask" cannot be run, the tests will be skipped.
|
||||
@@ -4427,10 +4427,10 @@ test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
|
||||
chan puts -nonewline $f abcdef
|
||||
lappend l [chan tell $f]
|
||||
chan close $f
|
||||
lappend l [file size $f]
|
||||
lappend l [file size $path(test3)]
|
||||
# truncate...
|
||||
chan close [open $path(test3) w]
|
||||
lappend l [file size $f]
|
||||
lappend l [file size $path(test3)]
|
||||
set l
|
||||
} {0 6 6 4294967296 4294967302 4294967302 0}
|
||||
|
||||
|
||||
@@ -36927,6 +36927,15 @@ test clock-67.1 {clock format, %% with a letter following [Bug 2819334]} {
|
||||
clock format [clock seconds] -format %%r
|
||||
} %r
|
||||
|
||||
test clock-67.2 {Bug d19a30db57} -body {
|
||||
# error, not segfault
|
||||
tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222
|
||||
} -returnCodes error -match glob -result *
|
||||
test clock-67.3 {Bug d19a30db57} -body {
|
||||
# error, not segfault
|
||||
tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222
|
||||
} -returnCodes error -match glob -result *
|
||||
|
||||
# cleanup
|
||||
|
||||
namespace delete ::testClock
|
||||
|
||||
@@ -104,6 +104,9 @@ test cmdAH-2.6.1 {Tcl_CdObjCmd} {
|
||||
list [catch {cd ""} msg] $msg
|
||||
} {1 {couldn't change working directory to "": no such file or directory}}
|
||||
|
||||
test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -returnCodes error -body {
|
||||
cd .\0
|
||||
} -result "couldn't change working directory to \".\0\": no such file or directory"
|
||||
test cmdAH-2.7 {Tcl_ConcatObjCmd} {
|
||||
concat
|
||||
} {}
|
||||
|
||||
@@ -422,14 +422,22 @@ test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
|
||||
list [catch {exec [interpreter] << $script} msg] $msg
|
||||
} {0 OK}
|
||||
|
||||
# Special test for compiling tokens from a copy of the source
|
||||
# string [Bug #599788]
|
||||
# Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342]
|
||||
test compile-14.1 {testing errors in element name; segfault?} {} {
|
||||
catch {set a([error])} msg1
|
||||
catch {set bubba([join $abba $jubba]) $vol} msg2
|
||||
list $msg1 $msg2
|
||||
} {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}}
|
||||
|
||||
test compile-14.2 {testing element name "$"} -body {
|
||||
unset -nocomplain a
|
||||
set a() 1
|
||||
set a(1) 2
|
||||
set a($) 3
|
||||
list [set a()] [set a(1)] [set a($)] [unset a() a(1); lindex [array names a] 0]
|
||||
} -cleanup {unset a} -result [list 1 2 3 {$}]
|
||||
|
||||
|
||||
# Tests compile-15.* cover Tcl Bug 633204
|
||||
test compile-15.1 {proper TCL_RETURN code from [return]} {
|
||||
proc p {} {catch return}
|
||||
|
||||
@@ -1212,7 +1212,7 @@ test dict-23.1 {dict compilation crash: Bug 3487626} {
|
||||
}
|
||||
}} [linenumber]
|
||||
} 5
|
||||
test dict-23.2 {dict compilation crash: Bug 3487626} knownBug {
|
||||
test dict-23.2 {dict compilation crash: Bug 3487626} {
|
||||
# Something isn't quite right in line number and continuation line
|
||||
# tracking; at time of writing, this test produces 7, not 5, which
|
||||
# indicates that the extra newlines in the non-script argument are
|
||||
@@ -1243,6 +1243,41 @@ j
|
||||
}
|
||||
}} [linenumber]
|
||||
} 5
|
||||
test dict-23.3 {CompileWord OBOE} {
|
||||
# segfault when buggy
|
||||
apply {{} {tcl::dict::lappend foo bar \
|
||||
[format baz]}}
|
||||
} {bar baz}
|
||||
test dict-23.4 {CompileWord OBOE} {
|
||||
apply {n {
|
||||
dict set foo {*}{
|
||||
} [return [incr n -[linenumber]]] val
|
||||
}} [linenumber]
|
||||
} 1
|
||||
test dict-23.5 {CompileWord OBOE} {
|
||||
# segfault when buggy
|
||||
apply {{} {tcl::dict::incr foo \
|
||||
[format bar]}}
|
||||
} {bar 1}
|
||||
test dict-23.6 {CompileWord OBOE} {
|
||||
apply {n {
|
||||
dict get {a b} {*}{
|
||||
} [return [incr n -[linenumber]]]
|
||||
}} [linenumber]
|
||||
} 1
|
||||
test dict-23.7 {CompileWord OBOE} {
|
||||
apply {n {
|
||||
dict for {a b} [return [incr n -[linenumber]]] {*}{
|
||||
} {}
|
||||
}} [linenumber]
|
||||
} 2
|
||||
test dict-23.8 {CompileWord OBOE} {
|
||||
apply {n {
|
||||
dict update foo {*}{
|
||||
} [return [incr n -[linenumber]]] x {}
|
||||
}} [linenumber]
|
||||
} 1
|
||||
|
||||
rename linenumber {}
|
||||
|
||||
# cleanup
|
||||
|
||||
@@ -7165,6 +7165,14 @@ test expr-48.1 {Bug 1770224} {
|
||||
expr {-0x8000000000000001 >> 0x8000000000000000}
|
||||
} -1
|
||||
|
||||
test expr-50.1 {test sqrt() of bignums with non-Inf answer} {
|
||||
expr {sqrt("1[string repeat 0 616]") == 1e308}
|
||||
} 1
|
||||
|
||||
test expr-51.1 {test round-to-even on input} {
|
||||
expr 6.9294956446009195e15
|
||||
} 6929495644600920.0
|
||||
|
||||
# cleanup
|
||||
if {[info exists a]} {
|
||||
unset a
|
||||
|
||||
@@ -708,6 +708,9 @@ test filesystem-6.32 {empty file name} {
|
||||
test filesystem-6.33 {empty file name} {
|
||||
list [catch {file writable ""} msg] $msg
|
||||
} {0 0}
|
||||
test filesystem-6.34 {file name with (invalid) nul character} {
|
||||
list [catch "open foo\x00" msg] $msg
|
||||
} [list 1 "couldn't open \"foo\x00\": filename is invalid on this platform"]
|
||||
|
||||
# Make sure the testfilesystem hasn't been registered.
|
||||
if {[testConstraint testfilesystem]} {
|
||||
|
||||
173
tests/for.test
173
tests/for.test
@@ -14,6 +14,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
namespace import -force ::tcltest::*
|
||||
}
|
||||
|
||||
testConstraint bug-05489ce335 [testConstraint knownBug]
|
||||
|
||||
# Basic "for" operation.
|
||||
|
||||
test for-1.1 {TclCompileForCmd: missing initial command} {
|
||||
@@ -811,7 +813,176 @@ test for-6.18 {Tcl_ForObjCmd: for command result} {
|
||||
1 {invoked "continue" outside of a loop} \
|
||||
]
|
||||
|
||||
|
||||
test for-8.0 {Coverity CID 1251203: break vs continue in for-step clause} {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
list a [\
|
||||
for {set i 0} {$i < 5} {incr i; list a [eval {}]} {
|
||||
incr j
|
||||
}]
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {6 5 3}
|
||||
test for-8.1 {Coverity CID 1251203: break vs continue in for-step clause} bug-05489ce335 {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
list a [\
|
||||
for {set i 0} {$i < 5} {incr i;list a [eval break]} {
|
||||
incr j
|
||||
}]
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {2 1 3}
|
||||
test for-8.2 {Coverity CID 1251203: break vs continue in for-step clause} bug-05489ce335 {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
list a [\
|
||||
for {set i 0} {$i < 5} {incr i;list a [eval continue]} {
|
||||
incr j
|
||||
}]
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {1 1 3}
|
||||
test for-8.3 {break in for-step clause} {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
list a [\
|
||||
for {set i 0} {$i < 5} {incr i; break} {
|
||||
incr j
|
||||
}]
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {2 1 3}
|
||||
test for-8.4 {continue in for-step clause} bug-05489ce335 {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
list a [\
|
||||
for {set i 0} {$i < 5} {incr i; continue} {
|
||||
incr j
|
||||
}]
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {1 1 3}
|
||||
test for-8.5 {break in for-step clause} bug-05489ce335 {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
list a [\
|
||||
for {set i 0} {$i < 5} {incr i; list a [break]} {
|
||||
incr j
|
||||
}]
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {2 1 3}
|
||||
test for-8.6 {continue in for-step clause} bug-05489ce335 {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
list a [\
|
||||
for {set i 0} {$i < 5} {incr i; list a [continue]} {
|
||||
incr j
|
||||
}]
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {1 1 3}
|
||||
test for-8.7 {break in for-step clause} {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
list a [\
|
||||
for {set i 0} {$i < 5} {incr i;eval break} {
|
||||
incr j
|
||||
}]
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {2 1 3}
|
||||
test for-8.8 {continue in for-step clause} bug-05489ce335 {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
list a [\
|
||||
for {set i 0} {$i < 5} {incr i;eval continue} {
|
||||
incr j
|
||||
}]
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {1 1 3}
|
||||
test for-8.9 {break in for-step clause} {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
for {set i 0} {$i < 5} {incr i;eval break} {
|
||||
incr j
|
||||
}
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {2 1 3}
|
||||
test for-8.10 {continue in for-step clause} {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
for {set i 0} {$i < 5} {incr i;eval continue} {
|
||||
incr j
|
||||
}
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {1 1 3}
|
||||
test for-8.11 {break in for-step clause} {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
for {set i 0} {$i < 5} {incr i;break} {
|
||||
incr j
|
||||
}
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {2 1 3}
|
||||
test for-8.12 {continue in for-step clause} {
|
||||
apply {{} {
|
||||
for {set k 0} {$k < 3} {incr k} {
|
||||
set j 0
|
||||
for {set i 0} {$i < 5} {incr i;continue} {
|
||||
incr j
|
||||
}
|
||||
incr i
|
||||
}
|
||||
list $i $j $k
|
||||
}}
|
||||
} {1 1 3}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
|
||||
@@ -254,6 +254,17 @@ test foreach-9.1 {compiled empty var list} {
|
||||
list [catch { foo } msg] $msg
|
||||
} {1 {foreach varlist is empty}}
|
||||
|
||||
test foreach-9.2 {line numbers} -setup {
|
||||
proc linenumber {} {dict get [info frame -1] line}
|
||||
} -body {
|
||||
apply {n {
|
||||
foreach x y {*}{
|
||||
} {return [incr n -[linenumber]]}
|
||||
}} [linenumber]
|
||||
} -cleanup {
|
||||
rename linenumber {}
|
||||
} -result 1
|
||||
|
||||
test foreach-10.1 {foreach: [Bug 1671087]} -setup {
|
||||
proc demo {} {
|
||||
set vals {1 2 3 4}
|
||||
|
||||
@@ -54,7 +54,7 @@ if {![file exists $httpdFile]} {
|
||||
}
|
||||
|
||||
if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
|
||||
set httpthread [testthread create "
|
||||
set httpthread [testthread create -joinable "
|
||||
source [list $httpdFile]
|
||||
testthread wait
|
||||
"]
|
||||
@@ -120,7 +120,7 @@ test http-3.2 {http::geturl} {
|
||||
set err
|
||||
} {Unsupported URL: http:junk}
|
||||
set url //[info hostname]:$port
|
||||
set badurl //[info hostname]:6666
|
||||
set badurl //[info hostname]:[expr $port+1]
|
||||
test http-3.3 {http::geturl} {
|
||||
set token [http::geturl $url]
|
||||
http::data $token
|
||||
@@ -130,7 +130,7 @@ test http-3.3 {http::geturl} {
|
||||
</body></html>"
|
||||
set tail /a/b/c
|
||||
set url //[info hostname]:$port/a/b/c
|
||||
set fullurl http://user:pass@[info hostname]:$port/a/b/c
|
||||
set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c
|
||||
set binurl //[info hostname]:$port/binary
|
||||
set posturl //[info hostname]:$port/post
|
||||
set badposturl //[info hostname]:$port/droppost
|
||||
@@ -554,6 +554,7 @@ if {[info exists httpthread]} {
|
||||
testthread send -async $httpthread {
|
||||
testthread exit
|
||||
}
|
||||
testthread join $httpthread
|
||||
} else {
|
||||
close $listen
|
||||
}
|
||||
|
||||
770
tests/io.test
770
tests/io.test
@@ -41,7 +41,7 @@ testConstraint testthread [llength [info commands testthread]]
|
||||
|
||||
# You need a *very* special environment to do some tests. In
|
||||
# particular, many file systems do not support large-files...
|
||||
testConstraint largefileSupport 0
|
||||
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]
|
||||
|
||||
# some tests can only be run is umask is 2
|
||||
# if "umask" cannot be run, the tests will be skipped.
|
||||
@@ -1445,6 +1445,105 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee
|
||||
lappend x [catch {close $f} msg] $msg
|
||||
set x
|
||||
} "{} timeout {} timeout \u7266 {} eof 0 {}"
|
||||
test io-12.6 {ReadChars: too many chars read} {
|
||||
proc driver {cmd args} {
|
||||
variable buffer
|
||||
variable index
|
||||
set chan [lindex $args 0]
|
||||
switch -- $cmd {
|
||||
initialize {
|
||||
set index($chan) 0
|
||||
set buffer($chan) [encoding convertto utf-8 \
|
||||
[string repeat \uBEEF 20][string repeat . 20]]
|
||||
return {initialize finalize watch read}
|
||||
}
|
||||
finalize {
|
||||
unset index($chan) buffer($chan)
|
||||
return
|
||||
}
|
||||
watch {}
|
||||
read {
|
||||
set n [lindex $args 1]
|
||||
set new [expr {$index($chan) + $n}]
|
||||
set result [string range $buffer($chan) $index($chan) $new-1]
|
||||
set index($chan) $new
|
||||
return $result
|
||||
}
|
||||
}
|
||||
}
|
||||
set c [chan create read [namespace which driver]]
|
||||
chan configure $c -encoding utf-8
|
||||
while {![eof $c]} {
|
||||
read $c 15
|
||||
}
|
||||
close $c
|
||||
} {}
|
||||
test io-12.7 {ReadChars: too many chars read [bc5b790099]} {
|
||||
proc driver {cmd args} {
|
||||
variable buffer
|
||||
variable index
|
||||
set chan [lindex $args 0]
|
||||
switch -- $cmd {
|
||||
initialize {
|
||||
set index($chan) 0
|
||||
set buffer($chan) [encoding convertto utf-8 \
|
||||
[string repeat \uBEEF 10]....\uBEEF]
|
||||
return {initialize finalize watch read}
|
||||
}
|
||||
finalize {
|
||||
unset index($chan) buffer($chan)
|
||||
return
|
||||
}
|
||||
watch {}
|
||||
read {
|
||||
set n [lindex $args 1]
|
||||
set new [expr {$index($chan) + $n}]
|
||||
set result [string range $buffer($chan) $index($chan) $new-1]
|
||||
set index($chan) $new
|
||||
return $result
|
||||
}
|
||||
}
|
||||
}
|
||||
set c [chan create read [namespace which driver]]
|
||||
chan configure $c -encoding utf-8
|
||||
while {![eof $c]} {
|
||||
read $c 7
|
||||
}
|
||||
close $c
|
||||
} {}
|
||||
test io-12.8 {ReadChars: multibyte chars split} {
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation binary
|
||||
puts -nonewline $f [string repeat a 9]\xc2\xa0
|
||||
close $f
|
||||
set f [open $path(test1)]
|
||||
fconfigure $f -encoding utf-8 -buffersize 10
|
||||
set in [read $f]
|
||||
close $f
|
||||
scan [string index $in end] %c
|
||||
} 160
|
||||
test io-12.9 {ReadChars: multibyte chars split} {
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation binary
|
||||
puts -nonewline $f [string repeat a 9]\xc2
|
||||
close $f
|
||||
set f [open $path(test1)]
|
||||
fconfigure $f -encoding utf-8 -buffersize 10
|
||||
set in [read $f]
|
||||
close $f
|
||||
scan [string index $in end] %c
|
||||
} 194
|
||||
test io-12.10 {ReadChars: multibyte chars split} {
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation binary
|
||||
puts -nonewline $f [string repeat a 9]\xc2
|
||||
close $f
|
||||
set f [open $path(test1)]
|
||||
fconfigure $f -encoding utf-8 -buffersize 11
|
||||
set in [read $f]
|
||||
close $f
|
||||
scan [string index $in end] %c
|
||||
} 194
|
||||
|
||||
test io-13.1 {TranslateInputEOL: cr mode} {} {
|
||||
set f [open $path(test1) w]
|
||||
@@ -1559,6 +1658,45 @@ test io-13.8 {TranslateInputEOL: auto mode: \r\n} {
|
||||
close $f
|
||||
set x
|
||||
} "abcd\ndef"
|
||||
test io-13.8.1 {TranslateInputEOL: auto mode: \r\n} {
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation lf
|
||||
puts -nonewline $f "abcd\r\ndef"
|
||||
close $f
|
||||
set f [open $path(test1)]
|
||||
fconfigure $f -translation auto
|
||||
set x {}
|
||||
lappend x [read $f 5]
|
||||
lappend x [read $f]
|
||||
close $f
|
||||
set x
|
||||
} [list "abcd\n" "def"]
|
||||
test io-13.8.2 {TranslateInputEOL: auto mode: \r\n} {
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation lf
|
||||
puts -nonewline $f "abcd\r\ndef"
|
||||
close $f
|
||||
set f [open $path(test1)]
|
||||
fconfigure $f -translation auto -buffersize 6
|
||||
set x {}
|
||||
lappend x [read $f 5]
|
||||
lappend x [read $f]
|
||||
close $f
|
||||
set x
|
||||
} [list "abcd\n" "def"]
|
||||
test io-13.8.3 {TranslateInputEOL: auto mode: \r\n} {
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation lf
|
||||
puts -nonewline $f "abcd\r\n\r\ndef"
|
||||
close $f
|
||||
set f [open $path(test1)]
|
||||
fconfigure $f -translation auto -buffersize 7
|
||||
set x {}
|
||||
lappend x [read $f 5]
|
||||
lappend x [read $f]
|
||||
close $f
|
||||
set x
|
||||
} [list "abcd\n" "\ndef"]
|
||||
test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation lf
|
||||
@@ -2747,7 +2885,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa
|
||||
variable x running
|
||||
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
|
||||
proc writelots {s l} {
|
||||
for {set i 0} {$i < 2000} {incr i} {
|
||||
for {set i 0} {$i < 9000} {incr i} {
|
||||
puts $s $l
|
||||
}
|
||||
}
|
||||
@@ -2778,7 +2916,7 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa
|
||||
close $ss
|
||||
vwait [namespace which -variable x]
|
||||
set c
|
||||
} 2000
|
||||
} 9000
|
||||
test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} {
|
||||
# On Mac, this test screws up sockets such that subsequent tests using port 2828
|
||||
# either cause errors or panic().
|
||||
@@ -3960,6 +4098,46 @@ test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} {
|
||||
} {{hello
|
||||
} {hello
|
||||
}}
|
||||
test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} {
|
||||
file delete $path(pipe)
|
||||
set f1 [open $path(pipe) w]
|
||||
puts $f1 {chan configure stdout -translation crlf}
|
||||
puts $f1 {puts [gets stdin]}
|
||||
puts $f1 {puts [gets stdin]}
|
||||
close $f1
|
||||
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
|
||||
puts $f1 hello
|
||||
flush $f1
|
||||
set x ""
|
||||
lappend x [read $f1 6]
|
||||
puts $f1 hello
|
||||
flush $f1
|
||||
lappend x [read $f1]
|
||||
close $f1
|
||||
set x
|
||||
} {{hello
|
||||
} {hello
|
||||
}}
|
||||
test io-32.11.2 {Tcl_Read from a pipe} {stdio openpipe} {
|
||||
file delete $path(pipe)
|
||||
set f1 [open $path(pipe) w]
|
||||
puts $f1 {chan configure stdout -translation crlf}
|
||||
puts $f1 {puts [gets stdin]}
|
||||
puts $f1 {puts [gets stdin]}
|
||||
close $f1
|
||||
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
|
||||
puts $f1 hello
|
||||
flush $f1
|
||||
set x ""
|
||||
lappend x [read $f1 6]
|
||||
puts $f1 hello
|
||||
flush $f1
|
||||
lappend x [read $f1]
|
||||
close $f1
|
||||
set x
|
||||
} {{hello
|
||||
} {hello
|
||||
}}
|
||||
test io-32.12 {Tcl_Read, -nonewline} {
|
||||
file delete $path(test1)
|
||||
set f1 [open $path(test1) w]
|
||||
@@ -4154,6 +4332,110 @@ test io-33.10 {Tcl_Gets, exercising double buffering} {
|
||||
close $f
|
||||
set y
|
||||
} 300
|
||||
test io-33.11 {TclGetsObjBinary, [10dc6daa37]} -setup {
|
||||
proc driver {cmd args} {
|
||||
variable buffer
|
||||
variable index
|
||||
set chan [lindex $args 0]
|
||||
switch -- $cmd {
|
||||
initialize {
|
||||
set index($chan) 0
|
||||
set buffer($chan) .......
|
||||
return {initialize finalize watch read}
|
||||
}
|
||||
finalize {
|
||||
unset index($chan) buffer($chan)
|
||||
return
|
||||
}
|
||||
watch {}
|
||||
read {
|
||||
set n [lindex $args 1]
|
||||
if {$n > 3} {set n 3}
|
||||
set new [expr {$index($chan) + $n}]
|
||||
set result [string range $buffer($chan) $index($chan) $new-1]
|
||||
set index($chan) $new
|
||||
return $result
|
||||
}
|
||||
}
|
||||
}
|
||||
} -body {
|
||||
set c [chan create read [namespace which driver]]
|
||||
chan configure $c -translation binary -blocking 0
|
||||
list [gets $c] [gets $c] [gets $c] [gets $c]
|
||||
} -cleanup {
|
||||
close $c
|
||||
rename driver {}
|
||||
} -result {{} {} {} .......}
|
||||
test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup {
|
||||
proc driver {cmd args} {
|
||||
variable buffer
|
||||
variable index
|
||||
set chan [lindex $args 0]
|
||||
switch -- $cmd {
|
||||
initialize {
|
||||
set index($chan) 0
|
||||
set buffer($chan) .......
|
||||
return {initialize finalize watch read}
|
||||
}
|
||||
finalize {
|
||||
unset index($chan) buffer($chan)
|
||||
return
|
||||
}
|
||||
watch {}
|
||||
read {
|
||||
set n [lindex $args 1]
|
||||
if {$n > 3} {set n 3}
|
||||
set new [expr {$index($chan) + $n}]
|
||||
set result [string range $buffer($chan) $index($chan) $new-1]
|
||||
set index($chan) $new
|
||||
return $result
|
||||
}
|
||||
}
|
||||
}
|
||||
} -body {
|
||||
set c [chan create read [namespace which driver]]
|
||||
chan configure $c -blocking 0
|
||||
list [gets $c] [gets $c] [gets $c] [gets $c]
|
||||
} -cleanup {
|
||||
close $c
|
||||
rename driver {}
|
||||
} -result {{} {} {} .......}
|
||||
test io-33.13 {Tcl_GetsObj, [10dc6daa37]} -setup {
|
||||
proc driver {cmd args} {
|
||||
variable buffer
|
||||
variable index
|
||||
set chan [lindex $args 0]
|
||||
switch -- $cmd {
|
||||
initialize {
|
||||
set index($chan) 0
|
||||
set buffer($chan) [string repeat \
|
||||
[string repeat . 64]\n[string repeat . 25] 2]
|
||||
return {initialize finalize watch read}
|
||||
}
|
||||
finalize {
|
||||
unset index($chan) buffer($chan)
|
||||
return
|
||||
}
|
||||
watch {}
|
||||
read {
|
||||
set n [lindex $args 1]
|
||||
if {$n > 65} {set n 65}
|
||||
set new [expr {$index($chan) + $n}]
|
||||
set result [string range $buffer($chan) $index($chan) $new-1]
|
||||
set index($chan) $new
|
||||
return $result
|
||||
}
|
||||
}
|
||||
}
|
||||
} -body {
|
||||
set c [chan create read [namespace which driver]]
|
||||
chan configure $c -blocking 0
|
||||
list [gets $c] [gets $c] [gets $c] [gets $c] [gets $c]
|
||||
} -cleanup {
|
||||
close $c
|
||||
rename driver {}
|
||||
} -result [list [string repeat . 64] {} [string repeat . 89] \
|
||||
[string repeat . 25] {}]
|
||||
|
||||
# Test Tcl_Seek and Tcl_Tell.
|
||||
|
||||
@@ -4433,10 +4715,10 @@ test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
|
||||
puts -nonewline $f abcdef
|
||||
lappend l [tell $f]
|
||||
close $f
|
||||
lappend l [file size $f]
|
||||
lappend l [file size $path(test3)]
|
||||
# truncate...
|
||||
close [open $path(test3) w]
|
||||
lappend l [file size $f]
|
||||
lappend l [file size $path(test3)]
|
||||
set l
|
||||
} {0 6 6 4294967296 4294967302 4294967302 0}
|
||||
|
||||
@@ -4701,6 +4983,92 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
|
||||
close $f
|
||||
list $c $l $e
|
||||
} {21 8 1}
|
||||
test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body {
|
||||
file delete $path(test1)
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation cr
|
||||
puts $f abc\ndef
|
||||
close $f
|
||||
set s [file size $path(test1)]
|
||||
set f [open $path(test1) r]
|
||||
fconfigure $f -translation crlf
|
||||
set l [string length [set in [read $f]]]
|
||||
set e [eof $f]
|
||||
close $f
|
||||
list $s $l $e [scan [string index $in end] %c]
|
||||
} -result {8 8 1 13}
|
||||
test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body {
|
||||
file delete $path(test1)
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation cr -eofchar \x1a
|
||||
puts $f abc\ndef
|
||||
close $f
|
||||
set s [file size $path(test1)]
|
||||
set f [open $path(test1) r]
|
||||
fconfigure $f -translation crlf -eofchar \x1a
|
||||
set l [string length [set in [read $f]]]
|
||||
set e [eof $f]
|
||||
close $f
|
||||
list $s $l $e [scan [string index $in end] %c]
|
||||
} -result {9 8 1 13}
|
||||
test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body {
|
||||
file delete $path(test1)
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation cr -eofchar \x1a
|
||||
puts $f {}
|
||||
close $f
|
||||
set s [file size $path(test1)]
|
||||
set f [open $path(test1) r]
|
||||
fconfigure $f -translation crlf -eofchar \x1a
|
||||
set l [string length [set in [read $f]]]
|
||||
set e [eof $f]
|
||||
close $f
|
||||
list $s $l $e [scan [string index $in end] %c]
|
||||
} -result {2 1 1 13}
|
||||
test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body {
|
||||
file delete $path(test1)
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation cr
|
||||
puts $f {}
|
||||
close $f
|
||||
set s [file size $path(test1)]
|
||||
set f [open $path(test1) r]
|
||||
fconfigure $f -translation crlf
|
||||
set l [string length [set in [read $f]]]
|
||||
set e [eof $f]
|
||||
close $f
|
||||
list $s $l $e [scan [string index $in end] %c]
|
||||
} -result {1 1 1 13}
|
||||
test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body {
|
||||
file delete $path(test1)
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation cr -eofchar {}
|
||||
set i [format abc\ndef\n%cqrs\nuvw 26]
|
||||
puts $f $i
|
||||
close $f
|
||||
set c [file size $path(test1)]
|
||||
set f [open $path(test1) r]
|
||||
fconfigure $f -translation crlf -eofchar \x1a
|
||||
set l [string length [set in [read $f]]]
|
||||
set e [eof $f]
|
||||
close $f
|
||||
list $c $l $e [scan [string index $in end] %c]
|
||||
} -result {17 8 1 13}
|
||||
test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} {
|
||||
file delete $path(test1)
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation cr -eofchar {}
|
||||
set i [format \n%cqrsuvw 26]
|
||||
puts $f $i
|
||||
close $f
|
||||
set c [file size $path(test1)]
|
||||
set f [open $path(test1) r]
|
||||
fconfigure $f -translation crlf -eofchar \x1a
|
||||
set l [string length [set in [read $f]]]
|
||||
set e [eof $f]
|
||||
close $f
|
||||
list $c $l $e [scan [string index $in end] %c]
|
||||
} {9 1 1 13}
|
||||
|
||||
# Test Tcl_InputBlocked
|
||||
|
||||
@@ -4723,6 +5091,29 @@ test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} {
|
||||
close $f1
|
||||
set x
|
||||
} {{} 1 hello 0 {} 1}
|
||||
test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} {stdio openpipe} {
|
||||
set f1 [open "|[list [interpreter]]" r+]
|
||||
chan configure $f1 -encoding binary -translation lf -eofchar {}
|
||||
puts $f1 {
|
||||
chan configure stdout -encoding binary -translation lf -eofchar {}
|
||||
puts hello_from_pipe
|
||||
}
|
||||
flush $f1
|
||||
gets $f1
|
||||
fconfigure $f1 -blocking off -buffering full
|
||||
puts $f1 {puts hello}
|
||||
set x ""
|
||||
lappend x [gets $f1]
|
||||
lappend x [fblocked $f1]
|
||||
flush $f1
|
||||
after 200
|
||||
lappend x [gets $f1]
|
||||
lappend x [fblocked $f1]
|
||||
lappend x [gets $f1]
|
||||
lappend x [fblocked $f1]
|
||||
close $f1
|
||||
set x
|
||||
} {{} 1 hello 0 {} 1}
|
||||
test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} {
|
||||
set f1 [open "|[list [interpreter]]" r+]
|
||||
fconfigure $f1 -buffering line
|
||||
@@ -6540,11 +6931,23 @@ test io-52.4 {TclCopyChannel} {fcopy} {
|
||||
fconfigure $f1 -translation lf -blocking 0
|
||||
fconfigure $f2 -translation cr -blocking 0
|
||||
fcopy $f1 $f2 -size 40
|
||||
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
|
||||
set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
|
||||
close $f1
|
||||
close $f2
|
||||
lappend result [file size $path(test1)]
|
||||
} {0 0 40}
|
||||
} {0 0 0 40}
|
||||
test io-52.4.1 {TclCopyChannel} {fcopy} {
|
||||
file delete $path(test1)
|
||||
set f1 [open $thisScript]
|
||||
set f2 [open $path(test1) w]
|
||||
fconfigure $f1 -translation lf -blocking 0 -buffersize 10000000
|
||||
fconfigure $f2 -translation cr -blocking 0
|
||||
fcopy $f1 $f2 -size 40
|
||||
set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
|
||||
close $f1
|
||||
close $f2
|
||||
lappend result [file size $path(test1)]
|
||||
} {0 0 0 40}
|
||||
test io-52.5 {TclCopyChannel, all} {fcopy} {
|
||||
file delete $path(test1)
|
||||
set f1 [open $thisScript]
|
||||
@@ -6730,6 +7133,150 @@ test io-52.11 {TclCopyChannel & encodings} {fcopy} {
|
||||
file size $path(kyrillic.txt)
|
||||
} 3
|
||||
|
||||
test io-52.12 {coverage of -translation auto} {
|
||||
file delete $path(test1) $path(test2)
|
||||
set out [open $path(test1) wb]
|
||||
chan configure $out -translation lf
|
||||
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
|
||||
close $out
|
||||
set in [open $path(test1)]
|
||||
chan configure $in -buffersize 8
|
||||
set out [open $path(test2) w]
|
||||
chan configure $out -translation lf
|
||||
fcopy $in $out
|
||||
close $in
|
||||
close $out
|
||||
file size $path(test2)
|
||||
} 29
|
||||
test io-52.13 {coverage of -translation cr} {
|
||||
file delete $path(test1) $path(test2)
|
||||
set out [open $path(test1) wb]
|
||||
chan configure $out -translation lf
|
||||
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
|
||||
close $out
|
||||
set in [open $path(test1)]
|
||||
chan configure $in -buffersize 8 -translation cr
|
||||
set out [open $path(test2) w]
|
||||
chan configure $out -translation lf
|
||||
fcopy $in $out
|
||||
close $in
|
||||
close $out
|
||||
file size $path(test2)
|
||||
} 30
|
||||
test io-52.14 {coverage of -translation crlf} {
|
||||
file delete $path(test1) $path(test2)
|
||||
set out [open $path(test1) wb]
|
||||
chan configure $out -translation lf
|
||||
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
|
||||
close $out
|
||||
set in [open $path(test1)]
|
||||
chan configure $in -buffersize 8 -translation crlf
|
||||
set out [open $path(test2) w]
|
||||
chan configure $out -translation lf
|
||||
fcopy $in $out
|
||||
close $in
|
||||
close $out
|
||||
file size $path(test2)
|
||||
} 29
|
||||
test io-52.14.1 {coverage of -translation crlf} {
|
||||
file delete $path(test1) $path(test2)
|
||||
set out [open $path(test1) wb]
|
||||
chan configure $out -translation lf
|
||||
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
|
||||
close $out
|
||||
set in [open $path(test1)]
|
||||
chan configure $in -buffersize 8 -translation crlf
|
||||
set out [open $path(test2) w]
|
||||
fcopy $in $out -size 2
|
||||
close $in
|
||||
close $out
|
||||
file size $path(test2)
|
||||
} 2
|
||||
test io-52.14.2 {coverage of -translation crlf} {
|
||||
file delete $path(test1) $path(test2)
|
||||
set out [open $path(test1) wb]
|
||||
chan configure $out -translation lf
|
||||
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
|
||||
close $out
|
||||
set in [open $path(test1)]
|
||||
chan configure $in -translation crlf
|
||||
set out [open $path(test2) w]
|
||||
fcopy $in $out -size 9
|
||||
close $in
|
||||
close $out
|
||||
file size $path(test2)
|
||||
} 9
|
||||
test io-52.15 {coverage of -translation crlf} {
|
||||
file delete $path(test1) $path(test2)
|
||||
set out [open $path(test1) wb]
|
||||
chan configure $out -translation lf
|
||||
puts -nonewline $out abcdefg\r
|
||||
close $out
|
||||
set in [open $path(test1)]
|
||||
chan configure $in -buffersize 8 -translation crlf
|
||||
set out [open $path(test2) w]
|
||||
fcopy $in $out
|
||||
close $in
|
||||
close $out
|
||||
file size $path(test2)
|
||||
} 8
|
||||
test io-52.16 {coverage of eofChar handling} {
|
||||
file delete $path(test1) $path(test2)
|
||||
set out [open $path(test1) wb]
|
||||
chan configure $out -translation lf
|
||||
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
|
||||
close $out
|
||||
set in [open $path(test1)]
|
||||
chan configure $in -buffersize 8 -translation lf -eofchar a
|
||||
set out [open $path(test2) w]
|
||||
fcopy $in $out
|
||||
close $in
|
||||
close $out
|
||||
file size $path(test2)
|
||||
} 0
|
||||
test io-52.17 {coverage of eofChar handling} {
|
||||
file delete $path(test1) $path(test2)
|
||||
set out [open $path(test1) wb]
|
||||
chan configure $out -translation lf
|
||||
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
|
||||
close $out
|
||||
set in [open $path(test1)]
|
||||
chan configure $in -buffersize 8 -translation lf -eofchar d
|
||||
set out [open $path(test2) w]
|
||||
fcopy $in $out
|
||||
close $in
|
||||
close $out
|
||||
file size $path(test2)
|
||||
} 3
|
||||
test io-52.18 {coverage of eofChar handling} {
|
||||
file delete $path(test1) $path(test2)
|
||||
set out [open $path(test1) wb]
|
||||
chan configure $out -translation lf
|
||||
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
|
||||
close $out
|
||||
set in [open $path(test1)]
|
||||
chan configure $in -buffersize 8 -translation crlf -eofchar h
|
||||
set out [open $path(test2) w]
|
||||
fcopy $in $out
|
||||
close $in
|
||||
close $out
|
||||
file size $path(test2)
|
||||
} 8
|
||||
test io-52.19 {coverage of eofChar handling} {
|
||||
file delete $path(test1) $path(test2)
|
||||
set out [open $path(test1) wb]
|
||||
chan configure $out -translation lf
|
||||
puts -nonewline $out abcdefg\rhijklmn\nopqrstu\r\nvwxyz
|
||||
close $out
|
||||
set in [open $path(test1)]
|
||||
chan configure $in -buffersize 10 -translation crlf -eofchar h
|
||||
set out [open $path(test2) w]
|
||||
fcopy $in $out
|
||||
close $in
|
||||
close $out
|
||||
file size $path(test2)
|
||||
} 8
|
||||
|
||||
test io-53.1 {CopyData} {fcopy} {
|
||||
file delete $path(test1)
|
||||
set f1 [open $thisScript]
|
||||
@@ -6799,17 +7346,17 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven
|
||||
for {set x 0} {$x < 12} {incr x} {
|
||||
append big $big
|
||||
}
|
||||
file delete $path(test1)
|
||||
# file delete $path(test1)
|
||||
file delete $path(pipe)
|
||||
set f1 [open $path(pipe) w]
|
||||
puts $f1 {
|
||||
puts ready
|
||||
fcopy stdin stdout -command { set x }
|
||||
vwait x
|
||||
set f [open $path(test1) w]
|
||||
fconfigure $f -translation lf
|
||||
puts $f "done"
|
||||
close $f
|
||||
# set f [open $path(test1) w]
|
||||
# fconfigure $f -translation lf
|
||||
# puts $f "done"
|
||||
# close $f
|
||||
}
|
||||
close $f1
|
||||
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
|
||||
@@ -6821,7 +7368,7 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven
|
||||
set result ""
|
||||
fileevent $f1 read [namespace code {
|
||||
append result [read $f1 1024]
|
||||
if {[string length $result] >= [string length $big]} {
|
||||
if {[string length $result] >= [string length $big]+1} {
|
||||
set x done
|
||||
}
|
||||
}]
|
||||
@@ -6830,6 +7377,38 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven
|
||||
set big {}
|
||||
set x
|
||||
} done
|
||||
test io-53.4.1 {Bug 894da183c8} {stdio fcopy} {
|
||||
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
|
||||
variable x
|
||||
for {set x 0} {$x < 12} {incr x} {
|
||||
append big $big
|
||||
}
|
||||
file delete $path(pipe)
|
||||
set f1 [open $path(pipe) w]
|
||||
puts $f1 [list file delete $path(test1)]
|
||||
puts $f1 {
|
||||
puts ready
|
||||
set f [open io-53.4.1 w]
|
||||
chan configure $f -translation lf
|
||||
fcopy stdin $f -command { set x }
|
||||
vwait x
|
||||
close $f
|
||||
}
|
||||
puts $f1 "close \[[list open $path(test1) w]]"
|
||||
close $f1
|
||||
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
|
||||
set result [gets $f1]
|
||||
fconfigure $f1 -blocking 0 -buffersize 125000 -translation lf
|
||||
puts $f1 $big
|
||||
fconfigure $f1 -blocking 1
|
||||
close $f1
|
||||
set big {}
|
||||
while {[catch {glob $path(test1)}]} {after 50}
|
||||
file delete $path(test1)
|
||||
set check [file size io-53.4.1]
|
||||
file delete io-53.4.1
|
||||
set check
|
||||
} 266241
|
||||
set result {}
|
||||
proc FcopyTestAccept {sock args} {
|
||||
after 1000 "close $sock"
|
||||
@@ -7200,6 +7779,113 @@ test io-53.11 {Bug 2895565} -setup {
|
||||
removeFile in
|
||||
} -result {40 bytes copied}
|
||||
|
||||
# test io-53.12 not backported. Tests feature only in 8.6+
|
||||
|
||||
test io-53.13 {TclCopyChannel: read error reporting} -setup {
|
||||
proc driver {cmd args} {
|
||||
variable buffer
|
||||
variable index
|
||||
set chan [lindex $args 0]
|
||||
switch -- $cmd {
|
||||
initialize {
|
||||
return {initialize finalize watch read}
|
||||
}
|
||||
finalize {
|
||||
return
|
||||
}
|
||||
watch {}
|
||||
read {
|
||||
error FAIL
|
||||
}
|
||||
}
|
||||
}
|
||||
set outFile [makeFile {} out]
|
||||
} -body {
|
||||
set in [chan create read [namespace which driver]]
|
||||
chan configure $in -translation binary
|
||||
set out [open $outFile wb]
|
||||
chan copy $in $out
|
||||
} -cleanup {
|
||||
catch {close $in}
|
||||
catch {close $out}
|
||||
removeFile out
|
||||
rename driver {}
|
||||
} -result {error reading "*": *} -returnCodes error -match glob
|
||||
test io-53.14 {TclCopyChannel: write error reporting} -setup {
|
||||
proc driver {cmd args} {
|
||||
variable buffer
|
||||
variable index
|
||||
set chan [lindex $args 0]
|
||||
switch -- $cmd {
|
||||
initialize {
|
||||
return {initialize finalize watch write}
|
||||
}
|
||||
finalize {
|
||||
return
|
||||
}
|
||||
watch {}
|
||||
write {
|
||||
error FAIL
|
||||
}
|
||||
}
|
||||
}
|
||||
set inFile [makeFile {aaa} in]
|
||||
} -body {
|
||||
set in [open $inFile rb]
|
||||
set out [chan create write [namespace which driver]]
|
||||
chan configure $out -translation binary
|
||||
chan copy $in $out
|
||||
} -cleanup {
|
||||
catch {close $in}
|
||||
catch {close $out}
|
||||
removeFile in
|
||||
rename driver {}
|
||||
} -result {error writing "*": *} -returnCodes error -match glob
|
||||
test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup {
|
||||
proc driver {cmd args} {
|
||||
variable buffer
|
||||
variable index
|
||||
variable blocked
|
||||
set chan [lindex $args 0]
|
||||
switch -- $cmd {
|
||||
initialize {
|
||||
set index($chan) 0
|
||||
set buffer($chan) [encoding convertto utf-8 \
|
||||
[string repeat a 100]]
|
||||
set blocked($chan) 1
|
||||
return {initialize finalize watch read}
|
||||
}
|
||||
finalize {
|
||||
unset index($chan) buffer($chan) blocked($chan)
|
||||
return
|
||||
}
|
||||
watch {}
|
||||
read {
|
||||
if {$blocked($chan)} {
|
||||
set blocked($chan) [expr {!$blocked($chan)}]
|
||||
return -code error EAGAIN
|
||||
}
|
||||
set n [lindex $args 1]
|
||||
set new [expr {$index($chan) + $n}]
|
||||
set result [string range $buffer($chan) $index($chan) $new-1]
|
||||
set index($chan) $new
|
||||
return $result
|
||||
}
|
||||
}
|
||||
}
|
||||
set c [chan create read [namespace which driver]]
|
||||
chan configure $c -encoding utf-8
|
||||
set out [makeFile {} out]
|
||||
set outChan [open $out w]
|
||||
chan configure $outChan -encoding utf-8
|
||||
} -body {
|
||||
chan copy $c $outChan
|
||||
} -cleanup {
|
||||
close $outChan
|
||||
close $c
|
||||
removeFile out
|
||||
} -result 100
|
||||
|
||||
test io-54.1 {Recursive channel events} {socket fileevent} {
|
||||
# This test checks to see if file events are delivered during recursive
|
||||
# event loops when there is buffered data on the channel.
|
||||
@@ -7778,6 +8464,64 @@ test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} {} {
|
||||
list $code [string map [list $f @@] $msg]
|
||||
} {1 {can not find channel named "@@"}}
|
||||
|
||||
test io-73.3 {[5adc350683] [gets] after EOF} -setup {
|
||||
set fn [makeFile {} io-73.3]
|
||||
set rfd [open $fn r]
|
||||
set wfd [open $fn a]
|
||||
chan configure $wfd -buffering line
|
||||
read $rfd
|
||||
} -body {
|
||||
set result [eof $rfd]
|
||||
puts $wfd "more data"
|
||||
lappend result [eof $rfd]
|
||||
lappend result [gets $rfd]
|
||||
lappend result [eof $rfd]
|
||||
lappend result [gets $rfd]
|
||||
lappend result [eof $rfd]
|
||||
} -cleanup {
|
||||
close $wfd
|
||||
close $rfd
|
||||
removeFile io-73.3
|
||||
} -result {1 1 {more data} 0 {} 1}
|
||||
|
||||
test io-73.4 {[5adc350683] [read] after EOF} -setup {
|
||||
set fn [makeFile {} io-73.4]
|
||||
set rfd [open $fn r]
|
||||
set wfd [open $fn a]
|
||||
chan configure $wfd -buffering line
|
||||
read $rfd
|
||||
} -body {
|
||||
set result [eof $rfd]
|
||||
puts $wfd "more data"
|
||||
lappend result [eof $rfd]
|
||||
lappend result [read $rfd]
|
||||
lappend result [eof $rfd]
|
||||
} -cleanup {
|
||||
close $wfd
|
||||
close $rfd
|
||||
removeFile io-73.4
|
||||
} -result {1 1 {more data
|
||||
} 1}
|
||||
|
||||
test io-73.5 {effect of eof on encoding end flags} -setup {
|
||||
set fn [makeFile {} io-73.5]
|
||||
set rfd [open $fn r]
|
||||
set wfd [open $fn a]
|
||||
chan configure $wfd -buffering none -translation binary
|
||||
chan configure $rfd -buffersize 5 -encoding utf-8
|
||||
read $rfd
|
||||
} -body {
|
||||
set result [eof $rfd]
|
||||
puts -nonewline $wfd "more\u00c2\u00a0data"
|
||||
lappend result [eof $rfd]
|
||||
lappend result [read $rfd]
|
||||
lappend result [eof $rfd]
|
||||
} -cleanup {
|
||||
close $wfd
|
||||
close $rfd
|
||||
removeFile io-73.5
|
||||
} -result [list 1 1 more\u00a0data 1]
|
||||
|
||||
# ### ### ### ######### ######### #########
|
||||
|
||||
# cleanup
|
||||
|
||||
107
tests/ioCmd.test
107
tests/ioCmd.test
@@ -755,6 +755,90 @@ test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match g
|
||||
rename foo {}
|
||||
set res
|
||||
} -result {{} {initialize rc* {read write}} 1 {*all required methods*} {}}
|
||||
test iocmd-21.20 {Bug 88aef05cda} -setup {
|
||||
proc foo {method chan args} {
|
||||
switch -- $method blocking {
|
||||
chan configure $chan -blocking [lindex $args 0]
|
||||
return
|
||||
} initialize {
|
||||
return {initialize finalize watch blocking read write
|
||||
configure cget cgetall}
|
||||
} finalize {
|
||||
return
|
||||
}
|
||||
}
|
||||
set ch [chan create {read write} foo]
|
||||
} -body {
|
||||
list [catch {chan configure $ch -blocking 0} m] $m
|
||||
} -cleanup {
|
||||
close $ch
|
||||
rename foo {}
|
||||
} -match glob -result {1 {*nested eval*}}
|
||||
test iocmd-21.21 {[close] in [read] segfaults} -setup {
|
||||
proc foo {method chan args} {
|
||||
switch -- $method initialize {
|
||||
return {initialize finalize watch read}
|
||||
} finalize {} watch {} read {
|
||||
close $chan
|
||||
return a
|
||||
}
|
||||
}
|
||||
set ch [chan create read foo]
|
||||
} -body {
|
||||
read $ch 0
|
||||
} -cleanup {
|
||||
close $ch
|
||||
rename foo {}
|
||||
} -result {}
|
||||
test iocmd-21.22 {[close] in [read] segfaults} -setup {
|
||||
proc foo {method chan args} {
|
||||
switch -- $method initialize {
|
||||
return {initialize finalize watch read}
|
||||
} finalize {} watch {} read {
|
||||
catch {close $chan}
|
||||
return a
|
||||
}
|
||||
}
|
||||
set ch [chan create read foo]
|
||||
} -body {
|
||||
read $ch 1
|
||||
} -returnCodes error -cleanup {
|
||||
catch {close $ch}
|
||||
rename foo {}
|
||||
} -match glob -result {*invalid argument*}
|
||||
test iocmd-21.23 {[close] in [gets] segfaults} -setup {
|
||||
proc foo {method chan args} {
|
||||
switch -- $method initialize {
|
||||
return {initialize finalize watch read}
|
||||
} finalize {} watch {} read {
|
||||
catch {close $chan}
|
||||
return \n
|
||||
}
|
||||
}
|
||||
set ch [chan create read foo]
|
||||
} -body {
|
||||
gets $ch
|
||||
} -cleanup {
|
||||
catch {close $ch}
|
||||
rename foo {}
|
||||
} -result {}
|
||||
test iocmd-21.24 {[close] in binary [gets] segfaults} -setup {
|
||||
proc foo {method chan args} {
|
||||
switch -- $method initialize {
|
||||
return {initialize finalize watch read}
|
||||
} finalize {} watch {} read {
|
||||
catch {close $chan}
|
||||
return \n
|
||||
}
|
||||
}
|
||||
set ch [chan create read foo]
|
||||
} -body {
|
||||
chan configure $ch -translation binary
|
||||
gets $ch
|
||||
} -cleanup {
|
||||
catch {close $ch}
|
||||
rename foo {}
|
||||
} -result {}
|
||||
|
||||
# --- --- --- --------- --------- ---------
|
||||
# Helper commands to record the arguments to handler methods.
|
||||
@@ -1013,6 +1097,20 @@ test iocmd-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glo
|
||||
rename foo {}
|
||||
unset res
|
||||
} -result {{read rc* 4096} {} 0}
|
||||
test iocmd-23.11 {chan read, close pulls the rug out} -match glob -body {
|
||||
set res {}
|
||||
proc foo {args} {
|
||||
oninit; onfinal; track
|
||||
set args [lassign $args sub id]
|
||||
if {$sub ne "read"} {return}
|
||||
close $id
|
||||
return {}
|
||||
}
|
||||
set c [chan create {r} foo]
|
||||
note [read $c]
|
||||
rename foo {}
|
||||
set res
|
||||
} -result {{read rc* 4096} {}}
|
||||
|
||||
# --- === *** ###########################
|
||||
# method write
|
||||
@@ -1940,13 +2038,13 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
|
||||
proc foo {args} {
|
||||
oninit; onfinal; track;
|
||||
# destroy interpreter during channel access
|
||||
# Actually not possible for an interp to destroy itself.
|
||||
interp delete {}
|
||||
return}
|
||||
suicide
|
||||
}
|
||||
set chan [chan create {r w} foo]
|
||||
fconfigure $chan -buffering none
|
||||
set chan
|
||||
}]
|
||||
interp alias $ida suicide {} interp delete $ida
|
||||
|
||||
# Move channel to 2nd thread.
|
||||
interp eval $ida [list testchannel cut $chan]
|
||||
@@ -1965,8 +2063,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
|
||||
set res
|
||||
}]
|
||||
set res
|
||||
} -constraints {testchannel impossible} \
|
||||
-result {Owner lost}
|
||||
} -constraints {testchannel} -result {Owner lost}
|
||||
|
||||
test iocmd-32.2 {delete interp of reflected chan} {
|
||||
# Bug 3034840
|
||||
|
||||
150
tests/iogt.test
150
tests/iogt.test
@@ -159,8 +159,8 @@ proc fevent {fdelay idelay blocks script data} {
|
||||
|
||||
#puts stdout ">>>>>" ; flush stdout
|
||||
|
||||
uplevel #0 set sock $sk
|
||||
set res [uplevel #0 $script]
|
||||
uplevel 1 set sock $sk
|
||||
set res [uplevel 1 $script]
|
||||
|
||||
catch {close $sk}
|
||||
return $res
|
||||
@@ -242,6 +242,36 @@ proc id_fulltrail {var op data} {
|
||||
return $res
|
||||
}
|
||||
|
||||
proc id_torture {chan op data} {
|
||||
switch -- $op {
|
||||
create/write -
|
||||
create/read -
|
||||
delete/write -
|
||||
delete/read -
|
||||
clear_read {;#ignore}
|
||||
flush/write -
|
||||
flush/read {}
|
||||
write {
|
||||
global level
|
||||
if {$level} {
|
||||
return
|
||||
}
|
||||
incr level
|
||||
testchannel unstack $chan
|
||||
testchannel transform $chan \
|
||||
-command [namespace code [list id_torture $chan]]
|
||||
return $data
|
||||
}
|
||||
read {
|
||||
testchannel unstack $chan
|
||||
testchannel transform $chan \
|
||||
-command [namespace code [list id_torture $chan]]
|
||||
return $data
|
||||
}
|
||||
query/maxRead {return -1}
|
||||
}
|
||||
}
|
||||
|
||||
proc counter {var op data} {
|
||||
variable $var
|
||||
upvar 0 $var n
|
||||
@@ -364,6 +394,10 @@ proc audit_flow {var -attach channel} {
|
||||
testchannel transform $channel -command [namespace code [list id_fulltrail $var]]
|
||||
}
|
||||
|
||||
proc torture {-attach channel} {
|
||||
testchannel transform $channel -command [namespace code [list id_torture $channel]]
|
||||
}
|
||||
|
||||
proc stopafter {var n -attach channel} {
|
||||
variable $var
|
||||
upvar 0 $var vn
|
||||
@@ -518,6 +552,7 @@ query/maxRead
|
||||
read
|
||||
query/maxRead
|
||||
flush/read
|
||||
query/maxRead
|
||||
delete/read
|
||||
--------
|
||||
create/write
|
||||
@@ -570,6 +605,7 @@ read {
|
||||
}
|
||||
query/maxRead {} -1
|
||||
flush/read {} {}
|
||||
query/maxRead {} -1
|
||||
delete/read {} *ignored*
|
||||
--------
|
||||
create/write {} *ignored*
|
||||
@@ -624,6 +660,7 @@ read {%^&*()_+-=
|
||||
}
|
||||
query/maxRead {} -1
|
||||
flush/read {} {}
|
||||
query/maxRead {} -1
|
||||
write %^&*()_+-= %^&*()_+-=
|
||||
write {
|
||||
} {
|
||||
@@ -632,9 +669,27 @@ delete/read {} *ignored*
|
||||
flush/write {} {}
|
||||
delete/write {} *ignored*}
|
||||
|
||||
test iogt-2.4 {basic I/O, mixed trail} {testchannel} {
|
||||
set fh [open $path(dummy) r]
|
||||
torture -attach $fh
|
||||
chan configure $fh -buffersize 2
|
||||
set x [read $fh]
|
||||
testchannel unstack $fh
|
||||
close $fh
|
||||
set x
|
||||
} {}
|
||||
test iogt-2.5 {basic I/O, mixed trail} {testchannel} {
|
||||
set ::level 0
|
||||
set fh [open $path(dummyout) w]
|
||||
torture -attach $fh
|
||||
puts -nonewline $fh abcdef
|
||||
flush $fh
|
||||
testchannel unstack $fh
|
||||
close $fh
|
||||
} {}
|
||||
|
||||
test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} \
|
||||
{testchannel unknownFailure} {
|
||||
{testchannel knownBug} {
|
||||
# This test to check the validity of aquired 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
|
||||
@@ -651,6 +706,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} \
|
||||
set fin [open $path(dummy) r]
|
||||
|
||||
fevent 1000 500 {20 20 20 10 1 1} {
|
||||
variable copy
|
||||
close $fin
|
||||
|
||||
set fout [open dummyout w]
|
||||
@@ -688,7 +744,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} \
|
||||
} {1 {create/write create/read write flush/write flush/read delete/write delete/read}}
|
||||
|
||||
|
||||
test iogt-4.0 {fileevent readable, after transform} {testchannel unknownFailure} {
|
||||
test iogt-4.0 {fileevent readable, after transform} {testchannel knownBug} {
|
||||
set fin [open $path(dummy) r]
|
||||
set data [read $fin]
|
||||
close $fin
|
||||
@@ -718,10 +774,11 @@ test iogt-4.0 {fileevent readable, after transform} {testchannel unknownFailure}
|
||||
}
|
||||
|
||||
fevent 1000 500 {20 20 20 10 1} {
|
||||
variable stop
|
||||
audit_flow trail -attach $sock
|
||||
rblocks_t rbuf trail 23 -attach $sock
|
||||
|
||||
fileevent $sock readable [list Get $sock]
|
||||
fileevent $sock readable [namespace code [list Get $sock]]
|
||||
|
||||
flush $sock ; # now, or fcopy will error us out
|
||||
# But the 1 second delay should be enough to
|
||||
@@ -819,7 +876,7 @@ delete/write {} *ignored*
|
||||
delete/read {} *ignored*} ; # catch unescaped quote "
|
||||
|
||||
|
||||
test iogt-5.0 {EOF simulation} {testchannel unknownFailure} {
|
||||
test iogt-5.0 {EOF simulation} {testchannel knownBug} {
|
||||
set fin [open $path(dummy) r]
|
||||
set fout [open $path(dummyout) w]
|
||||
|
||||
@@ -916,6 +973,15 @@ test iogt-6.0 {Push back} testchannel {
|
||||
} {xxx}
|
||||
|
||||
test iogt-6.1 {Push back and up} {testchannel knownBug} {
|
||||
|
||||
# This test demonstrates the bug/misfeature in the stacked
|
||||
# channel implementation that data can be discarded if it is
|
||||
# read into the buffers of one channel in the stack, and then
|
||||
# that channel is popped before anything above it reads.
|
||||
#
|
||||
# This bug can be worked around by always setting -buffersize
|
||||
# to 1, but who wants to do that?
|
||||
|
||||
set f [open $path(dummy) r]
|
||||
|
||||
# contents of dummy = "abcdefghi..."
|
||||
@@ -930,6 +996,78 @@ test iogt-6.1 {Push back and up} {testchannel knownBug} {
|
||||
set res
|
||||
} {xxxghi}
|
||||
|
||||
# Driver for a base channel that emits several short "files"
|
||||
# with each terminated by a fleeting EOF
|
||||
proc driver {cmd args} {
|
||||
variable buffer
|
||||
variable index
|
||||
set chan [lindex $args 0]
|
||||
switch -- $cmd {
|
||||
initialize {
|
||||
set index($chan) 0
|
||||
set buffer($chan) .....
|
||||
return {initialize finalize watch read}
|
||||
}
|
||||
finalize {
|
||||
if {![info exists index($chan)]} {return}
|
||||
unset index($chan) buffer($chan)
|
||||
return
|
||||
}
|
||||
watch {}
|
||||
read {
|
||||
set n [lindex $args 1]
|
||||
if {![info exists index($chan)]} {
|
||||
driver initialize $chan
|
||||
}
|
||||
set new [expr {$index($chan) + $n}]
|
||||
set result [string range $buffer($chan) $index($chan) $new-1]
|
||||
set index($chan) $new
|
||||
if {[string length $result] == 0} {
|
||||
driver finalize $chan
|
||||
}
|
||||
return $result
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
test iogt-7.0 {Handle fleeting EOF} -constraints {testchannel} -body {
|
||||
set chan [chan create read [namespace which driver]]
|
||||
identity -attach $chan
|
||||
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
|
||||
[read $chan] [eof $chan]
|
||||
} -cleanup {
|
||||
close $chan
|
||||
} -result {0 ..... 1 {} 0 ..... 1}
|
||||
|
||||
proc delay {op data} {
|
||||
variable store
|
||||
switch -- $op {
|
||||
create/write - create/read -
|
||||
delete/write - delete/read -
|
||||
flush/write - write -
|
||||
clear_read {;#ignore}
|
||||
flush/read -
|
||||
read {
|
||||
if {![info exists store]} {set store {}}
|
||||
set reply $store
|
||||
set store $data
|
||||
return $reply
|
||||
}
|
||||
query/maxRead {return -1}
|
||||
}
|
||||
}
|
||||
|
||||
test iogt-7.1 {Handle fleeting EOF} -constraints {testchannel} -body {
|
||||
set chan [chan create read [namespace which driver]]
|
||||
testchannel transform $chan -command [namespace code delay]
|
||||
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
|
||||
[read $chan] [eof $chan]
|
||||
} -cleanup {
|
||||
close $chan
|
||||
} -result {0 ..... 1 {} 0 ..... 1}
|
||||
|
||||
rename delay {}
|
||||
rename driver {}
|
||||
|
||||
# cleanup
|
||||
foreach file [list dummy dummyout __echo_srv__.tcl] {
|
||||
|
||||
@@ -29,7 +29,7 @@ MODIFICATIONS.
|
||||
|
||||
GOVERNMENT USE: If you are acquiring this software on behalf of the
|
||||
U.S. government, the Government shall have only "Restricted Rights"
|
||||
in the software and related documentation as defined in the Federal
|
||||
in the software and related documentation as defined in the Federal
|
||||
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you
|
||||
are acquiring the software on behalf of the Department of Defense, the
|
||||
software shall be classified as "Commercial Computer Software" and the
|
||||
@@ -37,4 +37,4 @@ Government shall have only "Restricted Rights" as defined in Clause
|
||||
252.227-7013 (b) (3) of DFARs. Notwithstanding the foregoing, the
|
||||
authors grant the U.S. Government and others acting in its behalf
|
||||
permission to use and distribute the software in accordance with the
|
||||
terms specified in this license.
|
||||
terms specified in this license.
|
||||
|
||||
@@ -130,6 +130,58 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} {
|
||||
p
|
||||
} "a b c"
|
||||
|
||||
test lreplace-4.1 {Bug ccc2c2cc98: lreplace edge case} {
|
||||
lreplace {} 1 1
|
||||
} {}
|
||||
test lreplace-4.2 {Bug ccc2c2cc98: lreplace edge case} {
|
||||
lreplace { } 1 1
|
||||
} {}
|
||||
test lreplace-4.3 {lreplace edge case} {
|
||||
lreplace {1 2 3} 2 0
|
||||
} {1 2 3}
|
||||
test lreplace-4.4 {lreplace edge case} {
|
||||
lreplace {1 2 3 4 5} 3 1
|
||||
} {1 2 3 4 5}
|
||||
test lreplace-4.5 {lreplace edge case} {
|
||||
lreplace {1 2 3 4 5} 3 0 _
|
||||
} {1 2 3 _ 4 5}
|
||||
test lreplace-4.6 {lreplace end-x: bug a4cb3f06c4} {
|
||||
lreplace {0 1 2 3 4} 0 end-2
|
||||
} {3 4}
|
||||
test lreplace-4.6.1 {lreplace end-x: bug a4cb3f06c4} {
|
||||
lreplace {0 1 2 3 4} 0 end-2 a b c
|
||||
} {a b c 3 4}
|
||||
test lreplace-4.7 {lreplace with two end-indexes: increasing} {
|
||||
lreplace {0 1 2 3 4} end-2 end-1
|
||||
} {0 1 4}
|
||||
test lreplace-4.7.1 {lreplace with two end-indexes: increasing} {
|
||||
lreplace {0 1 2 3 4} end-2 end-1 a b c
|
||||
} {0 1 a b c 4}
|
||||
test lreplace-4.8 {lreplace with two end-indexes: equal} {
|
||||
lreplace {0 1 2 3 4} end-2 end-2
|
||||
} {0 1 3 4}
|
||||
test lreplace-4.8.1 {lreplace with two end-indexes: equal} {
|
||||
lreplace {0 1 2 3 4} end-2 end-2 a b c
|
||||
} {0 1 a b c 3 4}
|
||||
test lreplace-4.9 {lreplace with two end-indexes: decreasing} {
|
||||
lreplace {0 1 2 3 4} end-2 end-3
|
||||
} {0 1 2 3 4}
|
||||
test lreplace-4.9.1 {lreplace with two end-indexes: decreasing} {
|
||||
lreplace {0 1 2 3 4} end-2 end-3 a b c
|
||||
} {0 1 a b c 2 3 4}
|
||||
test lreplace-4.10 {lreplace with two equal indexes} {
|
||||
lreplace {0 1 2 3 4} 2 2
|
||||
} {0 1 3 4}
|
||||
test lreplace-4.10.1 {lreplace with two equal indexes} {
|
||||
lreplace {0 1 2 3 4} 2 2 a b c
|
||||
} {0 1 a b c 3 4}
|
||||
test lreplace-4.11 {lreplace end index first} {
|
||||
lreplace {0 1 2 3 4} end-2 1 a b c
|
||||
} {0 1 a b c 2 3 4}
|
||||
test lreplace-4.12 {lreplace end index first} {
|
||||
lreplace {0 1 2 3 4} end-2 2 a b c
|
||||
} {0 1 a b c 3 4}
|
||||
|
||||
# cleanup
|
||||
catch {unset foo}
|
||||
::tcltest::cleanupTests
|
||||
|
||||
@@ -301,7 +301,7 @@ test namespace-9.4 {Tcl_Import, simple import} {
|
||||
}
|
||||
test_ns_import::p
|
||||
} {cmd1: 123}
|
||||
test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} {
|
||||
test namespace-9.5 {Tcl_Import, RFE 1230597} {
|
||||
list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
|
||||
} {0 {}}
|
||||
test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} {
|
||||
@@ -556,6 +556,15 @@ test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} {
|
||||
lappend l [info commands ::test_ns_import::*]
|
||||
}
|
||||
} {::test_ns_import::cmd1 {}}
|
||||
test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} {
|
||||
# Will panic if still buggy
|
||||
namespace eval src {namespace export foo; proc foo {} {}}
|
||||
namespace eval dst {namespace import [namespace parent]::src::foo}
|
||||
trace add command src::foo delete \
|
||||
"[list namespace delete [namespace current]::dst] ;#"
|
||||
proc src::foo {} {}
|
||||
namespace delete src
|
||||
} {}
|
||||
|
||||
test namespace-14.1 {TclGetNamespaceForQualName, absolute names} {
|
||||
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
||||
|
||||
@@ -656,6 +656,9 @@ test parse-12.24 {Tcl_ParseVarName procedure, missing close paren in array refer
|
||||
test parse-12.25 {Tcl_ParseVarName procedure, nested array reference} testparser {
|
||||
testparser {$x(a$y(b$z))} 0
|
||||
} {- {$x(a$y(b$z))} 1 word {$x(a$y(b$z))} 8 variable {$x(a$y(b$z))} 7 text x 0 text a 0 variable {$y(b$z)} 4 text y 0 text b 0 variable {$z} 1 text z 0 {}}
|
||||
test parse-12.26 {Tcl_ParseVarName [d2ffcca163] non-ascii} testparser {
|
||||
testparser "$\u0433" -1
|
||||
} "- {$\u0433} 1 word {$\u0433} 2 text {$} 0 text \u0433 0 {}"
|
||||
|
||||
test parse-13.1 {Tcl_ParseVar procedure} testparsevar {
|
||||
set abc 24
|
||||
|
||||
@@ -1051,6 +1051,15 @@ test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body {
|
||||
testexprparser 0b02 -1
|
||||
} -returnCodes error -match glob -result {*invalid binary number*}
|
||||
|
||||
test parseExpr-22.19 {Bug d2ffcca163} -constraints testexprparser -body {
|
||||
testexprparser \u0433 -1
|
||||
} -returnCodes error -match glob -result {*invalid character*}
|
||||
test parseExpr-22.20 {Bug d2ffcca163} -constraints testexprparser -body {
|
||||
testexprparser \u043f -1
|
||||
} -returnCodes error -match glob -result {*invalid character*}
|
||||
test parseExpr-22.21 {Bug d2ffcca163} -constraints testexprparser -body {
|
||||
testexprparser in\u0433(0) -1
|
||||
} -returnCodes error -match glob -result {missing operand*}
|
||||
|
||||
# cleanup
|
||||
cleanupTests
|
||||
|
||||
@@ -1,4 +1,4 @@
|
||||
# The file tests the tcl_platform variable
|
||||
# The file tests the tcl_platform variable and platform package.
|
||||
#
|
||||
# This file contains a collection of tests for one or more of the Tcl
|
||||
# built-in commands. Sourcing this file into Tcl runs the tests and
|
||||
@@ -20,6 +20,10 @@ namespace eval ::tcl::test::platform {
|
||||
|
||||
testConstraint testCPUID [llength [info commands testcpuid]]
|
||||
|
||||
test platform-1.0 {tcl_platform(engine)} {
|
||||
set tcl_platform(engine)
|
||||
} {Tcl}
|
||||
|
||||
test platform-1.1 {TclpSetVariables: tcl_platform} {
|
||||
interp create i
|
||||
i eval {catch {unset tcl_platform(debug)}}
|
||||
@@ -27,7 +31,7 @@ test platform-1.1 {TclpSetVariables: tcl_platform} {
|
||||
set result [i eval {lsort [array names tcl_platform]}]
|
||||
interp delete i
|
||||
set result
|
||||
} {byteOrder machine os osVersion platform pointerSize user wordSize}
|
||||
} {byteOrder engine machine os osVersion platform pointerSize user wordSize}
|
||||
|
||||
# Test assumes twos-complement arithmetic, which is true of virtually
|
||||
# everything these days. Note that this does *not* use wide(), and
|
||||
@@ -54,6 +58,17 @@ test platform-3.1 {CPU ID on Windows/UNIX} \
|
||||
-match regexp \
|
||||
-result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}
|
||||
|
||||
# The platform package makes very few promises, but does promise that the
|
||||
# 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 {
|
||||
platform::identify
|
||||
} -result {^([^-]+-)+[^-]+$}
|
||||
test platform-4.2 {format of platform::generic result} -match regexp -body {
|
||||
platform::generic
|
||||
} -result {^([^-]+-)+[^-]+$}
|
||||
|
||||
# cleanup
|
||||
cleanupTests
|
||||
|
||||
|
||||
@@ -1068,6 +1068,59 @@ test reg-33.13 {Bug 1810264 - infinite loop} {
|
||||
test reg-33.14 {Bug 1810264 - super-expensive expression} nonPortable {
|
||||
regexp {(x{200}){200}$y} {x}
|
||||
} 0
|
||||
|
||||
test reg-33.15 {constraint fixes} {
|
||||
regexp {(^)+^} x
|
||||
} 1
|
||||
test reg-33.16 {constraint fixes} {
|
||||
regexp {($^)+} x
|
||||
} 0
|
||||
test reg-33.17 {constraint fixes} {
|
||||
regexp {(^$)*} x
|
||||
} 1
|
||||
test reg-33.18 {constraint fixes} {
|
||||
regexp {(^(?!aa))+} {aa bb cc}
|
||||
} 0
|
||||
test reg-33.19 {constraint fixes} {
|
||||
regexp {(^(?!aa)(?!bb)(?!cc))+} {aa x}
|
||||
} 0
|
||||
test reg-33.20 {constraint fixes} {
|
||||
regexp {(^(?!aa)(?!bb)(?!cc))+} {bb x}
|
||||
} 0
|
||||
test reg-33.21 {constraint fixes} {
|
||||
regexp {(^(?!aa)(?!bb)(?!cc))+} {cc x}
|
||||
} 0
|
||||
test reg-33.22 {constraint fixes} {
|
||||
regexp {(^(?!aa)(?!bb)(?!cc))+} {dd x}
|
||||
} 1
|
||||
|
||||
test reg-33.23 {} {
|
||||
regexp {abcd(\m)+xyz} x
|
||||
} 0
|
||||
test reg-33.24 {} {
|
||||
regexp {abcd(\m)+xyz} a
|
||||
} 0
|
||||
test reg-33.25 {} {
|
||||
regexp {^abcd*(((((^(a c(e?d)a+|)+|)+|)+|)+|a)+|)} x
|
||||
} 0
|
||||
test reg-33.26 {} {
|
||||
regexp {a^(^)bcd*xy(((((($a+|)+|)+|)+$|)+|)+|)^$} x
|
||||
} 0
|
||||
test reg-33.27 {} {
|
||||
regexp {xyz(\Y\Y)+} x
|
||||
} 0
|
||||
test reg-33.28 {} {
|
||||
regexp {x|(?:\M)+} x
|
||||
} 1
|
||||
test reg-33.29 {} {
|
||||
# This is near the limits of the RE engine
|
||||
regexp [string repeat x*y*z* 480] x
|
||||
} 1
|
||||
|
||||
test reg-33.30 {Bug 1080042} {
|
||||
regexp {(\Y)+} foo
|
||||
} 1
|
||||
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
|
||||
@@ -166,7 +166,7 @@ test safe-6.3 {test safe interpreters knowledge of the world} {
|
||||
set r [lreplace $r $threaded $threaded]
|
||||
}
|
||||
set r
|
||||
} {byteOrder platform pointerSize wordSize}
|
||||
} {byteOrder engine platform pointerSize wordSize}
|
||||
|
||||
# more test should be added to check that hostname, nameofexecutable,
|
||||
# aren't leaking infos, but they still do...
|
||||
|
||||
@@ -280,6 +280,12 @@ test scan-4.48 {Tcl_ScanObjCmd, float scanning} {
|
||||
test scan-4.49 {Tcl_ScanObjCmd, float scanning} {
|
||||
list [scan {.1 0.2 3.} {%e %f %g} x y z] $x $y $z
|
||||
} {3 0.1 0.2 3.0}
|
||||
test scan-4.49-uc-1 {Tcl_ScanObjCmd, float scanning} {
|
||||
list [scan {0.5*0.75} {%E%c%G} x y z] $x $y $z
|
||||
} {3 0.5 42 0.75}
|
||||
test scan-4.49-uc-2 {Tcl_ScanObjCmd, float scanning} {
|
||||
list [scan {5e-1*75E-2} {%E%c%G} x y z] $x $y $z
|
||||
} {3 0.5 42 0.75}
|
||||
test scan-4.50 {Tcl_ScanObjCmd, float scanning} {
|
||||
list [scan {1234567890a} %f x] $x
|
||||
} {1 1234567890.0}
|
||||
@@ -359,6 +365,9 @@ test scan-4.63 {scanning of large and negative hex integers} {
|
||||
list [scan $scanstring {%x %x %x} a b c] \
|
||||
[expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }]
|
||||
} {3 1 1 1}
|
||||
test scan-4.64 {scanning of hex with %X} {
|
||||
scan "123 abc f78" %X%X%X
|
||||
} {291 2748 3960}
|
||||
|
||||
# clean up from last two tests
|
||||
|
||||
@@ -515,14 +524,14 @@ test scan-8.4 {error conditions} {
|
||||
list [catch {scan a %O x} msg] $msg
|
||||
} {1 {bad scan conversion character "O"}}
|
||||
test scan-8.5 {error conditions} {
|
||||
list [catch {scan a %X x} msg] $msg
|
||||
} {1 {bad scan conversion character "X"}}
|
||||
list [catch {scan a %B x} msg] $msg
|
||||
} {1 {bad scan conversion character "B"}}
|
||||
test scan-8.6 {error conditions} {
|
||||
list [catch {scan a %F x} msg] $msg
|
||||
} {1 {bad scan conversion character "F"}}
|
||||
test scan-8.7 {error conditions} {
|
||||
list [catch {scan a %E x} msg] $msg
|
||||
} {1 {bad scan conversion character "E"}}
|
||||
list [catch {scan a %p x} msg] $msg
|
||||
} {1 {bad scan conversion character "p"}}
|
||||
test scan-8.8 {error conditions} {
|
||||
list [catch {scan a "%d %d" a} msg] $msg
|
||||
} {1 {different numbers of variable names and field specifiers}}
|
||||
|
||||
@@ -305,6 +305,11 @@ test set-old-7.18 {unset command, -nocomplain (no abbreviation)} {
|
||||
catch {unset -nocomp}
|
||||
list [info exists -nocomp] [catch {unset -nocomp}]
|
||||
} {0 1}
|
||||
test set-old-7.19 {unset command, both switches} {
|
||||
set -- val
|
||||
list [info exists --] [catch {unset -nocomplain --}] [info exists --]\
|
||||
[catch {unset -nocomplain -- --}] [info exists --]
|
||||
} {1 0 1 0 0}
|
||||
|
||||
# Array command.
|
||||
|
||||
|
||||
@@ -67,6 +67,10 @@ namespace import -force ::tcltest::*
|
||||
testConstraint testthread [llength [info commands testthread]]
|
||||
testConstraint exec [llength [info commands exec]]
|
||||
|
||||
# Produce a random port number in the Dynamic/Private range
|
||||
# from 49152 through 65535.
|
||||
proc randport {} { expr {int(rand()*16383+49152)} }
|
||||
|
||||
# If remoteServerIP or remoteServerPort are not set, check in the
|
||||
# environment variables for externally set values.
|
||||
#
|
||||
@@ -573,7 +577,86 @@ test socket-2.11 {detecting new data} {socket} {
|
||||
close $sock
|
||||
set result
|
||||
} {a:one b: c:two}
|
||||
|
||||
test socket-2.12 {} {socket stdio} {
|
||||
file delete $path(script)
|
||||
set f [open $path(script) w]
|
||||
puts $f {
|
||||
set server [socket -server accept_client 0]
|
||||
puts [lindex [chan configure $server -sockname] 2]
|
||||
proc accept_client { client host port } {
|
||||
chan configure $client -blocking 0 -buffering line
|
||||
write_line $client
|
||||
}
|
||||
proc write_line client {
|
||||
if { [catch { chan puts $client [string repeat . 720000]}] } {
|
||||
puts [catch {chan close $client}]
|
||||
} else {
|
||||
puts signal1
|
||||
after 0 write_line $client
|
||||
}
|
||||
}
|
||||
chan event stdin readable {set forever now}
|
||||
vwait forever
|
||||
exit
|
||||
}
|
||||
close $f
|
||||
set f [open "|[list [interpreter] $path(script)]" r+]
|
||||
gets $f port
|
||||
set sock [socket 127.0.0.1 $port]
|
||||
chan event $sock readable [list read_lines $sock $f]
|
||||
proc read_lines { sock pipe } {
|
||||
gets $pipe
|
||||
chan close $sock
|
||||
chan event $pipe readable [list readpipe $pipe]
|
||||
}
|
||||
proc readpipe {pipe} {
|
||||
while {![string is integer [set ::done [gets $pipe]]]} {}
|
||||
}
|
||||
vwait ::done
|
||||
close $f
|
||||
set ::done
|
||||
} 0
|
||||
test socket-2.13 {Bug 1758a0b603} {socket stdio} {
|
||||
file delete $path(script)
|
||||
set f [open $path(script) w]
|
||||
puts $f {
|
||||
set server [socket -server accept 0]
|
||||
puts [lindex [chan configure $server -sockname] 2]
|
||||
proc accept { client host port } {
|
||||
chan configure $client -blocking 0 -buffering line -buffersize 1
|
||||
puts $client [string repeat . 720000]
|
||||
puts ready
|
||||
chan event $client writable [list setup $client]
|
||||
}
|
||||
proc setup client {
|
||||
chan event $client writable {set forever write}
|
||||
after 5 {set forever timeout}
|
||||
}
|
||||
vwait forever
|
||||
puts $forever
|
||||
}
|
||||
close $f
|
||||
set pipe [open |[list [interpreter] $path(script)] r]
|
||||
gets $pipe port
|
||||
set sock [socket localhost $port]
|
||||
chan configure $sock -blocking 0 -buffering line
|
||||
chan event $sock readable [list read_lines $sock $pipe ]
|
||||
proc read_lines { sock pipe } {
|
||||
gets $pipe
|
||||
gets $sock line
|
||||
after idle [list stop $sock $pipe]
|
||||
chan event $sock readable {}
|
||||
}
|
||||
proc stop {sock pipe} {
|
||||
variable done
|
||||
close $sock
|
||||
set done [gets $pipe]
|
||||
}
|
||||
variable done
|
||||
vwait [namespace which -variable done]
|
||||
close $pipe
|
||||
set done
|
||||
} write
|
||||
|
||||
test socket-3.1 {socket conflict} {socket stdio} {
|
||||
file delete $path(script)
|
||||
@@ -1683,6 +1766,37 @@ if {[string match sock* $commandSocket] == 1} {
|
||||
}
|
||||
catch {close $commandSocket}
|
||||
catch {close $remoteProcChan}
|
||||
test socket-14.13 {testing writable event when quick failure} -constraints {socket win supported_inet} -body {
|
||||
# Test for bug 336441ed59 where a quick background fail was ignored
|
||||
|
||||
# Test only for windows as socket -async 255.255.255.255 fails
|
||||
# directly on unix
|
||||
|
||||
# The following connect should fail very quickly
|
||||
set a1 [after 2000 {set x timeout}]
|
||||
set s [socket -async 255.255.255.255 43434]
|
||||
fileevent $s writable {set x writable}
|
||||
vwait x
|
||||
set x
|
||||
} -cleanup {
|
||||
catch {close $s}
|
||||
after cancel $a1
|
||||
} -result writable
|
||||
|
||||
test socket-14.14 {testing fileevent readable on failed async socket connect} -constraints [list socket] -body {
|
||||
# Test for bug 581937ab1e
|
||||
|
||||
set a1 [after 5000 {set x timeout}]
|
||||
# This connect should fail
|
||||
set s [socket -async localhost [randport]]
|
||||
fileevent $s readable {set x readable}
|
||||
vwait x
|
||||
set x
|
||||
} -cleanup {
|
||||
catch {close $s}
|
||||
after cancel $a1
|
||||
} -result readable
|
||||
|
||||
::tcltest::cleanupTests
|
||||
flush stdout
|
||||
return
|
||||
|
||||
@@ -187,6 +187,16 @@ test source-3.5 {return with special code etc.} -setup {
|
||||
invoked from within
|
||||
"source $sourcefile"} {a b c}}
|
||||
|
||||
test source-4.1 {continuation line parsing} -setup {
|
||||
set sourcefile [makeFile [string map {CL \\\n} {
|
||||
format %s "[dict get [info frame 0] type]:CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]"
|
||||
}] source.file]
|
||||
} -body {
|
||||
source $sourcefile
|
||||
} -cleanup {
|
||||
removeFile source.file
|
||||
} -result {source: 3 4 5}
|
||||
|
||||
test source-6.1 {source is binary ok} -setup {
|
||||
# Note [makeFile] writes in the system encoding.
|
||||
# [source] defaults to reading in the system encoding.
|
||||
|
||||
@@ -254,6 +254,32 @@ test thread-6.1 {freeing very large object trees in a thread} testthread {
|
||||
set res
|
||||
} {0}
|
||||
|
||||
test thread-8.1 {threaded fork stress} -constraints {thread} -setup {
|
||||
unset -nocomplain ::threadCount ::execCount ::threads ::thread
|
||||
set ::threadCount 10
|
||||
set ::execCount 10
|
||||
} -body {
|
||||
set ::threads [list]
|
||||
for {set i 0} {$i < $::threadCount} {incr i} {
|
||||
lappend ::threads [thread::create -joinable [string map \
|
||||
[list %execCount% $::execCount] {
|
||||
proc execLs {} {
|
||||
if {$::tcl_platform(platform) eq "windows"} then {
|
||||
return [exec $::env(COMSPEC) /c DIR]
|
||||
} else {
|
||||
return [exec /bin/ls]
|
||||
}
|
||||
}
|
||||
set j {%execCount%}; while {[incr j -1]} {execLs}
|
||||
}]]
|
||||
}
|
||||
foreach ::thread $::threads {
|
||||
thread::join $::thread
|
||||
}
|
||||
} -cleanup {
|
||||
unset -nocomplain ::threadCount ::execCount ::threads ::thread
|
||||
} -result {}
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
@@ -17,7 +17,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
|
||||
}
|
||||
|
||||
testConstraint testupvar [llength [info commands testupvar]]
|
||||
|
||||
|
||||
test upvar-1.1 {reading variables with upvar} {
|
||||
proc p1 {a b} {set c 22; set d 33; p2}
|
||||
proc p2 {} {upvar a x1 b x2 c x3 d x4; set a abc; list $x1 $x2 $x3 $x4 $a}
|
||||
@@ -332,7 +332,7 @@ test upvar-8.9 {upvar won't create namespace variable that refers to procedure v
|
||||
unset ::test_ns_1::a
|
||||
}
|
||||
list [catch {MakeLink 1} msg] $msg
|
||||
} {1 {bad variable name "a": upvar won't create namespace variable that refers to procedure variable}}
|
||||
} {1 {bad variable name "a": can't create namespace variable that refers to procedure variable}}
|
||||
test upvar-8.10 {upvar will create element alias for new array element} {
|
||||
catch {unset upvarArray}
|
||||
array set upvarArray {}
|
||||
@@ -405,6 +405,17 @@ test upvar-9.7 {Tcl_UpVar procedure} testupvar {
|
||||
} {1234}
|
||||
catch {unset a}
|
||||
|
||||
test upvar-10.1 {CompileWord OBOE} -setup {
|
||||
proc linenumber {} {dict get [info frame -1] line}
|
||||
} -body {
|
||||
apply {n {
|
||||
upvar 1 {*}{
|
||||
} [return [incr n -[linenumber]]] x
|
||||
}} [linenumber]
|
||||
} -cleanup {
|
||||
rename linenumber {}
|
||||
} -result 1
|
||||
|
||||
|
||||
#
|
||||
# Tests for 'namespace upvar'. As the implementation is essentially the same as
|
||||
@@ -542,7 +553,41 @@ test upvar-NS-1.9 {nsupvar links to correct variable} \
|
||||
-returnCodes error \
|
||||
-cleanup {namespace delete test_ns_1}
|
||||
|
||||
|
||||
test upvar-NS-3.1 {CompileWord OBOE} -setup {
|
||||
proc linenumber {} {dict get [info frame -1] line}
|
||||
} -body {
|
||||
apply {n {
|
||||
namespace upvar {*}{
|
||||
} [return [incr n -[linenumber]]] x y
|
||||
}} [linenumber]
|
||||
} -cleanup {
|
||||
rename linenumber {}
|
||||
} -result 1
|
||||
test upvar-NS-3.2 {CompileWord OBOE} -setup {
|
||||
proc linenumber {} {dict get [info frame -1] line}
|
||||
} -body {
|
||||
apply {n {
|
||||
namespace upvar :: {*}{
|
||||
} [return [incr n -[linenumber]]] x
|
||||
}} [linenumber]
|
||||
} -cleanup {
|
||||
rename linenumber {}
|
||||
} -result 1
|
||||
test upvar-NS-3.3 {CompileWord OBOE} -setup {
|
||||
proc linenumber {} {dict get [info frame -1] line}
|
||||
} -body {
|
||||
apply {n {
|
||||
variable x {*}{
|
||||
} [return [incr n -[linenumber]]]
|
||||
}} [linenumber]
|
||||
} -cleanup {
|
||||
rename linenumber {}
|
||||
} -result 1
|
||||
|
||||
# cleanup
|
||||
::tcltest::cleanupTests
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
|
||||
@@ -278,15 +278,15 @@ test utf-20.1 {TclUniCharNcmp} {
|
||||
} {}
|
||||
|
||||
test utf-21.1 {TclUniCharIsAlnum} {
|
||||
# this returns 1 with Unicode 6 compliance
|
||||
# this returns 1 with Unicode 7 compliance
|
||||
string is alnum \u1040\u021f\u0220
|
||||
} {1}
|
||||
test utf-21.2 {unicode alnum char in regc_locale.c} {
|
||||
# this returns 1 with Unicode 6 compliance
|
||||
# this returns 1 with Unicode 7 compliance
|
||||
list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220]
|
||||
} {1 1}
|
||||
test utf-21.3 {unicode print char in regc_locale.c} {
|
||||
# this returns 1 with Unicode 6 compliance
|
||||
# this returns 1 with Unicode 7 compliance
|
||||
regexp {^[[:print:]]+$} \ufbc1
|
||||
} 1
|
||||
test utf-21.4 {TclUniCharIsGraph} {
|
||||
@@ -319,11 +319,11 @@ test utf-21.10 {unicode print char in regc_locale.c} {
|
||||
} {0}
|
||||
test utf-21.11 {TclUniCharIsControl} {
|
||||
# [Bug 3464428]
|
||||
string is control \u00ad
|
||||
string is control \u0000\u001f\u00ad\u0605\u061c\u180e\u2066\ufeff
|
||||
} {1}
|
||||
test utf-21.12 {unicode control char in regc_locale.c} {
|
||||
# [Bug 3464428], [Bug a876646efe]
|
||||
regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad
|
||||
regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad\u0605\u061c\u180e\u2066\ufeff
|
||||
} {1}
|
||||
|
||||
test utf-22.1 {TclUniCharIsWordChar} {
|
||||
@@ -334,30 +334,30 @@ test utf-22.2 {TclUniCharIsWordChar} {
|
||||
} 10
|
||||
|
||||
test utf-23.1 {TclUniCharIsAlpha} {
|
||||
# this returns 1 with Unicode 6 compliance
|
||||
string is alpha \u021f\u0220
|
||||
# this returns 1 with Unicode 7 compliance
|
||||
string is alpha \u021f\u0220\u037f\u052f
|
||||
} {1}
|
||||
test utf-23.2 {unicode alpha char in regc_locale.c} {
|
||||
# this returns 1 with Unicode 6 compliance
|
||||
regexp {^[[:alpha:]]+$} \u021f\u0220
|
||||
# this returns 1 with Unicode 7 compliance
|
||||
regexp {^[[:alpha:]]+$} \u021f\u0220\u037f\u052f
|
||||
} {1}
|
||||
|
||||
test utf-24.1 {TclUniCharIsDigit} {
|
||||
# this returns 1 with Unicode 6 compliance
|
||||
# this returns 1 with Unicode 7 compliance
|
||||
string is digit \u1040\uabf0
|
||||
} {1}
|
||||
test utf-24.2 {unicode digit char in regc_locale.c} {
|
||||
# this returns 1 with Unicode 6 compliance
|
||||
# this returns 1 with Unicode 7 compliance
|
||||
list [regexp {^[[:digit:]]+$} \u1040\uabf0] [regexp {^\d+$} \u1040\uabf0]
|
||||
} {1 1}
|
||||
|
||||
test utf-24.3 {TclUniCharIsSpace} {
|
||||
# this returns 1 with Unicode 6 compliance
|
||||
string is space \u1680\u180e
|
||||
# this returns 1 with Unicode 7 compliance
|
||||
string is space \u1680\u180e\u202f
|
||||
} {1}
|
||||
test utf-24.4 {unicode space char in regc_locale.c} {
|
||||
# this returns 1 with Unicode 6 compliance
|
||||
list [regexp {^[[:space:]]+$} \u1680\u180e] [regexp {^\s+$} \u1680\u180e]
|
||||
# this returns 1 with Unicode 7 compliance
|
||||
list [regexp {^[[:space:]]+$} \u1680\u180e\u202f] [regexp {^\s+$} \u1680\u180e\u202f]
|
||||
} {1 1}
|
||||
|
||||
testConstraint teststringobj [llength [info commands teststringobj]]
|
||||
|
||||
@@ -275,7 +275,7 @@ test var-3.11 {MakeUpvar, my var looks like array elem} -body {
|
||||
catch {unset aaaaa}
|
||||
set aaaaa 789789
|
||||
upvar #0 aaaaa foo(bar)
|
||||
} -returnCodes 1 -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element}
|
||||
} -returnCodes 1 -result {bad variable name "foo(bar)": can't create a scalar variable that looks like an array element}
|
||||
|
||||
test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname {
|
||||
catch {unset a}
|
||||
|
||||
@@ -1110,16 +1110,16 @@ test winFCmd-18.1.2 {Windows reserved path names} -constraints win -body {
|
||||
} -result "absolute"
|
||||
|
||||
test winFCmd-18.1.3 {Windows reserved path names} -constraints win -body {
|
||||
file pathtype com5
|
||||
} -result "relative"
|
||||
file pathtype com9
|
||||
} -result "absolute"
|
||||
|
||||
test winFCmd-18.1.4 {Windows reserved path names} -constraints win -body {
|
||||
file pathtype lpt3
|
||||
} -result "absolute"
|
||||
|
||||
test winFCmd-18.1.5 {Windows reserved path names} -constraints win -body {
|
||||
file pathtype lpt4
|
||||
} -result "relative"
|
||||
file pathtype lpt9
|
||||
} -result "absolute"
|
||||
|
||||
test winFCmd-18.1.6 {Windows reserved path names} -constraints win -body {
|
||||
file pathtype nul
|
||||
@@ -1238,6 +1238,11 @@ test winFCmd-19.8 {Windows extended path names} -constraints nt -setup {
|
||||
catch {file delete $tmpfile}
|
||||
} -result [list 0 {} [list "tcl[pid].tmp "]]
|
||||
|
||||
test winFCmd-19.9 {Windows devices path names} -constraints nt -body {
|
||||
file normalize //./com1
|
||||
} -result //./com1
|
||||
|
||||
|
||||
# This block of code used to occur after the "return" call, so I'm
|
||||
# commenting it out and assuming that this code is still under construction.
|
||||
#foreach source {tef ted tnf tnd "" nul com1} {
|
||||
|
||||
Reference in New Issue
Block a user