Import Tcl 8.6.10
This commit is contained in:
Steve Dower
@@ -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:
|
||||
|
||||
Reference in New Issue
Block a user