diff options
author | jan.nijtmans <nijtmans@users.sourceforge.net> | 2021-01-19 13:54:31 (GMT) |
---|---|---|
committer | jan.nijtmans <nijtmans@users.sourceforge.net> | 2021-01-19 13:54:31 (GMT) |
commit | 0fd2a17f4fd34ee05559f7e7ced1c09f3591c5c3 (patch) | |
tree | 8e2728f38ee549fde9d139e0f2bbf960f1630b55 /tests | |
parent | f942af920c1c31f578e24aae999d86191ec65f39 (diff) | |
parent | f387d58e76f3ac8a528db48b000583f3c1eb21aa (diff) | |
download | tcl-0fd2a17f4fd34ee05559f7e7ced1c09f3591c5c3.zip tcl-0fd2a17f4fd34ee05559f7e7ced1c09f3591c5c3.tar.gz tcl-0fd2a17f4fd34ee05559f7e7ced1c09f3591c5c3.tar.bz2 |
Merge 8.7
Diffstat (limited to 'tests')
181 files changed, 31831 insertions, 9301 deletions
diff --git a/tests/README b/tests/README index ce2382e..e86100f 100644 --- a/tests/README +++ b/tests/README @@ -59,7 +59,7 @@ should correspond to the Tcl or C code file that they are testing. For example, the test file for the C file "tclCmdAH.c" is "cmdAH.test". Test files that contain black-box tests may not correspond to any Tcl or C code file so they should match the pattern -"*_bb.test". +"*_bb.test". Be sure your new test file can be run from any working directory. @@ -72,12 +72,12 @@ as well as an installation environment. If your test file contains tests that should not be run in one or more of those cases, please use the constraints mechanism to skip those tests. -4. Incompatibilities of package tcltest 2.1 with +4. Incompatibilities of package tcltest 2.1 with testing machinery of very old versions of Tcl: ------------------------------------------------ 1) Global variables such as VERBOSE, TESTS, and testConfig of the - old machinery correspond to the [configure -verbose], + old machinery correspond to the [configure -verbose], [configure -match], and [testConstraint] commands of tcltest 2.1, respectively. diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test new file mode 100644 index 0000000..fffc1cc --- /dev/null +++ b/tests/aaa_exit.test @@ -0,0 +1,54 @@ +# Commands covered: exit, emphasis on finalization hangs +# +# 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 +# generates output for errors. No output means no errors were found. +# +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +test exit-1.1 {normal, quick exit} { + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\"" r] + set aft [after 1000 {set done "Quick exit hangs !!!"}] + fileevent $f readable {after cancel $aft;set done OK} + vwait done + if {$done != "OK"} { + fconfigure $f -blocking 0 + close $f + } else { + if {[catch {close $f} err]} { + set done "Quick exit misbehaves: $err" + } + } + set done +} OK + +test exit-1.2 {full-finalized exit} { + set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\"" r] + set aft [after 1000 {set done "Full-finalized exit hangs !!!"}] + fileevent $f readable {after cancel $aft;set done OK} + vwait done + if {$done != "OK"} { + fconfigure $f -blocking 0 + close $f + } else { + if {[catch {close $f} err]} { + set done "Full-finalized exit misbehaves: $err" + } + } + set done +} OK + + +# cleanup +::tcltest::cleanupTests +return diff --git a/tests/all.tcl b/tests/all.tcl index 05d3024..8cd0cf4 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -1,19 +1,32 @@ # all.tcl -- # # This file contains a top-level script to run all of the Tcl -# tests. Execute it by invoking "source all.test" when running tcltest +# tests. Execute it by invoking "source all.tcl" when running tcltest # in this directory. # -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2000 by Ajuba Solutions +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2000 Ajuba Solutions # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package prefer latest -package require Tcl 8.5 -package require tcltest 2.2 -namespace import tcltest::* -configure {*}$argv -testdir [file dir [info script]] -runAllTests -proc exit args {} +package require tcltest 2.5 +namespace import ::tcltest::* + +configure {*}$argv -testdir [file dirname [file dirname [file normalize [ + info script]/...]]] + +if {[singleProcess]} { + interp debug {} -frame 1 +} + +set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] +unset -nocomplain env(ERROR_ON_FAILURES) +if {[runAllTests] && $ErrorOnFailures} {exit 1} +# if calling direct only (avoid rewrite exit if inlined or interactive): +if { [info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]] + && !([info exists ::tcl_interactive] && $::tcl_interactive) +} { + proc exit args {} +}
\ No newline at end of file diff --git a/tests/append.test b/tests/append.test index 69c6381..a174615 100644 --- a/tests/append.test +++ b/tests/append.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } unset -nocomplain x @@ -32,7 +32,7 @@ test append-1.3 {append command} { test append-2.1 {long appends} { set x "" - for {set i 0} {$i < 1000} {set i [expr $i+1]} { + for {set i 0} {$i < 1000} {incr i} { append x "foobar " } set y "foobar" @@ -158,7 +158,7 @@ test append-5.1 {long lappends} -setup { if {$l != $size} { return "length mismatch: should have been $size, was $l" } - for {set i 0} {$i < $size} {set i [expr $i+1]} { + for {set i 0} {$i < $size} {incr i} { set j [lindex $var $i] if {$j ne "item $i"} { return "element $i should have been \"item $i\", was \"$j\"" @@ -292,6 +292,23 @@ test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env } -cleanup { unset -nocomplain ::env(__DUMMY__) } -result {0 {new value}} + +test append-10.1 {Bug 214cc0eb22: lappend with no values} { + set lst "# 1 2 3" + [subst lappend] lst +} "# 1 2 3" +test append-10.2 {Bug 214cc0eb22: lappend with no values} -body { + set lst "1 \{ 2" + [subst lappend] lst +} -returnCodes error -result {unmatched open brace in list} +test append-10.3 {Bug 214cc0eb22: expanded lappend with no values} { + set lst "# 1 2 3" + [subst lappend] lst {*}[list] +} "# 1 2 3" +test append-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body { + set lst "1 \{ 2" + [subst lappend] lst {*}[list] +} -returnCodes error -result {unmatched open brace in list} unset -nocomplain i x result y catch {rename foo ""} diff --git a/tests/appendComp.test b/tests/appendComp.test index f85c3ba..66f2a5c 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } catch {unset x} @@ -41,7 +41,7 @@ test appendComp-1.3 {append command} { test appendComp-2.1 {long appends} { proc foo {} { set x "" - for {set i 0} {$i < 1000} {set i [expr $i+1]} { + for {set i 0} {$i < 1000} {incr i} { append x "foobar " } set y "foobar" @@ -223,7 +223,7 @@ test appendComp-5.1 {long lappends} -setup { } } -body { set x "" - for {set i 0} {$i < 300} {set i [expr $i+1]} { + for {set i 0} {$i < 300} {incr i} { lappend x "item $i" } check $x 300 @@ -359,9 +359,9 @@ test appendComp-7.9 {append var does not trigger read trace} -setup { } -result {0} test appendComp-8.1 {defer error to runtime} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { proc foo {} { proc append args {} append @@ -369,7 +369,7 @@ test appendComp-8.1 {defer error to runtime} -setup { foo } } -cleanup { - interp delete slave + interp delete child } -result {} # New tests for bug 3057639 to show off the more consistent behaviour of @@ -438,6 +438,27 @@ test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing } -cleanup { unset -nocomplain ::env(__DUMMY__) } -result {0 {new value}} + +test appendComp-10.1 {Bug 214cc0eb22: lappend with no values} { + apply {lst { + lappend lst + }} "# 1 2 3" +} "# 1 2 3" +test appendComp-10.2 {Bug 214cc0eb22: lappend with no values} -body { + apply {lst { + lappend lst + }} "1 \{ 2" +} -returnCodes error -result {unmatched open brace in list} +test appendComp-10.3 {Bug 214cc0eb22: expanded lappend with no values} { + apply {lst { + lappend lst {*}[list] + }} "# 1 2 3" +} "# 1 2 3" +test appendComp-10.4 {Bug 214cc0eb22: expanded lappend with no values} -body { + apply {lst { + lappend lst {*}[list] + }} "1 \{ 2" +} -returnCodes error -result {unmatched open brace in list} catch {unset i x result y} catch {rename foo ""} diff --git a/tests/apply.test b/tests/apply.test index ba19b81..e2be172 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -4,16 +4,16 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2005-2006 Miguel Sofer +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2005-2006 Miguel Sofer # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -25,7 +25,7 @@ testConstraint memory [llength [info commands memory]] # Tests for wrong number of arguments -test apply-1.1 {too few arguments} -returnCodes error -body { +test apply-1.1 {not enough arguments} -returnCodes error -body { apply } -result {wrong # args: should be "apply lambdaExpr ?arg ...?"} @@ -228,7 +228,7 @@ test apply-8.3 {args treatment} { apply [list {x args} $applyBody] 1 2 3 } {{x 1} {args {2 3}}} test apply-8.4 {default values} { - apply [list {{x 1} {y 2}} $applyBody] + apply [list {{x 1} {y 2}} $applyBody] } {{x 1} {y 2}} test apply-8.5 {default values} { apply [list {{x 1} {y 2}} $applyBody] 3 4 diff --git a/tests/assemble.test b/tests/assemble.test index 7d4e5d1..55124d0 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -2,8 +2,8 @@ # # Test suite for the 'tcl::unsupported::assemble' command # -# Copyright (c) 2010 by Ozgur Dogan Ugurlu. -# Copyright (c) 2010 by Kevin B. Kenny. +# Copyright © 2010 Ozgur Dogan Ugurlu. +# Copyright © 2010 Kevin B. Kenny. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -12,7 +12,7 @@ # Commands covered: assemble if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } namespace eval tcl::unsupported {namespace export assemble} @@ -175,8 +175,7 @@ test assemble-4.1 {syntax error} { -match glob -result {1 {extra characters after close-brace} {extra characters after close-brace while executing -"{}extra - " +"{}e" ("assemble" body, line 2)*}} } test assemble-4.2 {null command} { @@ -302,12 +301,12 @@ test assemble-7.1 {add, wrong # args} { -result {wrong # args*} } test assemble-7.2 {add} { - -body { + -body { assemble { push 2 push 2 add - } + } } -result {4} } @@ -350,7 +349,7 @@ test assemble-7.5 {bitwise ops} { } test assemble-7.6 {div} { -body { - assemble {push 999999; push 7; div} + assemble {push 999999; push 7; div} } -result 142857 } @@ -361,7 +360,7 @@ test assemble-7.7 {dup} { } } -result 9 -} +} test assemble-7.8 {eq} { -body { list \ @@ -639,7 +638,7 @@ test assemble-7.24 {lsetList} { test assemble-7.25 {lshift} { -body { assemble {push 16; push 4; lshift} - } + } -result 256 } test assemble-7.26 {mod} { @@ -679,7 +678,7 @@ test assemble-7.30 {pop} { test assemble-7.31 {rshift} { -body { assemble {push 257; push 4; rshift} - } + } -result 16 } test assemble-7.32 {storeArrayStk} { @@ -853,10 +852,11 @@ test assemble-8.5 {bad context} { -body { namespace eval assem { set x 1 - list [catch {assemble {load x}} result] $result $errorCode + assemble {load x} } } - -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} + -result {cannot use this instruction to create a variable in a non-proc context} + -errorCode {TCL ASSEM LVT} -cleanup {namespace delete assem} } test assemble-8.6 {load1} { @@ -1111,10 +1111,10 @@ test assemble-9.6 {concat} { } test assemble-9.7 {concat} { -body { - list [catch {assemble {concat 0}} result] $result $::errorCode + assemble {concat 0} } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {unset result} + -result {operand must be positive} + -errorCode {TCL ASSEM POSITIVE} } # assemble-10 -- eval and expr @@ -1202,7 +1202,7 @@ test assemble-10.7 {expr - noncompilable} { # assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend, # nsupvar, variable, upvar) - + test assemble-11.1 {exist - wrong # args} { -body { assemble {exist} @@ -1311,7 +1311,7 @@ test assemble-11.10 {variable} { } # assemble-12 - ASSEM_LVT1 (incr and incrArray) - + test assemble-12.1 {incr - wrong # args} { -body { assemble {incr} @@ -1536,55 +1536,35 @@ test assemble-14.7 {incrArrayStkImm} { # assemble-15 - listIndexImm -test assemble-15.1 {listIndexImm - wrong # args} { - -body { - assemble {listIndexImm} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-15.2 {listIndexImm - wrong # args} { - -body { - assemble {listIndexImm too many} - } - -returnCodes error - -match glob - -result {wrong # args*} -} -test assemble-15.3 {listIndexImm - bad substitution} { - -body { - list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode - } - -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} - -cleanup {unset result} -} -test assemble-15.4 {listIndexImm - invalid index} { - -body { - assemble {listIndexImm rubbish} - } - -returnCodes error - -match glob - -result {bad index "rubbish"*} -} -test assemble-15.5 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm 2} - } - -result c -} -test assemble-15.6 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm end-1} - } - -result b -} -test assemble-15.7 {listIndexImm} { - -body { - assemble {push {a b c}; listIndexImm end} - } - -result c -} +test assemble-15.1 {listIndexImm - wrong # args} -body { + assemble {listIndexImm} +} -returnCodes error -match glob -result {wrong # args*} +test assemble-15.2 {listIndexImm - wrong # args} -body { + assemble {listIndexImm too many} +} -returnCodes error -match glob -result {wrong # args*} +test assemble-15.3 {listIndexImm - bad substitution} -body { + list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode +} -cleanup { + unset result +} -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} +test assemble-15.4 {listIndexImm - invalid index} -body { + assemble {listIndexImm rubbish} +} -returnCodes error -match glob -result {bad index "rubbish"*} +test assemble-15.5 {listIndexImm} -body { + assemble {push {a b c}; listIndexImm 2} +} -result c +test assemble-15.6 {listIndexImm} -body { + assemble {push {a b c}; listIndexImm end-1} +} -result b +test assemble-15.7 {listIndexImm} -body { + assemble {push {a b c}; listIndexImm end} +} -result c +test assemble-15.8 {listIndexImm} -body { + assemble {push {a b c}; listIndexImm end+2} +} -result {} +test assemble-15.9 {listIndexImm} -body { + assemble {push {a b c}; listIndexImm -1-1} +} -result {} # assemble-16 - invokeStk @@ -1744,16 +1724,16 @@ test assemble-17.9 {jump - resolve a label multiple times} { set result {} assemble { jump common - + label zero - pop + pop incrImm case 1 pop push a append result pop jump common - + label one pop incrImm case 1 @@ -1762,7 +1742,7 @@ test assemble-17.9 {jump - resolve a label multiple times} { append result pop jump common - + label common load case dup @@ -1781,7 +1761,7 @@ test assemble-17.9 {jump - resolve a label multiple times} { push 3 eq jumpTrue three - + label two pop incrImm case 1 @@ -1790,7 +1770,7 @@ test assemble-17.9 {jump - resolve a label multiple times} { append result pop jump common - + label three pop incrImm case 1 @@ -1888,7 +1868,7 @@ test assemble-17.15 {multiple passes of code resizing} { append body {label b15; push b; concat 2; nop; nop; jump c} \n append body {label d} proc x {} [list assemble $body] - } + } -body { x } @@ -2081,7 +2061,7 @@ test assemble-20.5 {lsetFlat - negative operand count} { test assemble-20.6 {lsetFlat} { -body { assemble {push b; push a; lsetFlat 2} - } + } -result b } test assemble-20.7 {lsetFlat} { @@ -3067,12 +3047,12 @@ test assemble-40.1 {unbalanced stack} { [catch { assemble { push 3 - dup - mult + dup + mult push 4 - dup - mult - pop + dup + mult + pop expon } } result] $result $::errorInfo @@ -3171,7 +3151,7 @@ test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} { load n; # max dup; # max n jump start; # max n - + label loop; # max n over 1; # max n max over 1; # max in max n @@ -3181,29 +3161,29 @@ test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} { reverse 2; # n max pop; # n dup; # n n - + label skip; # max n dup; # max n n push 2; # max n n 2 mod; # max n n%2 jumpTrue odd; # max n - + push 2; # max n 2 div; # max n/2 -> max n jump start; # max n - + label odd; # max n push 3; # max n 3 mult; # max 3*n push 1; # max 3*n 1 add; # max 3*n+1 - + label start; # max n dup; # max n n push 1; # max n n 1 neq; # max n n>1 jumpTrue loop; # max n - + pop; # max } } @@ -3233,7 +3213,7 @@ test assemble-51.3 {memory leak testing} memory { load n; # max dup; # max n jump start; # max n - + label loop; # max n over 1; # max n max over 1; # max in max n @@ -3243,29 +3223,29 @@ test assemble-51.3 {memory leak testing} memory { reverse 2; # n max pop; # n dup; # n n - + label skip; # max n dup; # max n n push 2; # max n n 2 mod; # max n n%2 jumpTrue odd; # max n - + push 2; # max n 2 div; # max n/2 -> max n jump start; # max n - + label odd; # max n push 3; # max n 3 mult; # max 3*n push 1; # max 3*n 1 add; # max 3*n+1 - + label start; # max n dup; # max n n push 1; # max n n 1 neq; # max n n>1 jumpTrue loop; # max n - + pop; # max } }} 1 @@ -3280,6 +3260,92 @@ test assemble-51.4 {memory leak testing} memory { } } } 0 + +test assemble-52.1 {Bug 3154ea2759} { + apply {{} { + # Needs six exception ranges to force the range allocations to use the + # malloced store. + ::tcl::unsupported::assemble { + beginCatch @badLabel + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel + label @badLabel + push 1; # should be pushReturnCode + label @okLabel + endCatch + pop + + beginCatch @badLabel2 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel2 + label @badLabel2 + push 1; # should be pushReturnCode + label @okLabel2 + endCatch + pop + + beginCatch @badLabel3 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel3 + label @badLabel3 + push 1; # should be pushReturnCode + label @okLabel3 + endCatch + pop + + beginCatch @badLabel4 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel4 + label @badLabel4 + push 1; # should be pushReturnCode + label @okLabel4 + endCatch + pop + + beginCatch @badLabel5 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel5 + label @badLabel5 + push 1; # should be pushReturnCode + label @okLabel5 + endCatch + pop + + beginCatch @badLabel6 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel6 + label @badLabel6 + push 1; # should be pushReturnCode + label @okLabel6 + endCatch + pop + } + }} +} {}; # must not crash rename fillTables {} rename assemble {} diff --git a/tests/assemble1.bench b/tests/assemble1.bench index 18fd3a9..e294108 100644 --- a/tests/assemble1.bench +++ b/tests/assemble1.bench @@ -20,7 +20,7 @@ proc ulam2 {n} { load n; # max dup; # max n jump start; # max n - + label loop; # max n over 1; # max n max over 1; # max in max n @@ -30,29 +30,29 @@ proc ulam2 {n} { reverse 2; # n max pop; # n dup; # n n - + label skip; # max n dup; # max n n push 2; # max n n 2 mod; # max n n%2 jumpTrue odd; # max n - + push 2; # max n 2 div; # max n/2 -> max n jump start; # max n - + label odd; # max n push 3; # max n 3 mult; # max 3*n push 1; # max 3*n 1 add; # max 3*n+1 - + label start; # max n dup; # max n n push 1; # max n n 1 neq; # max n n>1 jumpTrue loop; # max n - + pop; # max } } @@ -60,12 +60,12 @@ set tcl_traceCompile 2; ulam2 1; set tcl_traceCompile 0 proc test1 {n} { for {set i 1} {$i <= $n} {incr i} { - ulam1 $i + ulam1 $i } } proc test2 {n} { for {set i 1} {$i <= $n} {incr i} { - ulam2 $i + ulam2 $i } } @@ -75,11 +75,10 @@ for {set j 0} {$j < 10} {incr j} { test1 30000 set after [clock microseconds] puts "compiled: [expr {1e-6 * ($after - $before)}]" - + test2 1 set before [clock microseconds] test2 30000 set after [clock microseconds] puts "assembled: [expr {1e-6 * ($after - $before)}]" } -
\ No newline at end of file diff --git a/tests/assocd.test b/tests/assocd.test index d1489b3..9a200ae 100644 --- a/tests/assocd.test +++ b/tests/assocd.test @@ -4,20 +4,20 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testgetassocdata [llength [info commands testgetassocdata]] testConstraint testsetassocdata [llength [info commands testsetassocdata]] @@ -36,15 +36,21 @@ test assocd-1.4 {testing setting assoc data} testsetassocdata { testsetassocdata abc "abc d e f" } "" -test assocd-2.1 {testing getting assoc data} testgetassocdata { - testgetassocdata a -} 2 -test assocd-2.2 {testing getting assoc data} testgetassocdata { - testgetassocdata 123 -} 456 -test assocd-2.3 {testing getting assoc data} testgetassocdata { +test assocd-2.1 {testing getting assoc data} -setup { + testsetassocdata a 2 +} -constraints {testgetassocdata} -body { + testgetassocdata a +} -result 2 +test assocd-2.2 {testing getting assoc data} -setup { + testsetassocdata 123 456 +} -constraints {testgetassocdata} -body { + testgetassocdata 123 +} -result 456 +test assocd-2.3 {testing getting assoc data} -setup { + testsetassocdata abc "abc d e f" +} -constraints {testgetassocdata} -body { testgetassocdata abc -} {abc d e f} +} -result "abc d e f" test assocd-2.4 {testing getting assoc data} testgetassocdata { testgetassocdata xxx } "" @@ -60,5 +66,5 @@ test assocd-3.3 {testing deleting assoc data} testdelassocdata { } {0 {}} # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/async.test b/tests/async.test index cb67cc2..0f0af0e 100644 --- a/tests/async.test +++ b/tests/async.test @@ -4,23 +4,23 @@ # library procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testasync [llength [info commands testasync]] -testConstraint threaded [::tcl::pkgconfig get threaded] +testConstraint knownMsvcBug [expr {![info exists ::env(CI_BUILD_WITH_MSVC)]}] proc async1 {result code} { global aresult acode @@ -149,7 +149,7 @@ test async-3.1 {deleting handlers} testasync { } {3 del2 {0 0 0 del1 del2}} test async-4.1 {async interrupting bytecode sequence} -constraints { - testasync threaded + testasync } -setup { set hm [testasync create async3] proc nothing {} { @@ -157,21 +157,28 @@ test async-4.1 {async interrupting bytecode sequence} -constraints { } } -body { apply {{handle} { - global aresult - set aresult {Async event not delivered} - testasync marklater $handle - for {set i 0} { - $i < 2500000 && $aresult eq "Async event not delivered" - } {incr i} { - nothing - } + global aresult + set aresult {Async event not delivered} + testasync marklater $handle + # allow plenty of time to pass in case valgrind is running + set start [clock seconds] + while { + [clock seconds] - $start < 180 && $aresult eq "Async event not delivered" + } { + # be less busy + after 100 + nothing + } return $aresult }} $hm } -result {test pattern} -cleanup { + # give other threads some time to go way so that valgrind doesn't pick up + # "still reachable" cases from early thread termination + after 100 testasync delete $hm } test async-4.2 {async interrupting straight bytecode sequence} -constraints { - testasync threaded + testasync } -setup { set hm [testasync create async3] } -body { @@ -179,16 +186,24 @@ test async-4.2 {async interrupting straight bytecode sequence} -constraints { global aresult set aresult {Async event not delivered} testasync marklater $handle - for {set i 0} { - $i < 2500000 && $aresult eq "Async event not delivered" - } {incr i} {} + # allow plenty of time to pass in case valgrind is running + set start [clock seconds] + while { + [clock seconds] - $start < 180 && $aresult eq "Async event not delivered" + } { + # be less busy + after 100 + } return $aresult }} $hm } -result {test pattern} -cleanup { + # give other threads some time to go way so that valgrind doesn't pick up + # "still reachable" cases from early thread termination + after 100 testasync delete $hm } test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { - testasync threaded + testasync knownMsvcBug } -setup { set hm [testasync create async3] } -body { @@ -201,6 +216,9 @@ test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { return $aresult }]] $hm } -result {test pattern} -cleanup { + # give other threads some time to go way so that valgrind doesn't pick up + # "still reachable" cases from early thread termination + after 100 testasync delete $hm } diff --git a/tests/auto-files.zip b/tests/auto-files.zip Binary files differnew file mode 100644 index 0000000..b8bdf88 --- /dev/null +++ b/tests/auto-files.zip diff --git a/tests/auto0/auto1/file1.tcl b/tests/auto0/auto1/file1.tcl new file mode 100644 index 0000000..bd8b92b --- /dev/null +++ b/tests/auto0/auto1/file1.tcl @@ -0,0 +1,3 @@ +proc report1 {args} { + return ok1 +} diff --git a/tests/auto0/auto1/package1.tcl b/tests/auto0/auto1/package1.tcl new file mode 100644 index 0000000..32d7c56 --- /dev/null +++ b/tests/auto0/auto1/package1.tcl @@ -0,0 +1,5 @@ +proc HeresPackage1 {args} { + return OK1 +} + +package provide SafeTestPackage1 1.2.3 diff --git a/tests/auto0/auto1/pkgIndex.tcl b/tests/auto0/auto1/pkgIndex.tcl new file mode 100644 index 0000000..babb6d5 --- /dev/null +++ b/tests/auto0/auto1/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded SafeTestPackage1 1.2.3 [list source [file join $dir package1.tcl]] diff --git a/tests/auto0/auto1/tclIndex b/tests/auto0/auto1/tclIndex new file mode 100644 index 0000000..bbfa6d4 --- /dev/null +++ b/tests/auto0/auto1/tclIndex @@ -0,0 +1,9 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(report1) [list source [file join $dir file1.tcl]] diff --git a/tests/auto0/auto2/file2.tcl b/tests/auto0/auto2/file2.tcl new file mode 100644 index 0000000..5bc622f --- /dev/null +++ b/tests/auto0/auto2/file2.tcl @@ -0,0 +1,3 @@ +proc report2 {args} { + return ok2 +} diff --git a/tests/auto0/auto2/package2.tcl b/tests/auto0/auto2/package2.tcl new file mode 100644 index 0000000..61774df --- /dev/null +++ b/tests/auto0/auto2/package2.tcl @@ -0,0 +1,5 @@ +proc HeresPackage2 {args} { + return OK2 +} + +package provide SafeTestPackage2 2.3.4 diff --git a/tests/auto0/auto2/pkgIndex.tcl b/tests/auto0/auto2/pkgIndex.tcl new file mode 100644 index 0000000..1022691 --- /dev/null +++ b/tests/auto0/auto2/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded SafeTestPackage2 2.3.4 [list source [file join $dir package2.tcl]] diff --git a/tests/auto0/auto2/tclIndex b/tests/auto0/auto2/tclIndex new file mode 100644 index 0000000..9cd2a74 --- /dev/null +++ b/tests/auto0/auto2/tclIndex @@ -0,0 +1,9 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(report2) [list source [file join $dir file2.tcl]] diff --git a/tests/auto0/modules/mod1/test1-1.0.tm b/tests/auto0/modules/mod1/test1-1.0.tm new file mode 100644 index 0000000..927fa6f --- /dev/null +++ b/tests/auto0/modules/mod1/test1-1.0.tm @@ -0,0 +1,5 @@ +namespace eval mod1::test1 {} + +proc mod1::test1::try1 args { + return res1 +} diff --git a/tests/auto0/modules/mod2/test2-2.0.tm b/tests/auto0/modules/mod2/test2-2.0.tm new file mode 100644 index 0000000..b5cd45b --- /dev/null +++ b/tests/auto0/modules/mod2/test2-2.0.tm @@ -0,0 +1,5 @@ +namespace eval mod2::test2 {} + +proc mod2::test2::try2 args { + return res2 +} diff --git a/tests/auto0/modules/test0-0.5.tm b/tests/auto0/modules/test0-0.5.tm new file mode 100644 index 0000000..19f3613 --- /dev/null +++ b/tests/auto0/modules/test0-0.5.tm @@ -0,0 +1,5 @@ +namespace eval test0 {} + +proc test0::try0 args { + return res0 +} diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test index 8f29131..214a969 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -3,14 +3,14 @@ # This file contains tests related to autoloading and generating the # autoloading index. # -# Copyright (c) 1998 Lucent Technologies, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998 Lucent Technologies, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -32,7 +32,7 @@ makeFile {# Test file for: # Note that procedures and itcl class definitions can be nested inside of # namespaces. # -# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# Copyright © 1993-1998 Lucent Technologies, Inc. # This shouldn't cause any problems namespace import -force blt::* @@ -40,8 +40,8 @@ namespace import -force blt::* # Should be able to handle "proc" definitions, even if they are preceded by # white space. -proc normal {x y} {return [expr $x+$y]} - proc indented {x y} {return [expr $x+$y]} +proc normal {x y} {return [expr {$x+$y}]} + proc indented {x y} {return [expr {$x+$y}]} # # Should be able to handle proc declarations within namespaces, even if they @@ -146,10 +146,10 @@ test autoMkindex-1.3 {examine tclIndex} -setup { test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { file delete tclIndex - interp create slave + interp create child } -body { auto_mkindex . autoMkindex.tcl - slave eval { + child eval { namespace eval blt {} set auto_path [linsert $auto_path 0 .] set info [list [catch {namespace import buried::*} result] $result] @@ -159,28 +159,28 @@ test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { return $info } } -cleanup { - interp delete slave + interp delete child } -result "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two" # Test auto_mkindex hooks -# Slave hook executes interesting code in the interp used to watch code. -test autoMkindex-3.1 {slaveHook} -setup { +# Child hook executes interesting code in the interp used to watch code. +test autoMkindex-3.1 {childHook} -setup { file delete tclIndex } -body { - auto_mkindex_parser::slavehook { + auto_mkindex_parser::childhook { _%@namespace eval ::blt { proc foo {} {} _%@namespace export foo } } - auto_mkindex_parser::slavehook { _%@namespace import -force ::blt::* } + auto_mkindex_parser::childhook { _%@namespace import -force ::blt::* } auto_mkindex . autoMkindex.tcl file exists tclIndex } -cleanup { # Reset initCommands to avoid trashing other tests AutoMkindexTestReset -} -result 1 +} -result 1 # The auto_mkindex_parser::command is used to register commands that create # new commands. test autoMkindex-3.2 {auto_mkindex_parser::command} -setup { @@ -236,6 +236,38 @@ test autoMkindex-3.3 {auto_mkindex_parser::command} -setup { # Reset initCommands to avoid trashing other tests AutoMkindexTestReset } -result "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}" +makeFile { + +namespace eval wok { + namespace ensemble create -subcommands {commands vars} + + proc commands {{pattern *}} { + puts [join [lsort -dictionary [info commands $pattern]] \n] + } + + proc vars {{pattern *}} { + puts [join [lsort -dictionary [info vars $pattern]] \n] + } + +} + +} ensemblecommands.tcl + +test autoMkindex-3.4 {ensemble commands in tclIndex} { + file delete tclIndex + auto_mkindex . ensemblecommands.tcl + set f [open tclIndex r] + set dat [list] + foreach r [split [string trim [read $f]] "\n"] { + if {[string match {set auto_index*} $r]} { + lappend dat $r + } + } + set result [lsort $dat] + close $f + set result +} {{set auto_index(::wok::commands) [list source [file join $dir ensemblecommands.tcl]]} {set auto_index(::wok::vars) [list source [file join $dir ensemblecommands.tcl]]} {set auto_index(wok) [list source [file join $dir ensemblecommands.tcl]]}} +removeFile ensemblecommands.tcl test autoMkindex-4.1 {platform independent source commands} -setup { file delete tclIndex @@ -303,14 +335,14 @@ test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup { proc {[magic mojo proc]} {} {} } [file join pkg magicchar2.tcl] set result {} - interp create slave + interp create child } -body { auto_mkindex . pkg/magicchar2.tcl - # Make a slave interp to test the autoloading - slave eval {lappend auto_path [pwd]} - slave eval {catch {{[magic mojo proc]}}} + # Make a child interp to test the autoloading + child eval {lappend auto_path [pwd]} + child eval {catch {{[magic mojo proc]}}} } -cleanup { - interp delete slave + interp delete child removeFile [file join pkg magicchar2.tcl] removeDirectory pkg } -result 0 diff --git a/tests/basic.test b/tests/basic.test index 7435571..f4c57fe 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -9,17 +9,19 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testevalex [llength [info commands testevalex]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] @@ -31,7 +33,7 @@ catch {interp delete test_interp} catch {rename p ""} catch {rename q ""} catch {rename cmd ""} -catch {unset x} +unset -nocomplain x test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} { catch {interp delete test_interp} @@ -224,6 +226,21 @@ test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified i list [test_ns_basic::cmd] \ [namespace delete test_ns_basic] } {::test_ns_basic {}} +test basic-15.2 {Tcl_CreateObjCommand, Bug 0e4d88b650} -setup { + proc deleter {ns args} { + namespace delete $ns + } + namespace eval n { + proc p {} {} + } + trace add command n::p delete [list [namespace which deleter] [namespace current]::n] +} -body { + proc n::p {} {} +} -cleanup { + namespace delete n + rename deleter {} +} + test basic-16.1 {TclInvokeStringCommand} {emptyTest} { } {} @@ -241,7 +258,7 @@ test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace quali } list [test_ns_basic::p] \ [rename test_ns_basic::p test_ns_basic::q] \ - [test_ns_basic::q] + [test_ns_basic::q] } {{p in ::test_ns_basic} {} {p in ::test_ns_basic}} test basic-18.2 {TclRenameCommand, existing cmd must be found} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -267,14 +284,24 @@ test basic-18.4 {TclRenameCommand, bad new name} { } rename test_ns_basic::p :::george::martha } {} -test basic-18.5 {TclRenameCommand, new name must not already exist} { +test basic-18.5 {TclRenameCommand, new name must not already exist} -setup { + if {![llength [info commands :::george::martha]]} { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_basic { + proc p {} { + return "p in [namespace current]" + } + } + rename test_ns_basic::p :::george::martha + } +} -body { namespace eval test_ns_basic { proc q {} { return 42 } } list [catch {rename test_ns_basic::q :::george::martha} msg] $msg -} {1 {can't rename to ":::george::martha": command already exists}} +} -result {1 {can't rename to ":::george::martha": command already exists}} test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} @@ -302,7 +329,7 @@ test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespace catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename q ""} - catch {unset x} + unset -nocomplain x set x [namespace eval test_ns_basic::test_ns_basic2 { # the following creates a cmd in the global namespace testcmdtoken create p @@ -355,7 +382,7 @@ test basic-23.1 {Tcl_DeleteCommand} {emptyTest} { test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { catch {interp delete test_interp} - catch {unset x} + unset -nocomplain x interp create test_interp interp eval test_interp { proc useSet {} { @@ -427,7 +454,7 @@ test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} -setup { # string would have been freed, leaving garbage bytes for the error # message. set f [open $fName w] - fileevent $f writable "fileevent $f writable {}; error foo" + chan event $f writable "chan event $f writable {}; error foo" set x {} vwait x close $f @@ -444,11 +471,11 @@ test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body { # a - the pure-list internal rep is destroyed by shimmering # b - the command returns an error # As the error code in Tcl_EvalObjv accesses the list elements, this will - # cause a segfault if [Bug 1119369] has not been fixed. + # cause a segfault if [Bug 1119369] has not been fixed. # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. # - set SRC [list foo 1] ;# pure-list command + set SRC [list foo 1] ;# pure-list command proc foo str { # Shimmer pure-list to cmdName, cleanup and error proc $::SRC {} {}; $::SRC @@ -466,11 +493,11 @@ test basic-26.3 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body { # Follow the pure-list branch in a manner that # a - the pure-list internal rep is destroyed by shimmering # b - the command accesses its command line - # This will cause a segfault if [Bug 1119369] has not been fixed. + # This will cause a segfault if [Bug 1119369] has not been fixed. # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. # - set SRC [list foo 1] ;# pure-list command + set SRC [list foo 1] ;# pure-list command proc foo str { # Shimmer pure-list to cmdName, cleanup and error proc $::SRC {} {}; $::SRC @@ -547,8 +574,8 @@ test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} { catch {close $f} set res [catch { set f [open |[list [interpreter]] w+] - fconfigure $f -buffering line - puts $f {fconfigure stdout -buffering line} + chan configure $f -buffering line + puts $f {chan configure stdout -buffering line} puts $f continue puts $f {puts $::errorInfo} puts $f {puts DONE} @@ -582,7 +609,7 @@ test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup { invoked "break" outside of a loop while executing "break" - (file "*BREAKtest" line 3)} + (file "*BREAKtest" line 3)} test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup { set fName [makeFile { @@ -599,7 +626,7 @@ test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup { } -returnCodes error -match glob -result {invoked "break" outside of a loop while executing "break" - (file "*BREAKtest" line 4)} + (file "*BREAKtest" line 4)} test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup { set fName [makeFile { @@ -645,9 +672,9 @@ proc l3 {} { } # Do all tests once byte compiled and once with direct string evaluation -for {set noComp 0} {$noComp <= 1} {incr noComp} { +foreach noComp {0 1} { -if $noComp { +if {$noComp} { interp alias {} run {} testevalex set constraints testevalex } else { @@ -727,7 +754,7 @@ test basic-48.1.$noComp {expansion: parsing} $constraints { # Another comment list 1 2\ 3 {*}$::l1 - + # Comment again } } {1 2 3 a {b b} c d} @@ -800,7 +827,7 @@ test basic-48.13.$noComp {expansion: odd usage} $constraints { test basic-48.14.$noComp {expansion: hash command} -setup { catch {rename \# ""} set cmd "#" - } -constraints $constraints -body { + } -constraints $constraints -body { run { {*}$cmd apa bepa } } -cleanup { unset cmd @@ -860,7 +887,7 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup { stress set tmp $end set end [getbytes] - } + } set leak [expr {$end - $tmp}] } -cleanup { unset end i tmp @@ -868,21 +895,17 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup { rename stress {} } -result 0 -test basic-48.17.$noComp {expansion: object safety} -setup { - set old_precision $::tcl_precision - set ::tcl_precision 4 - } -constraints $constraints -body { +test basic-48.17.$noComp {expansion: object safety} -constraints $constraints -body { set third [expr {1.0/3.0}] set l [list $third $third] set x [run {list $third {*}$l $third}] - set res [list] + set res [list] foreach t $x { lappend res [expr {$t * 3.0}] } set res } -cleanup { - set ::tcl_precision $old_precision - unset old_precision res t l x third + unset res t l x third } -result {1.0 1.0 1.0 1.0} test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body { @@ -937,6 +960,24 @@ test basic-48.23.$noComp {expansion: handle return codes} -constraints $constrai unset res t } -result {0 10 1 Hejsan} +test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup { + unset -nocomplain a +} -body { + run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]} +} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a} + +test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -constraints $constraints -setup { + unset -nocomplain ::CRLF + set ::CRLF "\r\n" +} -body { + # Force variant that turned up in Bug 2c154a40be as that's externally + # noticeable in an important downstream project. + run {scan [list {*}$::CRLF]x %c%c%c} +} -cleanup { + unset -nocomplain ::CRLF +} -result {120 {} {}} + + } ;# End of noComp loop test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { @@ -959,6 +1000,16 @@ test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { set ::context } {global} +test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup { + interp create child + interp alias {} foo child return +} -body { + list [catch foo m] $m +} -cleanup { + unset -nocomplain m + interp delete child +} -result {0 {}} + # Clean up after expand tests unset noComp l1 l2 constraints rename l3 {} @@ -972,6 +1023,6 @@ catch {rename p ""} catch {rename q ""} catch {rename cmd ""} catch {rename value:at: ""} -catch {unset x} -::tcltest::cleanupTests +unset -nocomplain x +cleanupTests return diff --git a/tests/binary.test b/tests/binary.test index 6c00508..8b326d4 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -4,18 +4,19 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}] +testConstraint testbytestring [llength [info commands testbytestring]] # Big test for correct ordering of data in [expr] proc testIEEE {} { @@ -758,7 +759,16 @@ test binary-21.12 {Tcl_BinaryObjCmd: scan} -setup { } -body { list [binary scan "abc def \x00ghi " A* arg1] $arg1 } -result [list 1 "abc def \x00ghi"] - +test binary-21.13 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { + list [binary scan "abc def \x00 " C* arg1] $arg1 +} -result {1 {abc def }} +test binary-21.12 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { + list [binary scan "abc def \x00ghi" C* arg1] $arg1 +} -result {1 {abc def }} test binary-22.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { binary scan abc b } -result {not enough arguments for all format specifiers} @@ -1506,6 +1516,18 @@ test binary-37.9 {GetFormatSpec: numbers} { binary scan $x f* bla set bla } {1.0 -1.0 2.0 -2.0 0.0} +test binary-37.10 {GetFormatSpec: count overflow} { + binary scan x a[format %ld 0x7fffffff] r +} 0 +test binary-37.11 {GetFormatSpec: count overflow} { + binary scan x a[format %ld 0x10000000] r +} 0 +test binary-37.12 {GetFormatSpec: count overflow} { + binary scan x a[format %ld 0x100000000] r +} 0 +test binary-37.13 {GetFormatSpec: count overflow} { + binary scan x a[format %lld 0x10000000000000000] r +} 0 test binary-38.1 {FormatNumber: word alignment} { set x [binary format c1s1 1 1] @@ -1582,38 +1604,46 @@ test binary-40.4 {ScanNumber: NaN} -body { list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1 } -match glob -result {1 -NaN*} -test binary-41.1 {ScanNumber: word alignment} { - unset -nocomplain arg1; unset arg2 +test binary-41.1 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -body { list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2 -} {2 1 1} -test binary-41.2 {ScanNumber: word alignment} { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1} +test binary-41.2 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -body { list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2 -} {2 1 1} -test binary-41.3 {ScanNumber: word alignment} { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1} +test binary-41.3 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -body { list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2 -} {2 1 1} -test binary-41.4 {ScanNumber: word alignment} { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1} +test binary-41.4 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -body { list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2 -} {2 1 1} -test binary-41.5 {ScanNumber: word alignment} bigEndian { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1} +test binary-41.5 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -constraints bigEndian -body { list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2 -} {2 1 1.600000023841858} -test binary-41.6 {ScanNumber: word alignment} littleEndian { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1.600000023841858} +test binary-41.6 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -constraints littleEndian -body { list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2 -} {2 1 1.600000023841858} -test binary-41.7 {ScanNumber: word alignment} bigEndian { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1.600000023841858} +test binary-41.7 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -constraints bigEndian -body { list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2 -} {2 1 1.6} -test binary-41.8 {ScanNumber: word alignment} littleEndian { - unset -nocomplain arg1; unset arg2 +} -result {2 1 1.6} +test binary-41.8 {ScanNumber: word alignment} -setup { + unset -nocomplain arg1 arg2 +} -constraints littleEndian -body { list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2 -} {2 1 1.6} +} -result {2 1 1.6} test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} -constraints {} -body { binary ? @@ -1627,22 +1657,6 @@ test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} { binary format W 7810179016327718216 } lcTolleH -test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} { - binary scan HelloTcl W x - set x -} 5216694956358656876 -test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} { - binary scan lcTolleH w x - set x -} 5216694956358656876 -test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { - binary scan [binary format w [expr {wide(3) << 31}]] w x - set x -} 6442450944 -test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { - binary scan [binary format W [expr {wide(3) << 31}]] W x - set x -} 6442450944 test binary-43.5 {Tcl_BinaryObjCmd: scan wide int} {} { unset -nocomplain arg1 list [binary scan \x80[string repeat \x00 7] W arg1] $arg1 @@ -1664,6 +1678,31 @@ test binary-43.9 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { list [binary scan [string repeat \x00 7]\x80[string repeat \x00 7]\x80 wuw arg1 arg2] $arg1 $arg2 } {2 9223372036854775808 -9223372036854775808} +test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} { + binary scan HelloTcl W x + set x +} 5216694956358656876 +test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} { + binary scan lcTolleH w x + set x +} 5216694956358656876 +test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { + binary scan [binary format w [expr {wide(3) << 31}]] w x + set x +} 6442450944 +test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { + binary scan [binary format W [expr {wide(3) << 31}]] W x + set x +} 6442450944 +test binary-44.5 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} { + binary scan [binary format w [expr {(wide(3) << 31) + (wide(3) << 64)}]] w x + set x +} 6442450944 +test binary-44.6 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} { + binary scan [binary format W [expr {(wide(3) << 31) + (wide(3) << 64)}]] W x + set x +} 6442450944 + test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} { binary scan [binary format sws 16450 -1 19521] c* x set x @@ -2481,9 +2520,9 @@ test binary-71.6 {binary decode hex} -body { test binary-71.7 {binary decode hex} -body { binary decode hex "61\n\n\n61" } -result {aa} -test binary-71.8 {binary decode hex} -body { +test binary-71.8 {binary decode hex} -match glob -body { binary decode hex -strict "61 61" -} -returnCodes error -result {invalid hexadecimal digit " " at position 2} +} -returnCodes error -result {invalid hexadecimal digit " " * at position 2} test binary-71.9 {binary decode hex} -body { set r [binary decode hex "6"] list [string length $r] $r @@ -2491,6 +2530,34 @@ test binary-71.9 {binary decode hex} -body { test binary-71.10 {binary decode hex} -body { string length [binary decode hex " "] } -result 0 +test binary-71.11 {binary decode hex: Bug b98fa55285} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c26\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {29 38} +test binary-71.12 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.13 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.14 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} test binary-72.1 {binary encode base64} -body { binary encode base64 @@ -2576,6 +2643,9 @@ test binary-72.27 {binary encode base64} -body { test binary-72.28 {binary encode base64} -body { binary encode base64 -maxlen 6 -wrapchar 0123456789 abcabcabc } -result {YWJjYW0123456789JjYWJj} +test binary-72.29 {binary encode base64} { + string length [binary encode base64 -maxlen 3 -wrapchar \xca abc] +} 5 test binary-73.1 {binary decode base64} -body { binary decode base64 @@ -2589,19 +2659,19 @@ test binary-73.3 {binary decode base64} -body { test binary-73.4 {binary decode base64} -body { binary decode base64 [string repeat YWJj 20] } -result [string repeat abc 20] -test binary-73.5 {binary encode base64} -body { +test binary-73.5 {binary decode base64} -body { binary decode base64 AAECAwQAAQID } -result "\0\1\2\3\4\0\1\2\3" -test binary-73.6 {binary encode base64} -body { +test binary-73.6 {binary decode base64} -body { binary decode base64 AA== } -result "\0" -test binary-73.7 {binary encode base64} -body { +test binary-73.7 {binary decode base64} -body { binary decode base64 AAA= } -result "\0\0" -test binary-73.8 {binary encode base64} -body { +test binary-73.8 {binary decode base64} -body { binary decode base64 AAAA } -result "\0\0\0" -test binary-73.9 {binary encode base64} -body { +test binary-73.9 {binary decode base64} -body { binary decode base64 AAAAAA== } -result "\0\0\0\0" test binary-73.10 {binary decode base64} -body { @@ -2614,11 +2684,11 @@ test binary-73.11 {binary decode base64} -body { } -result [string repeat abc 20] test binary-73.12 {binary decode base64} -body { binary decode base64 -strict ":YWJj" -} -returnCodes error -match glob -result {invalid base64 character ":" at position 0} +} -returnCodes error -match glob -result {invalid base64 character ":" * at position 0} test binary-73.13 {binary decode base64} -body { set s "[string repeat YWJj 10]:[string repeat YWJj 10]" binary decode base64 -strict $s -} -returnCodes error -match glob -result {invalid base64 character ":" at position 40} +} -returnCodes error -match glob -result {invalid base64 character ":" * at position 40} test binary-73.14 {binary decode base64} -body { set s "[string repeat YWJj 10]\n [string repeat YWJj 10]" binary decode base64 -strict $s @@ -2642,111 +2712,192 @@ test binary-73.23 {binary decode base64} -body { test binary-73.24 {binary decode base64} -body { string length [binary decode base64 " "] } -result 0 +test binary-73.25 {binary decode base64} -body { + list [string length [set r [binary decode base64 WA==\n]]] $r +} -result {1 X} +test binary-73.26 {binary decode base64} -body { + list [string length [set r [binary decode base64 WFk=\n]]] $r +} -result {2 XY} +test binary-73.27 {binary decode base64} -body { + list [string length [set r [binary decode base64 WFla\n]]] $r +} -result {3 XYZ} +test binary-73.28 {binary decode base64} -body { + list [string length [set r [binary decode base64 -strict WA==\n]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} +test binary-73.29 {binary decode base64} -body { + list [string length [set r [binary decode base64 -strict WFk=\n]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} +test binary-73.30 {binary decode base64} -body { + list [string length [set r [binary decode base64 -strict WFla\n]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} +test binary-73.31 {binary decode base64} -body { + list [string length [set r [binary decode base64 -strict WA==WFla]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} +test binary-73.32 {binary decode base64, bug [00d04c4f12]} -body { + list \ + [string length [binary decode base64 =]] \ + [string length [binary decode base64 " ="]] \ + [string length [binary decode base64 " ="]] \ + [string length [binary decode base64 "\r\n\t="]] \ +} -result [lrepeat 4 0] +test binary-73.33 {binary decode base64, bug [00d04c4f12]} -body { + list \ + [string length [binary decode base64 ==]] \ + [string length [binary decode base64 " =="]] \ + [string length [binary decode base64 " =="]] \ + [string length [binary decode base64 " =="]] \ +} -result [lrepeat 4 0] +test binary-73.34 {binary decode base64, (compatibility) unfulfilled base64 (single char) in non-strict mode} -body { + list \ + [expr {[binary decode base64 a] eq [binary decode base64 ""]}] \ + [expr {[binary decode base64 abcda] eq [binary decode base64 "abcd"]}] +} -result [lrepeat 2 1] +test binary-73.35 {binary decode base64, bad base64 in strict mode} -body { + set r {} + foreach c {a " a" " a" " a" " a" abcda abcdabcda a= a== abcda= abcda==} { + lappend r \ + [catch {binary decode base64 $c}] \ + [catch {binary decode base64 -strict $c}] + } + set r +} -result [lrepeat 11 0 1] +test binary-73.36 {binary decode base64: check encoded & decoded equals original} -body { + set r {} + for {set i 0} {$i < 255 && [llength $r] < 20} {incr i} { + foreach c {1 2 3 4 5 6 7 8} { + set c [string repeat [format %c $i] $c] + if {[set a [binary decode base64 [set x [binary encode base64 $c]]]] ne $c} { + lappend r "encode & decode is wrong on string `$c` (encoded: $x): `$a` != `$c`" + } + } + } + join $r \n +} -result {} +test binary-73.37 {binary decode base64: Bug ffeb2097af} { + binary decode base64 [binary encode base64 -maxlen 3 -wrapchar : abc] +} abc test binary-74.1 {binary encode uuencode} -body { binary encode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-74.2 {binary encode uuencode} -body { binary encode uuencode abc -} -result {86)C} +} -result {#86)C +} test binary-74.3 {binary encode uuencode} -body { binary encode uuencode {} } -result {} test binary-74.4 {binary encode uuencode} -body { binary encode uuencode [string repeat abc 20] -} -result [string repeat 86)C 20] +} -result "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" test binary-74.5 {binary encode uuencode} -body { binary encode uuencode \0\1\2\3\4\0\1\2\3 -} -result "``\$\"`P0``0(#" +} -result ")``\$\"`P0``0(#\n" test binary-74.6 {binary encode uuencode} -body { binary encode uuencode \0 -} -result {````} +} -result {!`` +} test binary-74.7 {binary encode uuencode} -body { binary encode uuencode \0\0 -} -result {````} +} -result "\"``` +" test binary-74.8 {binary encode uuencode} -body { binary encode uuencode \0\0\0 -} -result {````} +} -result {#```` +} test binary-74.9 {binary encode uuencode} -body { binary encode uuencode \0\0\0\0 -} -result {````````} -test binary-74.10 {binary encode uuencode} -body { - binary encode uuencode -maxlen 0 -wrapchar | abcabcabc -} -result {86)C86)C86)C} -test binary-74.11 {binary encode uuencode} -body { - binary encode uuencode -maxlen 1 -wrapchar | abcabcabc -} -result {8|6|)|C|8|6|)|C|8|6|)|C} +} -result {$`````` +} +test binary-74.10 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -foo 30 abcabcabc +} -result {bad option "-foo": must be -maxlen or -wrapchar} +test binary-74.11 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 4 abcabcabc +} -result {line length out of range} +test binary-74.12 {binary encode uuencode} -body { + binary encode uuencode -maxlen 5 -wrapchar \t abcabcabc +} -result #86)C\t#86)C\t#86)C\t +test binary-74.13 {binary encode uuencode} -body { + binary encode uuencode -maxlen 85 -wrapchar \t abcabcabc +} -result )86)C86)C86)C\t +test binary-74.14 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 86 abcabcabc +} -result {line length out of range} test binary-75.1 {binary decode uuencode} -body { binary decode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-75.2 {binary decode uuencode} -body { - binary decode uuencode 86)C + binary decode uuencode "#86)C\n" } -result {abc} test binary-75.3 {binary decode uuencode} -body { binary decode uuencode {} } -result {} +test binary-75.3.1 {binary decode uuencode} -body { + binary decode uuencode `\n +} -result {} test binary-75.4 {binary decode uuencode} -body { - binary decode uuencode [string repeat "86)C" 20] + binary decode uuencode "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" } -result [string repeat abc 20] test binary-75.5 {binary decode uuencode} -body { - binary decode uuencode "``\$\"`P0``0(#" + binary decode uuencode ")``\$\"`P0``0(#" } -result "\0\1\2\3\4\0\1\2\3" test binary-75.6 {binary decode uuencode} -body { - string length [binary decode uuencode {`}] + string length [binary decode uuencode "`\n"] } -result 0 test binary-75.7 {binary decode uuencode} -body { - string length [binary decode uuencode {``}] + string length [binary decode uuencode "!`\n"] } -result 1 test binary-75.8 {binary decode uuencode} -body { - string length [binary decode uuencode {```}] + string length [binary decode uuencode "\"``\n"] } -result 2 test binary-75.9 {binary decode uuencode} -body { - string length [binary decode uuencode {````}] + string length [binary decode uuencode "#```\n"] } -result 3 test binary-75.10 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n>[string repeat 86)C 10]" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.11 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.12 {binary decode uuencode} -body { binary decode uuencode -strict "|86)C" -} -returnCodes error -match glob -result {invalid uuencode character "|" at position 0} +} -returnCodes error -match glob -result {invalid uuencode character "|" * at position 0} test binary-75.13 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]|[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]|[string repeat 86)C 10]" binary decode uuencode -strict $s -} -returnCodes error -match glob -result {invalid uuencode character "|" at position 40} +} -returnCodes error -match glob -result {invalid uuencode character "|" * at position 41} test binary-75.14 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]" binary decode uuencode -strict $s } -returnCodes error -match glob -result {invalid uuencode character *} test binary-75.20 {binary decode uuencode} -body { - set r [binary decode uuencode 8] + set r [binary decode uuencode " 8"] list [string length $r] $r } -result {0 {}} test binary-75.21 {binary decode uuencode} -body { - set r [binary decode uuencode 86] + set r [binary decode uuencode "!86"] list [string length $r] $r } -result {1 a} test binary-75.22 {binary decode uuencode} -body { - set r [binary decode uuencode 86)] + set r [binary decode uuencode "\"86)"] list [string length $r] $r } -result {2 ab} test binary-75.23 {binary decode uuencode} -body { - set r [binary decode uuencode 86)C] + set r [binary decode uuencode "#86)C"] list [string length $r] $r } -result {3 abc} test binary-75.24 {binary decode uuencode} -body { - set s "04)\# " + set s "#04)\# " binary decode uuencode $s } -result ABC test binary-75.25 {binary decode uuencode} -body { - set s "04)\#z" + set s "#04)\#z" binary decode uuencode $s -} -returnCodes error -match glob -result {invalid uuencode character "z" at position 4} +} -returnCodes error -match glob -result {invalid uuencode character "z" * at position 5} test binary-75.26 {binary decode uuencode} -body { string length [binary decode uuencode " "] } -result 0 @@ -2769,7 +2920,50 @@ test binary-76.2 {binary string appending growth algorithm} win { # Append to it string length [append str [binary format a* foo]] } 3 + +test binary-77.1 {string cat ops on all bytearrays} { + apply {{a b} { + return [binary format H* $a][binary format H* $b] + }} ab cd +} [binary format H* abcd] +test binary-77.2 {string cat ops on all bytearrays} { + apply {{a b} { + set one [binary format H* $a] + return $one[binary format H* $b] + }} ab cd +} [binary format H* abcd] + +test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678]} -body { + # just test for BO-segfault (high surrogate w/o advance source pointer for out of BMP char if TCL_UTF_MAX == 3): + binary encode hex \U0001f415 + binary scan \U0001f415 a* v; set v + set str {} +} -result {} + +testConstraint testsetbytearraylength \ + [expr {"testsetbytearraylength" in [info commands]}] + +test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B C] 1 +} A +test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat \u0141 B C] 1 +} A + +test binary-80.1 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { + testbytestring "\u4E4E" +} -result "expected byte sequence but character 0 was '\u4E4E' (U+004E4E)" +test binary-80.2 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { + testbytestring [testbytestring "\x00\xA0\xA0\xA0\xE4\xB9\x8E"] +} -result "expected byte sequence but character 4 was '\u4E4E' (U+004E4E)" +test binary-80.3 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { + testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xE4\xB9\x8E"] +} -result "expected byte sequence but character 4 was '\u4E4E' (U+004E4E)" +test binary-80.4 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { + testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"] +} -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)" + # ---------------------------------------------------------------------- # cleanup diff --git a/tests/case.test b/tests/case.test index 6d63cea..1c12e3a 100644 --- a/tests/case.test +++ b/tests/case.test @@ -4,15 +4,20 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {![llength [info commands case]]} { + # No "case" command? So no need to test + return +} + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/chan.test b/tests/chan.test index da44ffd..3e65433 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -2,13 +2,13 @@ # command. Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # -# Copyright (c) 2005 Donal K. Fellows +# Copyright © 2005 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -61,7 +61,7 @@ test chan-4.5 {chan command: check valid inValue, invalid outValue} -body { } -returnCodes error -match glob -result {bad value for -eofchar:*} test chan-4.6 {chan command: check no inValue, valid outValue} -body { chan configure stdout -eofchar [list {} \x27] -} -returnCodes ok -result {} +} -returnCodes ok -result {} -cleanup {chan configure stdout -eofchar [list {} {}]} test chan-5.1 {chan command: copy subcommand} -body { chan copy foo @@ -135,7 +135,7 @@ test chan-16.4 {chan command: pending subcommand} -body { chan pending {input output} stdout } -returnCodes error -result "bad mode \"input output\": must be input or output" test chan-16.5 {chan command: pending input subcommand} -body { - chan pending input stdout + chan pending input stdout } -result -1 test chan-16.6 {chan command: pending input subcommand} -body { chan pending input stdin @@ -173,7 +173,7 @@ test chan-16.9 {chan command: pending input subcommand} -setup { lappend ::chan-16.9-data $r $l $e $b $i - if {$r != -1 || $e || $l || !$b || $i > 128} { + if {$r >= 0 || $e || $l || !$b || $i > 128} { set data [read $sock $i] lappend ::chan-16.9-data [string range $data 0 2] lappend ::chan-16.9-data [string range $data end-2 end] @@ -194,7 +194,7 @@ test chan-16.9 {chan command: pending input subcommand} -setup { set ::chan-16.9-data [list] set ::chan-16.9-done 0 } -body { - after idle chan-16.9-client + after idle chan-16.9-client vwait ::chan-16.9-done set ::chan-16.9-data } -result {-1 0 0 1 36 -1 0 0 1 72 -1 0 0 1 108 -1 0 0 1 144 ABC 890} -cleanup { diff --git a/tests/chanio.test b/tests/chanio.test index 9bb11f7..04f0e3f 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6,19 +6,24 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2}]} { - chan puts stderr "Skipping tests in [info script]. tcltest 2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } + namespace eval ::tcl::test::io { - namespace import ::tcltest::* + + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } variable umaskValue variable path @@ -29,22 +34,26 @@ namespace eval ::tcl::test::io { variable msg variable expected - ::tcltest::loadTestedCommands - catch [list package require -exact Tcltest [info patchlevel]] - + catch { + ::tcltest::loadTestedCommands + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [info loaded {} Tcltest] + } + package require tcltests + + testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] - testConstraint exec [llength [info commands exec]] - testConstraint openpipe 1 - testConstraint fileevent [llength [info commands fileevent]] - testConstraint fcopy [llength [info commands fcopy]] testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] - testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] + testConstraint testservicemode [llength [info commands testservicemode]] + testConstraint notWinCI [expr { + $::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] + testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] # 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. @@ -124,10 +133,10 @@ test chan-io-1.8 {Tcl_WriteChars: WriteChars} { # Executing this test without the fix for the referenced bug applied to # tcl will cause tcl, more specifically WriteChars, to go into an infinite # loop. - set f [open $path(test2) w] - chan configure $f -encoding iso2022-jp - chan puts -nonewline $f [format %s%c [string repeat " " 4] 12399] - chan close $f + set f [open $path(test2) w] + chan configure $f -encoding iso2022-jp + chan puts -nonewline $f [format %s%c [string repeat " " 4] 12399] + chan close $f contents $path(test2) } " \x1b\$B\$O\x1b(B" test chan-io-1.9 {Tcl_WriteChars: WriteChars} { @@ -242,7 +251,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod test chan-io-3.4 {WriteChars: loop over stage buffer} { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 16 + chan configure $f -encoding jis0208 -buffersize 16 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -253,7 +262,7 @@ test chan-io-3.5 {WriteChars: saved != 0} { # be moved to beginning of next channel buffer to preserve requested # buffersize. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 17 + chan configure $f -encoding jis0208 -buffersize 17 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -282,7 +291,7 @@ test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { # on flush. The truncated bytes are moved to the beginning of the next # channel buffer. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 17 + chan configure $f -encoding jis0208 -buffersize 17 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -347,7 +356,7 @@ test chan-io-4.5 {TranslateOutputEOL: crlf} { test chan-io-5.1 {CheckFlush: not full} { set f [open $path(test1) w] - chan configure $f + chan configure $f chan puts -nonewline $f "12345678901234567890" set x [list [contents $path(test1)]] chan close $f @@ -435,7 +444,7 @@ set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a test chan-io-6.6 {Tcl_GetsObj: loop test} -body { - # if (dst >= dstEnd) + # if (dst >= dstEnd) set f [open $path(test1) w] chan puts $f $a chan puts $f hi @@ -445,7 +454,7 @@ test chan-io-6.6 {Tcl_GetsObj: loop test} -body { } -cleanup { chan close $f } -result [list 256 $a] -test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints {stdio openpipe} -body { +test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints stdio -body { # if (FilterInputBytes(chanPtr, &gs) != 0) set f [openpipe w+ $path(cat)] chan puts -nonewline $f "hi\nwould" @@ -706,7 +715,7 @@ test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} -constraints {testc } -result [list 15 "123456789012345" 15] test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # (FilterInputBytes() != 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {crlf lf} -buffering none @@ -744,7 +753,7 @@ test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} -body { chan close $f } -result [list 16 "123456789012345\r" 1] test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} -body { - # not (*eol == '\n') + # not (*eol == '\n') set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "123456789012345\rabcd\r\nefg" @@ -846,7 +855,7 @@ test chan-io-6.42 {Tcl_GetsObj: auto mode: several chars} -setup { } -result {4 abcd 4 efgh 4 ijkl 4 mnop -1 {}} test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # if (chanPtr->flags & INPUT_SAW_CR) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none @@ -854,7 +863,7 @@ test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { chan configure $f -buffersize 16 lappend x [chan gets $f] chan configure $f -blocking 0 - lappend x [chan gets $f line] $line [testchannel queuedcr $f] + lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan configure $f -blocking 1 chan puts -nonewline $f "\nabcd\refg\x1a" lappend x [chan gets $f line] $line [testchannel queuedcr $f] @@ -864,15 +873,15 @@ test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { } -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg} test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { - # not (*eol == '\n') +} -constraints {stdio testchannel fileevent} -body { + # not (*eol == '\n') set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 lappend x [chan gets $f] chan configure $f -blocking 0 - lappend x [chan gets $f line] $line [testchannel queuedcr $f] + lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan configure $f -blocking 1 chan puts -nonewline $f "abcd\refg\x1a" lappend x [chan gets $f line] $line [testchannel queuedcr $f] @@ -882,11 +891,11 @@ test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { } -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg} test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # Tcl_ExternalToUtf() set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none - chan configure $f -encoding unicode + chan configure $f -encoding utf-16 chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 chan gets $f @@ -900,7 +909,7 @@ test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup } -result {15 123456789abcdef 1 4 abcd 0} test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # memmove() set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none @@ -951,7 +960,7 @@ test chan-io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} -constraints {test chan close $f } -result {123456 0 8 78901} test chan-io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} -constraints {testchannel} -body { - # not (*eol == '\n') + # not (*eol == '\n') set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "123456\r78901" @@ -1018,7 +1027,7 @@ test chan-io-6.55 {Tcl_GetsObj: overconverted} -body { test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup { update variable x {} -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe w+ $path(cat)] chan configure $f -buffering none chan puts -nonewline $f "foobar" @@ -1085,7 +1094,7 @@ test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup { } -result [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup { variable x "" -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" @@ -1119,7 +1128,7 @@ test chan-io-8.1 {PeekAhead: only go to device if no more cached data} -constrai } -result 7 test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { variable x {} -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # not (bufPtr->nextPtr == NULL) set f [openpipe w+ $path(cat)] chan configure $f -translation lf -encoding ascii -buffering none @@ -1127,7 +1136,7 @@ test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { chan event $f read [namespace code { lappend x [chan gets $f line] $line [testchannel inputbuffered $f] }] - chan configure $f -encoding unicode -buffersize 16 -blocking 0 + chan configure $f -encoding utf-16 -buffersize 16 -blocking 0 vwait [namespace which -variable x] chan configure $f -translation auto -encoding ascii -blocking 1 # here @@ -1136,7 +1145,7 @@ test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { } -cleanup { chan close $f } -result {-1 {} 42 15 123456789012345 25} -test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel openpipe fileevent} -body { +test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel fileevent} -body { # (bytesLeft == 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} @@ -1165,7 +1174,7 @@ test chan-io-8.4 {PeekAhead: cached data available in this buffer} -body { chan close $f } -result $a unset a -test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel openpipe fileevent} -body { +test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel fileevent} -body { # (bufPtr->nextAdded < bufPtr->length) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} @@ -1176,8 +1185,8 @@ test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {st } -cleanup { chan close $f } -result {15 abcdefghijklmno 1} -test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel openpipe fileevent} -body { - # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) +test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel fileevent} -body { + # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffersize 16 chan puts -nonewline $f "abcdefghijklmno\r" @@ -1189,7 +1198,7 @@ test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio te } -result {15 abcdefghijklmno 1} test chan-io-8.7 {PeekAhead: cleanup} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # Make sure bytes are removed from buffer. set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffering none @@ -1340,7 +1349,7 @@ test chan-io-12.3 {ReadChars: allocate more space} -body { } -result {abcdefghijklmnopqrstuvwxyz} test chan-io-12.4 {ReadChars: split-up char} -setup { variable x {} -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # (srcRead == 0) set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none -buffersize 16 @@ -1362,7 +1371,7 @@ test chan-io-12.4 {ReadChars: split-up char} -setup { } -result [list "123456789012345" 1 "\u672c" 0] test chan-io-12.5 {ReadChars: chan events on partial characters} -setup { variable x {} -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set path(test1) [makeFile { chan configure stdout -encoding binary -buffering none chan gets stdin; chan puts -nonewline "\xe7" @@ -1417,7 +1426,7 @@ test chan-io-13.2 {TranslateInputEOL: crlf mode} -body { chan close $f } -result "abcd\ndef\n" test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} -body { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\r\ndef\r" @@ -1429,7 +1438,7 @@ test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} -body { chan close $f } -result "abcd\ndef\r" test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} -body { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\r\ndef\rfgh" @@ -1441,7 +1450,7 @@ test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} -body { chan close $f } -result "abcd\ndef\rfgh" test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} -body { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\r\ndef\nfgh" @@ -1455,7 +1464,7 @@ test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} -body { test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup { variable x {} variable y {} -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. set f [openpipe w+ $path(cat)] @@ -1473,7 +1482,7 @@ test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup } -cleanup { chan close $f } -result [list "abcdefghj\n" 1 "01234" 0] -test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints {testchannel openpipe} -body { +test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints testchannel -body { # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf @@ -1509,7 +1518,7 @@ test chan-io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} -body { chan close $f } -result "abcd\ndef" test chan-io-13.10 {TranslateInputEOL: auto mode: \n} -body { - # not (*src == '\r') + # not (*src == '\r') set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\ndef" @@ -1574,7 +1583,7 @@ test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} -setup { interp delete x } -result {line line none} set path(test3) [makeFile {} test3] -test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec openpipe} -body { +test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints exec -body { set f [open $path(test1) w] chan puts -nonewline $f { chan close stdin @@ -1671,7 +1680,7 @@ set path(script) [makeFile {} script] test chan-io-14.8 {reuse of stdio special channels} -setup { file delete $path(script) file delete $path(test1) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [open $path(script) w] chan puts -nonewline $f { chan close stderr @@ -1694,7 +1703,7 @@ test chan-io-14.8 {reuse of stdio special channels} -setup { test chan-io-14.9 {reuse of stdio special channels} -setup { file delete $path(script) file delete $path(test1) -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [open $path(script) w] chan puts $f { array set path [lindex $argv 0] @@ -1878,7 +1887,7 @@ test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -bod } -result {{{} {}} {auto lf}} test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { set path(stdout) [makeFile {} stdout] -} -constraints {stdio openpipe} -body { +} -constraints {stdio notWinCI} -body { set f [open $path(script) w] chan puts -nonewline $f { chan close stdout @@ -1963,7 +1972,7 @@ test chan-io-26.1 {Tcl_GetChannelInstanceData} -body { # Don't care what pid is (but must be a number), just want to exercise it. set f [openpipe r << exit] pid $f -} -constraints {stdio openpipe} -cleanup { +} -constraints stdio -cleanup { chan close $f } -match regexp -result {^\d+$} @@ -2022,7 +2031,7 @@ test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} -setup { test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup { file delete $path(test1) set l "" -} -constraints {unixOrPc} -body { +} -constraints {unixOrWin} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffersize 60 -eofchar {} lappend l [file size $path(test1)] @@ -2038,7 +2047,7 @@ set path(output) [makeFile {} output] test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio asyncPipeChan Close openpipe} -body { +} -constraints {stdio asyncPipeChan Close} -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f { @@ -2108,7 +2117,7 @@ test chan-io-28.2 {Chan CloseChannel called when all references are dropped} -se test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio asyncPipeChan Close nonPortable openpipe} -body { +} -constraints {stdio asyncPipeChan Close nonPortable} -body { set f [open $path(pipe) w] chan puts $f { # Need to not have eof char appended on chan close, because the other @@ -2162,7 +2171,7 @@ test chan-io-28.4 {Tcl_Chan Close} -constraints {testchannel} -setup { } -result ok test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { file delete $path(script) -} -constraints {stdio unix testchannel openpipe} -body { +} -constraints {stdio unix testchannel} -body { set f [open $path(script) w] chan puts $f { chan close stdin @@ -2214,13 +2223,17 @@ test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup { puts $sok DONE exit 0 } echo.tcl] -} -body { + variable done + unset -nocomplain done + set done "" + set timer "" set ff [openpipe r $echo] gets $ff port +} -body { set s [socket 127.0.0.1 $port] puts $s Hey close $s w - set timer [after 1000 [namespace code {set ::done Failed}]] + set timer [after 1000 [namespace code {set done Failed}]] set acc {} fileevent $s readable [namespace code { if {[gets $s line]<0} { @@ -2230,11 +2243,11 @@ test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup { } }] vwait [namespace which -variable done] - after cancel $timer - close $s r - close $ff list $done $acc } -cleanup { + catch {close $s} + close $ff + after cancel $timer removeFile echo.tcl } -result {Succeeded {Hey DONE}} @@ -2375,7 +2388,7 @@ test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} -setup { test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 "set f1 \[[list open $path(longfile) r]]" chan puts $f1 { @@ -2402,7 +2415,7 @@ test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup { test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts [chan gets stdin] @@ -2455,7 +2468,7 @@ test chan-io-29.15 {Tcl_Flush, channel not open for writing} -setup { } -match glob -result {channel "*" wasn't opened for writing} test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} -setup { set fd [openpipe r cat longfile] -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { chan flush $fd } -returnCodes error -cleanup { catch {chan close $fd} @@ -2531,7 +2544,7 @@ test chan-io-29.20 {Implicit flush when buffer is full} -setup { } -result {4096 12288 12600} test chan-io-29.21 {Tcl_Flush to pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {set x [chan read stdin 6]} chan puts $f1 {set cnt [string length $x]} @@ -2546,7 +2559,7 @@ test chan-io-29.21 {Tcl_Flush to pipe} -setup { } -result "read 6 characters" test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan configure stdout -buffering full @@ -2570,7 +2583,7 @@ test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup { } -result {hello hello bye} test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts hello @@ -2607,7 +2620,7 @@ test chan-io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} -setup { } -result "{} {Line 1\nLine 2}" test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup { file delete $path(test3) -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe w $path(cat) | [interpreter] $path(cat) > $path(test3)] chan puts $f "Line 1" chan puts $f "Line 2" @@ -2618,7 +2631,7 @@ test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup { } -cleanup { chan close $f } -result "Line 1\nLine 2\n" -test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs openpipe} -body { +test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs} -body { set f [open "|[list cat -u]" r+] chan puts $f "Line1" chan flush $f @@ -2631,7 +2644,7 @@ test chan-io-29.27 {Tcl_Flush on chan closed pipeline} -setup { set f [open $path(pipe) w] chan puts $f {exit} chan close $f -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [openpipe r+ $path(pipe)] chan gets $f chan puts $f output @@ -2684,7 +2697,7 @@ test chan-io-29.30 {Tcl_WriteChars, crlf mode} -setup { test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f {chan configure $f -translation lf} @@ -2717,7 +2730,7 @@ test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { set result ok } # allow a little time for the background process to chan close. - # otherwise, the following test fails on the [file delete $path(output) + # otherwise, the following test fails on the [file delete $path(output)] # on Windows because a process still has the file open. after 100 set v 1; vwait v return $result @@ -2725,7 +2738,7 @@ test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio asyncPipeChan Close openpipe} -body { +} -constraints {stdio asyncPipeChan Close} -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f {chan configure $f -translation lf} @@ -2784,7 +2797,7 @@ test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} -s chan puts $s $l } } -} -constraints {socket tempNotMac fileevent} -body { +} -constraints {socket tempNotMac fileevent notWinCI} -body { proc accept {s a p} { variable x chan event $s readable [namespace code [list readit $s]] @@ -2810,7 +2823,7 @@ test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} -s chan close $cs chan close $ss vwait [namespace which -variable x] - return $c + set c } -result 2000 test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} -setup { catch {interp delete x} @@ -3038,7 +3051,7 @@ test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} -setup { string length [chan read $f] } -cleanup { chan close $f -} -result [expr 700*15+1] +} -result [expr {700*15 + 1}] test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup { file delete $path(test1) } -body { @@ -3055,7 +3068,7 @@ test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup { string length [chan read $f] } -cleanup { chan close $f -} -result [expr 700*15+1] +} -result [expr {700*15 + 1}] test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} -setup { file delete $path(test1) } -body { @@ -3891,13 +3904,13 @@ test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} -setup { } chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf + chan configure $f -translation crlf while {[chan gets $f line] >= 0} { append c $line\n } chan close $f string length $c -} -result [expr 700*15+1] +} -result [expr {700*15 + 1}] test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup { file delete $path(test1) set c "" @@ -3917,7 +3930,7 @@ test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup { } chan close $f string length $c -} -result [expr 700*15+1] +} -result [expr {700*15 + 1}] # Test Tcl_Read and buffering. @@ -3998,7 +4011,7 @@ test chan-io-32.9 {Tcl_Read, read to end of file} { } ok test chan-io-32.10 {Tcl_Read from a pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 @@ -4012,7 +4025,7 @@ test chan-io-32.10 {Tcl_Read from a pipe} -setup { test chan-io-32.11 {Tcl_Read from a pipe} -setup { file delete $path(pipe) set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan puts $f1 {chan puts [chan gets stdin]} @@ -4124,7 +4137,7 @@ test chan-io-33.2 {Tcl_Gets into variable} { } ok test chan-io-33.3 {Tcl_Gets from pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 @@ -4150,12 +4163,20 @@ test chan-io-33.4 {Tcl_Gets with long line} -setup { } -cleanup { chan close $f } -result {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} -test chan-io-33.5 {Tcl_Gets with long line} { +test chan-io-33.5 {Tcl_Gets with long line} -setup { + set f [open $path(test3) w] + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + close $f +} -body { set f [open $path(test3)] set x [chan gets $f y] chan close $f list $x $y -} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +} -result {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} test chan-io-33.6 {Tcl_Gets and end of file} -setup { file delete $path(test3) set x {} @@ -4326,7 +4347,7 @@ test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position } -result {44 rstuv 49} test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup { set pipe [openpipe] -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { chan seek $pipe 0 current } -returnCodes error -cleanup { chan close $pipe @@ -4436,13 +4457,13 @@ test chan-io-34.15 {Tcl_Tell combined with seeking} -setup { } -cleanup { chan close $f1 } -result {10 20} -test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints {stdio openpipe} -body { +test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints stdio -body { set f1 [openpipe] chan tell $f1 } -cleanup { chan close $f1 } -result -1 -test chan-io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { +test chan-io-34.17 {Tcl_Tell on pipe: always -1} stdio { set f1 [openpipe] chan puts $f1 {chan puts hello} chan flush $f1 @@ -4516,10 +4537,10 @@ test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup { 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)] } -result {0 6 6 4294967296 4294967302 4294967302 0} # Test Tcl_Eof @@ -4544,7 +4565,7 @@ test chan-io-35.1 {Tcl_Eof} -setup { } -cleanup { chan close $f } -result {0 0 0 0 1 1} -test chan-io-35.2 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { +test chan-io-35.2 {Tcl_Eof with pipe} -constraints stdio -setup { file delete $path(pipe) } -body { set f1 [open $path(pipe) w] @@ -4563,7 +4584,7 @@ test chan-io-35.2 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { } -cleanup { chan close $f1 } -result {0 0 0 1} -test chan-io-35.3 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { +test chan-io-35.3 {Tcl_Eof with pipe} -constraints stdio -setup { file delete $path(pipe) } -body { set f1 [open $path(pipe) w] @@ -4601,7 +4622,7 @@ test chan-io-35.4 {Tcl_Eof, eof detection on nonblocking file} -setup { test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup { file delete $path(pipe) set l "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [open $path(pipe) w] chan puts $f { exit @@ -4786,7 +4807,7 @@ test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup { test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup { set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [openpipe] chan puts $f1 {chan puts hello_from_pipe} chan flush $f1 @@ -4806,7 +4827,7 @@ test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup { } -result {{} 1 hello 0 {} 1} test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} -setup { set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [openpipe] chan configure $f1 -buffering line chan puts $f1 {chan puts hello_from_pipe} @@ -5080,7 +5101,7 @@ test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} -setup { test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup { file delete $path(pipe) set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan gets stdin @@ -5145,7 +5166,7 @@ test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -encoding {} + chan configure $f -encoding {} chan puts -nonewline $f \xe7\x89\xa6 chan close $f set f [open $path(test1) r] @@ -5177,7 +5198,7 @@ test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup { } -result {unknown encoding "foobar"} test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} -setup { variable x {} -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe r+ $path(cat)] chan configure $f -encoding binary chan puts -nonewline $f "\xe7" @@ -5290,7 +5311,7 @@ test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or\ test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\ writable so we can't change -eofchar or -translation} -setup { set l [list] -} -body { +} -body { set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] chan configure $sock -eofchar D -translation lf lappend l [chan configure $sock -eofchar] \ @@ -5318,24 +5339,24 @@ test chan-io-40.1 {POSIX open access modes: RDWR} -setup { test chan-io-40.2 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -constraints {unix} -body { - set f [open $path(test3) {WRONLY CREAT} 0600] + set f [open $path(test3) {WRONLY CREAT} 0o600] file stat $path(test3) stats - set x [format "0%o" [expr $stats(mode)&0o777]] + set x [format 0o%03o [expr {$stats(mode) & 0o777}]] chan puts $f "line 1" chan close $f set f [open $path(test3) r] lappend x [chan gets $f] } -cleanup { chan close $f -} -result {0600 {line 1}} +} -result {0o600 {line 1}} test chan-io-40.3 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -constraints {unix umask} -body { # This test only works if your umask is 2, like ouster's. chan close [open $path(test3) {WRONLY CREAT}] file stat $path(test3) stats - format "0%o" [expr $stats(mode)&0o777] -} -result [format %04o [expr {0o666 & ~ $umaskValue}]] + format 0o%03o [expr {$stats(mode) & 0o777}] +} -result [format 0o%03o [expr {0o666 & ~ $umaskValue}]] test chan-io-40.4 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -body { @@ -5443,7 +5464,7 @@ test chan-io-40.13 {POSIX open access modes: WRONLY} -body { set x [list [catch {chan gets $f} msg] $msg] chan close $f lappend x [viewFile test3] -} -match glob -result {1 {channel "*" wasn't opened for reading} abzzy} +} -match glob -result {1 {channel "*" wasn't opened for reading} abzzy} test chan-io-40.14 {POSIX open access modes: RDWR} -match regexp -body { file delete $path(test3) open $path(test3) RDWR @@ -5537,7 +5558,7 @@ test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] set result {} -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] chan event $f r "chan read f" chan event $f2 r "chan read f2" @@ -5557,7 +5578,7 @@ test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { test chan-io-44.1 {FileEventProc procedure: normal read event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 readable [namespace code { set x [chan gets $f2]; chan event $f2 readable {} }] @@ -5577,7 +5598,7 @@ test chan-io-44.2 {FileEventProc procedure: error in read event} -setup { } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 readable {error bogus} chan puts $f2 text; chan flush $f2 variable x initial @@ -5591,7 +5612,7 @@ test chan-io-44.2 {FileEventProc procedure: error in read event} -setup { test chan-io-44.3 {FileEventProc procedure: normal write event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 writable [namespace code { lappend x "triggered" incr count -1 @@ -5617,7 +5638,7 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -setup { } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 writable {error bad-write} variable x initial vwait [namespace which -variable x] @@ -5627,7 +5648,9 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -setup { catch {chan close $f2} catch {chan close $f3} } -result {bad-write {}} -test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { +test chan-io-44.5 {FileEventProc procedure: end of file} -constraints { + stdio unixExecs fileevent +} -body { set f4 [openpipe r $path(cat) << foo] chan event $f4 readable [namespace code { if {[chan gets $f4 line] < 0} { @@ -5640,9 +5663,10 @@ test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpi variable x initial vwait [namespace which -variable x] vwait [namespace which -variable x] - chan close $f4 set x -} {initial foo eof} +} -cleanup { + chan close $f4 +} -result {initial foo eof} chan close $f makeFile "foo bar" foo @@ -5703,7 +5727,7 @@ test chan-io-45.3 {DeleteFileEvent, cleanup on chan close} {fileevent} { # Execute these tests only if the "testfevent" command is present. -test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { +test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent notOSX} { testfevent create set script "set f \[[list open $path(foo) r]]\n" append script { @@ -5713,9 +5737,10 @@ test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileeven chan event $f readable {} }] } + set timer [after 10 lappend x timeout] testfevent cmd $script - after 1 ;# We must delay because Windows takes a little time to notice - update + vwait x + after cancel $timer testfevent cmd {chan close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} @@ -5848,6 +5873,8 @@ test chan-io-47.6 {file events on shared files, deleting file events} -setup { testfevent delete chan close $f } -result {{script 1} {}} +unset path(foo) +removeFile foo set path(bar) [makeFile {} bar] @@ -5901,7 +5928,7 @@ test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { set path(my_script) [makeFile {} my_script] test chan-io-48.3 {testing readability conditions} -setup { set l "" -} -constraints {stdio unix nonBlockFiles openpipe fileevent} -body { +} -constraints {stdio unix nonBlockFiles fileevent} -body { set f [open $path(bar) w] chan puts $f abcdefg chan puts $f abcdefg @@ -5943,6 +5970,9 @@ test chan-io-48.3 {testing readability conditions} -setup { } -cleanup { chan close $f } -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} +unset path(bar) +removeFile bar + test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup { file delete $path(test1) set c 0 @@ -6352,17 +6382,21 @@ test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} -setup { test chan-io-50.1 {testing handler deletion} -setup { file delete $path(test1) -} -constraints {testchannelevent} -body { +} -constraints testchannelevent -body { set f [open $path(test1) w] chan close $f set f [open $path(test1) r] + variable z not_called + set timer [after 50 lappend z timeout] + testservicemode 0 testchannelevent $f add readable [namespace code { variable z called testchannelevent $f delete 0 }] - variable z not_called - update - return $z + testservicemode 1 + vwait z + after cancel $timer + set z } -cleanup { chan close $f } -result called @@ -6370,16 +6404,21 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] set z "" -} -constraints {testchannelevent} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] +} -constraints {testchannelevent testservicemode} -body { proc delhandler {f i} { variable z lappend z "called delhandler $f $i" testchannelevent $f delete 0 } - update + set z "" + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + vwait z + after cancel $timer string equal $z \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } -cleanup { @@ -6388,11 +6427,7 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] - set z "" -} -constraints {testchannelevent} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] +} -constraints {testchannelevent testservicemode} -body { proc notcalled {f i} { variable z lappend z "notcalled was called!! $f $i" @@ -6404,7 +6439,15 @@ test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { testchannelevent $f delete 0 lappend z "delhandler $f $i deleted myself" } - update + set z "" + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + vwait z + after cancel $timer string equal $z \ [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] @@ -6415,7 +6458,7 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent} -body { +} -constraints testchannelevent -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code { if {$u eq "recursive"} { @@ -6429,19 +6472,20 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { }] variable u toplevel variable z "" - update - return $z + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z } -cleanup { chan close $f + update } -result {{delrecursive calling recursive} {delrecursive deleting recursive}} test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f]] - testchannelevent $f add readable [namespace code [list del $f]] + update +} -constraints {testchannelevent testservicemode notOSX} -body { proc notcalled {f} { variable z lappend z "notcalled was called!! $f" @@ -6457,33 +6501,46 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { } else { set u recursive lappend z "del calling recursive" - update + set timer [after 50 lappend z timeout] + set mode [testservicemode 1] + vwait z + after cancel $timer + testservicemode $mode lappend z "del after update" } } set z "" set u toplevel - update - return $z + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f]] + testchannelevent $f add readable [namespace code [list del $f]] + testservicemode 1 + vwait z + after cancel $timer + set z } -cleanup { chan close $f + update } -result [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list second $f]] - testchannelevent $f add readable [namespace code [list first $f]] +} -constraints {testchannelevent testservicemode} -body { proc first {f} { variable u variable z if {$u eq "toplevel"} { lappend z "first called" + set mode [testservicemode 1] + set timer [after 50 lappend z timeout] set u first - update + vwait z + after cancel $timer + testservicemode $mode lappend z "first after update" } else { lappend z "first called not toplevel" @@ -6506,8 +6563,15 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { } set z "" set u toplevel - update - return $z + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list second $f]] + testchannelevent $f add readable [namespace code [list first $f]] + testservicemode 1 + vwait z + after cancel $timer + set z } -cleanup { chan close $f } -result [list {first called} {first called not toplevel} \ @@ -6658,7 +6722,7 @@ test chan-io-52.6 {TclCopyChannel} -setup { set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 chan configure $f2 -translation lf -blocking 0 - set s0 [chan copy $f1 $f2 -size [expr [file size $thisScript] + 5]] + set s0 [chan copy $f1 $f2 -size [expr {[file size $thisScript] + 5}]] set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 chan close $f2 @@ -6689,7 +6753,7 @@ test chan-io-52.7 {TclCopyChannel} -constraints {fcopy} -setup { test chan-io-52.8 {TclCopyChannel} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set f1 [open $path(pipe) w] chan configure $f1 -translation lf chan puts $f1 " @@ -6755,7 +6819,12 @@ test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} { chan close $out file size $path(utf8-fcopy.txt) } 5 -test chan-io-52.11 {TclCopyChannel & encodings} {fcopy} { +test chan-io-52.11 {TclCopyChannel & encodings} -setup { + set f [open $path(utf8-fcopy.txt) w] + fconfigure $f -encoding utf-8 -translation lf + puts $f "\u0410\u0410" + close $f +} -constraints {fcopy} -body { # binary to encoding => the input has to be in utf-8 to make sense to the # encoder set in [open $path(utf8-fcopy.txt) r] @@ -6767,7 +6836,7 @@ test chan-io-52.11 {TclCopyChannel & encodings} {fcopy} { chan close $in chan close $out file size $path(kyrillic.txt) -} 3 +} -result 3 test chan-io-53.1 {CopyData} -setup { file delete $path(test1) @@ -6805,7 +6874,7 @@ test chan-io-53.2 {CopyData} -setup { test chan-io-53.3 {CopyData: background read underflow} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio unix openpipe fcopy} -body { +} -constraints {stdio unix fcopy} -body { set f1 [open $path(pipe) w] chan puts -nonewline $f1 { chan puts ready @@ -6843,7 +6912,7 @@ test chan-io-53.4 {CopyData: background write overflow} -setup { } file delete $path(test1) file delete $path(pipe) -} -constraints {stdio unix openpipe fileevent fcopy} -body { +} -constraints {stdio unix fileevent fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts ready @@ -6895,7 +6964,7 @@ test chan-io-53.5 {CopyData: error during chan copy} {socket fcopy} { chan close $listen ;# This means the socket open never really succeeds chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g. } chan close $in @@ -6907,7 +6976,7 @@ test chan-io-53.6 {CopyData: error during chan copy} -setup { file delete $path(pipe) file delete $path(test1) catch {unset fcopyTestDone} -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 "exit 1" chan close $f1 @@ -6915,7 +6984,7 @@ test chan-io-53.6 {CopyData: error during chan copy} -setup { set out [open $path(test1) w] chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] } return $fcopyTestDone ;# 0 for plain end of file @@ -6941,7 +7010,7 @@ test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup { variable fcopyTestDone file delete $path(pipe) catch {unset fcopyTestDone} -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set fcopyTestCount 0 set f1 [open $path(pipe) w] chan puts $f1 { @@ -6968,7 +7037,7 @@ test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup { vwait [namespace which -variable fcopyTestDone] } # -1=error 0=script error N=number of bytes - expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1 + expr {($fcopyTestDone == 0) ? $fcopyTestCount : -1} } -cleanup { catch {chan close $in} chan close $out @@ -6991,7 +7060,7 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. @@ -7008,7 +7077,7 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se vwait ::forever catch {after cancel $token} # Report - return $::RES + set ::RES } -cleanup { chan close $f chan close $g @@ -7031,7 +7100,7 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at # Channels to copy between set f [open $foo r] ; chan configure $f -translation binary set g [open $bar w] ; chan configure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Initialize and force eof on the input. chan seek $f 0 end ; chan read $f 1 set ::RES [chan eof $f] @@ -7089,7 +7158,7 @@ test chan-io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { } set ::forever {} set out [open $out w] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { chan copy $pipe $out -size 6 -command ::done set token [after 5000 { set ::forever {fcopy hangs} @@ -7162,7 +7231,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { chan configure $b -translation binary -buffering none chan event $a readable [namespace code "done $a"] chan event $b readable [namespace code "done $b"] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Now pass data through the server in both directions. set ::forever {} chan puts $a AB @@ -7208,7 +7277,7 @@ test chan-io-54.1 {Recursive channel events} {socket fileevent} { for {set i 0} {$i < 10} {incr i} { if {![catch { set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]] - }]} then { + }]} { set done 1 break } @@ -7280,7 +7349,7 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} -setup { chan close $writer chan close $s after cancel $after - return $counter + set counter } -cleanup { if {$accept ne {}} {chan close $accept} } -result 1 @@ -7307,7 +7376,7 @@ test chan-io-55.1 {ChannelEventScriptInvoker: deletion} -constraints { chan event $f writable [namespace code [list eventScript $f]] variable x not_done vwait [namespace which -variable x] - return $x + set x } -cleanup { interp bgerror {} $handler } -result {got_error} @@ -7352,7 +7421,7 @@ test chan-io-57.1 {buffered data and file events, gets} -setup { vwait [namespace which -variable result] lappend result [chan gets $s2] vwait [namespace which -variable result] - return $result + set result } -cleanup { chan close $s chan close $s2 @@ -7377,14 +7446,14 @@ test chan-io-57.2 {buffered data and file events, read} -setup { vwait [namespace which -variable result] lappend result [chan read $s2 9] vwait [namespace which -variable result] - return $result + set result } -cleanup { chan close $s chan close $s2 chan close $server } -result {1 readable 234567890 timer} -test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} { +test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} { set out [open $path(script) w] chan puts $out { chan puts "normal message from pipe" @@ -7422,11 +7491,12 @@ test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} { string equal $result [testmainthread] } {1} -test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent} { +test chan-io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] + chan puts $out "catch {load $::tcltestlib Tcltest}" chan puts $out { - chan puts [encoding convertfrom identity \xe2] + chan puts [testbytestring \xe2] exit 1 } proc readit {pipe} { diff --git a/tests/clock.test b/tests/clock.test index 0202fc7..4283020 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -6,13 +6,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. +# Copyright © 2004 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -35,9 +35,9 @@ testConstraint y2038 \ # TEST PLAN # clock-1: -# [clock format] - tests of bad and empty arguments +# [clock format] - tests of bad and empty arguments # -# clock-2 +# clock-2 # formatting of year, month and day of month # # clock-3 @@ -195,7 +195,7 @@ namespace eval ::tcl::clock { l li lii liii liv lv lvi lvii lviii lix lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix - lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii + lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii lxxxix xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix c @@ -271,9 +271,9 @@ test clock-1.3 "clock format - empty val" { test clock-1.4 "clock format - bad flag" {*}{ -body { list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode - } + } -match glob - -result {1 {bad switch "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badSwitch -oops}} + -result {1 {bad option "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}} } test clock-1.5 "clock format - bad timezone" { @@ -15416,30 +15416,9 @@ test clock-5.29 {time zone boundary case 1948-09-26 01:00:01} detroit { clock format -671047199 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit } {01:00:01 -0500 EST} -test clock-5.30 {time zone boundary case 1967-06-14 01:59:59} detroit { - clock format -80499601 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0500 EST} -test clock-5.31 {time zone boundary case 1967-06-14 03:00:00} detroit { - clock format -80499600 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:00 -0400 EDT} -test clock-5.32 {time zone boundary case 1967-06-14 03:00:01} detroit { - clock format -80499599 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {03:00:01 -0400 EDT} -test clock-5.33 {time zone boundary case 1967-10-29 01:59:59} detroit { - clock format -68666401 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:59:59 -0400 EDT} -test clock-5.34 {time zone boundary case 1967-10-29 01:00:00} detroit { - clock format -68666400 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:00 -0500 EST} -test clock-5.35 {time zone boundary case 1967-10-29 01:00:01} detroit { - clock format -68666399 -format {%H:%M:%S %z %Z} \ - -timezone :America/Detroit -} {01:00:01 -0500 EST} + +# Detroit did not observe Daylight Saving Time in 1967 + test clock-5.36 {time zone boundary case 1972-12-31 23:59:59} detroit { clock format 94712399 -format {%H:%M:%S %z %Z} \ -timezone :America/Detroit @@ -35045,6 +35024,24 @@ test clock-30.8 {clock add months, negative} { set x4 [clock format $f4 -format %Y-%m-%d -timezone :UTC] list $x1 $x2 $x3 $x4 } {2000-02-29 2000-01-31 1999-12-31 1999-11-30} +test clock-30.8a {clock add months, negative, over threshold of a year} { + set t [clock scan 2019-01-31 -format %Y-%m-%d -gmt 1] + list [clock format [clock add $t -1 month -gmt 1] -format %Y-%m-%d -gmt 1] \ + [clock format [clock add $t -2 month -gmt 1] -format %Y-%m-%d -gmt 1] \ + [clock format [clock add $t -3 month -gmt 1] -format %Y-%m-%d -gmt 1] \ + [clock format [clock add $t -4 month -gmt 1] -format %Y-%m-%d -gmt 1] +} {2018-12-31 2018-11-30 2018-10-31 2018-09-30} +test clock-30.8b {clock add months, negative, over threshold of a year} { + set t [clock scan 2000-01-28 -format %Y-%m-%d -gmt 1] + for {set i 1} {$i < 24} {incr i 1} { + set f1 [clock add $t -$i month -gmt 1] + set f2 [clock add $f1 $i month -gmt 1] + if {$f2 != $t} { + error "\[clock add $t -$i month -gmt 1\] does not consider\ + \[clock add $f1 $i month -gmt 1\] != $t" + } + } +} {} test clock-30.9 {clock add days} { set t [clock scan {2000-01-01 12:34:56} -format {%Y-%m-%d %H:%M:%S} \ -timezone :UTC] @@ -35221,7 +35218,7 @@ test clock-30.25 {clock add seconds at DST conversion} { test clock-31.1 {system locale} \ -constraints win \ - -setup { + -setup { namespace eval ::tcl::clock { namespace import -force ::testClock::registry } @@ -35244,7 +35241,7 @@ test clock-31.1 {system locale} \ test clock-31.2 {system locale} \ -constraints win \ - -setup { + -setup { namespace eval ::tcl::clock { namespace import -force ::testClock::registry } @@ -35267,7 +35264,7 @@ test clock-31.2 {system locale} \ test clock-31.3 {system locale} \ -constraints win \ - -setup { + -setup { namespace eval ::tcl::clock { namespace import -force ::testClock::registry } @@ -35290,7 +35287,7 @@ test clock-31.3 {system locale} \ test clock-31.4 {system locale} \ -constraints win \ - -setup { + -setup { namespace eval ::tcl::clock { namespace import -force ::testClock::registry } @@ -35327,7 +35324,7 @@ test clock-31.4 {system locale} \ test clock-31.5 {system locale} \ -constraints win \ - -setup { + -setup { namespace eval ::tcl::clock { namespace import -force ::testClock::registry } @@ -35364,7 +35361,7 @@ test clock-31.5 {system locale} \ test clock-31.6 {system locale} \ -constraints win \ - -setup { + -setup { namespace eval ::tcl::clock { namespace import -force ::testClock::registry } @@ -35434,25 +35431,25 @@ test clock-32.1 {scan/format across the Gregorian change} { } set problems } {} - + # Legacy tests # clock clicks test clock-33.1 {clock clicks tests} { - expr [clock clicks]+1 + expr {[clock clicks] + 1} concat {} } {} test clock-33.2 {clock clicks tests} { set start [clock clicks] after 10 set end [clock clicks] - expr "$end > $start" + expr {$end > $start} } {1} test clock-33.3 {clock clicks tests} { list [catch {clock clicks foo} msg] $msg -} {1 {bad switch "foo": must be -milliseconds or -microseconds}} +} {1 {bad option "foo": must be -milliseconds or -microseconds}} test clock-33.4 {clock clicks tests} { - expr [clock clicks -milliseconds]+1 + expr {[clock clicks -milliseconds] + 1} concat {} } {} test clock-33.4a {clock milliseconds} { @@ -35462,48 +35459,64 @@ test clock-33.4a {clock milliseconds} { test clock-33.5 {clock clicks tests, millisecond timing test} { # This test can fail on a system that is so heavily loaded that # the test takes >60 ms to run. - set start [clock clicks -milli] - after 10 - set end [clock clicks -milli] + if {[lindex [timerate { + set start [clock clicks -milli] + timerate {} 10; # short but precise busy wait + set end [clock clicks -milli] + } 1 1] 0] > 60000} { + ::tcltest::Skip "timing issue" + } # 60 msecs seems to be the max time slice under Windows 95/98 expr { ($end > $start) && (($end - $start) <= 60) ? - "ok" : + "ok" : "test should have taken 0-60 ms, actually took [expr $end - $start]"} } {ok} test clock-33.5a {clock tests, millisecond timing test} { # This test can fail on a system that is so heavily loaded that # the test takes >60 ms to run. - set start [clock milliseconds] - after 10 - set end [clock milliseconds] + if {[lindex [timerate { + set start [clock milliseconds] + timerate {} 10; # short but precise busy wait + set end [clock milliseconds] + } 1 1] 0] > 60000} { + ::tcltest::Skip "timing issue" + } # 60 msecs seems to be the max time slice under Windows 95/98 expr { ($end > $start) && (($end - $start) <= 60) ? - "ok" : + "ok" : "test should have taken 0-60 ms, actually took [expr $end - $start]"} } {ok} test clock-33.6 {clock clicks, milli with too much abbreviation} { list [catch { clock clicks ? } msg] $msg -} {1 {bad switch "?": must be -milliseconds or -microseconds}} +} {1 {bad option "?": must be -milliseconds or -microseconds}} test clock-33.7 {clock clicks, milli with too much abbreviation} { list [catch { clock clicks - } msg] $msg -} {1 {ambiguous switch "-": must be -milliseconds or -microseconds}} +} {1 {ambiguous option "-": must be -milliseconds or -microseconds}} test clock-33.8 {clock clicks test, microsecond timing test} { # This test can fail on a system that is so heavily loaded that # the test takes >60 ms to run. - set start [clock clicks -micro] - after 10 - set end [clock clicks -micro] + if {[lindex [timerate { + set start [clock clicks -micro] + timerate {} 10; # short but precise busy wait + set end [clock clicks -micro] + } 1 1] 0] > 60000} { + ::tcltest::Skip "timing issue" + } expr {($end > $start) && (($end - $start) <= 60000)} } {1} test clock-33.8a {clock test, microsecond timing test} { # This test can fail on a system that is so heavily loaded that # the test takes >60 ms to run. - set start [clock microseconds] - after 10 - set end [clock microseconds] + if {[lindex [timerate { + set start [clock microseconds] + timerate {} 10; # short but precise busy wait + set end [clock microseconds] + } 1 1] 0] > 60000} { + ::tcltest::Skip "timing issue" + } expr {($end > $start) && (($end - $start) <= 60000)} } {1} @@ -35607,7 +35620,7 @@ test clock-34.8 {clock scan tests} { } {Oct 23,1992 15:00 GMT} test clock-34.9 {clock scan tests} { list [catch {clock scan "Jan 12" -bad arg} msg] $msg -} {1 {bad switch "-bad", must be -base, -format, -gmt, -locale or -timezone}} +} {1 {bad option "-bad", must be -base, -format, -gmt, -locale or -timezone}} # The following two two tests test the two year date policy test clock-34.10 {clock scan tests} { set time [clock scan "1/1/71" -gmt true] @@ -35617,7 +35630,6 @@ test clock-34.11 {clock scan tests} { set time [clock scan "1/1/37" -gmt true] clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true } {Jan 01,2037 00:00 GMT} - test clock-34.12 {clock scan, relative times} { set time [clock scan "Oct 23, 1992 -1 day"] clock format $time -format {%b %d, %Y} @@ -35769,7 +35781,6 @@ test clock-34.43 {last monday in november} { } set res } {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25} - test clock-34.44 {2nd monday in november} { set res {} foreach i {91 92 93 94 95 96} { @@ -35802,42 +35813,99 @@ test clock-34.47 {ago with multiple relative units} { set res [clock scan "2 days 2 hours ago" -base $base] expr {$base - $res} } 180000 - test clock-34.48 {more than one ToD} {*}{ - -body {clock scan {10:00 11:00}} + -body {clock scan {10:00 11:00}} -returnCodes error -result {unable to convert date-time string "10:00 11:00": more than one time of day in string} } - test clock-34.49 {more than one date} {*}{ - -body {clock scan {1/1/2001 2/2/2002}} + -body {clock scan {1/1/2001 2/2/2002}} -returnCodes error -result {unable to convert date-time string "1/1/2001 2/2/2002": more than one date in string} } - test clock-34.50 {more than one time zone} {*}{ - -body {clock scan {10:00 EST CST}} + -body {clock scan {10:00 EST CST}} -returnCodes error -result {unable to convert date-time string "10:00 EST CST": more than one time zone in string} } - test clock-34.51 {more than one weekday} {*}{ - -body {clock scan {Monday Tuesday}} + -body {clock scan {Monday Tuesday}} -returnCodes error -result {unable to convert date-time string "Monday Tuesday": more than one weekday in string} } - test clock-34.52 {more than one ordinal month} {*}{ - -body {clock scan {next January next March}} + -body {clock scan {next January next March}} -returnCodes error -result {unable to convert date-time string "next January next March": more than one ordinal month in string} } - - +test clock-34.53 {clock scan, ISO 8601 point in time format} { + set time [clock scan "19921023T00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} "Oct 23, 1992 00:00:00" +test clock-34.54 {clock scan, ISO 8601 point in time format} { + set time [clock scan "1992-10-23T00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} "Oct 23, 1992 00:00:00" +test clock-34.55 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "19921023MST000000"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.56 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "19921023M000000"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.57 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "1992-10-23M00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.58 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "1992-10-23MST00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.59 {clock scan tests (-TZ)} { + set time [clock scan "31 Jan 14 23:59:59 -0100"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Feb 01,2014 00:59:59 GMT} +test clock-34.60 {clock scan tests (+TZ)} { + set time [clock scan "31 Jan 14 23:59:59 +0100"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 31,2014 22:59:59 GMT} +test clock-34.61 {clock scan tests (-TZ)} { + set time [clock scan "23:59:59 -0100" -base 0 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 02,1970 00:59:59 GMT} +test clock-34.62 {clock scan tests (+TZ)} { + set time [clock scan "23:59:59 +0100" -base 0 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 01,1970 22:59:59 GMT} +test clock-34.63 {clock scan tests (TZ)} { + set time [clock scan "Mon, 30 Jun 2014 23:59:59 CEST"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jun 30,2014 21:59:59 GMT} +test clock-34.64 {clock scan tests (TZ)} { + set time [clock scan "Fri, 31 Jan 2014 23:59:59 CET"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 31,2014 22:59:59 GMT} +test clock-34.65 {clock scan tests (relspec, day unit not TZ)} { + set time [clock scan "23:59:59 +15 day" -base 2000000 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Feb 08,1970 23:59:59 GMT} +test clock-34.66 {clock scan tests (relspec, day unit not TZ)} { + set time [clock scan "23:59:59 -15 day" -base 2000000 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 09,1970 23:59:59 GMT} +test clock-34.67 {clock scan tests (merid and TZ)} { + set time [clock scan "10:59 pm CET" -base 2000000 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 24,1970 21:59:00 GMT} +test clock-34.68 {clock scan tests (merid and TZ)} { + set time [clock scan "10:59 pm +0100" -base 2000000 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 24,1970 21:59:00 GMT} # clock seconds test clock-35.1 {clock seconds tests} { - expr [clock seconds]+1 + expr {[clock seconds] + 1} concat {} } {} test clock-35.2 {clock seconds tests} { @@ -35847,7 +35915,7 @@ test clock-35.3 {clock seconds tests} { set start [clock seconds] after 2000 set end [clock seconds] - expr "$end > $start" + expr {$end > $start} } {1} @@ -35924,7 +35992,7 @@ test clock-38.2 {make sure TZ is not cached after unset} \ } } \ -result 1 - + test clock-39.1 {regression - synonym timezones} { clock format 0 -format {%H:%M:%S} -timezone :US/Eastern @@ -35996,7 +36064,7 @@ test clock-44.1 {regression test - time zone name containing hyphen } \ } } \ -result {12:34:56-0500} - + test clock-45.1 {regression test - time zone containing only two digits} \ -body { clock scan 1985-04-12T10:15:30+04 -format %Y-%m-%dT%H:%M:%S%Z @@ -36041,7 +36109,7 @@ test clock-48.1 {Bug 1185933: 'i' destroyed by clock init} -setup { test clock-49.1 {regression test - localtime with negative arg (Bug 1237907)} \ -body { - list [catch { + list [catch { clock format -86400 -timezone :localtime -format %Y } result] $result } \ @@ -36280,7 +36348,7 @@ test clock-56.1 {use of zoneinfo, version 1} {*}{ } -result {2004-01-01 00:00:00 MST} } - + test clock-56.2 {use of zoneinfo, version 2} {*}{ -setup { clock format [clock seconds] @@ -36330,7 +36398,7 @@ test clock-56.2 {use of zoneinfo, version 2} {*}{ removeFile PhoenixTwo $tzdir2 removeDirectory Test $tzdir removeDirectory zoneinfo - } + } -body { clock format 1072940400 -timezone :Test/PhoenixTwo \ -format {%Y-%m-%d %H:%M:%S %Z} @@ -36540,7 +36608,7 @@ test clock-56.3 {use of zoneinfo, version 2, Y2038 compliance} {*}{ removeFile TijuanaTwo $tzdir2 removeDirectory Test $tzdir removeDirectory zoneinfo - } + } -body { clock format 2224738800 -timezone :Test/TijuanaTwo \ -format {%Y-%m-%d %H:%M:%S %Z} @@ -36692,7 +36760,7 @@ test clock-56.4 {Bug 3470928} {*}{ removeFile Windhoek $tzdir2 removeDirectory Test $tzdir removeDirectory zoneinfo - } + } -result {Sun Jan 08 22:30:06 WAST 2012} } @@ -36703,7 +36771,7 @@ test clock-57.1 {clock scan - abbreviated options} { test clock-58.1 {clock l10n - Japanese localisation} {*}{ -setup { proc backslashify { string } { - + set retval {} foreach char [split $string {}] { scan $char %c ccode @@ -36720,16 +36788,18 @@ test clock-58.1 {clock l10n - Japanese localisation} {*}{ } -body { set trouble {} - foreach {date jdate} [list \ - 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 \ - 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 \ - 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 \ - 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 \ - 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 \ - 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 \ - 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 \ - 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 \ - ] { + foreach {date jdate} { + 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 + 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 + 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 + 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 + 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 + 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 + 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 + 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 + 2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5 + 2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5 + } { set status [catch { set secs [clock scan $date \ -timezone +0900 \ @@ -36809,52 +36879,52 @@ test clock-59.1 {military time zones} { test clock-60.1 {case insensitive weekday names} { clock scan "2000-W01 monday" -gmt true -format "%G-W%V %a" -} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"] +} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"] test clock-60.2 {case insensitive weekday names} { clock scan "2000-W01 Monday" -gmt true -format "%G-W%V %a" -} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"] +} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"] test clock-60.3 {case insensitive weekday names} { clock scan "2000-W01 MONDAY" -gmt true -format "%G-W%V %a" -} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"] +} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"] test clock-60.4 {case insensitive weekday names} { clock scan "2000-W01 friday" -gmt true -format "%G-W%V %a" -} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"] +} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"] test clock-60.5 {case insensitive weekday names} { clock scan "2000-W01 Friday" -gmt true -format "%G-W%V %a" -} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"] +} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"] test clock-60.6 {case insensitive weekday names} { clock scan "2000-W01 FRIDAY" -gmt true -format "%G-W%V %a" -} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"] +} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"] test clock-60.7 {case insensitive month names} { clock scan "1 january 2000" -gmt true -format "%d %b %Y" -} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"] +} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"] test clock-60.8 {case insensitive month names} { clock scan "1 January 2000" -gmt true -format "%d %b %Y" -} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"] +} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"] test clock-60.9 {case insensitive month names} { clock scan "1 JANUARY 2000" -gmt true -format "%d %b %Y" -} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"] +} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"] test clock-60.10 {case insensitive month names} { clock scan "1 december 2000" -gmt true -format "%d %b %Y" -} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"] +} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"] test clock-60.11 {case insensitive month names} { clock scan "1 December 2000" -gmt true -format "%d %b %Y" -} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"] +} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"] test clock-60.12 {case insensitive month names} { clock scan "1 DECEMBER 2000" -gmt true -format "%d %b %Y" -} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"] +} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"] test clock-61.1 {overflow of a wide integer on output} {*}{ -body { clock format 0x8000000000000000 -format %s -gmt true - } + } -result {integer value too large to represent} -returnCodes error } test clock-61.2 {overflow of a wide integer on output} {*}{ -body { clock format -0x8000000000000001 -format %s -gmt true - } + } -result {integer value too large to represent} -returnCodes error } @@ -36907,7 +36977,7 @@ test clock-65.1 {clock add, bad option [Bug 2481670]} {*}{ } -match glob -returnCodes error - -result {bad switch "-foo"*} + -result {bad option "-foo"*} } test clock-66.1 {clock scan, no date, never-before-seen timezone} {*}{ @@ -36927,6 +36997,38 @@ 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 * +test clock-67.4 {Change format %x output on global locale change [Bug 4a0c163d24]} -setup { + package require msgcat + set current [msgcat::mclocale] +} -body { + msgcat::mclocale de_de + set res [regexp {^\d{2}\.\d{2}\.\d{4}$} [clock format 1 -locale current -format %x]] + msgcat::mclocale en_uk + lappend res [regexp {^\d{2}/\d{2}/\d{4}$} [clock format 1 -locale current -format %x]] +} -cleanup { + msgcat::mclocale $current +} -result {1 1} +test clock-67.5 {Change scan %x output on global locale change [Bug 4a0c163d24]} -setup { + package require msgcat + set current [msgcat::mclocale] +} -body { + msgcat::mclocale de_de + set res [clock scan "01.01.1970" -locale current -format %x -gmt 1] + msgcat::mclocale en_uk + # This will fail without the bug fix, as still de_de is active + expr {$res == [clock scan "01/01/1970" -locale current -format %x -gmt 1]} +} -cleanup { + msgcat::mclocale $current +} -result {1} + # cleanup namespace delete ::testClock diff --git a/tests/cmdAH.test b/tests/cmdAH.test index f192b6a..afc012d 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -4,28 +4,33 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1996-1998 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] +testConstraint time64bit [expr { + $::tcl_platform(pointerSize) >= 8 || + [llength [info command testsize]] && [testsize st_mtime] >= 8 +}] testConstraint linkDirectory [expr { ![testConstraint win] || - ([string index $tcl_platform(osVersion) 0] >= 5 + ($::tcl_platform(osVersion) >= 5.0 && [lindex [file system [temporaryDirectory]] 1] eq "NTFS") }] +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] global env set cmdAHwd [pwd] @@ -70,6 +75,12 @@ test cmdAH-1.2 {Tcl_CatchObjCmd, errors} { test cmdAH-1.3 {Tcl_CatchObjCmd, errors} -returnCodes error -body { catch foo bar baz spaz } -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} +test cmdAH-1.4 {Bug 3595576} { + catch {catch {} -> noSuchNs::var} +} 1 +test cmdAH-1.5 {Bug 3595576} { + catch {catch error -> noSuchNs::var} +} 1 test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body { cd foo bar @@ -135,6 +146,13 @@ test cmdAH-2.6.2 {cd} -constraints {unix nonPortable} -setup { } -cleanup { cd $dir } -result {/} +test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -setup { + set dir [pwd] +} -returnCodes error -body { + cd .\0 +} -cleanup { + cd $dir +} -match glob -result "couldn't change working directory to \".\0\": *" test cmdAH-2.7 {Tcl_ConcatObjCmd} { concat } {} @@ -154,10 +172,10 @@ test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { test cmdAH-4.1 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding -} -result {wrong # args: should be "encoding option ?arg ...?"} +} -result {wrong # args: should be "encoding subcommand ?arg ...?"} test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding foo -} -result {bad option "foo": must be convertfrom, convertto, dirs, names, or system} +} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto } -result {wrong # args: should be "encoding convertto ?encoding? data"} @@ -175,7 +193,7 @@ test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system identity + encoding system iso8859-1 encoding convertto jis0208 \u4e4e } -cleanup { encoding system $system @@ -197,7 +215,7 @@ test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system identity + encoding system iso8859-1 encoding convertfrom jis0208 8C } -cleanup { encoding system $system @@ -211,18 +229,18 @@ test cmdAH-4.12 {Tcl_EncodingObjCmd} -returnCodes error -body { test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { - encoding system identity + encoding system iso8859-1 encoding system } -cleanup { encoding system $system -} -result identity +} -result iso8859-1 test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file } -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -244,7 +262,7 @@ test cmdAH-6.3 {Tcl_FileObjCmd: volumes} -constraints unix -body { test cmdAH-6.4 {Tcl_FileObjCmd: volumes} -constraints win -body { set volumeList [string tolower [file volumes]] set element [lsearch -exact $volumeList "c:/"] - list [expr {$element>-1}] [glob -nocomplain [lindex $volumeList $element]*] + list [expr {$element>=0}] [glob -nocomplain [lindex $volumeList $element]*] } -match glob -result {1 *} # attributes @@ -306,7 +324,7 @@ test cmdAH-8.13 {Tcl_FileObjCmd: dirname} testsetplatform { test cmdAH-8.14 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname //foo -} // +} //foo test cmdAH-8.15 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix file dirname //foo/bar @@ -450,7 +468,7 @@ test cmdAH-9.13 {Tcl_FileObjCmd: tail} testsetplatform { test cmdAH-9.14 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail //foo -} foo +} {} test cmdAH-9.15 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail //foo/bar @@ -553,6 +571,13 @@ test cmdAH-9.51 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {foo\bar} } bar +test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} { + list \ + [file tail {~/~foo}] \ + [file tail {~/test/~foo}] \ + [file tail [file normalize {~/~foo}]] \ + [file tail [file normalize {~/test/~foo}]] +} [lrepeat 4 ./~foo] # rootname test cmdAH-10.1 {Tcl_FileObjCmd: rootname} -returnCodes error -body { @@ -820,13 +845,13 @@ test cmdAH-16.1 {Tcl_FileObjCmd: readable} { } test cmdAH-16.2 {Tcl_FileObjCmd: readable} { -constraints testchmod - -setup {testchmod 0444 $gorpfile} + -setup {testchmod 0o444 $gorpfile} -body {file readable $gorpfile} -result 1 } test cmdAH-16.3 {Tcl_FileObjCmd: readable} { -constraints {unix notRoot testchmod} - -setup {testchmod 0333 $gorpfile} + -setup {testchmod 0o333 $gorpfile} -body {file readable $gorpfile} -result 0 } @@ -839,13 +864,13 @@ test cmdAH-17.1 {Tcl_FileObjCmd: writable} { } test cmdAH-17.2 {Tcl_FileObjCmd: writable} { -constraints {notRoot testchmod} - -setup {testchmod 0555 $gorpfile} + -setup {testchmod 0o555 $gorpfile} -body {file writable $gorpfile} -result 0 } test cmdAH-17.3 {Tcl_FileObjCmd: writable} { -constraints testchmod - -setup {testchmod 0222 $gorpfile} + -setup {testchmod 0o222 $gorpfile} -body {file writable $gorpfile} -result 1 } @@ -864,25 +889,25 @@ test cmdAH-18.2 {Tcl_FileObjCmd: executable} {notRoot} { test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} { # Only on unix will setting the execute bit on a regular file cause that # file to be executable. - testchmod 0775 $gorpfile + testchmod 0o775 $gorpfile file exe $gorpfile } 1 test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body { - # On pc, must be a .exe, .com, etc. - set x [file exe $gorpfile] - set gorpexe [makeFile foo gorp.exe] - lappend x [file exe $gorpexe] -} -cleanup { - removeFile $gorpexe -} -result {0 1} -test cmdAH-18.5.1 {Tcl_FileObjCmd: executable} -constraints {win} -body { - # On pc, must be a .exe, .com, etc. - set x [file exe $gorpfile] - set gorpexe [makeFile foo gorp.exe] - lappend x [file exe [string toupper $gorpexe]] + # On windows, must be a .exe, .com, etc. + set x {} + set gorpexes {} + foreach ext {exe com cmd bat} { + lappend x [file exe nosuchfile.$ext] + set gorpexe [makeFile foo gorp.$ext] + lappend gorpexes $gorpexe + lappend x [file exe $gorpexe] [file exe [string toupper $gorpexe]] + } + set x } -cleanup { - removeFile $gorpexe -} -result {0 1} + foreach gorpexe $gorpexes { + removeFile $gorpexe + } +} -result {0 1 1 0 1 1 0 1 1 0 1 1} test cmdAH-18.6 {Tcl_FileObjCmd: executable} {} { # Directories are always executable. file exe $dirfile @@ -941,20 +966,33 @@ test cmdAH-19.11 {Tcl_FileObjCmd: exists} -constraints {unix notRoot} -setup { } -body { makeDirectory /tmp/tcl.foo.dir makeFile 12345 /tmp/tcl.foo.dir/file - file attributes /tmp/tcl.foo.dir -permissions 0000 + file attributes /tmp/tcl.foo.dir -permissions 0 file exists /tmp/tcl.foo.dir/file } -cleanup { - file attributes /tmp/tcl.foo.dir -permissions 0775 + file attributes /tmp/tcl.foo.dir -permissions 0o775 removeFile /tmp/tcl.foo.dir/file removeDirectory /tmp/tcl.foo.dir } -result 0 +test cmdAH-19.12 {Bug 3608360: [file exists] mustn't do globbing} -setup { + set newdirfile [makeDirectory newdir.file] + set cwd [pwd] + cd $newdirfile + # Content of file is totally unimportant; name is *not* + set innocentBystander [makeFile "abc" [file join $newdirfile foo.bar]] +} -body { + list [file exists foo.bar] [file exists *.bar] +} -cleanup { + cd $cwd + removeFile $innocentBystander + removeDirectory $newdirfile +} -result {1 0} # Stat related commands catch {testsetplatform $platform} removeFile $gorpfile set gorpfile [makeFile "Test string" gorp.file] -catch {file attributes $gorpfile -permissions 0765} +catch {file attributes $gorpfile -permissions 0o765} # avoid problems with non-local filesystems if {[testConstraint unix] && [file exists /tmp]} { @@ -1005,6 +1043,16 @@ test cmdAH-20.6 {Tcl_FileObjCmd: atime touch} -setup { set modatime [file atime $file $newatime] expr {$newatime == $modatime ? 1 : "$newatime != $modatime"} } -result 1 +test cmdAH-20.7 { + Tcl_FileObjCmd: atime (built-in Windows names) +} -constraints {win} -body { + file atime con +} -result "could not get access time for file \"con\"" -returnCodes error +test cmdAH-20.7.1 { + Tcl_FileObjCmd: atime (built-in Windows names with dir path and extension) +} -constraints {win} -body { + file atime [file join [temporaryDirectory] CON.txt] +} -match regexp -result {could not (?:get access time|read)} -returnCodes error if {[testConstraint unix] && [file exists /tmp]} { removeFile touch.me /tmp @@ -1045,7 +1093,7 @@ test cmdAH-23.4 {Tcl_FileObjCmd: lstat} -setup { unset -nocomplain stat } -constraints {unix nonPortable} -body { file lstat $linkfile stat - list $stat(nlink) [expr $stat(mode)&0777] $stat(type) + list $stat(nlink) [expr {$stat(mode) & 0o777}] $stat(type) } -result {1 511 link} test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { list [catch {file lstat _bogus_ stat} msg] [string tolower $msg] \ @@ -1236,13 +1284,59 @@ test cmdAH-24.13 {Tcl_FileObjCmd: directory mtime} -setup { } -cleanup { file delete -force $dirname } -result {0 1} +test cmdAH-24.14 { + Tcl_FileObjCmd: mtime (built-in Windows names) +} -constraints {win} -body { + file mtime con +} -result "could not get modification time for file \"con\"" -returnCodes error +test cmdAH-24.14.1 { + Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension) +} -constraints {win} -body { + file mtime [file join [temporaryDirectory] CON.txt] +} -match regexp -result {could not (?:get modification time|read)} -returnCodes error + +# 3155760000 is 64-bit unix time, Wed Jan 01 00:00:00 GMT 2070: +test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup { + set filename [makeFile "" foo.text] +} -body { + list [file atime $filename 3155760000] [file atime $filename] +} -cleanup { + removeFile $filename +} -result {3155760000 3155760000} +test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup { + set filename [makeFile "" foo.text] +} -body { + list [file mtime $filename 3155760000] [file mtime $filename] +} -cleanup { + file delete -force $filename +} -result {3155760000 3155760000} # owned test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body { file owned a b } -result {wrong # args: should be "file owned name"} -test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -body { - file owned $gorpfile +test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -setup { + set fn $gorpfile + # prefer temp file to check owner (try to avoid bug [7de2d722bd]): + if { + [info exists ::env(TEMP)] && [file isdirectory $::env(TEMP)] && + [file dirname $fn] ne [file normalize $::env(TEMP)] + } { + set fn [file join $::env(TEMP)/test-owner-from-tcl.txt] + set fn [makeFile "data" test-owner-from-tcl.txt $::env(TEMP)] + } + # be sure we have really owned this file before trying to check that + # (avoid dependency on admin with UAC and the setting "System objects: + # Default owner for objects created by members of the Administrators group"): + catch { + exec takeown /F [file nativename $fn] + } +} -body { + file owned $fn +} -cleanup { + if {$fn ne $gorpfile} { + removeFile $fn + } } -result 1 test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup { # Avoid problems with AFS @@ -1255,6 +1349,16 @@ test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup { test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} { file owned / } 0 +test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints {win notWine} -body { + if {[info exists env(SystemRoot)]} { + file owned $env(SystemRoot) + } else { + file owned $env(windir) + } +} -result 0 +test cmdAH-25.4 {Tcl_FileObjCmd: owned} -body { + file owned nosuchfile +} -result 0 # readlink test cmdAH-26.1 {Tcl_FileObjCmd: readlink} -returnCodes error -body { @@ -1285,11 +1389,26 @@ test cmdAH-27.2 {Tcl_FileObjCmd: size} { test cmdAH-27.3 {Tcl_FileObjCmd: size} { list [catch {file size _bogus_} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} +test cmdAH-27.4 { + Tcl_FileObjCmd: size (built-in Windows names) +} -constraints {win} -body { + file size con +} -result 0 +test cmdAH-27.4.1 { + Tcl_FileObjCmd: size (built-in Windows names with dir path and extension) +} -constraints {win} -body { + try { + set res [file size [file join [temporaryDirectory] con.txt]] + } trap {POSIX ENOENT} {} { + set res 0 + } + set res +} -result 0 catch {testsetplatform $platform} removeFile $gorpfile set gorpfile [makeFile "Test string" gorp.file] -catch {file attributes $gorpfile -permissions 0765} +catch {file attributes $gorpfile -permissions 0o765} # stat test cmdAH-28.1 {Tcl_FileObjCmd: stat} -returnCodes error -body { @@ -1316,8 +1435,8 @@ test cmdAH-28.5 {Tcl_FileObjCmd: stat} -constraints {unix} -setup { unset -nocomplain stat } -body { file stat $gorpfile stat - expr {$stat(mode) & 0o777} -} -result {501} + format 0o%03o [expr {$stat(mode) & 0o777}] +} -result 0o765 test cmdAH-28.6 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_ stat} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} @@ -1376,12 +1495,29 @@ test cmdAH-28.12 {Tcl_FileObjCmd: stat} -setup { } -cleanup { removeFile $filename } -result 1 +test cmdAH-28.13 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup { + unset -nocomplain stat +} -body { + file stat con stat + lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)} +} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} +test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup { + unset -nocomplain stat +} -body { + try { + file stat [file join [temporaryDirectory] CON.txt] stat + set res [lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)}] + } trap {POSIX ENOENT} {} { + set res {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} + } + set res +} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} unset -nocomplain stat # type test cmdAH-29.1 {Tcl_FileObjCmd: type} -returnCodes error -body { - file size a b -} -result {wrong # args: should be "file size name"} + file type a b +} -result {wrong # args: should be "file type name"} test cmdAH-29.2 {Tcl_FileObjCmd: type} { file type $dirfile } directory @@ -1403,7 +1539,7 @@ test cmdAH-29.4 {Tcl_FileObjCmd: type} -constraints {unix} -setup { } -cleanup { file delete $linkfile } -result link -test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory} -setup { +test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory notWine} -setup { set tempdir [makeDirectory temp] } -body { set linkdir [file join [temporaryDirectory] link.dir] @@ -1416,11 +1552,26 @@ test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory} -setup { test cmdAH-29.5 {Tcl_FileObjCmd: type} { list [catch {file type _bogus_} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} +test cmdAH-29.6 { + Tcl_FileObjCmd: type (built-in Windows names) +} -constraints {win} -body { + file type con +} -result "characterSpecial" +test cmdAH-29.6.1 { + Tcl_FileObjCmd: type (built-in Windows names, with dir path and extension) +} -constraints {win} -body { + try { + set res [file type [file join [temporaryDirectory] CON.txt]] + } trap {POSIX ENOENT} {} { + set res {characterSpecial} + } + set res +} -result "characterSpecial" # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x } -match glob -result {unknown or ambiguous subcommand "ex": must be *} @@ -1488,7 +1639,7 @@ test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} { lsort [safeInterp eval [list file channels]] } [lsort [list stdout $newFileId]] test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} { - # we can now write to $newFileId from slave + # we can now write to $newFileId from child safeInterp eval [list puts $newFileId "hello"] } {} interp transfer {} $newFileId safeInterp @@ -1552,6 +1703,62 @@ test cmdAH-32.6 {file tempfile - templates} -body { } -constraints {unix nonPortable} -cleanup { catch {file delete $name} } -result ok + +test cmdAH-33.1 {file tempdir} -body { + file tempdir a b +} -returnCodes error -result {wrong # args: should be "file tempdir ?template?"} +test cmdAH-33.2 {file tempdir} -body { + set d [file tempdir] + list [file tail $d] [file exists $d] [file type $d] \ + [glob -nocomplain -directory $d *] +} -match glob -result {tcl_* 1 directory {}} -cleanup { + catch {file delete $d} +} +test cmdAH-33.3 {file tempdir} -body { + set d [file tempdir gorp] + list [file tail $d] [file exists $d] [file type $d] \ + [glob -nocomplain -directory $d *] +} -match glob -result {gorp_* 1 directory {}} -cleanup { + catch {file delete $d} +} +test cmdAH-33.4 {file tempdir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -body { + set pre [glob -nocomplain -directory $base *] + set d [file normalize [file tempdir $base/]] + list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \ + $pre [glob -nocomplain -directory $d *] +} -match glob -result {GORP:/tcl_* 1 directory {} {}} -cleanup { + catch {file delete -force $base} +} +test cmdAH-33.5 {file tempdir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -body { + set pre [glob -nocomplain -directory $base *] + set d [file normalize [file tempdir $base/gorp]] + list [string map [list $base GORP:] $d] [file exists $d] [file type $d] \ + $pre [glob -nocomplain -directory $d *] +} -match glob -result {GORP:/gorp_* 1 directory {} {}} -cleanup { + catch {file delete -force $base} +} +test cmdAH-33.6 {file tempdir: missing parent dir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -returnCodes error -body { + file tempdir $base/quux/ +} -cleanup { + catch {file delete -force $base} +} -result {can't create temporary directory: no such file or directory} +test cmdAH-33.7 {file tempdir: missing parent dir} -setup { + set base [file join [temporaryDirectory] gorp] + file mkdir $base +} -returnCodes error -body { + file tempdir $base/quux/foobar +} -cleanup { + catch {file delete -force $base} +} -result {can't create temporary directory: no such file or directory} # This shouldn't work, but just in case a test above failed... catch {close $newFileId} @@ -1565,7 +1772,7 @@ unset -nocomplain platform # Tcl_ForObjCmd is tested in for.test -catch {file attributes $dirfile -permissions 0777} +catch {file attributes $dirfile -permissions 0o777} removeDirectory $dirfile removeFile $gorpfile # No idea how well [removeFile] copes with links... diff --git a/tests/cmdIL.test b/tests/cmdIL.test index efb0bce..83fe80e 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -2,24 +2,27 @@ # tclCmdIL.c. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } + ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] - +source [file join [file dirname [info script]] internals.tcl] +namespace import -force ::tcltest::internals::* + test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body { lsort } -result {wrong # args: should be "lsort ?-option value ...? list"} @@ -147,6 +150,24 @@ test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} { {{b i g} 12345} {{d e m o} 34512} } } {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}} +test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii [list \0 \x7f \x80 \uffff] +} [list \0 \x7f \x80 \uffff] +test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii -nocase [list \0 \x7f \x80 \uffff] +} [list \0 \x7f \x80 \uffff] +test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff] +} [list \0 \x7f \x80 \uffff \U01ffff] +test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff] +} [list \0 \x7f \x80 \uffff \U01ffff] +test cmdIL-1.41 {lsort -stride and -index} -body { + lsort -stride 2 -index -2 {a 2 b 1} +} -returnCodes error -result {index "-2" out of range} +test cmdIL-1.42 {lsort -stride and-index} -body { + lsort -stride 2 -index -1-1 {a 2 b 1} +} -returnCodes error -result {index "-1-1" out of range} # Can't think of any good tests for the MergeSort and MergeLists procedures, # except a bunch of random lists to sort. @@ -203,6 +224,36 @@ test cmdIL-3.4.1 {SortCompare procedure, -index option} -body { test cmdIL-3.5 {SortCompare procedure, -index option} -body { lsort -integer -index 2 {{20 10 13} {15}} } -returnCodes error -result {element 2 missing from sublist "15"} +test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index 1+3 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {element 4 missing from sublist "1 . c"} +test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index -1-1 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "-1-1" out of range} +test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index -2 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "-2" out of range} +test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index end-4 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {element end-4 missing from sublist "1 . c"} +test cmdIL-3.5.5 {SortCompare procedure, -index option} { + lsort -index {} {a b} +} {a b} +test cmdIL-3.5.6 {SortCompare procedure, -index option} { + lsort -index {} [list a \{] +} {a \{} +test cmdIL-3.5.7 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index end--1 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "end--1" out of range} +test cmdIL-3.5.8 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index end+1 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "end+1" out of range} +test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index end+2 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "end+2" out of range} +test cmdIL-3.5.10 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index 0 {{}} +} -returnCodes error -result {element 0 missing from sublist ""} test cmdIL-3.6 {SortCompare procedure, -index option} { lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}} } {{3 25 20} {2 5 25} {1 15 30}} @@ -219,8 +270,8 @@ test cmdIL-3.10 {SortCompare procedure, -integer option} -body { lsort -integer {3 q} } -returnCodes error -result {expected integer but got "q"} test cmdIL-3.11 {SortCompare procedure, -integer option} { - lsort -integer {35 21 0x20 30 0o23 100 8} -} {8 0o23 21 30 0x20 35 100} + lsort -integer {35 21 0x20 0d30 0o23 100 8} +} {8 0o23 21 0d30 0x20 35 100} test cmdIL-3.12 {SortCompare procedure, -real option} -body { lsort -real {6...4 3} } -returnCodes error -result {expected floating-point number but got "6...4"} @@ -417,6 +468,15 @@ test cmdIL-4.34 {SortCompare procedure, -ascii option with -nocase option} { test cmdIL-4.35 {SortCompare procedure, -ascii option with -nocase option} { lsort -ascii -nocase {d E c B a D35 d300 100 20} } {100 20 a B c d d300 D35 E} +test cmdIL-4.36 {SortCompare procedure, UTF-8 with -nocase option} { + scan [lsort -ascii -nocase [list \u101 \u100]] %c%c%c +} {257 32 256} +test cmdIL-4.37 {SortCompare procedure, UTF-8 with -nocase option} { + scan [lsort -ascii -nocase [list a\u0000a a]] %c%c%c%c%c +} {97 32 97 0 97} +test cmdIL-4.38 {SortCompare procedure, UTF-8 with -nocase option} { + scan [lsort -ascii -nocase [list a a\u0000a]] %c%c%c%c%c +} {97 32 97 0 97} test cmdIL-5.1 {lsort with list style index} { lsort -ascii -decreasing -index {0 1} { @@ -454,7 +514,7 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { foreach e $l {lappend n [list [expr {rand()}] $e]} lindex [lsort -real -index $l $n] 1 1 } - expr srand(1) + expr {srand(1)} test_lsort 0 } -result 0 -cleanup { rename test_lsort "" @@ -462,6 +522,21 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { test cmdIL-5.6 {lsort with multiple list-style index options} { lsort -index {1 2 3} -index 0 {{a b} {c d} {b e}} } {{a b} {b e} {c d}} +test cmdIL-5.7 {lsort memory exhaustion} -constraints {testWithLimit} -body { + # test it in child process (with limited address space) ca. 80MB extra memory + # on x64 system it would be not enough to sort 4M items (the half 2M only), + # warn and skip if no error (enough memory) or error by list creation: + testWithLimit \ + -warn-on-code 0 -warn-on-alloc-error 1 \ + -addmem [expr {$tcl_platform(pointerSize)*4000000 + $tcl_platform(pointerSize)*3*2000000}] \ + { + # create list and get length (avoid too long output in interactive shells): + llength [set l [lrepeat 4000000 ""]] + # test OOM: + llength [lsort $l] + } + # expecting error no memory by sort +} -returnCodes 1 -result {no enough memory to proccess sort of 4000000 items} # Compiled version test cmdIL-6.1 {lassign command syntax} -returnCodes error -body { @@ -717,6 +792,61 @@ test cmdIL-7.8 {lreverse command - shared intrep [Bug 1675044]} -setup { rename K {} } -result 1 +test cmdIL-8.1 {lremove command: error path} -returnCodes error -body { + lremove +} -result {wrong # args: should be "lremove list ?index ...?"} +test cmdIL-8.2 {lremove command: error path} -returnCodes error -body { + lremove {{}{}} +} -result {list element in braces followed by "{}" instead of space} +test cmdIL-8.3 {lremove command: error path} -returnCodes error -body { + lremove {a b c} gorp +} -result {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?} +test cmdIL-8.4 {lremove command: no indices} -body { + lremove {a b c} +} -result {a b c} +test cmdIL-8.5 {lremove command: before start} -body { + lremove {a b c} -1 +} -result {a b c} +test cmdIL-8.6 {lremove command: after end} -body { + lremove {a b c} 3 +} -result {a b c} +test cmdIL-8.7 {lremove command} -body { + lremove {a b c} 0 +} -result {b c} +test cmdIL-8.8 {lremove command} -body { + lremove {a b c} 1 +} -result {a c} +test cmdIL-8.9 {lremove command} -body { + lremove {a b c} end +} -result {a b} +test cmdIL-8.10 {lremove command} -body { + lremove {a b c} end-1 +} -result {a c} +test cmdIL-8.11 {lremove command} -body { + lremove {a b c d e} 1 3 +} -result {a c e} +test cmdIL-8.12 {lremove command} -body { + lremove {a b c d e} 3 1 +} -result {a c e} +test cmdIL-8.13 {lremove command: same index twice} -body { + lremove {a b c d e} 2 2 +} -result {a b d e} +test cmdIL-8.14 {lremove command: same index twice} -body { + lremove {a b c d e} 3 end-1 +} -result {a b c e} +test cmdIL-8.15 {lremove command: many indices} -body { + lremove {a b c d e} 1 3 1 4 0 +} -result {c} + +# This belongs in info test, but adding tests there breaks tests +# that compute source file line numbers. +test info-20.6 {Bug 3587651} -setup { + namespace eval my {namespace eval tcl {namespace eval mathfunc { + proc demo x {return 42} + }}}} -body { namespace eval my {expr {"demo" in [info functions]}}} -cleanup { + namespace delete my +} -result 1 + # cleanup ::tcltest::cleanupTests return diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index 69d7171..37b8a0b 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -6,20 +6,20 @@ # and generates output for errors. No output means no errors were # found. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testcmdinfo [llength [info commands testcmdinfo]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] @@ -101,7 +101,7 @@ test cmdinfo-6.1 {Names for commands created when outside namespaces} \ # cleanup catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1} catch {rename x1 ""} -::tcltest::cleanupTests +cleanupTests return # Local Variables: diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 2d68138..ef9790f 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -4,16 +4,16 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcl::test::cmdMZ { @@ -22,6 +22,7 @@ namespace eval ::tcl::test::cmdMZ { namespace import ::tcltest::makeFile namespace import ::tcltest::removeFile namespace import ::tcltest::temporaryDirectory + namespace import ::tcltest::testConstraint namespace import ::tcltest::test proc ListGlobMatch {expected actual} { @@ -58,7 +59,7 @@ test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} -setup { # This test fails on various unix platforms (eg Linux) where permissions # caching causes this to fail. The caching is strictly incorrect, but we # have no control over that. - file attr . -permissions 000 + file attr . -permissions 0 pwd } -returnCodes error -cleanup { cd $cwd @@ -227,14 +228,14 @@ foreach {testid script} { # More tests of Tcl_SourceObjCmd are in source.test test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints { - unixOrPc + unixOrWin } -returnCodes error -body { source } -match glob -result {wrong # args: should be "source*fileName"} test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints { - unixOrPc + unixOrWin } -returnCodes error -body { - source a b + source a b c d e f } -match glob -result {wrong # args: should be "source*fileName"} test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body { set file [makeFile { @@ -316,6 +317,18 @@ test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { # The tests for Tcl_SubstObjCmd are in subst.test # The tests for Tcl_SwitchObjCmd are in switch.test +# todo: rewrite this if monotonic clock is provided resp. command "after" +# gets microsecond accuracy (RFE [fdfbd5e10] gets merged): +proc _nrt_sleep {msec} { + set usec [expr {$msec * 1000}] + set stime [clock microseconds] + while {abs([clock microseconds] - $stime) < $usec} { + # don't use after 0 unless it's NRT-capable, so yes - busy-wait (but it's more precise): + # after 0 + } +} +_nrt_sleep 0; # warm up (clock, compile, etc) + test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body { time } -returnCodes error -result {wrong # args: should be "time command ?count?"} @@ -331,9 +344,13 @@ test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body { time {format 1} } -match regexp -result {^\d+ microseconds per iteration} -test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} { - expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]} -} 1 +test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} -body { + set m1 [lindex [time {_nrt_sleep 0.01}] 0] + set m2 [lindex [time {_nrt_sleep 10.0}] 0] + list \ + [expr {$m1 < $m2}] \ + $m1 $m2; # interesting only in error case. +} -match glob -result [list 1 *] test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { list [catch {time {error foo}} msg] $msg $::errorInfo } {1 foo {foo @@ -341,6 +358,143 @@ test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { "error foo" invoked from within "time {error foo}"}} +test cmdMZ-5.7.1 {Tcl_TimeObjCmd: return from time} { + set x 0 + proc r1 {} {upvar x x; time {incr x; return "r1"; incr x} 10} + list [r1] $x +} {r1 1} +test cmdMZ-5.8 {Tcl_TimeObjCmd: done optimization: nested call of self inside time (if compiled)} { + set x [set y 0] + set m1 { + if {[incr x] <= 5} { + # nested call should return result, so covering that: + if {![string is integer -strict [eval $m1]]} {error unexpected} + } + # increase again (no "continue" from nested call): + incr x + } + time {incr y; eval $m1} 5 + list $y $x +} {5 20} + +test cmdMZ-6.1 {Tcl_TimeRateObjCmd: basic format of command} { + list [catch {timerate} msg] $msg +} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}} +test cmdMZ-6.2.1 {Tcl_TimeRateObjCmd: basic format of command} { + list [catch {timerate a b c d} msg] $msg +} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}} +test cmdMZ-6.2.2 {Tcl_TimeRateObjCmd: basic format of command} { + list [catch {timerate a b c} msg] $msg +} {1 {expected integer but got "b"}} +test cmdMZ-6.2.3 {Tcl_TimeRateObjCmd: basic format of command} { + list [catch {timerate a b} msg] $msg +} {1 {expected integer but got "b"}} +test cmdMZ-6.3 {Tcl_TimeRateObjCmd: basic format of command} { + list [catch {timerate -overhead b {} a b} msg] $msg +} {1 {expected floating-point number but got "b"}} +test cmdMZ-6.4 {Tcl_TimeRateObjCmd: compile of script happens even with negative iteration counts} { + list [catch {timerate "foreach a {c d e} \{" -12456} msg] $msg +} {1 {missing close-brace}} +test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} { + regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0] +} 1 +test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} { + regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0] +} 1 +test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} -body { + set m1 [timerate {_nrt_sleep 0.01} 50] + set m2 [timerate {_nrt_sleep 1.00} 50] + list [list \ + [expr {[lindex $m1 0] < [lindex $m2 0]}] \ + [expr {[lindex $m1 0] < 100}] \ + [expr {[lindex $m2 0] > 100}] \ + [expr {[lindex $m1 2] > 500}] \ + [expr {[lindex $m2 2] < 500}] \ + [expr {[lindex $m1 4] > 10000}] \ + [expr {[lindex $m2 4] < 10000}] \ + [expr {[lindex $m1 6] > 5 && [lindex $m1 6] < 100}] \ + [expr {[lindex $m2 6] > 5 && [lindex $m2 6] < 100}] \ + ] $m1 $m2; # interesting only in error case. +} -match glob -result [list [lrepeat 9 1] *] +test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} { + list [catch {timerate {error foo} 1} msg] $msg $::errorInfo +} {1 foo {foo + while executing +"error foo" + invoked from within +"timerate {error foo} 1"}} +test cmdMZ-6.7.1 {Tcl_TimeRateObjCmd: return from timerate} { + set x 0 + proc r1 {} {upvar x x; timerate {incr x; return "r1"; incr x} 1000 10} + list [r1] $x +} {r1 1} +test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} -body { + set m1 [timerate {break}] + list [list \ + [expr {[lindex $m1 0] < 1000}] \ + [expr {[lindex $m1 2] == 1}] \ + [expr {[lindex $m1 4] > 1000}] \ + [expr {[lindex $m1 6] < 10}] \ + ] $m1; # interesting only in error case. +} -match glob -result [list {1 1 1 1} *] +test cmdMZ-6.8.1 {Tcl_TimeRateObjCmd: allow (conditional) continue in timerate} -body { + set m1 [timerate {continue; return -code error "unexpected"} 1000 10] + list [list \ + [expr {[lindex $m1 0] < 1000}] \ + [expr {[lindex $m1 2] == 10}] \ + [expr {[lindex $m1 4] > 1000}] \ + [expr {[lindex $m1 6] < 100}] \ + ] $m1; # interesting only in error case. +} -match glob -result [list {1 1 1 1} *] +test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} { + set m1 [timerate {} 1000 5]; # max-count wins + set m2 [timerate {_nrt_sleep 20} 1 5]; # max-time wins + list [lindex $m1 2] [lindex $m2 2] +} {5 1} +test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} -body { + set m1 [timerate -overhead 1e6 {_nrt_sleep 10} 100 1] + list [list \ + [expr {[lindex $m1 0] == 0.0}] \ + [expr {[lindex $m1 2] == 1}] \ + [expr {[lindex $m1 4] == 1000000}] \ + [expr {[lindex $m1 6] <= 0.001}] \ + ] $m1; # interesting only in error case. +} -match glob -result [list {1 1 1 1} *] +test cmdMZ-6.11 {Tcl_TimeRateObjCmd: done/continue optimization rollback} { + set m1 {set m2 ok} + if 1 $m1 + timerate $m1 1000 10 + if 1 $m1; # if rollback is missing throws an error: invoked "continue" outside of a loop +} ok +test cmdMZ-6.12 {Tcl_TimeRateObjCmd: done optimization: nested call of self inside timerate} { + set x 0 + set m1 { + if {[incr x] <= 5} { + # nested call should return result, so covering that: + if {![string is integer -strict [eval $m1]]} {error unexpected} + } + # increase again (no "continue" from nested call): + incr x + } + list [lindex [timerate $m1 1000 5] 2] $x +} {5 20} + +test cmdMZ-try-1.0 { + + fix for issue 45b9faf103f2 + + [try] interaction with local variable names produces segmentation violation + +} -body { + ::apply {{} { + set cmd try + $cmd { + lindex 5 + } on ok res {} + set res + }} +} -result 5 + # The tests for Tcl_WhileObjCmd are in while.test diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index bae26a0..03c5dc9 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -6,25 +6,20 @@ # "compExpr.test". Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { - testConstraint testmathfunctions 0 -} else { - testConstraint testmathfunctions 1 -} +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] # Big test for correct ordering of data in [expr] @@ -84,8 +79,8 @@ proc testIEEE {} { } testConstraint ieeeFloatingPoint [testIEEE] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] # procedures used below @@ -337,16 +332,9 @@ test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 - -# The following test is different for 32-bit versus 64-bit -# architectures because LONG_MIN is different - -test compExpr-old-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { +test compExpr-old-9.5 {CompileRelationalExpr: large shift expr} { expr {int(1<<63)} -} -9223372036854775808 -test compExpr-old-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { - expr {int(1<<31)} -} -2147483648 +} 9223372036854775808 test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} -body { expr x>>3 @@ -590,34 +578,18 @@ test compExpr-old-15.3 {CompileMathFuncCall: too many arguments} -body { test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body { catch {expr sin()} msg set ::errorInfo -} -match glob -result {too few arguments for math function* +} -match glob -result {not enough arguments for math function* while *ing "expr sin()"} -test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body { +test compExpr-old-15.5 {CompileMathFuncCall: not enough arguments} -body { catch {expr pow(1)} msg set ::errorInfo -} -match glob -result {too few arguments for math function* +} -match glob -result {not enough arguments for math function* while *ing "expr pow(1)"} test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * -test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr 2*T1() -} 246 -test compExpr-old-15.8 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T2()*3 -} 1035 -test compExpr-old-15.9 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T3(21, 37) -} 37 -test compExpr-old-15.10 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T3(21.2, 37) -} 37.0 -test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T3(-21.2, -17.5) -} -17.5 - test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { catch {unset a} set a(VALUE) ff15 diff --git a/tests/compExpr.test b/tests/compExpr.test index 14c875d..eaef772 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -2,25 +2,19 @@ # tclCompExpr.c. Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { - testConstraint testmathfunctions 0 -} else { - testConstraint testmathfunctions 1 -} +catch [list package require -exact tcl::test [info patchlevel]] # Constrain memory leak tests testConstraint memory [llength [info commands memory]] @@ -314,22 +308,16 @@ test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} { } {0 15} test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { - format %.6g [expr atan2(1.0, 2.0)] + format %.6g [expr {atan2(1.0, 2.0)}] } 0.463648 test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body { expr {do_it()} } -returnCodes error -match glob -result {* "*do_it"} -test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr 3*T1()-1 -} 368 -test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T2()*3 -} 1035 -test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body { +test compExpr-5.5 {CompileMathFuncCall procedure, not enough arguments} -body { expr {atan2(1.0)} -} -returnCodes error -match glob -result {too few arguments for math function*} +} -returnCodes error -match glob -result {not enough arguments for math function*} test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} { - format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))] + format %.6g [expr {pow(2.1, 27.5-(24.4*(5%2)))}] } 9.97424 test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} -body { expr {sinh(2.*)} @@ -353,9 +341,9 @@ test compExpr-7.1 {Memory Leak} -constraints memory -setup { } -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { - interp create slave - slave eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13 - interp delete slave + interp create child + child eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13 + interp delete child set tmp $end set end [getbytes] } @@ -383,10 +371,46 @@ test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setu unset end i tmp rename getbytes {} } -result 0 + +proc extract {opcodes descriptor} { + set instructions [dict values [dict get $descriptor instructions]] + return [lmap i $instructions { + if {[lindex $i 0] in $opcodes} {string cat $i} else continue + }] +} + +test compExpr-8.1 {TIP 582: expression comments} -setup {} -body { + extract {loadStk add} [tcl::unsupported::getbytecode script {expr { + $abc + # + $def + + $ghi + }}] +} -result {loadStk loadStk add} +test compExpr-8.2 {TIP 582: expression comments} -setup {} -body { + extract {loadStk add} [tcl::unsupported::getbytecode script {expr { + $abc + # + $def + # + $ghi }}] +} -result loadStk +test compExpr-8.3 {TIP 582: expression comments} -setup {} -body { + extract {loadStk add} [tcl::unsupported::getbytecode script {expr { + $abc + # + $def\ + + $ghi + }}] +} -result loadStk +test compExpr-8.4 {TIP 582: expression comments} -setup {} -body { + extract {loadStk add} [tcl::unsupported::getbytecode script {expr { + $abc + # + $def\\ + + $ghi + }}] +} -result {loadStk loadStk add} # cleanup catch {unset a} catch {unset b} +catch {rename extract ""} ::tcltest::cleanupTests return diff --git a/tests/compile.test b/tests/compile.test index 4d91940..23d81dd 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -5,17 +5,20 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint exec [llength [info commands exec]] testConstraint memory [llength [info commands memory]] @@ -122,7 +125,7 @@ test compile-3.4 {TclCompileCatchCmd: bcc'ed [return] is caught} { proc foo {} { set fail [catch { return 1 - }] ; # {} + }] ; # {} return 2 } foo @@ -132,8 +135,8 @@ test compile-3.5 {TclCompileCatchCmd: recover from error, [Bug 705406]} { catch { if {[a]} { if b {} - } - } + } + } } list [catch foo msg] $msg } {0 1} @@ -167,11 +170,41 @@ test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*} -cleanup {namespace delete catchtest} } +test compile-3.7 {TclCompileCatchCmd: error in storing options [Bug 3098302]} {*}{ + -setup { + namespace eval catchtest { + variable options1 {} + } + trace add variable catchtest::options1 write catchtest::failtrace + proc catchtest::failtrace {n1 n2 op} { + return -code error "trace on $n1 fails by request" + } + } + -body { + proc catchtest::x {} { + variable options1 + set count 0 + for {set i 0} {$i < 10} {incr i} { + set status2 [catch { + set status1 [catch { + return -code error -level 0 "original failure" + } result1 options1] + } result2 options2] + incr count + } + list $count $result2 + } + catchtest::x + } + -result {10 {can't set "options1": trace on options1 fails by request}} + -cleanup {namespace delete catchtest} +} + test compile-4.1 {TclCompileForCmd: command substituted test expression} { set i 0 set j 0 # Should be "forever" - for {} [expr $i < 3] {} { + for {} [expr {$i < 3}] {} { set j [incr i] if {$j > 3} break } @@ -194,6 +227,17 @@ test compile-5.2 {TclCompileForeachCmd: non-local variables} { foreach-test set ::foo } 3 +test compile-5.3 {TclCompileForeachCmd: [Bug b9b2079e6d]} -setup { + proc demo {} { + foreach x y { + if 1 break else + } + } +} -body { + demo +} -cleanup { + rename demo {} +} -returnCodes error -result {wrong # args: no script following "else" argument} test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} -setup { catch {unset x} @@ -234,7 +278,7 @@ test compile-7.1 {TclCompileWhileCmd: command substituted test expression} { set i 0 set j 0 # Should be "forever" - while [expr $i < 3] { + while [expr {$i < 3}] { set j [incr i] if {$j > 3} break } @@ -293,7 +337,7 @@ test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; incr}} } -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { - apply {{} { set r [list foobar] ; expr !a }} + apply {{} { set r [list foobar] ; expr [concat !a] }} } -returnCodes error -match glob -result * test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; expr {!a} }} @@ -303,13 +347,13 @@ test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { list [catch {p} msg] $msg } -returnCodes error -result {unmatched open brace in list} -# +# # Special section for tests of tclLiteral.c # The following tests check for incorrect memory handling in # TclReleaseLiteral. They are only effective when tcl is compiled with # TCL_MEM_DEBUG # -# Special test for leak on interp delete [Bug 467523]. +# Special test for leak on interp delete [Bug 467523]. test compile-12.1 {testing literal leak on interp delete} -setup { proc getbytes {} { set lines [split [memory info] "\n"] @@ -318,10 +362,10 @@ test compile-12.1 {testing literal leak on interp delete} -setup { } -constraints memory -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { - interp create foo - foo eval { + interp create foo + foo eval { namespace eval bar {} - } + } interp delete foo set tmp $end set end [getbytes] @@ -342,7 +386,7 @@ test compile-12.2 {testing error on literal deletion} -constraints {memory exec} } puts 0 } source.file] - exec [interpreter] $sourceFile + exec [interpreter] $sourceFile } -cleanup { catch {removeFile $sourceFile} } -result 0 @@ -425,14 +469,83 @@ 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 of nested compile (body in body compilation), should not generate stack overflow +# (with abnormal program termination), bug [fec0c17d39]: +proc _ti_gencode {} { + # creates test interpreter on demand with [gencode] generator: + if {[interp exists ti]} { + return + } + interp create ti + ti eval {proc gencode {nr {cmd eval} {nl 0}} { + set code "" + set e ""; if {$nl} {set e "\n"} + for {set i 0} {$i < $nr} {incr i} { + append code "$cmd \{$e" + } + append code "lappend result 1$e" + for {set i 0} {$i < $nr} {incr i} { + append code "\}$e" + } + #puts [format "%% %.40s ... %d bytes" $code [string length $code]] + return $code + }} +} +test compile-13.2 {TclCompileScript: testing expected nested scripts compilation} -setup { + _ti_gencode + interp recursionlimit ti [expr {10000+50}] + ti eval {set result {}} +} -body { + # Test different compilation variants (instructions evalStk, invokeStk, etc), + # with 1500 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack + # boxes or systems, please don't decrease it (either provide a constraint) + ti eval {foreach cmd {eval "if 1" try catch} { + set c [gencode [expr {![::tcl::pkgconfig get debug] ? 1500 : 1000}] $cmd] + if 1 $c + }} + ti eval {set result} +} -result {1 1 1 1} +test compile-13.3 {TclCompileScript: testing check of max depth by nested scripts compilation} -setup { + _ti_gencode + interp recursionlimit ti 100 + ti eval {set result {}} +} -body { + # Test different compilation variants (instructions evalStk, invokeStk, etc), + # with 500 nested scripts (bodies). It must generate "too many nested compilations" + # error for any variant we're testing here: + ti eval {foreach cmd {eval "if 1" try catch} { + set c [gencode 500 $cmd] + lappend errors [catch $c e] $e + }} + #puts $errors + # all of nested calls exceed the limit, so must end with "too many nested compilations" + # (or evaluations, depending on compile method/instruction and "mixed" compile within + # evaliation), so no one succeeds, the result must be empty: + ti eval {set result} +} -result {} +# +# clean up: +if {[interp exists ti]} { + interp delete ti +} +rename _ti_gencode {} + +# Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342] test compile-14.1 {testing errors in element name; segfault?} {} { catch {set a([error])} msg1 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]} { apply {{} {catch return}} @@ -450,9 +563,10 @@ test compile-15.5 {proper TCL_RETURN code from [return]} { apply {{} {catch {set a 1}; return}} } "" -for {set noComp 0} {$noComp <= 1} {incr noComp} { +# Do all tests once byte compiled and once with direct string evaluation +foreach noComp {0 1} { -if $noComp { +if {$noComp} { interp alias {} run {} testevalex set constraints testevalex } else { @@ -628,12 +742,15 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup # does not check the format of disassembled bytecode though; that's liable to # change without warning. +set disassemblables [linsert [join { + constructor destructor lambda method objmethod proc script +} ", "] end-1 or] test compile-18.1 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble } -match glob -result {wrong # args: should be "*"} test compile-18.2 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble ? -} -match glob -result {bad type "?": must be *} +} -result "bad type \"?\": must be $disassemblables" test compile-18.3 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble lambda } -match glob -result {wrong # args: should be "* lambda lambdaTerm"} @@ -707,6 +824,286 @@ test compile-18.19 {disassembler - basics} -setup { } -cleanup { foo destroy } -match glob -result * +# There never was a compile-18.20. +# The keys of the dictionary produced by [getbytecode] are defined. +set bytecodekeys {literals variables exception instructions auxiliary commands script namespace stackdepth exceptdepth} +test compile-18.21 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode +} -match glob -result {wrong # args: should be "*"} +test compile-18.22 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode ? +} -result "bad type \"?\": must be $disassemblables" +test compile-18.23 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode lambda +} -match glob -result {wrong # args: should be "* lambda lambdaTerm"} +test compile-18.24 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode lambda \{ +} -result "can't interpret \"\{\" as a lambda expression" +test compile-18.25 {disassembler - basics} -body { + dict keys [tcl::unsupported::getbytecode lambda {{} {}}] +} -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.26 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode proc +} -match glob -result {wrong # args: should be "* proc procName"} +test compile-18.27 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode proc nosuchproc +} -result {"nosuchproc" isn't a procedure} +test compile-18.28 {disassembler - basics} -setup { + proc chewonthis {} {} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename chewonthis {} +} -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.28.1 {disassembler - tricky bit} -setup { + eval [list proc chewonthis {} {}] +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename chewonthis {} +} -result $bytecodekeys +test compile-18.28.2 {disassembler - tricky bit} -setup { + eval {proc chewonthis {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename chewonthis {} +} -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.28.3 {disassembler - tricky bit} -setup { + proc Proc {n a b} { + proc $n $a $b + } + Proc chewonthis {} {} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename Proc {} + rename chewonthis {} +} -result $bytecodekeys +test compile-18.28.4 {disassembler - tricky bit} -setup { + proc Proc {n a b} { + tailcall proc $n $a $b + } + Proc chewonthis {} {} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename Proc {} + rename chewonthis {} +} -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.29 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode script +} -match glob -result {wrong # args: should be "* script script"} +test compile-18.30 {disassembler - basics} -body { + dict keys [tcl::unsupported::getbytecode script {}] +} -result $bytecodekeys +test compile-18.31 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method +} -match glob -result {wrong # args: should be "* method className methodName"} +test compile-18.32 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method nosuchclass foo +} -result {nosuchclass does not refer to an object} +test compile-18.33 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::getbytecode method justanobject foo +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.34 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode method oo::object nosuchmethod +} -result {unknown method "nosuchmethod"} +test compile-18.35 {disassembler - basics} -setup { + oo::class create foo {method bar {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode method foo bar] +} -cleanup { + foo destroy +} -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.36 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod +} -match glob -result {wrong # args: should be "* objmethod objectName methodName"} +test compile-18.37 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod nosuchobject foo +} -result {nosuchobject does not refer to an object} +test compile-18.38 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode objmethod oo::object nosuchmethod +} -result {unknown method "nosuchmethod"} +test compile-18.39 {disassembler - basics} -setup { + oo::object create foo + oo::objdefine foo {method bar {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode objmethod foo bar] +} -cleanup { + foo destroy +} -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.40 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble constructor +} -match glob -result {wrong # args: should be "* constructor className"} +test compile-18.41 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble constructor nosuchclass +} -result {nosuchclass does not refer to an object} +test compile-18.42 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::disassemble constructor justanobject +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.43 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::disassemble constructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined constructor} +test compile-18.44 {disassembler - basics} -setup { + oo::class create foo {constructor {} {set x 1}} +} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble constructor foo +} -cleanup { + foo destroy +} -match glob -result * +test compile-18.45 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode constructor +} -match glob -result {wrong # args: should be "* constructor className"} +test compile-18.46 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode constructor nosuchobject +} -result {nosuchobject does not refer to an object} +test compile-18.47 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::getbytecode constructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined constructor} +test compile-18.48 {disassembler - basics} -setup { + oo::class create foo {constructor {} {set x 1}} +} -body { + dict keys [tcl::unsupported::getbytecode constructor foo] +} -cleanup { + foo destroy +} -result "$bytecodekeys" +# There is no compile-18.49 +test compile-18.50 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble destructor +} -match glob -result {wrong # args: should be "* destructor className"} +test compile-18.51 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble destructor nosuchclass +} -result {nosuchclass does not refer to an object} +test compile-18.52 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::disassemble destructor justanobject +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.53 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::disassemble destructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined destructor} +test compile-18.54 {disassembler - basics} -setup { + oo::class create foo {destructor {set x 1}} +} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble destructor foo +} -cleanup { + foo destroy +} -match glob -result * +test compile-18.55 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode destructor +} -match glob -result {wrong # args: should be "* destructor className"} +test compile-18.56 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode destructor nosuchobject +} -result {nosuchobject does not refer to an object} +test compile-18.57 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::getbytecode destructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined destructor} +test compile-18.58 {disassembler - basics} -setup { + oo::class create foo {destructor {set x 1}} +} -body { + dict keys [tcl::unsupported::getbytecode destructor foo] +} -cleanup { + foo destroy +} -result "$bytecodekeys" + +test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { + # This will panic in a --enable-symbols=compile build, unless bug is fixed. + apply {{} {list [if 1]}} +} -returnCodes error -match glob -result * + +test compile-20.1 {ensure there are no infinite loops in optimizing} { + tcl::unsupported::disassemble script { + while 1 { + return -code continue -level 0 + } + } + return +} {} +test compile-20.2 {ensure there are no infinite loops in optimizing} { + tcl::unsupported::disassemble script { + while 1 { + while 1 { + return -code break -level 0 + } + } + } + return +} {} + +test compile-21.1 {stack balance management} { + apply {{} { + set result {} + while 1 { + lappend result a + lappend result [list b [break]] + lappend result c + } + return $result + }} +} a +test compile-21.2 {stack balance management} { + apply {{} { + set result {} + while {[incr i] <= 10} { + lappend result $i + lappend result [list b [continue] c] + lappend result c + } + return $result + }} +} {1 2 3 4 5 6 7 8 9 10} +test compile-21.3 {stack balance management} { + apply {args { + set result {} + while 1 { + lappend result a + lappend result [concat {*}$args [break]] + lappend result c + } + return $result + }} P Q R S T +} a +test compile-21.4 {stack balance management} { + apply {args { + set result {} + while {[incr i] <= 10} { + lappend result $i + lappend result [concat {*}$args [continue] c] + lappend result c + } + return $result + }} P Q R S T +} {1 2 3 4 5 6 7 8 9 10} + # TODO sometime - check that bytecode from tbcload is *not* disassembled. # cleanup diff --git a/tests/concat.test b/tests/concat.test index eeb11ca..976591e 100644 --- a/tests/concat.test +++ b/tests/concat.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/config.test b/tests/config.test index d14837e..f87250a 100644 --- a/tests/config.test +++ b/tests/config.test @@ -5,21 +5,21 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test pkgconfig-1.1 {query keys} { lsort [::tcl::pkgconfig list] -} {64bit bindir,install bindir,runtime compile_debug compile_stats debug docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded} +} {64bit bindir,install bindir,runtime compile_debug compile_stats debug dllfile,runtime docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded zipfile,runtime} test pkgconfig-1.2 {query keys multiple times} { string compare [::tcl::pkgconfig list] [::tcl::pkgconfig list] } 0 diff --git a/tests/coroutine.test b/tests/coroutine.test index 8272717..b129c03 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -1,21 +1,21 @@ -# Commands covered: coroutine, yield, [info coroutine] +# Commands covered: coroutine, yield, yieldto, [info coroutine] # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. # -# Copyright (c) 2008 by Miguel Sofer. +# Copyright © 2008 Miguel Sofer. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testnrelevels [llength [info commands testnrelevels]] testConstraint memory [llength [info commands memory]] @@ -66,7 +66,7 @@ test coroutine-1.3 {yield returns new arg} -setup { incr i } } - coroutine foo ::apply [list {{start 2} {stop 10}} $body] + coroutine foo ::apply [list {{start 2} {stop 10}} $body] set res {} } -body { for {set k 1} {$k < 4} {incr k} { @@ -342,6 +342,9 @@ test coroutine-3.6 {info frame, bug #2910094} -setup { rename stack {} rename a {} } -result {} +test coroutine-3.7 {bug 0b874c344d} { + dict get [coroutine X coroutine Y info frame 0] cmd +} {coroutine X coroutine Y info frame 0} test coroutine-4.1 {bug #2093188} -setup { proc foo {} { @@ -439,7 +442,7 @@ test coroutine-4.5 {bug #2724403} -constraints {memory} \ } -result 0 test coroutine-4.6 {compile context, bug #3282869} -setup { - unset ::x + unset -nocomplain ::x proc f x { coroutine D eval {yield X$x;yield Y} } @@ -473,7 +476,7 @@ test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} expr {[lindex [testnrelevels] 1] - 1} } proc relativeLevel base { - # remove the level for this proc's call + # remove the level for this proc's call expr {[getNumLevel] - $base - 1} } proc foo {} { @@ -514,7 +517,7 @@ test coroutine-5.2 {right numLevels within coro} -constraints {testnrelevels} \ expr {[lindex [testnrelevels] 1] - 1} } proc relativeLevel base { - # remove the level for this proc's call + # remove the level for this proc's call expr {[getNumLevel] - $base - 1} } proc foo base { @@ -585,7 +588,7 @@ test coroutine-7.2 {multi-argument yielding with yieldto} -body { coroutine a corobody coroutine b corobody list [a x] [a y z] [a \{p] [a \{q r] [a] [a] [rename a {}] \ - [b ok] [rename b {}] + [b ok] [rename b {}] } -cleanup { rename corobody {} } -result {x {y z 2} \{p {\{q r 2} {} 0 {} ok {}} @@ -609,6 +612,406 @@ test coroutine-7.3 {yielding between coroutines} -body { } -cleanup { catch {rename juggler ""} } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} +test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { + proc foo {a b} {catch yield; return 1} +} -cleanup { + rename foo {} +} -body { + coroutine demo lsort -command foo {a b} +} -result {b a} +test coroutine-7.5 {return codes} { + set result {} + foreach code {0 1 2 3 4 5} { + lappend result [catch {coroutine demo return -level 0 -code $code}] + } + set result +} {0 1 2 3 4 5} +test coroutine-7.6 {Early yield crashes} -setup { + set i [interp create] +} -body { + # Force into a child interpreter [bug 60559fd4a6] + $i eval { + proc foo args {} + trace add execution foo enter {catch yield} + coroutine demo foo + rename foo {} + return ok + } +} -cleanup { + interp delete $i +} -result ok +test coroutine-7.7 {Bug 2486550} -setup { + set i [interp create] + $i hide yield +} -body { + # Force into a child interpreter [bug 60559fd4a6] + $i eval { + coroutine demo interp invokehidden {} yield ok + } +} -cleanup { + $i eval demo + interp delete $i +} -result ok +test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + lappend ::result a + yield OUT + lappend ::result b + yieldto ::return -level 0 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + namespace delete cotest + namespace eval cotest {} + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + set y ::yieldto + lappend ::result a + yield OUT + lappend ::result b + $y ::return -level 0 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + namespace delete cotest + namespace eval cotest {} + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + lappend ::result a + yield OUT + lappend ::result b + yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + set y ::yieldto + lappend ::result a + yield OUT + lappend ::result b + $y ::return -level 0 -cotest [namespace delete ::cotest] 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.12 {coro floor above street level #3008307} -body { + proc c {} { + yield + } + proc cc {} { + coroutine C c + } + proc boom {} { + cc ; # coro created at level 2 + C ; # and called at level 1 + } + boom ; # does not crash: the coro floor is a good insulator + list +} -cleanup { + rename boom {}; rename cc {}; rename c {} +} -result {} + +test coroutine-8.0.0 {coro inject executed} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + demo + set ::result none + tcl::unsupported::inject demo set ::result inject-executed + demo + set ::result +} -result {inject-executed} +test coroutine-8.0.1 {coro inject after error} -body { + coroutine demo apply {{} { foreach i {1 2} yield; error test }} + demo + set ::result none + tcl::unsupported::inject demo set ::result inject-executed + lappend ::result [catch {demo} err] $err +} -result {inject-executed 1 test} +test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body { + interp create child + child eval { + coroutine demo apply {{} { while {1} yield }} + demo + tcl::unsupported::inject demo set ::result inject-executed + } + interp delete child +} -result {} +test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { + interp create child + child eval { + coroutine demo apply {{} { while {1} yield }} + demo + tcl::unsupported::inject demo set ::result inject-executed + } + child eval demo + set result [child eval {set ::result}] + + interp delete child + set result +} -result {inject-executed} + +test coroutine-9.1 {coroprobe with yield} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + list [coroprobe demo set i] [demo] [coroprobe demo set i] [demo] +} -cleanup { + catch {rename demo {}} +} -result {1 {} 2 {}} +test coroutine-9.2 {coroprobe with yieldto} -body { + coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }} + list [coroprobe demo set i] [demo a b] [coroprobe demo set i] [demo c d] +} -cleanup { + catch {rename demo {}} +} -result {1 {} 2 {{a b} {c d}}} +test coroutine-9.3 {coroprobe errors} -setup { + catch {rename demo {}} +} -body { + coroprobe demo set i +} -returnCodes error -result {can only inject a probe command into a coroutine} +test coroutine-9.4 {coroprobe errors} -body { + proc demo {} { foreach i {1 2} yield } + coroprobe demo set i +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {can only inject a probe command into a coroutine} +test coroutine-9.5 {coroprobe errors} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroprobe +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"} +test coroutine-9.6 {coroprobe errors} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroprobe demo +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "coroprobe coroName cmd ?arg1 arg2 ...?"} +test coroutine-9.7 {coroprobe errors in probe command} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroprobe demo set +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "set varName ?newValue?"} +test coroutine-9.8 {coroprobe errors in probe command} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + list [catch {coroprobe demo set}] [demo] [coroprobe demo set i] +} -cleanup { + catch {rename demo {}} +} -result {1 {} 2} +test coroutine-9.9 {coroprobe: advanced features} -setup { + set i [interp create] +} -body { + $i eval { + coroutine demo apply {{} { + set f [info level],[info frame] + foreach i {1 2} yield + }} + coroprobe demo apply {{} { + upvar 1 f f + list [info coroutine] [info level] [info frame] $f + }} + } +} -cleanup { + interp delete $i +} -result {::demo 2 3 1,2} + +test coroutine-10.1 {coroinject with yield} -setup { + set result {} +} -body { + coroutine demo apply {{} { lmap i {1 2} yield }} + coroinject demo apply {{op val} {lappend ::result $op $val}} + list $result [demo x] [demo y] $result +} -cleanup { + catch {rename demo {}} +} -result {{} {} {{yield x} y} {yield x}} +test coroutine-10.2 {coroinject stacking} -setup { + set result {} +} -body { + coroutine demo apply {{} { lmap i {1 2} yield }} + coroinject demo apply {{op val} {lappend ::result $op $val A;return $val}} + coroinject demo apply {{op val} {lappend ::result $op $val B;return $val}} + list $result [demo x] [demo y] $result +} -cleanup { + catch {rename demo {}} +} -result {{} {} {x y} {yield x B yield x A}} +test coroutine-10.3 {coroinject with yieldto} -setup { + set result {} +} -body { + coroutine demo apply {{} { lmap i {1 2} {yieldto string cat} }} + coroinject demo apply {{op val} {lappend ::result $op $val;return $val}} + list $result [demo x mp] [demo y le] $result +} -cleanup { + catch {rename demo {}} +} -result {{} {} {{x mp} {y le}} {yieldto {x mp}}} +test coroutine-10.4 {coroinject errors} -setup { + catch {rename demo {}} +} -body { + coroinject demo set i +} -returnCodes error -result {can only inject a command into a coroutine} +test coroutine-10.5 {coroinject errors} -body { + proc demo {} { foreach i {1 2} yield } + coroinject demo set i +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {can only inject a command into a coroutine} +test coroutine-10.6 {coroinject errors} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroinject +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"} +test coroutine-10.7 {coroinject errors} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroinject demo +} -returnCodes error -cleanup { + catch {rename demo {}} +} -result {wrong # args: should be "coroinject coroName cmd ?arg1 arg2 ...?"} +test coroutine-10.8 {coroinject errors in injected command} -body { + coroutine demo apply {{} { foreach i {1 2} yield }} + coroinject demo apply {args {error "ERR: $args"}} + list [catch demo msg] $msg [catch demo msg] $msg +} -cleanup { + catch {rename demo {}} +} -result {1 {ERR: yield {}} 1 {invalid command name "demo"}} +test coroutine-10.9 {coroinject: advanced features} -setup { + set i [interp create] +} -body { + $i eval { + coroutine demo apply {{} { + set l [info level] + set f [info frame] + lmap i {1 2} yield + }} + coroinject demo apply {{arg op val} { + global result + upvar 1 f f l l + lappend result [info coroutine] $arg $op $val + lappend result [info level] $l [info frame] $f + lappend result [yield $arg] + return [string toupper $val] + }} grill + list [demo ABC] [demo pqr] [demo def] $result + } +} -cleanup { + interp delete $i +} -result {grill {} {ABC def} {::demo grill yield ABC 2 1 3 2 pqr}} + +test coroutine-11.1 {coro type} { + coroutine demo eval { + yield + yield "PHASE 1" + yieldto string cat "PHASE 2" + ::tcl::unsupported::corotype [info coroutine] + } + list [demo] [::tcl::unsupported::corotype demo] \ + [demo] [::tcl::unsupported::corotype demo] [demo] +} {{PHASE 1} yield {PHASE 2} yieldto active} +test coroutine-11.2 {coro type} -setup { + catch {rename nosuchcommand ""} +} -returnCodes error -body { + ::tcl::unsupported::corotype nosuchcommand +} -result {can only get coroutine type of a coroutine} +test coroutine-11.3 {coro type} -returnCodes error -body { + proc notacoroutine {} {} + ::tcl::unsupported::corotype notacoroutine +} -returnCodes error -cleanup { + rename notacoroutine {} +} -result {can only get coroutine type of a coroutine} + +test coroutine-12.1 {coroutine general introspection} -setup { + set i [interp create] +} -body { + $i eval { + # Make the introspection code + namespace path tcl::unsupported + proc probe {type var} { + upvar 1 $var v + set f [info frame] + incr f -1 + set result [list $v [dict get [info frame $f] proc]] + if {$type eq "yield"} { + tailcall yield $result + } else { + tailcall yieldto string cat $result + } + } + proc pokecoro {c var} { + inject $c probe [corotype $c] $var + $c + } + + # Coroutine implementations + proc cbody1 {} { + set val [info coroutine] + set accum {} + while {[set val [yield $val]] ne ""} { + lappend accum $val + set val ok + } + return $accum + } + proc cbody2 {} { + set val [info coroutine] + set accum {} + while {[llength [set val [yieldto string cat $val]]]} { + lappend accum {*}$val + set val ok + } + return $accum + } + + # Make the coroutines + coroutine c1 cbody1 + coroutine c2 cbody2 + list [c1 abc] [c2 1 2 3] [pokecoro c1 accum] [pokecoro c2 accum] \ + [c1 def] [c2 4 5 6] [pokecoro c1 accum] [pokecoro c2 accum] \ + [c1] [c2] + } +} -cleanup { + interp delete $i +} -result {ok ok {abc ::cbody1} {{1 2 3} ::cbody2} ok ok {{abc def} ::cbody1} {{1 2 3 4 5 6} ::cbody2} {abc def} {1 2 3 4 5 6}} # cleanup unset lambda diff --git a/tests/dcall.test b/tests/dcall.test index 3df0ac8..e407e48 100644 --- a/tests/dcall.test +++ b/tests/dcall.test @@ -4,20 +4,20 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testdcall [llength [info commands testdcall]] @@ -41,5 +41,5 @@ test dcall-1.6 {deletion callbacks} testdcall { } {} # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/dict.test b/tests/dict.test index 77bacf6..d67f703 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -5,12 +5,12 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 2003-2009 Donal K. Fellows +# Copyright © 2003-2009 Donal K. Fellows # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -78,6 +78,24 @@ test dict-2.7 {dict create command - #-quoting in string rep} { test dict-2.8 {dict create command - #-quoting in string rep} -body { dict create #a x #b x } -match glob -result {{#?} x #? x} +test dict-2.9 {dict create command: compilation} { + apply {{} {dict create [format a] b}} +} {a b} +test dict-2.10 {dict create command: compilation} { + apply {{} {dict create [format a] b c d}} +} {a b c d} +test dict-2.11 {dict create command: compilation} { + apply {{} {dict create [format a] b c d a x}} +} {a x c d} +test dict-2.12 {dict create command: non-compilation} { + dict create [format a] b +} {a b} +test dict-2.13 {dict create command: non-compilation} { + dict create [format a] b c d +} {a b c d} +test dict-2.14 {dict create command: non-compilation} { + dict create [format a] b c d a x +} {a x c d} test dict-3.1 {dict get command} {dict get {a b} a} b test dict-3.2 {dict get command} {dict get {a b c d} a} b @@ -149,6 +167,43 @@ test dict-4.8 {dict replace command} -returnCodes error -body { } -result {missing value to go with key} test dict-4.9 {dict replace command} {dict replace [list a a] a b} {a b} test dict-4.10 {dict replace command} {dict replace [list a a] a b a c} {a c} +test dict-4.11 {dict replace command: canonicality is forced} { + dict replace { a b c d } +} {a b c d} +test dict-4.12 {dict replace command: canonicality is forced} { + dict replace {a b c d a e} +} {a e c d} +test dict-4.13 {dict replace command: type check is mandatory} -body { + dict replace { a b c d e } +} -errorCode {TCL VALUE DICTIONARY} -result {missing value to go with key} +test dict-4.14 {dict replace command: type check is mandatory} -body { + dict replace { a b {}c d } +} -returnCodes error -result {dict element in braces followed by "c" instead of space} +test dict-4.14a {dict replace command: type check is mandatory} { + catch {dict replace { a b {}c d }} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY JUNK} +test dict-4.15 {dict replace command: type check is mandatory} -body { + dict replace { a b ""c d } +} -returnCodes error -result {dict element in quotes followed by "c" instead of space} +test dict-4.15a {dict replace command: type check is mandatory} { + catch {dict replace { a b ""c d }} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY JUNK} +test dict-4.16 {dict replace command: type check is mandatory} -body { + dict replace " a b \"c d " +} -returnCodes error -result {unmatched open quote in dict} +test dict-4.16a {dict replace command: type check is mandatory} { + catch {dict replace " a b \"c d "} -> opt + dict get $opt -errorcode +} {TCL VALUE DICTIONARY QUOTE} +test dict-4.17 {dict replace command: type check is mandatory} -body { + dict replace " a b \{c d " +} -errorCode {TCL VALUE DICTIONARY BRACE} -result {unmatched open brace in dict} +test dict-4.18 {dict replace command: canonicality forcing doesn't leak} { + set example { a b c d } + list $example [dict replace $example] +} {{ a b c d } {a b c d}} test dict-5.1 {dict remove command} {dict remove {a b c d} a} {c d} test dict-5.2 {dict remove command} {dict remove {a b c d} c} {a b} @@ -161,6 +216,25 @@ test dict-5.6 {dict remove command} {dict remove {a b} c} {a b} test dict-5.7 {dict remove command} -returnCodes error -body { dict remove } -result {wrong # args: should be "dict remove dictionary ?key ...?"} +test dict-5.8 {dict remove command: canonicality is forced} { + dict remove { a b c d } +} {a b c d} +test dict-5.9 {dict remove command: canonicality is forced} { + dict remove {a b c d a e} +} {a e c d} +test dict-5.10 {dict remove command: canonicality forced by update} { + dict remove { a b c d } c +} {a b} +test dict-5.11 {dict remove command: type check is mandatory} -body { + dict remove { a b c d e } +} -returnCodes error -result {missing value to go with key} +test dict-5.12 {dict remove command: type check is mandatory} -body { + dict remove { a b {}c d } +} -returnCodes error -result {dict element in braces followed by "c" instead of space} +test dict-5.13 {dict remove command: canonicality forcing doesn't leak} { + set example { a b c d } + list $example [dict remove $example] +} {{ a b c d } {a b c d}} test dict-6.1 {dict keys command} {dict keys {a b}} a test dict-6.2 {dict keys command} {dict keys {c d}} c @@ -327,13 +401,13 @@ test dict-11.13 {dict incr command} -returnCodes error -body { dict incr dictv a a a } -cleanup { unset dictv -} -result {wrong # args: should be "dict incr varName key ?increment?"} +} -result {wrong # args: should be "dict incr dictVarName key ?increment?"} test dict-11.14 {dict incr command} -returnCodes error -body { set dictv a dict incr dictv } -cleanup { unset dictv -} -result {wrong # args: should be "dict incr varName key ?increment?"} +} -result {wrong # args: should be "dict incr dictVarName key ?increment?"} test dict-11.15 {dict incr command: write failure} -setup { unset -nocomplain dictVar } -body { @@ -404,10 +478,10 @@ test dict-12.6 {dict lappend command} -returnCodes error -body { } -result {missing value to go with key} test dict-12.7 {dict lappend command} -returnCodes error -body { dict lappend -} -result {wrong # args: should be "dict lappend varName key ?value ...?"} +} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"} test dict-12.8 {dict lappend command} -returnCodes error -body { dict lappend dictv -} -result {wrong # args: should be "dict lappend varName key ?value ...?"} +} -result {wrong # args: should be "dict lappend dictVarName key ?value ...?"} test dict-12.9 {dict lappend command} -returnCodes error -body { set dictv [dict create a "\{"] dict lappend dictv a a @@ -471,10 +545,10 @@ test dict-13.6 {dict append command} -returnCodes error -body { } -result {missing value to go with key} test dict-13.7 {dict append command} -returnCodes error -body { dict append -} -result {wrong # args: should be "dict append varName key ?value ...?"} +} -result {wrong # args: should be "dict append dictVarName key ?value ...?"} test dict-13.8 {dict append command} -returnCodes error -body { dict append dictv -} -result {wrong # args: should be "dict append varName key ?value ...?"} +} -result {wrong # args: should be "dict append dictVarName key ?value ...?"} test dict-13.9 {dict append command: write failure} -setup { unset -nocomplain dictVar } -body { @@ -492,16 +566,16 @@ test dict-13.11 {compiled dict append: invalidate string rep - Bug 3079830} { test dict-14.1 {dict for command: syntax} -returnCodes error -body { dict for -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.2 {dict for command: syntax} -returnCodes error -body { dict for x -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.3 {dict for command: syntax} -returnCodes error -body { dict for x x -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.4 {dict for command: syntax} -returnCodes error -body { dict for x x x x -} -result {wrong # args: should be "dict for {keyVar valueVar} dictionary script"} +} -result {wrong # args: should be "dict for {keyVarName valueVarName} dictionary script"} test dict-14.5 {dict for command: syntax} -returnCodes error -body { dict for x x x } -result {must have exactly two variable names} @@ -650,6 +724,24 @@ test dict-14.20 {dict for stack space compilation: bug 1903325} { concat "c=$y,$args" }} {} 1 2 3 } {c=1,2 3} +test dict-14.21 {compiled dict for and break} { + apply {{} { + dict for {a b} {c d e f} { + lappend result $a,$b + break + } + return $result + }} +} c,d +test dict-14.22 {dict for and exception range depths: Bug 3614382} { + apply {{} { + dict for {a b} {c d} { + dict for {e f} {g h} { + return 5 + } + } + }} +} 5 # There's probably a lot more tests to add here. Really ought to use a # coverage tool for this job... @@ -713,13 +805,13 @@ test dict-15.9 {dict set command: write failure} -setup { } -result {can't set "dictVar": variable is array} test dict-15.10 {dict set command: syntax} -returnCodes error -body { dict set -} -result {wrong # args: should be "dict set varName key ?key ...? value"} +} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"} test dict-15.11 {dict set command: syntax} -returnCodes error -body { dict set a -} -result {wrong # args: should be "dict set varName key ?key ...? value"} +} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"} test dict-15.12 {dict set command: syntax} -returnCodes error -body { dict set a a -} -result {wrong # args: should be "dict set varName key ?key ...? value"} +} -result {wrong # args: should be "dict set dictVarName key ?key ...? value"} test dict-15.13 {dict set command} -returnCodes error -body { set dictVar a dict set dictVar b c @@ -772,7 +864,7 @@ test dict-16.7 {dict unset command} -setup { } -result {0 {} 1} test dict-16.8 {dict unset command} -returnCodes error -body { dict unset dictVar -} -result {wrong # args: should be "dict unset varName key ?key ...?"} +} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"} test dict-16.9 {dict unset command: write failure} -setup { unset -nocomplain dictVar } -body { @@ -781,6 +873,55 @@ test dict-16.9 {dict unset command: write failure} -setup { } -returnCodes error -cleanup { unset dictVar } -result {can't set "dictVar": variable is array} +# Now test with an LVT present (i.e., the bytecoded version). +test dict-16.10 {dict unset command} -body { + apply {{} { + set dictVar {a b c d} + dict unset dictVar a + }} +} -result {c d} +test dict-16.11 {dict unset command} -body { + apply {{} { + set dictVar {a b c d} + dict unset dictVar c + }} +} -result {a b} +test dict-16.12 {dict unset command} -body { + apply {{} { + set dictVar {a b} + dict unset dictVar c + }} +} -result {a b} +test dict-16.13 {dict unset command} -body { + apply {{} { + set dictVar {a {b c d e}} + dict unset dictVar a b + }} +} -result {a {d e}} +test dict-16.14 {dict unset command} -returnCodes error -body { + apply {{} { + set dictVar a + dict unset dictVar a + }} +} -result {missing value to go with key} +test dict-16.15 {dict unset command} -returnCodes error -body { + apply {{} { + set dictVar {a b} + dict unset dictVar c d + }} +} -result {key "c" not known in dictionary} +test dict-16.16 {dict unset command} -body { + apply {{} {list [info exists dictVar] [dict unset dictVar a] [info exists dictVar]}} +} -result {0 {} 1} +test dict-16.17 {dict unset command} -returnCodes error -body { + apply {{} {dict unset dictVar}} +} -result {wrong # args: should be "dict unset dictVarName key ?key ...?"} +test dict-16.18 {dict unset command: write failure} -body { + apply {{} { + set dictVar(block) {} + dict unset dictVar a + }} +} -returnCodes error -result {can't set "dictVar": variable is array} test dict-17.1 {dict filter command: key} -body { set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} @@ -903,7 +1044,7 @@ test dict-17.17 {dict filter command: script} -body { } -result b test dict-17.18 {dict filter command: script} -returnCodes error -body { dict filter {a b} script {k k} -} -result {wrong # args: should be "dict filter dictionary script {keyVar valueVar} filterScript"} +} -result {wrong # args: should be "dict filter dictionary script {keyVarName valueVarName} filterScript"} test dict-17.19 {dict filter command: script} -returnCodes error -body { dict filter {a b} script k {continue} } -result {must have exactly two variable names} @@ -1111,19 +1252,64 @@ test dict-20.9 {dict merge command} { test dict-20.10 {dict merge command} { dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -} } {a - c d e f 1 - 3 4} +test dict-20.11 {dict merge command} { + apply {{} {dict merge}} +} {} +test dict-20.12 {dict merge command} { + apply {{} {dict merge {a b c d e f}}} +} {a b c d e f} +test dict-20.13 {dict merge command} -body { + apply {{} {dict merge {a b c d e}}} +} -result {missing value to go with key} -returnCodes error +test dict-20.14 {dict merge command} { + apply {{} {dict merge {a b c d} {e f g h}}} +} {a b c d e f g h} +test dict-20.15 {dict merge command} -body { + apply {{} {dict merge {a b c d e} {e f g h}}} +} -result {missing value to go with key} -returnCodes error +test dict-20.16 {dict merge command} -body { + apply {{} {dict merge {a b c d} {e f g h i}}} +} -result {missing value to go with key} -returnCodes error +test dict-20.17 {dict merge command} { + apply {{} {dict merge {a b c d e f} {e x g h}}} +} {a b c d e x g h} +test dict-20.18 {dict merge command} { + apply {{} {dict merge {a b c d} {a x c y}}} +} {a x c y} +test dict-20.19 {dict merge command} { + apply {{} {dict merge {a b c d} {c y a x}}} +} {a x c y} +test dict-20.20 {dict merge command} { + apply {{} {dict merge {a b c d e f} {a x 1 2 3 4} {a - 1 -}}} +} {a - c d e f 1 - 3 4} +test dict-20.21 {dict merge command: canonicality not forced} { + dict merge { a b c d } +} { a b c d } +test dict-20.22 {dict merge command: canonicality not forced} { + dict merge { a b c d } {} +} { a b c d } +test dict-20.23 {dict merge command: canonicality forced by update} { + dict merge { a b c d } {a b} +} {a b c d} +test dict-20.24 {dict merge command: type check is mandatory} -body { + dict merge { a b c d e } +} -returnCodes error -result {missing value to go with key} +test dict-20.25 {dict merge command: type check is mandatory} -body { + dict merge { a b {}c d } +} -returnCodes error -result {dict element in braces followed by "c" instead of space} test dict-21.1 {dict update command} -returnCodes 1 -body { dict update -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.2 {dict update command} -returnCodes 1 -body { dict update v -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.3 {dict update command} -returnCodes 1 -body { dict update v k -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.4 {dict update command} -returnCodes 1 -body { dict update v k v -} -result {wrong # args: should be "dict update varName key varName ?key varName ...? script"} +} -result {wrong # args: should be "dict update dictVarName key varName ?key varName ...? script"} test dict-21.5 {dict update command} -body { set a {b c} set result {} @@ -1261,10 +1447,10 @@ test dict-21.17 {dict update command: no recursive structures [Bug 1786481]} { test dict-22.1 {dict with command} -body { dict with -} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} +} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"} test dict-22.2 {dict with command} -body { dict with v -} -returnCodes 1 -result {wrong # args: should be "dict with dictVar ?key ...? script"} +} -returnCodes 1 -result {wrong # args: should be "dict with dictVarName ?key ...? script"} test dict-22.3 {dict with command} -body { unset -nocomplain v dict with v {error "in body"} @@ -1489,7 +1675,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 @@ -1521,6 +1707,451 @@ j }} [linenumber]}} } 5 rename linenumber {} + +test dict-24.1 {dict map command: syntax} -returnCodes error -body { + dict map +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} +test dict-24.2 {dict map command: syntax} -returnCodes error -body { + dict map x +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} +test dict-24.3 {dict map command: syntax} -returnCodes error -body { + dict map x x +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} +test dict-24.4 {dict map command: syntax} -returnCodes error -body { + dict map x x x x +} -result {wrong # args: should be "dict map {keyVarName valueVarName} dictionary script"} +test dict-24.5 {dict map command: syntax} -returnCodes error -body { + dict map x x x +} -result {must have exactly two variable names} +test dict-24.6 {dict map command: syntax} -returnCodes error -body { + dict map {x x x} x x +} -result {must have exactly two variable names} +test dict-24.7 {dict map command: syntax} -returnCodes error -body { + dict map "\{x" x x +} -result {unmatched open brace in list} +test dict-24.8 {dict map command} -setup { + set values {} + set keys {} +} -body { + # This test confirms that [dict keys], [dict values] and [dict map] + # all traverse a dictionary in the same order. + set dictv {a A b B c C} + dict map {k v} $dictv { + lappend keys $k + lappend values $v + } + set result [expr { + $keys eq [dict keys $dictv] && $values eq [dict values $dictv] + }] + expr {$result ? "YES" : [list "NO" $dictv $keys $values]} +} -cleanup { + unset result keys values k v dictv +} -result YES +test dict-24.9 {dict map command} { + dict map {k v} {} { + error "unexpected execution of 'dict map' body" + } +} {} +test dict-24.10 {dict map command: script results} -body { + set times 0 + dict map {k v} {a a b b} { + incr times + continue + error "shouldn't get here" + } + return $times +} -cleanup { + unset times k v +} -result 2 +test dict-24.11 {dict map command: script results} -body { + set times 0 + dict map {k v} {a a b b} { + incr times + break + error "shouldn't get here" + } + return $times +} -cleanup { + unset times k v +} -result 1 +test dict-24.12 {dict map command: script results} -body { + set times 0 + list [catch { + dict map {k v} {a a b b} { + incr times + error test + } + } msg] $msg $times $::errorInfo +} -cleanup { + unset times k v msg +} -result {1 test 1 {test + while executing +"error test" + ("dict map" body line 3) + invoked from within +"dict map {k v} {a a b b} { + incr times + error test + }"}} +test dict-24.13 {dict map command: script results} { + apply {{} { + dict map {k v} {a b} { + return ok,$k,$v + error "skipped return completely" + } + error "return didn't go far enough" + }} +} ok,a,b +test dict-24.14 {dict map command: handle representation loss} -setup { + set keys {} + set values {} +} -body { + set dictVar {a b c d e f g h} + list [dict size [dict map {k v} $dictVar { + if {[llength $dictVar]} { + lappend keys $k + lappend values $v + return -level 0 $k + } + }]] [lsort $keys] [lsort $values] +} -cleanup { + unset dictVar keys values k v +} -result {4 {a c e g} {b d f h}} +test dict-24.14a {dict map command: handle representation loss} -body { + apply {{} { + set dictVar {a b c d e f g h} + list [dict size [dict map {k v} $dictVar { + if {[llength $dictVar]} { + lappend keys $k + lappend values $v + return -level 0 $k + } + }]] [lsort $keys] [lsort $values] + }} +} -result {4 {a c e g} {b d f h}} +test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup { + unset -nocomplain accum + array set accum {} +} -body { + set dictVar {a1 a a2 b b1 c b2 d foo bar bar foo} + dict map {k v} $dictVar { + append accum($k) $v, + } + set result [lsort [array names accum]] + lappend result : + foreach k $result { + catch {lappend result $accum($k)} + } + return $result +} -cleanup { + unset dictVar k v result accum +} -result {a1 a2 b1 b2 bar foo : a, b, c, d, foo, bar,} +test dict-24.16 {dict map command in compilation context} { + apply {{} { + set res {x x x x x x} + dict map {k v} {a 0 b 1 c 2 d 3 e 4 f 5} { + lset res $v $k + continue + } + return $res + }} +} {a b c d e f} +test dict-24.17 {dict map command in compilation context} { + # Bug 1379349 (dict for) + apply {{} { + set d [dict create a 1] ;# Dict must be unshared! + dict map {k v} $d { + dict set d $k 0 ;# Any modification will do + } + return $d + }} +} {a 0} +test dict-24.17a {dict map command in compilation context} { + # Bug 1379349 (dict for) + apply {{} { + set d [dict create a 1] ;# Dict must be unshared! + dict map {k v} $d { + dict set d $k 0 ;# Any modification will do + } + }} +} {a {a 0}} +test dict-24.18 {dict map command in compilation context} { + # Bug 1382528 (dict for) + apply {{} { + dict map {k v} {} {} ;# Note empty dict + catch { error foo } ;# Note compiled [catch] + }} +} 1 +test dict-24.19 {dict map and invalid dicts: 'dict for' bug 1531184} -body { + di[list]ct map {k v} x {} +} -returnCodes 1 -result {missing value to go with key} +test dict-24.20 {dict map stack space compilation: 'dict for' bug 1903325} { + apply {{x y args} { + dict map {a b} $x {} + concat "c=$y,$args" + }} {} 1 2 3 +} {c=1,2 3} +proc linenumber {} { + dict get [info frame -1] line +} +test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} { + apply {{} {apply {n { + set e {} + set k {} + dict map {a b} {c {d {e {f g}}}} { + ::tcl::dict::map {h i} $b { + dict update i e j { + ::tcl::dict::update j f k { + return [expr {$n - [linenumber]}] + } + } + } + } + }} [linenumber]}} +} 5 +test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} { + apply {{} {apply {n { + set e {} + set k {} + dict map {a { +b +}} {c {d {e {f g}}}} { + ::tcl::dict::map {h { +i +}} ${ +b +} { + dict update { +i +} e { +j +} { + ::tcl::dict::update { +j +} f k { + return [expr {$n - [linenumber]}] + } + } + } + } + }} [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 +test dict-23.9 {CompileWord OBOE} { + apply {n { + dict exists {} {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} 1 +test dict-23.10 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.11 {CompileWord OBOE} { + apply {n { + dict with ::foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.12 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.13 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 +test dict-23.14 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 + +rename linenumber {} +test dict-24.22 {dict map results (non-compiled)} { + dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { + return -level 0 "$k,$v" + } +} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}} +test dict-24.23 {dict map results (compiled)} { + apply {{} { + dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { + return -level 0 "$k,$v" + } + }} +} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}} +test dict-24.23a {dict map results (compiled)} { + apply {{list} { + dict map {k v} [dict map {k v} $list { list $v $k }] { + return -level 0 "$k,$v" + } + }} {a 1 b 2 c 3 d 4} +} {a {a,1 a} b {b,2 b} c {c,3 c} d {d,4 d}} +test dict-24.24 {dict map with huge dict (non-compiled)} { + tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat 100000 x] x] { + expr { $k * $v } + }] +} 166666666600000 +test dict-24.25 {dict map with huge dict (compiled)} { + apply {{n} { + tcl::mathop::+ {*}[dict map {k v} [lsearch -all [lrepeat $n y] y] { + expr { $k * $v } + }] + }} 100000 +} 166666666600000 + +test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} { + # Test crashes on failure + apply {{} { + lassign {} item + dict update item item item two two {} + }} +} {} + +set dict dict; # Used to force interpretation, not compilation +test dict-26.1 {dict getdef command} -body { + dict getdef {a b} a c +} -result b +test dict-26.2 {dict getdef command} -body { + dict getdef {a b} b c +} -result c +test dict-26.3 {dict getdef command} -body { + dict getdef {a {b c}} a b d +} -result c +test dict-26.4 {dict getdef command} -body { + dict getdef {a {b c}} a c d +} -result d +test dict-26.5 {dict getdef command} -body { + dict getdef {a {b c}} b c d +} -result d +test dict-26.6 {dict getdef command} -returnCodes error -body { + dict getdef {a {b c d}} a b d +} -result {missing value to go with key} +test dict-26.7 {dict getdef command} -returnCodes error -body { + dict getdef +} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} +test dict-26.8 {dict getdef command} -returnCodes error -body { + dict getdef {} +} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} +test dict-26.9 {dict getdef command} -returnCodes error -body { + dict getdef {} {} +} -result {wrong # args: should be "dict getdef dictionary ?key ...? key default"} +test dict-26.10 {dict getdef command} -returnCodes error -body { + dict getdef {a b c} d e +} -result {missing value to go with key} +test dict-26.11 {dict getdef command} -body { + $dict getdef {a b} a c +} -result b +test dict-26.12 {dict getdef command} -body { + $dict getdef {a b} b c +} -result c +test dict-26.13 {dict getdef command} -body { + $dict getdef {a {b c}} a b d +} -result c +test dict-26.14 {dict getdef command} -body { + $dict getdef {a {b c}} a c d +} -result d +test dict-26.15 {dict getdef command} -body { + $dict getdef {a {b c}} b c d +} -result d +test dict-26.16 {dict getdef command} -returnCodes error -body { + $dict getdef {a {b c d}} a b d +} -result {missing value to go with key} +test dict-26.17 {dict getdef command} -returnCodes error -body { + $dict getdef {a b c} d e +} -result {missing value to go with key} + +test dict-27.1 {dict getwithdefault command} -body { + dict getwithdefault {a b} a c +} -result b +test dict-27.2 {dict getwithdefault command} -body { + dict getwithdefault {a b} b c +} -result c +test dict-27.3 {dict getwithdefault command} -body { + dict getwithdefault {a {b c}} a b d +} -result c +test dict-27.4 {dict getwithdefault command} -body { + dict getwithdefault {a {b c}} a c d +} -result d +test dict-27.5 {dict getwithdefault command} -body { + dict getwithdefault {a {b c}} b c d +} -result d +test dict-27.6 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault {a {b c d}} a b d +} -result {missing value to go with key} +test dict-27.7 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault +} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} +test dict-27.8 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault {} +} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} +test dict-27.9 {dict getwithdefault command} -returnCodes error -body { + dict getwithdefault {} {} +} -result {wrong # args: should be "dict getwithdefault dictionary ?key ...? key default"} +test dict-27.10 {dict getdef command} -returnCodes error -body { + dict getwithdefault {a b c} d e +} -result {missing value to go with key} +test dict-27.11 {dict getwithdefault command} -body { + $dict getwithdefault {a b} a c +} -result b +test dict-27.12 {dict getwithdefault command} -body { + $dict getwithdefault {a b} b c +} -result c +test dict-27.13 {dict getwithdefault command} -body { + $dict getwithdefault {a {b c}} a b d +} -result c +test dict-27.14 {dict getwithdefault command} -body { + $dict getwithdefault {a {b c}} a c d +} -result d +test dict-27.15 {dict getwithdefault command} -body { + $dict getwithdefault {a {b c}} b c d +} -result d +test dict-27.16 {dict getwithdefault command} -returnCodes error -body { + $dict getwithdefault {a {b c d}} a b d +} -result {missing value to go with key} +test dict-27.17 {dict getdef command} -returnCodes error -body { + $dict getwithdefault {a b c} d e +} -result {missing value to go with key} # cleanup ::tcltest::cleanupTests diff --git a/tests/dstring.test b/tests/dstring.test index 06121a3..11c5754 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -4,20 +4,20 @@ # procedures. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testdstring [llength [info commands testdstring]] if {[testConstraint testdstring]} { @@ -180,16 +180,37 @@ test dstring-2.12 {appending list elements} -constraints testdstring -setup { } -cleanup { testdstring free } -result {x #} -test dstring-2.13 {appending list elements} -constraints testdstring -body { - # This test shows lack of sophistication in Tcl_DStringAppendElement's - # decision about whether #-quoting can be disabled. +test dstring-2.13 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { + # This test checks the sophistication in Tcl_DStringAppendElement's + # decision about whether #-quoting can be disabled. testdstring append "x " -1 testdstring element # testdstring get } -cleanup { testdstring free -} -result {x {#}} +} -result {x #} +test dstring-2.14 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { + testdstring append " " -1 + testdstring element # + testdstring get +} -cleanup { + testdstring free +} -result { {#}} +test dstring-2.15 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { + # This test checks the sophistication in Tcl_DStringAppendElement's + # decision about whether #-quoting can be disabled. + testdstring append "x " -1 + testdstring element # + testdstring get +} -cleanup { + testdstring free +} -result {x #} test dstring-3.1 {nested sublists} -constraints testdstring -setup { testdstring free @@ -306,10 +327,11 @@ test dstring-3.9 {appending list elements} -constraints testdstring -setup { } -cleanup { testdstring free } -result {x {x #}} -test dstring-3.10 {appending list elements} -constraints testdstring -body { - # This test shows lack of sophistication in Tcl_DStringAppendElement's - # decision about whether #-quoting can be disabled. +test dstring-3.10 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { + # This test checks the sophistication in Tcl_DStringAppendElement's + # decision about whether #-quoting can be disabled. testdstring append x -1 testdstring start testdstring append "x " -1 @@ -318,7 +340,33 @@ test dstring-3.10 {appending list elements} -constraints testdstring -body { testdstring get } -cleanup { testdstring free -} -result {x {x {#}}} +} -result {x {x #}} +test dstring-3.11 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { + testdstring append x -1 + testdstring start + testdstring append " " -1 + testdstring element # + testdstring end + testdstring get +} -cleanup { + testdstring free +} -result {x { {#}}} +test dstring-3.12 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { + # This test checks the sophistication in Tcl_DStringAppendElement's + # decision about whether #-quoting can be disabled. + testdstring append x -1 + testdstring start + testdstring append "x " -1 + testdstring element # + testdstring end + testdstring get +} -cleanup { + testdstring free +} -result {x {x #}} test dstring-4.1 {truncation} -constraints testdstring -setup { testdstring free diff --git a/tests/encoding.test b/tests/encoding.test index 0374e2d..b1150c6 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -2,22 +2,24 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + namespace eval ::tcl::test::encoding { variable x -namespace import -force ::tcltest::* - catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] + package require -exact tcl::test [info patchlevel] } proc toutf {args} { @@ -34,8 +36,10 @@ proc runtests {} { # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] +testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint teststringbytes [llength [info commands teststringbytes]] testConstraint exec [llength [info commands exec]] -testConstraint testgetdefenc [llength [info commands testgetdefenc]] +testConstraint testgetencpath [llength [info commands testgetencpath]] # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested @@ -60,12 +64,12 @@ test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} { return $x } {{fromutf }} test encoding-1.3 {Tcl_GetEncoding: load encoding} { - list [encoding convertto jis0208 \u4e4e] \ + list [encoding convertto jis0208 乎] \ [encoding convertfrom jis0208 8C] -} "8C \u4e4e" +} "8C 乎" test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} { - encoding convertto jis0208 \u4e4e + encoding convertto jis0208 乎 } {8C} test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { set system [encoding system] @@ -73,15 +77,15 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { } -constraints {testencoding} -body { encoding system shiftjis ;# incr ref count encoding dirs [list [pwd]] - set x [encoding convertto shiftjis \u4e4e] ;# old one found - encoding system identity + set x [encoding convertto shiftjis 乎] ;# old one found + encoding system iso8859-1 llength shiftjis ;# Shimmer away any cache of Tcl_Encoding - lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg + lappend x [catch {encoding convertto shiftjis 乎} msg] $msg } -cleanup { - encoding system identity + encoding system iso8859-1 encoding dirs $path encoding system $system -} -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" +} -result "\x8C\xC1 1 {unknown encoding \"shiftjis\"}" test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup { set old [encoding system] @@ -133,9 +137,9 @@ test encoding-5.1 {Tcl_SetSystemEncoding} -setup { set old [encoding system] } -body { encoding system jis0208 - encoding convertto \u4e4e + encoding convertto 乎 } -cleanup { - encoding system identity + encoding system iso8859-1 encoding system $old } -result {8C} test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} { @@ -165,7 +169,7 @@ test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} { test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} { encoding convertfrom jis0208 8c8c8c8c -} "\u543e\u543e\u543e\u543e" +} "吾吾吾吾" test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C append a $a @@ -174,7 +178,7 @@ test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { append a $a set x [encoding convertfrom jis0208 $a] list [string length $x] [string index $x 0] -} "512 \u4e4e" +} "512 乎" test encoding-8.1 {Tcl_ExternalToUtf} { set f [open [file join [temporaryDirectory] dummy] w] @@ -182,18 +186,18 @@ test encoding-8.1 {Tcl_ExternalToUtf} { puts -nonewline $f "ab\x8c\xc1g" close $f set f [open [file join [temporaryDirectory] dummy] r] - fconfigure $f -translation binary -encoding shiftjis + fconfigure $f -translation binary -encoding shiftjis set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] return $x -} "ab\u4e4eg" +} "ab乎g" test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} { - encoding convertto jis0208 "\u543e\u543e\u543e\u543e" + encoding convertto jis0208 "吾吾吾吾" } {8c8c8c8c} test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} { - set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e + set a 乎乎乎乎乎乎乎乎 append a $a append a $a append a $a @@ -207,7 +211,7 @@ test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} { test encoding-10.1 {Tcl_UtfToExternal} { set f [open [file join [temporaryDirectory] dummy] w] fconfigure $f -translation binary -encoding shiftjis - puts -nonewline $f "ab\u4e4eg" + puts -nonewline $f "ab乎g" close $f set f [open [file join [temporaryDirectory] dummy] r] fconfigure $f -translation binary -encoding iso8859-1 @@ -235,40 +239,40 @@ test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} { encoding system iso8859-1 encoding dirs {} llength jis0208 ;# Shimmer any cached Tcl_Encoding in shared literal - set x [list [catch {encoding convertto jis0208 \u4e4e} msg] $msg] + set x [list [catch {encoding convertto jis0208 乎} msg] $msg] encoding dirs $path encoding system $system - lappend x [encoding convertto jis0208 \u4e4e] + lappend x [encoding convertto jis0208 乎] } {1 {unknown encoding "jis0208"} 8C} test encoding-11.2 {LoadEncodingFile: single-byte} { - encoding convertfrom jis0201 \xa1 -} "\uff61" + encoding convertfrom jis0201 \xA1 +} "。" test encoding-11.3 {LoadEncodingFile: double-byte} { encoding convertfrom jis0208 8C -} "\u4e4e" +} 乎 test encoding-11.4 {LoadEncodingFile: multi-byte} { - encoding convertfrom shiftjis \x8c\xc1 -} "\u4e4e" + encoding convertfrom shiftjis \x8C\xC1 +} 乎 test encoding-11.5 {LoadEncodingFile: escape file} { - viewable [encoding convertto iso2022 \u4e4e] -} [viewable "\x1b\$B8C\x1b(B"] + viewable [encoding convertto iso2022 乎] +} [viewable "\x1B\$B8C\x1B(B"] test encoding-11.5.1 {LoadEncodingFile: escape file} { - viewable [encoding convertto iso2022-jp \u4e4e] + viewable [encoding convertto iso2022-jp 乎] } [viewable "\x1b\$B8C\x1b(B"] test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup { set system [encoding system] set path [encoding dirs] - encoding system identity + encoding system iso8859-1 } -body { cd [temporaryDirectory] encoding dirs [file join tmp encoding] makeDirectory tmp makeDirectory [file join tmp encoding] set f [open [file join tmp encoding splat.enc] w] - fconfigure $f -translation binary + fconfigure $f -translation binary puts $f "abcdefghijklmnop" close $f - encoding convertto splat \u4e4e + encoding convertto splat 乎 } -returnCodes error -cleanup { file delete [file join [temporaryDirectory] tmp encoding splat.enc] removeDirectory [file join tmp encoding] @@ -277,64 +281,168 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} encoding dirs $path encoding system $system } -result {invalid encoding file "splat"} - +test encoding-11.8 {encoding: extended Unicode UTF-16} { + viewable [encoding convertto utf-16le 😹] +} {=Ø9Þ (=\u00d89\u00de)} +test encoding-11.9 {encoding: extended Unicode UTF-16} { + viewable [encoding convertto utf-16be 😹] +} {Ø=Þ9 (\u00d8=\u00de9)} # OpenEncodingFile is fully tested by the rest of the tests in this file. test encoding-12.1 {LoadTableEncoding: normal encoding} { - set x [encoding convertto iso8859-3 \u120] - append x [encoding convertto iso8859-3 \ud5] - append x [encoding convertfrom iso8859-3 \xd5] -} "\xd5?\u120" + set x [encoding convertto iso8859-3 \u0120] + append x [encoding convertto iso8859-3 \xD5] + append x [encoding convertfrom iso8859-3 \xD5] +} "\xD5?\u120" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { - set x [encoding convertto iso8859-3 ab\u0120g] - append x [encoding convertfrom iso8859-3 ab\xd5g] -} "ab\xd5gab\u120g" + set x [encoding convertto iso8859-3 ab\u0120g] + append x [encoding convertfrom iso8859-3 ab\xD5g] +} "ab\xD5gab\u120g" test encoding-12.3 {LoadTableEncoding: multi-byte encoding} { - set x [encoding convertto shiftjis ab\u4e4eg] + set x [encoding convertto shiftjis ab乎g] append x [encoding convertfrom shiftjis ab\x8c\xc1g] -} "ab\x8c\xc1gab\u4e4eg" +} "ab\x8C\xC1gab乎g" test encoding-12.4 {LoadTableEncoding: double-byte encoding} { - set x [encoding convertto jis0208 \u4e4e\u3b1] + set x [encoding convertto jis0208 乎α] append x [encoding convertfrom jis0208 8C&A] -} "8C&A\u4e4e\u3b1" +} "8C&A乎α" test encoding-12.5 {LoadTableEncoding: symbol encoding} { - set x [encoding convertto symbol \u3b3] - append x [encoding convertto symbol \u67] - append x [encoding convertfrom symbol \x67] -} "\x67\x67\u3b3" + set x [encoding convertto symbol γ] + append x [encoding convertto symbol g] + append x [encoding convertfrom symbol g] +} "ggγ" test encoding-13.1 {LoadEscapeTable} { - viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]] -} [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"] - -test encoding-14.1 {BinaryProc} { - encoding convertto identity \x12\x34\x56\xff\x69 -} "\x12\x34\x56\xc3\xbf\x69" + viewable [set x [encoding convertto iso2022 ab乎棙g]] +} [viewable "ab\x1B\$B8C\x1B\$\(DD%\x1B(Bg"] test encoding-15.1 {UtfToUtfProc} { - encoding convertto utf-8 \xa3 -} "\xc2\xa3" -test encoding-15.2 {UtfToUtfProc null character output} { - set x \u0000 - set y [encoding convertto utf-8 \u0000] - set y [encoding convertfrom identity $y] + encoding convertto utf-8 \xA3 +} "\xC2\xA3" +test encoding-15.2 {UtfToUtfProc null character output} testbytestring { + binary scan [testbytestring [encoding convertto utf-8 \x00]] H* z + set z +} 00 +test encoding-15.3 {UtfToUtfProc null character input} teststringbytes { + set y [encoding convertfrom utf-8 [encoding convertto utf-8 \x00]] + binary scan [teststringbytes $y] H* z + set z +} c080 +test encoding-15.4 {UtfToUtfProc emoji character input} -body { + set x \xED\xA0\xBD\xED\xB8\x82 + set y [encoding convertfrom utf-8 \xED\xA0\xBD\xED\xB8\x82] + list [string length $x] $y +} -result "6 😂" +test encoding-15.5 {UtfToUtfProc emoji character input} { + set x \xF0\x9F\x98\x82 + set y [encoding convertfrom utf-8 \xF0\x9F\x98\x82] + list [string length $x] $y +} "4 😂" +test encoding-15.6 {UtfToUtfProc emoji character output} { + set x \uDE02\uD83D\uDE02\uD83D + set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D] binary scan $y H* z - list [string bytelength $x] [string bytelength $y] $z -} {2 1 00} -test encoding-15.3 {UtfToUtfProc null character input} { - set x [encoding convertfrom identity \x00] - set y [encoding convertfrom utf-8 $x] - binary scan [encoding convertto identity $y] H* z - list [string bytelength $x] [string bytelength $y] $z -} {1 2 c080} - -test encoding-16.1 {UnicodeToUtfProc} { - set val [encoding convertfrom unicode NN] - list $val [format %x [scan $val %c]] -} "\u4e4e 4e4e" + list [string length $y] $z +} {10 edb882f09f9882eda0bd} +test encoding-15.7 {UtfToUtfProc emoji character output} { + set x \uDE02\uD83D\uD83D + set y [encoding convertto utf-8 \uDE02\uD83D\uD83D] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {3 9 edb882eda0bdeda0bd} +test encoding-15.8 {UtfToUtfProc emoji character output} { + set x \uDE02\uD83D\xE9 + set y [encoding convertto utf-8 \uDE02\uD83D\xE9] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {3 8 edb882eda0bdc3a9} +test encoding-15.9 {UtfToUtfProc emoji character output} { + set x \uDE02\uD83DX + set y [encoding convertto utf-8 \uDE02\uD83DX] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {3 7 edb882eda0bd58} +test encoding-15.10 {UtfToUtfProc high surrogate character output} { + set x \uDE02\xE9 + set y [encoding convertto utf-8 \uDE02\xE9] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {2 5 edb882c3a9} +test encoding-15.11 {UtfToUtfProc low surrogate character output} { + set x \uDA02\xE9 + set y [encoding convertto utf-8 \uDA02\xE9] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {2 5 eda882c3a9} +test encoding-15.12 {UtfToUtfProc high surrogate character output} { + set x \uDE02Y + set y [encoding convertto utf-8 \uDE02Y] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {2 4 edb88259} +test encoding-15.13 {UtfToUtfProc low surrogate character output} { + set x \uDA02Y + set y [encoding convertto utf-8 \uDA02Y] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {2 4 eda88259} +test encoding-15.14 {UtfToUtfProc high surrogate character output} { + set x \uDE02 + set y [encoding convertto utf-8 \uDE02] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {1 3 edb882} +test encoding-15.15 {UtfToUtfProc low surrogate character output} { + set x \uDA02 + set y [encoding convertto utf-8 \uDA02] + binary scan $y H* z + list [string length $x] [string length $y] $z +} {1 3 eda882} +test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { + set x \xF0\xA0\xA1\xC2 + set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2] + list [string length $x] $y +} "4 \xF0\xA0\xA1\xC2" +test encoding-15.17 {UtfToUtfProc emoji character output} { + set x 😂 + set y [encoding convertto utf-8 😂] + binary scan $y H* z + list [string length $y] $z +} {4 f09f9882} -test encoding-17.1 {UtfToUnicodeProc} { -} {} +test encoding-16.1 {Utf16ToUtfProc} -body { + set val [encoding convertfrom utf-16 NN] + list $val [format %x [scan $val %c]] +} -result "乎 4e4e" +test encoding-16.2 {Utf16ToUtfProc} -body { + set val [encoding convertfrom utf-16 "\xD8\xD8\xDC\xDC"] + list $val [format %x [scan $val %c]] +} -result "\U460DC 460dc" +test encoding-16.3 {Utf16ToUtfProc} -body { + set val [encoding convertfrom utf-16 "\xDC\xDC"] + list $val [format %x [scan $val %c]] +} -result "\uDCDC dcdc" +test encoding-16.4 {Ucs2ToUtfProc} -body { + set val [encoding convertfrom ucs-2 NN] + list $val [format %x [scan $val %c]] +} -result "\u4E4E 4e4e" +test encoding-16.4 {Ucs2ToUtfProc} -body { + set val [encoding convertfrom ucs-2 "\xD8\xD8\xDC\xDC"] + list $val [format %x [scan $val %c]] +} -result "\U460DC 460dc" + +test encoding-17.1 {UtfToUtf16Proc} -body { + encoding convertto utf-16 "\U460DC" +} -result "\xD8\xD8\xDC\xDC" +test encoding-17.2 {UtfToUtf16Proc} -body { + encoding convertto utf-16 "\uDCDC" +} -result "\xDC\xDC" +test encoding-17.3 {UtfToUtf16Proc} -body { + encoding convertto utf-16 "\uD8D8" +} -result "\xD8\xD8" +test encoding-17.4 {UtfToUcs2Proc} -body { + encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] +} -result "\uFFFD" test encoding-18.1 {TableToUtfProc} { } {} @@ -427,17 +535,17 @@ test encoding-24.2 {EscapeFreeProc on open channels} {exec} { viewable [runInSubprocess { encoding system cp1252; # Bug #2891556 crash revelator fconfigure stdout -encoding iso2022-jp - puts ab\u4e4e\u68d9g + puts ab乎棙g set env(TCL_FINALIZE_ON_EXIT) 1 exit }] -} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)" +} "ab\x1B\$B8C\x1B\$(DD%\x1B(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)" test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { # Bug #219314 - if we don't free escape encodings correctly on channel # closure, we go boom set file [makeFile { encoding system iso2022-jp - set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters + set a "乎乞也"; # 3 Japanese Kanji letters puts $a } iso2022.tcl] set f [open "|[list [interpreter] $file]"] @@ -446,7 +554,32 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { close $f removeFile iso2022.tcl list $count [viewable $line] -} [list 3 "\u4e4e\u4e5e\u4e5f (\\u4e4e\\u4e5e\\u4e5f)"] +} [list 3 "乎乞也 (\\u4e4e\\u4e5e\\u4e5f)"] + +test encoding-24.4 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC0\x80"] +} 1 +test encoding-24.5 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC0\x81"] +} 2 +test encoding-24.6 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC1\xBF"] +} 2 +test encoding-24.7 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xC2\x80"] +} 1 +test encoding-24.8 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xE0\x80\x80"] +} 3 +test encoding-24.9 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xE0\x9F\xBF"] +} 3 +test encoding-24.10 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xE0\xA0\x80"] +} 1 +test encoding-24.11 {Parse valid or invalid utf-8} { + string length [encoding convertfrom utf-8 "\xEF\xBF\xBF"] +} 1 file delete [file join [temporaryDirectory] iso2022.txt] @@ -570,15 +703,15 @@ foreach from {cp932 shiftjis euc-jp iso2022-jp} { } } -test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints { - testgetdefenc +test encoding-26.0 {Tcl_GetEncodingSearchPath} -constraints { + testgetencpath } -setup { - set origDir [testgetdefenc] - testsetdefenc slappy + set origPath [testgetencpath] + testsetencpath slappy } -body { - testgetdefenc + testgetencpath } -cleanup { - testsetdefenc $origDir + testsetencpath $origPath } -result slappy file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout] @@ -596,6 +729,21 @@ test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body { } -result "expected directory list but got \"\{not a list\"" } + + +test encoding-28.0 {all encodings load} -body { + set string hello + foreach name [encoding names] { + incr count + encoding convertto $name $string + + # discard the cached internal representation of Tcl_Encoding + # Unfortunately, without this, encoding 2-1 fails. + llength $name + } + return $count +} -result [expr {[info exists ::tcl_precision] ? 86 : 85}] + runtests } diff --git a/tests/env.test b/tests/env.test index 9010f52..5250ac8 100644 --- a/tests/env.test +++ b/tests/env.test @@ -4,61 +4,112 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } -# Some tests require the "exec" command. -# Skip them if exec is not defined. -testConstraint exec [llength [info commands exec]] +loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] +package require tcltests -# -# These tests will run on any platform (and indeed crashed on the Mac). So put -# them before you test for the existance of exec. -# -test env-1.1 {propagation of env values to child interpreters} -setup { - catch {interp delete child} - catch {unset env(test)} -} -body { - interp create child - set env(test) garbage - child eval {set env(test)} -} -cleanup { - interp delete child - unset env(test) -} -result {garbage} -# -# This one crashed on Solaris under Tcl8.0, so we only want to make sure it -# runs. -# -test env-1.2 {lappend to env value} -setup { - catch {unset env(test)} -} -body { - set env(test) aaaaaaaaaaaaaaaa - append env(test) bbbbbbbbbbbbbb - unset env(test) +# [exec] is required here to see the actual environment received by child +# processes. +proc getenv {} { + global printenvScript + catch {exec [interpreter] $printenvScript} out + if {$out eq "child process exited abnormally"} { + set out {} + } + return $out +} + + +proc envrestore {} { + # Restore the environment variables at the end of the test. + global env + variable env2 + + foreach name [array names env] { + unset env($name) + } + array set env $env2 + return } -test env-1.3 {reflection of env by "array names"} -setup { - catch {interp delete child} - catch {unset env(test)} -} -body { - interp create child - child eval {set env(test) garbage} - expr {"test" in [array names env]} -} -cleanup { - interp delete child - catch {unset env(test)} -} -result {1} -set printenvScript [makeFile { + +proc envprep {} { + # Save the current environment variables at the start of the test. + global env + variable keep + variable env2 + + set env2 [array get env] + foreach name [array names env] { + # Keep some environment variables that support operation of the tcltest + # package. + if {[string toupper $name] ni [string toupper $keep]} { + unset env($name) + } + } + return +} + + +proc encodingrestore {} { + variable sysenc + encoding system $sysenc + return +} + + +proc encodingswitch encoding { + variable sysenc + # Need to run [getenv] in known encoding, so save the current one here... + set sysenc [encoding system] + encoding system $encoding + return +} + + +proc setup1 {} { + global env + envprep + encodingswitch iso8859-1 +} + +proc setup2 {} { + global env + setup1 + set env(NAME1) {test string} + set env(NAME2) {new value} + set env(XYZZY) {garbage} +} + + +proc cleanup1 {} { + encodingrestore + envrestore +} + +variable keep { + TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY + SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH + DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING MSYSTEM + __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM + CommonProgramFiles CommonProgramFiles(x86) ProgramFiles + ProgramFiles(x86) CommonProgramW6432 ProgramW6432 + WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR +} + +variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { encoding system iso8859-1 proc lrem {listname name} { upvar $listname list @@ -70,7 +121,7 @@ set printenvScript [makeFile { } proc mangle s { regsub -all {\[|\\|\]} $s {\\&} s - regsub -all {[\u0000-\u001f\u007f-\uffff]} $s {[manglechar &]} s + regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar {&}]} s return [subst -novariables $s] } proc manglechar c { @@ -84,153 +135,174 @@ set printenvScript [makeFile { lrem names ComSpec lrem names "" } - foreach name { - TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY - SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH - DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING - __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles - } { + foreach name @keep@ { lrem names $name } foreach p $names { - puts "[mangle $p]=[mangle $env($p)]" + puts [mangle $p]=[mangle $env($p)] } exit -} printenv] +}] printenv] -# [exec] is required here to see the actual environment received by child -# processes. -proc getenv {} { - global printenvScript tcltest - catch {exec [interpreter] $printenvScript} out - if {$out eq "child process exited abnormally"} { - set out {} - } - return $out -} -# Save the current environment variables at the start of the test. - -set env2 [array get env] -foreach name [array names env] { - # Keep some environment variables that support operation of the tcltest - # package. - if {[string toupper $name] ni { - TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH - SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH - DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING - SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles - }} { - unset env($name) - } +test env-1.1 {propagation of env values to child interpreters} -setup { + catch {interp delete child} + catch {unset env(test)} +} -body { + interp create child + set env(test) garbage + child eval {set env(test)} +} -cleanup { + interp delete child + unset env(test) +} -result {garbage} + + +# This one crashed on Solaris under Tcl8.0, so we only want to make sure it +# runs. +test env-1.2 {lappend to env value} -setup { + catch {unset env(test)} +} -body { + set env(test) aaaaaaaaaaaaaaaa + append env(test) bbbbbbbbbbbbbb + unset env(test) } -# Need to run 'getenv' in known encoding, so save the current one here... -set sysenc [encoding system] -test env-2.1 {adding environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { - getenv +test env-1.3 {reflection of env by "array names"} -setup { + catch {interp delete child} + catch {unset env(test)} +} -body { + interp create child + child eval {set env(test) garbage} + expr {"test" in [array names env]} } -cleanup { - encoding system $sysenc -} -result {} -test env-2.2 {adding environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + interp delete child + catch {unset env(test)} +} -result 1 + + +test env-2.1 { + adding environment variables +} -constraints exec -setup setup1 -body { + getenv +} -cleanup cleanup1 -result {} + + +test env-2.2 { + adding environment variables +} -constraints exec -setup setup1 -body { set env(NAME1) "test string" getenv -} -cleanup { - encoding system $sysenc -} -result {NAME1=test string} -test env-2.3 {adding environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { +} -cleanup cleanup1 -result {NAME1=test string} + + +test env-2.3 {adding environment variables} -constraints exec -setup { + setup1 + set env(NAME1) "test string" +} -body { set env(NAME2) "more" getenv -} -cleanup { - encoding system $sysenc -} -result {NAME1=test string +} -cleanup cleanup1 -result {NAME1=test string NAME2=more} -test env-2.4 {adding environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + + +test env-2.4 { + adding environment variables +} -constraints exec -setup { + setup1 + set env(NAME1) "test string" + set env(NAME2) "more" +} -body { set env(XYZZY) "garbage" getenv -} -cleanup { - encoding system $sysenc +} -cleanup { cleanup1 } -result {NAME1=test string NAME2=more XYZZY=garbage} -set env(NAME2) "new value" -test env-3.1 {changing environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { +test env-2.5 {different encoding (wide chars)} -constraints {win exec} -setup { + # be sure set of (unicode) environment occurs if single-byte encoding is used: + encodingswitch cp1252 + # german (cp1252) and russian (cp1251) characters together encoded as utf-8: + set val 2d2dc3a4c3b6c3bcc39f2dd182d0b5d181d1822d2d + set env(XYZZY) [encoding convertfrom utf-8 [binary decode hex $val]] + # now switch to utf-8 (to see correct values from test): + encoding system utf-8 +} -body { + exec [interpreter] << [string map [list \$val $val] { + encoding system utf-8; fconfigure stdout -encoding utf-8 + set test [encoding convertfrom utf-8 [binary decode hex $val]] + puts "[expr {$env(XYZZY) eq $test}] \ngot:\t\ + $env(XYZZY) ([binary encode hex [encoding convertto $env(XYZZY)]]) \nexp:\t\ + $test ([binary encode hex [encoding convertto $test]])" + }] +} -cleanup { + encodingrestore + unset -nocomplain val f env(XYZZY) +} -match glob -result {1 *} + +test env-3.1 { + changing environment variables +} -constraints exec -setup setup2 -body { set result [getenv] unset env(NAME2) set result } -cleanup { - encoding system $sysenc + cleanup1 } -result {NAME1=test string NAME2=new value XYZZY=garbage} -test env-4.1 {unsetting environment variables: default} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + +test env-4.1 { + unsetting environment variables +} -constraints exec -setup setup2 -body { + unset -nocomplain env(NAME2) getenv -} -cleanup { - encoding system $sysenc -} -result {NAME1=test string +} -cleanup cleanup1 -result {NAME1=test string XYZZY=garbage} -test env-4.2 {unsetting environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { - unset env(NAME1) - getenv -} -cleanup { - unset env(XYZZY) - encoding system $sysenc -} -result {XYZZY=garbage} -test env-4.3 {setting international environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + +# env-4.2 is deleted + +test env-4.3 { + setting international environment variables +} -constraints exec -setup setup1 -body { set env(\ua7) \ub6 getenv -} -cleanup { - encoding system $sysenc -} -result {\u00a7=\u00b6} -test env-4.4 {changing international environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { +} -cleanup cleanup1 -result {\u00a7=\u00b6} + + +test env-4.4 { + changing international environment variables +} -constraints exec -setup setup1 -body { set env(\ua7) \ua7 getenv -} -cleanup { - encoding system $sysenc -} -result {\u00a7=\u00a7} -test env-4.5 {unsetting international environment variables} -setup { - encoding system iso8859-1 +} -cleanup cleanup1 -result {\u00a7=\u00a7} + + +test env-4.5 { + unsetting international environment variables +} -constraints exec -setup { + setup1 + set env(\ua7) \ua7 } -body { set env(\ub6) \ua7 unset env(\ua7) getenv -} -constraints {exec} -cleanup { - encoding system $sysenc - unset env(\ub6) -} -result {\u00b6=\u00a7} +} -cleanup cleanup1 -result {\u00b6=\u00a7} -test env-5.0 {corner cases - set a value, it should exist} -body { +test env-5.0 { + corner cases - set a value, it should exist +} -setup setup1 -body { set env(temp) a set env(temp) -} -cleanup { - unset env(temp) -} -result {a} -test env-5.1 {corner cases - remove one elem at a time} -setup { - set x [array get env] -} -body { +} -cleanup cleanup1 -result a + + +test env-5.1 { + corner cases - remove one elem at a time +} -setup setup1 -body { # When no environment variables exist, the env var will contain no # entries. The "array names" call synchs up the C-level environ array with # the Tcl level env array. Make sure an empty Tcl array is created. @@ -238,9 +310,9 @@ test env-5.1 {corner cases - remove one elem at a time} -setup { unset env($e) } array size env -} -cleanup { - array set env $x -} -result {0} +} -cleanup cleanup1 -result 0 + + test env-5.2 {corner cases - unset the env array} -setup { interp create i } -body { @@ -254,51 +326,109 @@ test env-5.2 {corner cases - unset the env array} -setup { } -cleanup { interp delete i } -result {0} -test env-5.3 {corner cases: unset the env in master should unset child} -setup { + + +test env-5.3 {corner cases: unset the env in parent should unset child} -setup { + setup1 interp create i } -body { - # Variables deleted in a master interp should be deleted in child interp + # Variables deleted in a parent interp should be deleted in child interp # too. - i eval { set env(THIS_SHOULD_EXIST) a} + i eval {set env(THIS_SHOULD_EXIST) a} set result [set env(THIS_SHOULD_EXIST)] unset env(THIS_SHOULD_EXIST) lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}] } -cleanup { + cleanup1 interp delete i } -result {a 1} + + test env-5.4 {corner cases - unset the env array} -setup { + setup1 interp create i } -body { # The info exists command should be in synch with the env array. # Know Bug: 1737 - i eval { set env(THIS_SHOULD_EXIST) a} + i eval {set env(THIS_SHOULD_EXIST) a} set result [info exists env(THIS_SHOULD_EXIST)] lappend result [set env(THIS_SHOULD_EXIST)] lappend result [info exists env(THIS_SHOULD_EXIST)] } -cleanup { + cleanup1 interp delete i } -result {1 a 1} -test env-5.5 {corner cases - cannot have null entries on Windows} {win} { + + +test env-5.5 { + corner cases - cannot have null entries on Windows +} -constraints win -body { set env() a catch {set env()} -} {1} +} -cleanup cleanup1 -result 1 -test env-6.1 {corner cases - add lots of env variables} {} { +test env-6.1 {corner cases - add lots of env variables} -setup setup1 -body { set size [array size env] for {set i 0} {$i < 100} {incr i} { set env(BOGUS$i) $i } expr {[array size env] - $size} -} 100 +} -cleanup cleanup1 -result 100 + +test env-7.1 {[219226]: whole env array should not be unset by read} -body { + set n [array size env] + set s [array startsearch env] + while {[array anymore env $s]} { + array nextelement env $s + incr n -1 + } + array donesearch env $s + return $n +} -result 0 + +test env-7.2 { + [219226]: links to env elements should not be removed by read +} -setup setup1 -body { + apply {{} { + set ::env(test7_2) ok + upvar env(test7_2) elem + set ::env(PATH) + return $elem + }} +} -cleanup cleanup1 -result ok + +test env-7.3 { + [9b4702]: testing existence of env(some_thing) should not destroy trace +} -setup setup1 -body { + apply {{} { + catch {unset ::env(test7_3)} + proc foo args { + set ::env(test7_3) ok + } + trace add variable ::env(not_yet_existent) write foo + info exists ::env(not_yet_existent) + set ::env(not_yet_existent) "Now I'm here"; + return [info exists ::env(test7_3)] + }} +} -cleanup cleanup1 -result 1 + +test env-8.0 { + memory usage - valgrind does not report reachable memory +} -body { + set res [set env(__DUMMY__) {i'm with dummy}] + unset env(__DUMMY__) + return $res +} -result {i'm with dummy} -# Restore the environment variables at the end of the test. -foreach name [array names env] { - unset env($name) -} -array set env $env2 # cleanup +rename getenv {} +rename envrestore {} +rename envprep {} +rename encodingrestore {} +rename encodingswitch {} + removeFile $printenvScript ::tcltest::cleanupTests return diff --git a/tests/error.test b/tests/error.test index 97bcc0a..064edc7 100644 --- a/tests/error.test +++ b/tests/error.test @@ -4,19 +4,22 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint memory [llength [info commands memory]] +customMatch pairwise {apply {{a b} { + string equal [lindex $b 0] [lindex $b 1] +}}} namespace eval ::tcl::test::error { if {[testConstraint memory]} { proc getbytes {} { @@ -179,6 +182,16 @@ test error-4.7 {errorstack via options dict } -body { catch {f 12} m d dict get $d -errorstack } -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} +test error-4.8 {errorstack from exec traces} -body { + proc foo args {} + proc goo {} foo + trace add execution foo enter {error bar;#} + catch goo m d + dict get $d -errorstack +} -cleanup { + rename goo {}; rename foo {} + unset -nocomplain m d +} -result {INNER {error bar} CALL goo UP 1} # Errors in error command itself @@ -314,6 +327,12 @@ test error-8.8 {throw syntax checks} -returnCodes error -body { test error-8.9 {throw syntax checks} -returnCodes error -body { throw {} foo } -result {type must be non-empty list} +test error-8.10 {Bug 33b7abb8a2: throw stack usage} -returnCodes error -body { + apply {code {throw $code foo}} {} +} -result {type must be non-empty list} +test error-8.11 {Bug 7174354ecb: throw error message} -returnCodes error -body { + throw {not {}a list} x[]y +} -result {list element in braces followed by "a" instead of space} # simple try tests: body completes with code ok @@ -601,21 +620,21 @@ test error-16.7 {try with variable assignment and propagation #2} { } list $em [dict get $opts -errorcode] } {bar FOO} -test error-16.8 {exception chaining (try=ok, handler=error)} { +test error-16.8 {exception chaining (try=ok, handler=error)} -body { #FIXME is the intent of this test correct? catch { try { list a b c } on ok {em opts} { throw BAR baz } } tryem tryopts - string equal $opts [dict get $tryopts -during] -} {1} -test error-16.9 {exception chaining (try=error, handler=error)} { + list $opts [dict get $tryopts -during] +} -match pairwise -result equal +test error-16.9 {exception chaining (try=error, handler=error)} -body { # The exception off the handler should chain to the exception off the # try-body (using the -during option) catch { try { throw FOO bar } trap {} {em opts} { throw BAR baz } } tryem tryopts - string equal $opts [dict get $tryopts -during] -} {1} + list $opts [dict get $tryopts -during] +} -match pairwise -result equal test error-16.10 {no exception chaining when handler is successful} { catch { try { throw FOO bar } trap {} {em opts} { list d e f } @@ -628,6 +647,131 @@ test error-16.11 {no exception chaining when handler is a non-error exception} { } tryem tryopts dict exists $tryopts -during } {0} +test error-16.12 {compiled try with successfully executed handler} { + apply {{} { + try { throw FOO bar } trap FOO {} { list a b c } + }} +} {a b c} +test error-16.13 {compiled try with exception (error) in handler} -body { + apply {{} { + try { throw FOO bar } trap FOO {} { throw BAR foo } + }} +} -returnCodes error -result {foo} +test error-16.14 {compiled try with exception (return) in handler} -body { + apply {{} { + list [catch { + try { throw FOO bar } trap FOO {} { return BAR } + } msg] $msg + }} +} -result {2 BAR} +test error-16.15 {compiled try with exception (break) in handler} { + apply {{} { + for { set i 5 } { $i < 10 } { incr i } { + try { throw FOO bar } trap FOO {} { break } + } + return $i + }} +} {5} +test error-16.16 {compiled try with exception (continue) in handler} { + apply {{} { + for { set i 5 } { $i < 10 } { incr i } { + try { throw FOO bar } trap FOO {} { continue } + incr i 20 + } + return $i + }} +} {10} +test error-16.17 {compiled try with variable assignment and propagation #1} { + # Ensure that the handler variables preserve the exception off the + # try-body, and are not modified by the exception off the handler + apply {{} { + catch { + try { throw FOO bar } trap FOO {em} { throw BAR baz } + } + return $em + }} +} {bar} +test error-16.18 {compiled try with variable assignment and propagation #2} { + apply {{} { + catch { + try { throw FOO bar } trap FOO {em opts} { throw BAR baz } + } + list $em [dict get $opts -errorcode] + }} +} {bar FOO} +test error-16.19 {compiled try exception chaining (try=ok, handler=error)} -body { + #FIXME is the intent of this test correct? + apply {{} { + catch { + try { list a b c } on ok {em opts} { throw BAR baz } + } tryem tryopts + list $opts [dict get $tryopts -during] + }} +} -match pairwise -result equal +test error-16.20 {compiled try exception chaining (try=error, handler=error)} -body { + # The exception off the handler should chain to the exception off the + # try-body (using the -during option) + apply {{} { + catch { + try { throw FOO bar } trap {} {em opts} { throw BAR baz } + } tryem tryopts + list $opts [dict get $tryopts -during] + }} +} -match pairwise -result equal +test error-16.21 {compiled try exception chaining (try=error, finally=error)} { + # The exception off the handler should chain to the exception off the + # try-body (using the -during option) + apply {{} { + catch { + try { throw FOO bar } finally { throw BAR baz } + } tryem tryopts + dict get $tryopts -during -errorcode + }} +} FOO +test error-16.22 {compiled try: no exception chaining when handler is successful} { + apply {{} { + catch { + try { throw FOO bar } trap {} {em opts} { list d e f } + } tryem tryopts + dict exists $tryopts -during + }} +} {0} +test error-16.23 {compiled try: no exception chaining when handler is a non-error exception} { + apply {{} { + catch { + try { throw FOO bar } trap {} {em opts} { break } + } tryem tryopts + dict exists $tryopts -during + }} +} {0} +test error-16.24 {compiled try exception chaining (try=ok, handler=error, finally=error)} -body { + apply {{} { + catch { + try { + list a b c + } on ok {em opts} { + throw BAR baz + } finally { + throw DING dong + } + } tryem tryopts + list $opts [dict get $tryopts -during -during] + }} +} -match pairwise -result equal +test error-16.25 {compiled try exception chaining (all errors)} -body { + apply {{} { + catch { + try { + throw FOO bar + } on error {em opts} { + throw BAR baz + } finally { + throw DING dong + } + } tryem tryopts + list $opts [dict get $tryopts -during -during] + }} +} -match pairwise -result equal # try tests - finally @@ -709,15 +853,15 @@ test error-18.5 {exception in finally doesn't affect variable assignment} { } list $em [dict get $opts -errorcode] } {bar FOO} -test error-18.6 {exception chaining in finally (try=ok)} { +test error-18.6 {exception chaining in finally (try=ok)} -body { catch { list a b c } em expopts catch { try { list a b c } finally { throw BAR foo } } em opts - string equal $expopts [dict get $opts -during] -} {1} + list $expopts [dict get $opts -during] +} -match pairwise -result equal test error-18.7 {exception chaining in finally (try=error)} { catch { try { throw FOO bar } finally { throw BAR baz } @@ -1040,6 +1184,12 @@ test error-21.8 {memory leaks in try: Bug 2910044} memory { } } 0 +test error-21.9 {Bug cee90e4e88} { + # Just don't panic. + apply {{} {try {} on ok {} - on return {} {}}} +} {} + + # negative case try tests - bad "trap" handler # what is the effect if we attempt to trap an errorcode that is not a list? # nested try diff --git a/tests/eval.test b/tests/eval.test index 70ceac8..5ffe309 100644 --- a/tests/eval.test +++ b/tests/eval.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/event.test b/tests/event.test index 0d1b06c..3f9735a 100644 --- a/tests/event.test +++ b/tests/event.test @@ -3,19 +3,19 @@ # this file into Tcl runs the tests and generates output for errors. No # output means no errors were found. # -# Copyright (c) 1995-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 namespace import -force ::tcltest::* catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] - set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [info loaded {} Tcltest] } @@ -23,16 +23,18 @@ testConstraint testfilehandler [llength [info commands testfilehandler]] testConstraint testexithandler [llength [info commands testexithandler]] testConstraint testfilewait [llength [info commands testfilewait]] testConstraint exec [llength [info commands exec]] - +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] + test event-1.1 {Tcl_CreateFileHandler, reading} -setup { testfilehandler close set result "" -} -constraints {testfilehandler} -body { +} -constraints {testfilehandler notOSX} -body { testfilehandler create 0 readable off testfilehandler clear 0 testfilehandler oneevent lappend result [testfilehandler counts 0] testfilehandler fillpartial 0 + update idletasks testfilehandler oneevent lappend result [testfilehandler counts 0] testfilehandler oneevent @@ -527,7 +529,7 @@ test event-11.4 {Tcl_VwaitCmd procedure} -setup { } -body { after 100 {set x x-done} after 200 {set y y-done} - after 300 {set z z-done} + after 400 {set z z-done} after idle {set q q-done} set x before set y before @@ -583,6 +585,34 @@ test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} { removeFile $test2file list $x $y $z } {3 3 done} +test event-11.7 {Bug 16828b3744} { + after idle { + set ::t::v 1 + namespace delete ::t + } + namespace eval ::t { + vwait ::t::v + } +} {} +test event-11.8 {Bug 16828b3744} -setup { + oo::class create A { + variable continue + + method start {} { + after idle [self] destroy + + set continue 0 + vwait [namespace current]::continue + } + destructor { + set continue 1 + } + } +} -body { + [A new] start +} -cleanup { + A destroy +} -result {} test event-12.1 {Tcl_UpdateCmd procedure} -returnCodes error -body { update a b diff --git a/tests/exec.test b/tests/exec.test index 64d3517..6a05c75 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -4,19 +4,31 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +# There is no point in running Valgrind on cases where [exec] forks but then +# fails and the child process doesn't go through full cleanup. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] +package require tcltests # All tests require the "exec" command. # Skip them if exec is not defined. testConstraint exec [llength [info commands exec]] +# Some skips when running in a macOS CI environment +testConstraint noosxCI [expr {![info exists ::env(MAC_CI)]}] + unset -nocomplain path # Utilities that are like bourne shell stalwarts, but cross-platform. @@ -157,7 +169,7 @@ test exec-2.6 {redirecting input from immediate source, with UTF} -setup { encoding system iso8859-1 proc quotenonascii s { regsub -all {\[|\\|\]} $s {\\&} s - regsub -all {[\u007f-\uffff]} $s \ + regsub -all "\[\u007f-\uffff\]" $s \ {[apply {c {format {\u%04x} [scan $c %c]}} &]} s return [subst -novariables $s] } @@ -300,7 +312,6 @@ test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} { # I/O redirection: combinations. set path(gorp.file2) [makeFile {} gorp.file2] -file delete $path(gorp.file2) test exec-7.1 {multiple I/O redirections} {exec} { exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file) @@ -326,11 +337,11 @@ test exec-8.2 {long input and output} {exec} { # Commands that return errors. -test exec-9.1 {commands returning errors} {exec} { +test exec-9.1 {commands returning errors} {exec notValgrind} { set x [catch {exec gorp456} msg] list $x [string tolower $msg] [string tolower $errorCode] } {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}} -test exec-9.2 {commands returning errors} {exec} { +test exec-9.2 {commands returning errors} {exec notValgrind} { string tolower [list [catch {exec [interpreter] echo foo | foo123} msg] $msg $errorCode] } {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}} test exec-9.3 {commands returning errors} -constraints {exec stdio} -body { @@ -340,7 +351,7 @@ test exec-9.4 {commands returning errors} -constraints {exec stdio} -body { exec [interpreter] $path(exit) 43 | [interpreter] $path(echo) "foo bar" } -returnCodes error -result {foo bar child process exited abnormally} -test exec-9.5 {commands returning errors} -constraints {exec stdio} -body { +test exec-9.5 {commands returning errors} -constraints {exec stdio notValgrind} -body { exec gorp456 | [interpreter] echo a b c } -returnCodes error -result {couldn't execute "gorp456": no such file or directory} test exec-9.6 {commands returning errors} -constraints {exec} -body { @@ -370,7 +381,7 @@ err} test exec-10.1 {errors in exec invocation} -constraints {exec} -body { exec -} -returnCodes error -result {wrong # args: should be "exec ?-switch ...? arg ?arg ...?"} +} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"} test exec-10.2 {errors in exec invocation} -constraints {exec} -body { exec | cat } -returnCodes error -result {illegal use of | or |& in command} @@ -429,13 +440,13 @@ test exec-10.19 {errors in exec invocation} -constraints {exec} -body { exec cat >@ $f } -returnCodes error -result "channel \"$f\" wasn't opened for writing" close $f -test exec-10.20 {errors in exec invocation} -constraints {exec} -body { +test exec-10.20 {errors in exec invocation} -constraints {exec notValgrind} -body { exec ~non_existent_user/foo/bar } -returnCodes error -result {user "non_existent_user" doesn't exist} -test exec-10.21 {errors in exec invocation} -constraints {exec} -body { +test exec-10.21 {errors in exec invocation} -constraints {exec notValgrind} -body { exec [interpreter] true | ~xyzzy_bad_user/x | false } -returnCodes error -result {user "xyzzy_bad_user" doesn't exist} -test exec-10.22 {errors in exec invocation} -constraints exec -body { +test exec-10.22 {errors in exec invocation} -constraints {exec notValgrind} -body { exec echo test > ~non_existent_user/foo/bar } -returnCodes error -result {user "non_existent_user" doesn't exist} # Commands in background. @@ -511,7 +522,7 @@ test exec-13.1 {setting errorCode variable} {exec} { test exec-13.2 {setting errorCode variable} {exec} { list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode] } {1 {posix enoent {no such file or directory}}} -test exec-13.3 {setting errorCode variable} {exec} { +test exec-13.3 {setting errorCode variable} {exec notValgrind} { set x [catch {exec _weird_cmd_} msg] list $x [string tolower $msg] [lindex $errorCode 0] \ [string tolower [lrange $errorCode 2 end]] @@ -545,11 +556,11 @@ test exec-14.1 {-keepnewline switch} {exec} { } "foo\n" test exec-14.2 {-keepnewline switch} -constraints {exec} -body { exec -keepnewline -} -returnCodes error -result {wrong # args: should be "exec ?-switch ...? arg ?arg ...?"} +} -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"} test exec-14.3 {unknown switch} -constraints {exec} -body { exec -gorp -} -returnCodes error -result {bad switch "-gorp": must be -ignorestderr, -keepnewline, or --} -test exec-14.4 {-- switch} -constraints {exec} -body { +} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --} +test exec-14.4 {-- switch} -constraints {exec notValgrind} -body { exec -- -gorp } -returnCodes error -result {couldn't execute "-gorp": no such file or directory} test exec-14.5 {-ignorestderr switch} {exec} { @@ -663,7 +674,9 @@ test exec-18.2 {exec cat deals with weird file names} -body { # Note that this test cannot be adapted to work on Windows; that platform has # no kernel support for an analog of O_APPEND. OTOH, that means we can assume # that there is a POSIX shell... -test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup { +# +# This test also fails in some cases when building with macOS +test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind noosxCI} -setup { set tmpfile [makeFile {0} tmpfile.exec-19.1] } -body { # Note that we have to allow for the current contents of the temporary @@ -671,8 +684,12 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup { exec /bin/sh -c \ {for a in 1 2 3; do sleep 1; echo $a; done} >>$tmpfile & exec /bin/sh -c \ + {for a in 4 5 6; do sleep 1; echo $a >&2; done} 2>>$tmpfile & + exec /bin/sh -c \ {for a in a b c; do sleep 1; echo $a; done} >>$tmpfile & - # The above two shell invokations take about 3 seconds to finish, so allow + exec /bin/sh -c \ + {for a in d e f; do sleep 1; echo $a >&2; done} 2>>$tmpfile & + # The above four shell invocations take about 3 seconds to finish, so allow # 5s (in case the machine is busy) after 5000 # Check that no bytes have got lost through mixups with overlapping @@ -681,7 +698,20 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup { file size $tmpfile } -cleanup { removeFile $tmpfile -} -result 14 +} -result 26 + +# Tests to ensure batch files and .CMD (Bug 9ece99d58b) +# can be executed on Windows +test exec-20.0 {exec .bat file} -constraints {win} -body { + set log [makeFile {} exec20.log] + exec [makeFile "echo %1> $log" exec20.bat] "Testing exec-20.0" + viewFile $log +} -result "\"Testing exec-20.0\"" +test exec-20.1 {exec .CMD file} -constraints {win} -body { + set log [makeFile {} exec201.log] + exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1" + viewFile $log +} -result "\"Testing exec-20.1\"" # ---------------------------------------------------------------------- # cleanup diff --git a/tests/execute.test b/tests/execute.test index 94af158..f22747c 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -8,19 +8,19 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} @@ -34,9 +34,14 @@ testConstraint testobj [expr { && [llength [info commands teststringobj]] }] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] testConstraint testexprlongobj [llength [info commands testexprlongobj]] + +if {[namespace which -command testbumpinterpepoch] eq ""} { + proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } +} + # Tests for the omnibus TclExecuteByteCode function: # INST_DONE not tested @@ -652,56 +657,56 @@ test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} -se namespace delete foo } -result {0 AHA!} test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup { - interp create slave + interp create child } -body { set script { llength {} } - slave eval {proc llength args {return AHA!}} + child eval {proc llength args {return AHA!}} set result {} lappend result [if 1 $script] - lappend result [slave eval $script] + lappend result [child eval $script] } -cleanup { - interp delete slave + interp delete child } -result {0 AHA!} test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body { set script { llength {} } - interp create slave + interp create child set result {} - lappend result [slave eval $script] - interp delete slave - interp create slave - lappend result [slave eval $script] + lappend result [child eval $script] + interp delete child + interp create child + lappend result [child eval $script] } -cleanup { - catch {interp delete slave} + catch {interp delete child} } -result {0 0} test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -constraints testexprlongobj -body { set e { [llength {}]+1 } set result {} - load {} Tcltest slave - interp alias {} e slave testexprlongobj + load {} Tcltest child + interp alias {} e child testexprlongobj lappend result [e $e] - interp delete slave - interp create slave - load {} Tcltest slave - interp alias {} e slave testexprlongobj + interp delete child + interp create child + load {} Tcltest child + interp alias {} e child testexprlongobj lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {{This is a result: 1} {This is a result: 1}} test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -body { set e { [llength {}]+1 } set result {} - interp alias {} e slave expr + interp alias {} e child expr lappend result [e $e] - interp delete slave - interp create slave - interp alias {} e slave expr + interp delete child + interp create child + interp alias {} e child expr lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {1 1} test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body { set e { [llength {}]+1 } @@ -724,7 +729,7 @@ test execute-6.14 {Tcl_ExprObj: exprcode context validation} -setup { } set result {} lappend result [expr $e] - lappend result [namespace eval foo {expr $e}] + lappend result [namespace eval foo [list expr $e]] } -cleanup { namespace delete foo } -result {1 2} @@ -733,25 +738,25 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setu } -body { set e { [llength {}]+1 } set result {} - lappend result [namespace eval foo {expr $e}] + lappend result [namespace eval foo [list expr $e]] namespace eval foo { proc llength {args} {return 1} } - lappend result [namespace eval foo {expr $e}] + lappend result [namespace eval foo [list expr $e]] } -cleanup { namespace delete foo } -result {1 2} test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -body { set e { [llength {}]+1 } - interp alias {} e slave expr - slave eval {proc llength args {return 1}} + interp alias {} e child expr + child eval {proc llength args {return 1}} set result {} lappend result [expr $e] lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {1 2} test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body { proc foo e {set v 0; expr $e} @@ -805,9 +810,9 @@ test execute-7.7 {Wide int handling in INST_EQ and [incr]} { set y [expr {$x+1}] expr {double($x) == double($y)} } 1 -test execute-7.8 {Wide int conversions can change sign} longIs32bit { - set x 0x80000000 - expr {int($x) < wide($x)} +test execute-7.8 {Wide int conversions can change sign} { + set x 0x8000000000000000 + expr {wide($x) < 0} } 1 test execute-7.9 {Wide int handling in INST_MOD} { expr {(wide(1)<<60) % ((wide(47)<<45)-1)} @@ -816,49 +821,49 @@ test execute-7.10 {Wide int handling in INST_MOD} { expr {((wide(1)<<60)-1) % 0x400000000} } 17179869183 test execute-7.11 {Wide int handling in INST_LSHIFT} { - expr wide(42)<<30 + expr {wide(42) << 30} } 45097156608 test execute-7.12 {Wide int handling in INST_LSHIFT} { - expr 12345678901<<3 + expr {12345678901 << 3} } 98765431208 test execute-7.13 {Wide int handling in INST_RSHIFT} { - expr 0x543210febcda9876>>7 + expr {0x543210febcda9876 >> 7} } 47397893236700464 test execute-7.14 {Wide int handling in INST_RSHIFT} { - expr wide(0x9876543210febcda)>>7 + expr {wide(0x9876543210febcda) >> 7} } -58286587177206407 test execute-7.15 {Wide int handling in INST_BITOR} { - expr wide(0x9876543210febcda) | 0x543210febcda9876 + expr {wide(0x9876543210febcda) | 0x543210febcda9876} } -2560765885044310786 test execute-7.16 {Wide int handling in INST_BITXOR} { - expr wide(0x9876543210febcda) ^ 0x543210febcda9876 + expr {wide(0x9876543210febcda) ^ 0x543210febcda9876} } -3727778945703861076 test execute-7.17 {Wide int handling in INST_BITAND} { - expr wide(0x9876543210febcda) & 0x543210febcda9876 + expr {wide(0x9876543210febcda) & 0x543210febcda9876} } 1167013060659550290 test execute-7.18 {Wide int handling in INST_ADD} { - expr wide(0x7fffffff)+wide(0x7fffffff) + expr {wide(0x7fffffff) + wide(0x7fffffff)} } 4294967294 test execute-7.19 {Wide int handling in INST_ADD} { - expr 0x7fffffff+wide(0x7fffffff) + expr {0x7fffffff + wide(0x7fffffff)} } 4294967294 test execute-7.20 {Wide int handling in INST_ADD} { - expr wide(0x7fffffff)+0x7fffffff + expr {wide(0x7fffffff) + 0x7fffffff} } 4294967294 test execute-7.21 {Wide int handling in INST_ADD} { - expr double(0x7fffffff)+wide(0x7fffffff) + expr {double(0x7fffffff) + wide(0x7fffffff)} } 4294967294.0 test execute-7.22 {Wide int handling in INST_ADD} { - expr wide(0x7fffffff)+double(0x7fffffff) + expr {wide(0x7fffffff) + double(0x7fffffff)} } 4294967294.0 test execute-7.23 {Wide int handling in INST_SUB} { - expr 0x123456789a-0x20406080a + expr {0x123456789a - 0x20406080a} } 69530054800 test execute-7.24 {Wide int handling in INST_MULT} { - expr 0x123456789a*193 + expr {0x123456789a * 193} } 15090186251290 test execute-7.25 {Wide int handling in INST_DIV} { - expr 0x123456789a/193 + expr {0x123456789a / 193} } 405116546 test execute-7.26 {Wide int handling in INST_UPLUS} { set x 0x123456871234568 @@ -887,12 +892,12 @@ test execute-7.31 {Wide int handling in abs()} { set y 0x123456871234568 concat [expr {abs($x)}] [expr {abs($y)}] } {730503879441204585 81985533099853160} -test execute-7.32 {Wide int handling} longIs32bit { +test execute-7.32 {Wide int handling} { expr {int(1024 * 1024 * 1024 * 1024)} -} 0 -test execute-7.33 {Wide int handling} longIs32bit { +} 1099511627776 +test execute-7.33 {Wide int handling} { expr {int(0x1 * 1024 * 1024 * 1024 * 1024)} -} 0 +} 1099511627776 test execute-7.34 {Wide int handling} { expr {wide(0x1) * 1024 * 1024 * 1024 * 1024} } 1099511627776 @@ -933,8 +938,7 @@ test execute-8.3 {Stack restoration} -setup { proc f {args} "f $arglst" proc run {} { # bump the interp's epoch - rename ::set ::dummy - rename ::dummy ::set + testbumpinterpepoch catch f msg set msg } @@ -948,8 +952,7 @@ test execute-8.4 {Compile epoch bump effect on stack trace} -setup { } proc FOO {} { catch {error bar} m o - rename ::set ::dummy - rename ::dummy ::set + testbumpinterpepoch return -options $o $m } } -body { @@ -978,10 +981,80 @@ test execute-8.5 {Bug 2038069} -setup { invoked from within "catch \[list error FOO\] m o"} -errorline 2} +test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup { + interp create child + child eval { + package require tcltest 2.5 + catch [list package require -exact tcl::test [info patchlevel]] + ::tcltest::loadTestedCommands + if {[namespace which -command testbumpinterpepoch] eq ""} { + proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } + } + } +} -body { + child eval { + lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C; + } + child eval { + set i 0; while {[incr i] < 3} { + lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C; + } + } + child eval { + set i 0; while {[incr i] < 3} { + lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C; + } + } + child eval { + catch { + lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C; + } + } + child eval {set res} +} -cleanup { + interp delete child +} -result [lrepeat 4 A B] +test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup { + interp create child + child eval { + package require tcltest 2.5 + catch [list package require -exact tcl::test [info patchlevel]] + ::tcltest::loadTestedCommands + if {[namespace which -command testbumpinterpepoch] eq ""} { + proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } + } + } +} -body { + set res {} + lappend res [catch { + child eval { + lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C; + } + } e] $e + lappend res [catch { + child eval { + lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C; + } + } e] $e + lappend res [catch { + child eval { + lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C; + } + } e] $e + lappend res [catch { + child eval { + lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C; + } + } e] $e + list $res [child eval {set res}] +} -cleanup { + interp delete child +} -result [list {1 test 1 test 2 test 3 {}} [lrepeat 4 A B]] + test execute-9.1 {Interp result resetting [Bug 1522803]} { set c 0 catch { - catch {set foo} + catch {error foo} expr {1/$c} } if {[string match *foo* $::errorInfo]} { @@ -996,16 +1069,16 @@ test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} { apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130 } {48 {304 304}} test execute-10.2 {Bug 2802881} -setup { - interp create slave + interp create child } -body { # If [Bug 2802881] is not fixed, this will segfault - slave eval { + child eval { trace add variable ::errorInfo write {expr {$foo} ;#} proc demo {} {a {}{}} demo } } -cleanup { - interp delete slave + interp delete child } -returnCodes error -match glob -result * test execute-10.3 {Bug 3072640} -setup { proc generate {n} { @@ -1013,9 +1086,10 @@ test execute-10.3 {Bug 3072640} -setup { yield $i } } - proc t {args} { - incr ::foo + proc t {args} { + incr ::foo } + set ::foo 0 trace add execution ::generate enterstep ::t } -body { coroutine coro generate 5 @@ -1029,9 +1103,9 @@ test execute-10.3 {Bug 3072640} -setup { } -result 4 test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { set x [lrepeat 1320 199] for {set i 0} {$i < 20} {incr i} { lappend x $i @@ -1041,8 +1115,70 @@ test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup { return ok } } -cleanup { - interp delete slave + interp delete child } -result ok + +test execute-11.2 {Bug 268b23df11} -setup { + proc zero {} {return 0} + proc crash {} {expr {abs([zero])}} + proc noop args {} + trace add execution crash enterstep noop +} -body { + crash +} -cleanup { + trace remove execution crash enterstep noop + rename noop {} + rename crash {} + rename zero {} +} -result 0 +test execute-11.3 {Bug a0ece9d6d4} -setup { + proc crash {} {expr {rand()}} + trace add execution crash enterstep {apply {args {info frame -2}}} +} -body { + string is double [crash] +} -cleanup { + trace remove execution crash enterstep {apply {args {info frame -2}}} + rename crash {} +} -result 1 + +test execute-12.1 {failing multi-lappend to unshared} -setup { + unset -nocomplain x y +} -body { + set x 1 + lappend x 2 3 + trace add variable x write {apply {args {error boo}}} + lappend x 4 5 +} -cleanup { + unset -nocomplain x y +} -returnCodes error -result {can't set "x": boo} +test execute-12.2 {failing multi-lappend to shared} -setup { + unset -nocomplain x y +} -body { + set x 1 + lappend x 2 3 + set y $x + trace add variable x write {apply {args {error boo}}} + lappend x 4 5 +} -cleanup { + unset -nocomplain x y +} -returnCodes error -result {can't set "x": boo} +test execute-12.3 {failing multi-lappend to unshared: LVT} -body { + apply {{} { + set x 1 + lappend x 2 3 + trace add variable x write {apply {args {error boo}}} + lappend x 4 5 + }} +} -returnCodes error -result {can't set "x": boo} +test execute-12.4 {failing multi-lappend to shared: LVT} -body { + apply {{} { + set x 1 + lappend x 2 3 + set y $x + trace add variable x write {apply {args {error boo}}} + lappend x 4 5 + }} +} -returnCodes error -result {can't set "x": boo} # cleanup if {[info commands testobj] != {}} { diff --git a/tests/expr-old.test b/tests/expr-old.test index 4f3cb2e..50fbba7 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -6,31 +6,26 @@ # "compExpr.test". Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-2000 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.1 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] - -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { - testConstraint testmathfunctions 0 -} else { - testConstraint testmathfunctions 1 -} +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] # Big test for correct ordering of data in [expr] @@ -145,7 +140,7 @@ test expr-old-1.50 {integer operators} {expr +36} 36 test expr-old-1.51 {integer operators} {expr +--++36} 36 test expr-old-1.52 {integer operators} {expr +36%+5} 1 test expr-old-1.53 {integer operators} { - catch {unset x} + unset -nocomplain x set x yes list [expr {1 && $x}] [expr {$x && 1}] \ [expr {0 || $x}] [expr {$x || 0}] @@ -422,13 +417,13 @@ test expr-old-21.3 {parenthesization} {expr +(3-4)} -1 # Embedded commands and variable names. -set a 16 -test expr-old-22.1 {embedded variables} {expr {2*$a}} 32 +set a 16 +test expr-old-22.1 {embedded variables} {expr {2*$a}} 32 test expr-old-22.2 {embedded variables} { set x -5 set y 10 expr {$x + $y} -} {5} +} {5} test expr-old-22.3 {embedded variables} { set x " -5" set y " +10" @@ -453,7 +448,7 @@ test expr-old-23.3 {double quotes} { test expr-old-23.4 {double quotes} {expr {"11\}\}22"}} 11}}22 test expr-old-23.5 {double quotes} {expr {"\*bc"}} {*bc} test expr-old-23.6 {double quotes} { - catch {unset bogus__} + unset -nocomplain bogus__ list [catch {expr {"$bogus__"}} msg] $msg } {1 {can't read "bogus__": no such variable}} test expr-old-23.7 {double quotes} { @@ -502,7 +497,7 @@ test expr-old-26.2 {error conditions} -body { test expr-old-26.3 {error conditions} -body { expr 2+4*( } -returnCodes error -match glob -result * -catch {unset _non_existent_} +unset -nocomplain _non_existent_ test expr-old-26.4 {error conditions} { list [catch {expr 2+$_non_existent_} msg] $msg } {1 {can't read "_non_existent_": no such variable}} @@ -529,7 +524,7 @@ test expr-old-26.10b {error conditions} ieeeFloatingPoint { list [catch {expr 2.0/0.0} msg] $msg } {0 Inf} test expr-old-26.11 {error conditions} -body { - expr 2# + expr 2` } -returnCodes error -match glob -result * test expr-old-26.12 {error conditions} -body { expr a.b @@ -581,7 +576,7 @@ test expr-old-27.4 {cancelled evaluation} { expr {1?2:[set a 2]} set a } 1 -catch {unset x} +unset -nocomplain x test expr-old-27.5 {cancelled evaluation} { list [catch {expr {[info exists x] && $x}} msg] $msg } {0 0} @@ -821,10 +816,10 @@ test expr-old-32.32 {math functions in expressions} { } {-1} test expr-old-32.33 {math functions in expressions} { expr int(1e60) -} 0 +} 999999999999999949387135297074018866963645011013410073083904 test expr-old-32.34 {math functions in expressions} { expr int(-1e60) -} 0 +} -999999999999999949387135297074018866963645011013410073083904 test expr-old-32.35 {math functions in expressions} { expr round(1.49) } {1} @@ -849,12 +844,6 @@ test expr-old-32.41 {math functions in expressions} { test expr-old-32.42 {math functions in expressions} { list [catch {expr hypot(5*.8,3)} msg] $msg } {0 5.0} -test expr-old-32.43 {math functions in expressions} testmathfunctions { - expr 2*T1() -} 246 -test expr-old-32.44 {math functions in expressions} testmathfunctions { - expr T2()*3 -} 1035 test expr-old-32.45 {math functions in expressions} { expr (0 <= rand()) && (rand() < 1) } {1} @@ -863,7 +852,7 @@ test expr-old-32.46 {math functions in expressions} -body { } -match glob -result {1 {too many arguments for math function*}} test expr-old-32.47 {math functions in expressions} -body { list [catch {expr srand()} msg] $msg -} -match glob -result {1 {too few arguments for math function*}} +} -match glob -result {1 {not enough arguments for math function*}} test expr-old-32.48 {math functions in expressions} -body { expr srand(3.79) } -returnCodes error -match glob -result * @@ -920,7 +909,7 @@ test expr-old-34.6 {errors in math functions} -body { } -returnCodes error -match glob -result * test expr-old-34.7 {errors in math functions} -body { list [catch {expr hypot(1.0)} msg] $msg -} -match glob -result {1 {too few arguments for math function*}} +} -match glob -result {1 {not enough arguments for math function*}} test expr-old-34.8 {errors in math functions} -body { list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg } -match glob -result {1 {too many arguments for math function*}} @@ -954,11 +943,6 @@ test expr-old-34.15 {errors in math functions} { test expr-old-34.16 {errors in math functions} { expr round(-1.0e30) } -1000000000000000019884624838656 -test expr-old-34.17 {errors in math functions} -constraints testmathfunctions \ - -body { - list [catch {expr T1(4)} msg] $msg - } -match glob -result {1 {too many arguments for math function*}} - test expr-old-36.1 {ExprLooksLikeInt procedure} -body { expr 0o289 } -returnCodes error -match glob -result {*invalid octal number*} @@ -1054,8 +1038,8 @@ test expr-old-37.8 {Tcl_ExprLong handles overflows} testexprlong { testexprlong -0x80000000 } {This is a result: -2147483648} test expr-old-37.9 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { - testexprlong -0xffffffff -} {This is a result: 1} + testexprlong -0x7fffffff +} {This is a result: -2147483647} test expr-old-37.10 {Tcl_ExprLong handles overflows} \ -constraints {testexprlong longIs32bit} \ -match glob \ @@ -1079,9 +1063,13 @@ test expr-old-37.13 {Tcl_ExprLong handles overflows} \ test expr-old-37.14 {Tcl_ExprLong handles overflows} testexprlong { testexprlong -2147483648. } {This is a result: -2147483648} -test expr-old-37.15 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { - testexprlong -4294967295. -} {This is a result: 1} +test expr-old-37.15 {Tcl_ExprLong handles overflows} \ + -constraints {testexprlong longIs32bit} \ + -match glob \ + -body { + list [catch {testexprlong -2147483649.} result] $result + } \ + -result {1 {integer value too large to represent*}} test expr-old-37.16 {Tcl_ExprLong handles overflows} \ -constraints {testexprlong longIs32bit} \ -match glob \ @@ -1122,7 +1110,7 @@ test expr-old-37.25 {Tcl_ExprDouble and NaN} \ {ieeeFloatingPoint testexprdouble} { list [catch {testexprdouble 0.0/0.0} result] $result } {1 {domain error: argument not in valid range}} - + test expr-old-38.1 {Verify Tcl_ExprString's basic operation} -constraints {testexprstring} -body { list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \ [catch {testexprstring "1+"} msg] $msg @@ -1161,8 +1149,8 @@ test expr-old-40.2 {min math function} -body { expr {min(0.0)} } -result 0.0 test expr-old-40.3 {min math function} -body { - list [catch {expr {min()}} msg] $msg -} -result {1 {too few arguments to math function "min"}} + expr {min()} +} -returnCodes error -result {not enough arguments for math function "min"} test expr-old-40.4 {min math function} -body { expr {min(wide(-1) << 30, 4.5, -10)} } -result [expr {wide(-1) << 30}] @@ -1172,6 +1160,12 @@ test expr-old-40.5 {min math function} -body { test expr-old-40.6 {min math function} -body { expr {min(300, "0xFF")} } -result 255 +test expr-old-40.7 {min math function} -body { + expr min(1[string repeat 0 10000], 1e300) +} -result 1e+300 +test expr-old-40.8 {min math function} -body { + expr {min(0, "a")} +} -returnCodes error -match glob -result * test expr-old-41.1 {max math function} -body { expr {max(0)} @@ -1180,8 +1174,8 @@ test expr-old-41.2 {max math function} -body { expr {max(0.0)} } -result 0.0 test expr-old-41.3 {max math function} -body { - list [catch {expr {max()}} msg] $msg -} -result {1 {too few arguments to math function "max"}} + expr {max()} +} -returnCodes error -result {not enough arguments for math function "max"} test expr-old-41.4 {max math function} -body { expr {max(wide(1) << 30, 4.5, -10)} } -result [expr {wide(1) << 30}] @@ -1191,6 +1185,12 @@ test expr-old-41.5 {max math function} -body { test expr-old-41.6 {max math function} -body { expr {max(200, "0xFF")} } -result 255 +test expr-old-41.7 {max math function} -body { + expr max(1[string repeat 0 10000], 1e300) +} -result 1[string repeat 0 10000] +test expr-old-41.8 {max math function} -body { + expr {max(0, "a")} +} -returnCodes error -match glob -result * # Special test for Pentium arithmetic bug of 1994: diff --git a/tests/expr.test b/tests/expr.test index 6ad7208..9add1f1 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -4,31 +4,26 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-2000 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.1 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -testConstraint testmathfunctions [expr { - ([catch {expr T1()} msg] != 1) || ($msg ne {invalid command name "tcl::mathfunc::T1"}) -}] +catch [list package require -exact tcl::test [info patchlevel]] # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] -testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] # Big test for correct ordering of data in [expr] @@ -138,7 +133,7 @@ proc do_twelve_days {} { unset xxx return $result } - + # start of tests catch {unset a b i x} @@ -416,17 +411,34 @@ test expr-8.34 {expr edge cases} -body { test expr-8.35 {expr edge cases} -body { expr {1ea} } -returnCodes error -match glob -result * +test expr-8.36 {CompileEqualtyExpr: string comparison ops} { + set x 012 + set y 0x0 + list [expr {$x < $y}] [expr {$x lt $y}] [expr {$x lt $x}] +} {0 1 0} +test expr-8.37 {CompileEqualtyExpr: string comparison ops} { + set x 012 + set y 0x0 + list [expr {$x <= $y}] [expr {$x le $y}] [expr {$x le $x}] +} {0 1 1} +test expr-8.38 {CompileEqualtyExpr: string comparison ops} { + set x 012 + set y 0x0 + list [expr {$x > $y}] [expr {$x gt $y}] [expr {$x gt $x}] +} {1 0 0} +test expr-8.39 {CompileEqualtyExpr: string comparison ops} { + set x 012 + set y 0x0 + list [expr {$x >= $y}] [expr {$x ge $y}] [expr {$x ge $x}] +} {1 0 1} test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 -test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { +test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} { expr {int(1<<63)} -} -9223372036854775808 -test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { - expr {int(1<<31)} -} -2147483648 +} 9223372036854775808 test expr-9.6 {CompileRelationalExpr: error in shift expr} -body { expr x>>3 } -returnCodes error -match glob -result * @@ -673,53 +685,18 @@ test expr-15.3 {CompileMathFuncCall: too many arguments} -body { test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} -body { catch {expr sin()} msg set ::errorInfo -} -match glob -result {too few arguments for math function* +} -match glob -result {not enough arguments for math function* while *ing "expr sin()"} -test expr-15.5 {CompileMathFuncCall: too few arguments} -body { +test expr-15.5 {CompileMathFuncCall: not enough arguments} -body { catch {expr pow(1)} msg set ::errorInfo -} -match glob -result {too few arguments for math function* +} -match glob -result {not enough arguments for math function* while *ing "expr pow(1)"} test expr-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * -test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr 2*T1() -} 246 -test expr-15.8 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T2()*3 -} 1035 -test expr-15.9 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T3(21, 37) -} 37 -test expr-15.10 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T3(21.2, 37) -} 37.0 -test expr-15.11 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T3(-21.2, -17.5) -} -17.5 -test expr-15.12 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(21, wide(37)) -} 37 -test expr=15.13 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(wide(21), 37) -} 37 -test expr=15.14 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(wide(21), wide(37)) -} 37 -test expr-15.15 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(21.0, wide(37)) -} 37.0 -test expr-15.16 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(wide(21), 37.0) -} 37.0 -test expr-15.17 {ExprCallMathFunc: non-numeric arg} -constraints { - testmathfunctions -} -body { - expr T3(0,"a") -} -returnCodes error -result {argument to math function didn't have numeric value} test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { @@ -752,7 +729,7 @@ test expr-18.1 {expr and conversion of operands to numbers} { catch {expr int($x)} expr {$x} } 11 -test expr-18.2 {whitespace strings should not be == 0 (buggy strtod)} { +test expr-18.2 {whitespace strings should not be == 0 (buggy strtol/strtoul)} { expr {" "} } { } @@ -910,6 +887,15 @@ test expr-22.9 {non-numeric floats: shared object equality and NaN} { set x NaN expr {$x == $x} } 0 +# Make sure [Bug d0f7ba56f0] stays fixed. +test expr-22.10 {non-numeric arguments: equality and NaN} { + set x NaN + expr {$x > "Gran"} +} 1 +test expr-22.11 {non-numeric arguments: equality and NaN} { + set x NaN + expr {"Gran" < $x} +} 1 # Tests for exponentiation handling test expr-23.1 {CompileExponentialExpr: just exponential expr} {expr 4**2} 16 @@ -1141,7 +1127,7 @@ test expr-23.54.11 {INST_EXPON: Bug 2798543} { expr {3**9 == 3**131081} } 0 test expr-23.54.12 {INST_EXPON: Bug 2798543} -body { - expr {3**9 == 3**268435465} + expr {3**268435456} } -returnCodes error -result {exponent too large} test expr-23.54.13 {INST_EXPON: Bug 2798543} { expr {(-3)**9 == (-3)**65545} @@ -1156,7 +1142,7 @@ test expr-23.55.2 {INST_EXPON: Bug 2798543} { expr {4**9 == 4**131081} } 0 test expr-23.55.3 {INST_EXPON: Bug 2798543} -body { - expr {4**9 == 4**268435465} + expr {4**268435456} } -returnCodes error -result {exponent too large} test expr-23.55.4 {INST_EXPON: Bug 2798543} { expr {(-4)**9 == (-4)**65545} @@ -1171,7 +1157,7 @@ test expr-23.56.2 {INST_EXPON: Bug 2798543} { expr {5**9 == 5**131081} } 0 test expr-23.56.3 {INST_EXPON: Bug 2798543} -body { - expr {5**9 == 5**268435465} + expr {5**268435456} } -returnCodes error -result {exponent too large} test expr-23.56.4 {INST_EXPON: Bug 2798543} { expr {(-5)**9 == (-5)**65545} @@ -1186,7 +1172,7 @@ test expr-23.57.2 {INST_EXPON: Bug 2798543} { expr {6**9 == 6**131081} } 0 test expr-23.57.3 {INST_EXPON: Bug 2798543} -body { - expr {6**9 == 6**268435465} + expr {6**268435456} } -returnCodes error -result {exponent too large} test expr-23.57.4 {INST_EXPON: Bug 2798543} { expr {(-6)**9 == (-6)**65545} @@ -1201,7 +1187,7 @@ test expr-23.58.2 {INST_EXPON: Bug 2798543} { expr {7**9 == 7**131081} } 0 test expr-23.58.3 {INST_EXPON: Bug 2798543} -body { - expr {7**9 == 7**268435465} + expr {7**268435456} } -returnCodes error -result {exponent too large} test expr-23.58.4 {INST_EXPON: Bug 2798543} { expr {(-7)**9 == (-7)**65545} @@ -1216,7 +1202,7 @@ test expr-23.59.2 {INST_EXPON: Bug 2798543} { expr {8**9 == 8**131081} } 0 test expr-23.59.3 {INST_EXPON: Bug 2798543} -body { - expr {8**9 == 8**268435465} + expr {8**268435456} } -returnCodes error -result {exponent too large} test expr-23.59.4 {INST_EXPON: Bug 2798543} { expr {(-8)**9 == (-8)**65545} @@ -1228,7 +1214,7 @@ test expr-23.60.1 {INST_EXPON: Bug 2798543} { expr {9**9 == 9**131081} } 0 test expr-23.60.2 {INST_EXPON: Bug 2798543} -body { - expr {9**9 == 9**268435465} + expr {9**268435456} } -returnCodes error -result {exponent too large} test expr-23.60.3 {INST_EXPON: Bug 2798543} { expr {(-9)**9 == (-9)**65545} @@ -1240,7 +1226,7 @@ test expr-23.61.1 {INST_EXPON: Bug 2798543} { expr {10**9 == 10**131081} } 0 test expr-23.61.2 {INST_EXPON: Bug 2798543} -body { - expr {10**9 == 10**268435465} + expr {10**268435456} } -returnCodes error -result {exponent too large} test expr-23.61.3 {INST_EXPON: Bug 2798543} { expr {(-10)**9 == (-10)**65545} @@ -1252,7 +1238,7 @@ test expr-23.62.1 {INST_EXPON: Bug 2798543} { expr {11**9 == 11**131081} } 0 test expr-23.62.2 {INST_EXPON: Bug 2798543} -body { - expr {11**9 == 11**268435465} + expr {11**268435456} } -returnCodes error -result {exponent too large} test expr-23.62.3 {INST_EXPON: Bug 2798543} { expr {(-11)**9 == (-11)**65545} @@ -1267,7 +1253,7 @@ test expr-23.63.2 {INST_EXPON: Bug 2798543} { expr {3**20 == 3**131092} } 0 test expr-23.63.3 {INST_EXPON: Bug 2798543} -body { - expr {3**20 == 3**268435476} + expr {3**268435456} } -returnCodes error -result {exponent too large} test expr-23.63.4 {INST_EXPON: Bug 2798543} { expr {(-3)**20 == (-3)**65556} @@ -1282,7 +1268,7 @@ test expr-23.64.2 {INST_EXPON: Bug 2798543} { expr {4**17 == 4**131089} } 0 test expr-23.64.3 {INST_EXPON: Bug 2798543} -body { - expr {4**17 == 4**268435473} + expr {4**268435456} } -returnCodes error -result {exponent too large} test expr-23.64.4 {INST_EXPON: Bug 2798543} { expr {(-4)**17 == (-4)**65553} @@ -1297,7 +1283,7 @@ test expr-23.65.2 {INST_EXPON: Bug 2798543} { expr {5**17 == 5**131089} } 0 test expr-23.65.3 {INST_EXPON: Bug 2798543} -body { - expr {5**17 == 5**268435473} + expr {5**268435456} } -returnCodes error -result {exponent too large} test expr-23.65.4 {INST_EXPON: Bug 2798543} { expr {(-5)**17 == (-5)**65553} @@ -1312,7 +1298,7 @@ test expr-23.66.2 {INST_EXPON: Bug 2798543} { expr {6**17 == 6**131089} } 0 test expr-23.66.3 {INST_EXPON: Bug 2798543} -body { - expr {6**17 == 6**268435473} + expr {6**268435456} } -returnCodes error -result {exponent too large} test expr-23.66.4 {INST_EXPON: Bug 2798543} { expr {(-6)**17 == (-6)**65553} @@ -1327,7 +1313,7 @@ test expr-23.67.2 {INST_EXPON: Bug 2798543} { expr {7**17 == 7**131089} } 0 test expr-23.67.3 {INST_EXPON: Bug 2798543} -body { - expr {7**17 == 7**268435473} + expr {7**268435456} } -returnCodes error -result {exponent too large} test expr-23.67.4 {INST_EXPON: Bug 2798543} { expr {(-7)**17 == (-7)**65553} @@ -1342,7 +1328,7 @@ test expr-23.68.2 {INST_EXPON: Bug 2798543} { expr {8**17 == 8**131089} } 0 test expr-23.68.3 {INST_EXPON: Bug 2798543} -body { - expr {8**17 == 8**268435473} + expr {8**268435456} } -returnCodes error -result {exponent too large} test expr-23.68.4 {INST_EXPON: Bug 2798543} { expr {(-8)**17 == (-8)**65553} @@ -1357,7 +1343,7 @@ test expr-23.69.2 {INST_EXPON: Bug 2798543} { expr {9**17 == 9**131089} } 0 test expr-23.69.3 {INST_EXPON: Bug 2798543} -body { - expr {9**17 == 9**268435473} + expr {9**268435456} } -returnCodes error -result {exponent too large} test expr-23.69.4 {INST_EXPON: Bug 2798543} { expr {(-9)**17 == (-9)**65553} @@ -1372,7 +1358,7 @@ test expr-23.70.2 {INST_EXPON: Bug 2798543} { expr {10**17 == 10**131089} } 0 test expr-23.70.3 {INST_EXPON: Bug 2798543} -body { - expr {10**17 == 10**268435473} + expr {10**268435456} } -returnCodes error -result {exponent too large} test expr-23.70.4 {INST_EXPON: Bug 2798543} { expr {(-10)**17 == (-10)**65553} @@ -1387,7 +1373,7 @@ test expr-23.71.2 {INST_EXPON: Bug 2798543} { expr {11**17 == 11**131089} } 0 test expr-23.71.3 {INST_EXPON: Bug 2798543} -body { - expr {11**17 == 11**268435473} + expr {11**268435456} } -returnCodes error -result {exponent too large} test expr-23.71.4 {INST_EXPON: Bug 2798543} { expr {(-11)**17 == (-11)**65553} @@ -1399,7 +1385,7 @@ test expr-23.72.1 {INST_EXPON: Bug 2798543} { expr {12**17 == 12**131089} } 0 test expr-23.72.2 {INST_EXPON: Bug 2798543} -body { - expr {12**17 == 12**268435473} + expr {12**268435456} } -returnCodes error -result {exponent too large} test expr-23.72.3 {INST_EXPON: Bug 2798543} { expr {(-12)**17 == (-12)**65553} @@ -1411,7 +1397,7 @@ test expr-23.73.1 {INST_EXPON: Bug 2798543} { expr {13**17 == 13**131089} } 0 test expr-23.73.2 {INST_EXPON: Bug 2798543} -body { - expr {13**17 == 13**268435473} + expr {13**268435456} } -returnCodes error -result {exponent too large} test expr-23.73.3 {INST_EXPON: Bug 2798543} { expr {(-13)**17 == (-13)**65553} @@ -1423,20 +1409,20 @@ test expr-23.74.1 {INST_EXPON: Bug 2798543} { expr {14**17 == 14**131089} } 0 test expr-23.74.2 {INST_EXPON: Bug 2798543} -body { - expr {14**17 == 14**268435473} + expr {14**268435456} } -returnCodes error -result {exponent too large} test expr-23.74.3 {INST_EXPON: Bug 2798543} { expr {(-14)**17 == (-14)**65553} } 0 - + # Some compilers get this wrong; ensure that we work around it correctly test expr-24.1 {expr edge cases; shifting} {expr int(5)>>32} 0 test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0 test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>32} 0 test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0 -test expr-24.5 {expr edge cases; shifting} longIs32bit {expr int(5<<32)} 0 -test expr-24.6 {expr edge cases; shifting} longIs32bit {expr int(5<<63)} 0 +test expr-24.5 {expr edge cases; shifting} {expr int(5<<32)} 21474836480 +test expr-24.6 {expr edge cases; shifting} {expr int(5<<63)} 46116860184273879040 test expr-24.7 {expr edge cases; shifting} {expr wide(5)<<32} 21474836480 test expr-24.8 {expr edge cases; shifting} {expr wide(10<<63)} 0 test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0 @@ -5777,7 +5763,7 @@ test expr-32.1 {expr mod basics} { 0 1 0 3 3 \ 0 -1 0 -1 -2 \ ] - + test expr-32.2 {expr div basics} { set mod_nums [list \ {-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \ @@ -5829,8 +5815,17 @@ test expr-32.5 {Bug 1585704} { test expr-32.6 {Bug 1585704} { expr -(1<<32)%(1<<63) } [expr (1<<63)-(1<<32)] +test expr-32.7 {bignum regression} { + expr {0%(1<<63)} +} 0 +test expr-32.8 {bignum regression} { + expr {0%-(1<<63)} +} 0 +test expr-32.9 {bignum regression} { + expr {0%-(1+(1<<63))} +} 0 -test expr-33.1 {parse largest long value} longIs32bit { +test expr-33.1 {parse largest long value} { set max_long_str 2147483647 set max_long_hex "0x7FFFFFFF " @@ -5844,7 +5839,7 @@ test expr-33.1 {parse largest long value} longIs32bit { [expr {$max_long + 0}] \ [expr {2147483647 + 0}] \ [expr {$max_long == $max_long_hex}] \ - [expr {int(2147483647 + 1) < 0}] \ + [expr {int(2147483647 + 1) > 0}] \ } {2147483647 2147483647 2147483647 2147483647 1 1} test expr-33.2 {parse smallest long value} longIs32bit { @@ -5864,7 +5859,7 @@ test expr-33.2 {parse smallest long value} longIs32bit { [expr {$min_long + 0}] \ [expr {-2147483648 + 0}] \ [expr {$min_long == $min_long_hex}] \ - [expr {int(-2147483648 - 1) == 0x7FFFFFFF}] \ + [expr {int(-2147483648 - 1) == -0x80000001}] \ } {-2147483648 -2147483648 -2147483648 -2147483648 1 1} test expr-33.3 {parse largest wide value} wideIs64bit { @@ -5944,17 +5939,17 @@ test expr-34.11 {expr edge cases} { test expr-34.12 {expr edge cases} { expr {$min % -2} } {0} -test expr-34.13 {expr edge cases} longIs32bit { +test expr-34.13 {expr edge cases} { expr {int($min / -1)} -} {-2147483648} +} {2147483648} test expr-34.14 {expr edge cases} { expr {$min % -1} } {0} -test expr-34.15 {expr edge cases} longIs32bit { - expr {int($min * -1)} +test expr-34.15 {expr edge cases} { + expr {-int($min * -1)} } $min -test expr-34.16 {expr edge cases} longIs32bit { - expr {int(-$min)} +test expr-34.16 {expr edge cases} { + expr {-int(-$min)} } $min test expr-34.17 {expr edge cases} { expr {$min / 1} @@ -6741,8 +6736,8 @@ test expr-39.8 {Tcl_ExprLongObj handles overflows} testexprlongobj { testexprlongobj -0x80000000 } {This is a result: -2147483648} test expr-39.9 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { - testexprlongobj -0xffffffff -} {This is a result: 1} + testexprlongobj -0x7fffffff +} {This is a result: -2147483647} test expr-39.10 {Tcl_ExprLongObj handles overflows} \ -constraints {testexprlongobj longIs32bit} \ -match glob \ @@ -6767,8 +6762,8 @@ test expr-39.14 {Tcl_ExprLongObj handles overflows} testexprlongobj { testexprlongobj -2147483648. } {This is a result: -2147483648} test expr-39.15 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { - testexprlongobj -4294967295. -} {This is a result: 1} + testexprlongobj -2147483648. +} {This is a result: -2147483648} test expr-39.16 {Tcl_ExprLongObj handles overflows} \ -constraints {testexprlongobj longIs32bit} \ -match glob \ @@ -6776,7 +6771,7 @@ test expr-39.16 {Tcl_ExprLongObj handles overflows} \ list [catch {testexprlongobj 4294967296.} result] $result } \ -result {1 {integer value too large to represent*}} - + test expr-39.17 {Check that Tcl_ExprDoubleObj doesn't modify interpreter result if no error} testexprdoubleobj { testexprdoubleobj 4.+1. } {This is a result: 5.0} @@ -6827,6 +6822,72 @@ test expr-41.2 {exponent underflow} { expr 1.0e-2147483630 } 0.0 +test expr-41.3 {exponent overflow} { + expr 1e2147483647 +} Inf +test expr-41.4 {exponent overflow} { + expr 1e2147483648 +} Inf +test expr-41.5 {exponent overflow} { + expr 100e2147483645 +} Inf +test expr-41.6 {exponent overflow} { + expr 100e2147483646 +} Inf +test expr-41.7 {exponent overflow} { + expr 1.0e2147483647 +} Inf +test expr-41.8 {exponent overflow} { + expr 1.0e2147483648 +} Inf +test expr-41.9 {exponent overflow} { + expr 1.2e2147483647 +} Inf +test expr-41.10 {exponent overflow} { + expr 1.2e2147483648 +} Inf + +test expr-41.11 {exponent overflow} { + expr 1e-2147483648 +} 0.0 +test expr-41.12 {exponent overflow} { + expr 1e-2147483649 +} 0.0 +test expr-41.13 {exponent overflow} { + expr 100e-2147483650 +} 0.0 +test expr-41.14 {exponent overflow} { + expr 100e-2147483651 +} 0.0 +test expr-41.15 {exponent overflow} { + expr 1.0e-2147483648 +} 0.0 +test expr-41.16 {exponent overflow} { + expr 1.0e-2147483649 +} 0.0 +test expr-41.17 {exponent overflow} { + expr 1.23e-2147483646 +} 0.0 +test expr-41.18 {exponent overflow} { + expr 1.23e-2147483647 +} 0.0 + +test expr-41.19 {numSigDigs == 0} { + expr 0e309 +} 0.0 +test expr-41.20 {numSigDigs == 0} { + expr 0e310 +} 0.0 +test expr-41.21 {negative zero, large exponent} { + expr -0e309 +} -0.0 +test expr-41.22 {negative zero, large exponent} { + expr -0e310 +} -0.0 +test expr-41.23 {floating point overflow on significand (Bug 1de6b0629e)} { + expr 123[string repeat 0 309]1e-310 +} 123.0 + test expr-42.1 {denormals} ieeeFloatingPoint { expr 7e-324 } 5e-324 @@ -7174,14 +7235,221 @@ 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 +test expr-52.1 { + comparison with empty string does not generate string representation +} { + set a [list one two three] + list [expr {$a eq {}}] [expr {$a < {}}] [expr {$a > {}}] [ + string match {*no string representation*} [ + ::tcl::unsupported::representation $a]] +} {0 0 1 1} -# cleanup -if {[info exists a]} { - unset a +foreach func {isfinite isinf isnan isnormal issubnormal} { + test expr-53.1.$func {float classification: basic arg handling} -body { + expr ${func}() + } -returnCodes error -result "not enough arguments for math function \"$func\"" + test expr-53.2.$func {float classification: basic arg handling} -body { + expr ${func}(1,2) + } -returnCodes error -result "too many arguments for math function \"$func\"" + test expr-53.3.$func {float classification: basic arg handling} -body { + expr ${func}(true) + } -returnCodes error -result {expected number but got "true"} + test expr-53.4.$func {float classification: basic arg handling} -body { + expr ${func}("gorp") + } -returnCodes error -result {expected number but got "gorp"} + test expr-53.5.$func {float classification: basic arg handling} -body { + expr ${func}(1.0) + } -match glob -result * + test expr-53.6.$func {float classification: basic arg handling} -body { + expr ${func}(0x123) + } -match glob -result * } -catch {unset min} -catch {unset max} + +test expr-54.0 {float classification: isfinite} {expr {isfinite(1.0)}} 1 +test expr-54.1 {float classification: isfinite} {expr {isfinite(-1.0)}} 1 +test expr-54.2 {float classification: isfinite} {expr {isfinite(0.0)}} 1 +test expr-54.3 {float classification: isfinite} {expr {isfinite(-0.0)}} 1 +test expr-54.4 {float classification: isfinite} {expr {isfinite(1/Inf)}} 1 +test expr-54.5 {float classification: isfinite} {expr {isfinite(-1/Inf)}} 1 +test expr-54.6 {float classification: isfinite} {expr {isfinite(1e-314)}} 1 +test expr-54.7 {float classification: isfinite} {expr {isfinite(inf)}} 0 +test expr-54.8 {float classification: isfinite} {expr {isfinite(-inf)}} 0 +test expr-54.9 {float classification: isfinite} {expr {isfinite(NaN)}} 0 + +test expr-55.0 {float classification: isinf} {expr {isinf(1.0)}} 0 +test expr-55.1 {float classification: isinf} {expr {isinf(-1.0)}} 0 +test expr-55.2 {float classification: isinf} {expr {isinf(0.0)}} 0 +test expr-55.3 {float classification: isinf} {expr {isinf(-0.0)}} 0 +test expr-55.4 {float classification: isinf} {expr {isinf(1/Inf)}} 0 +test expr-55.5 {float classification: isinf} {expr {isinf(-1/Inf)}} 0 +test expr-55.6 {float classification: isinf} {expr {isinf(1e-314)}} 0 +test expr-55.7 {float classification: isinf} {expr {isinf(inf)}} 1 +test expr-55.8 {float classification: isinf} {expr {isinf(-inf)}} 1 +test expr-55.9 {float classification: isinf} {expr {isinf(NaN)}} 0 + +test expr-56.0 {float classification: isnan} {expr {isnan(1.0)}} 0 +test expr-56.1 {float classification: isnan} {expr {isnan(-1.0)}} 0 +test expr-56.2 {float classification: isnan} {expr {isnan(0.0)}} 0 +test expr-56.3 {float classification: isnan} {expr {isnan(-0.0)}} 0 +test expr-56.4 {float classification: isnan} {expr {isnan(1/Inf)}} 0 +test expr-56.5 {float classification: isnan} {expr {isnan(-1/Inf)}} 0 +test expr-56.6 {float classification: isnan} {expr {isnan(1e-314)}} 0 +test expr-56.7 {float classification: isnan} {expr {isnan(inf)}} 0 +test expr-56.8 {float classification: isnan} {expr {isnan(-inf)}} 0 +test expr-56.9 {float classification: isnan} {expr {isnan(NaN)}} 1 + +test expr-57.0 {float classification: isnormal} {expr {isnormal(1.0)}} 1 +test expr-57.1 {float classification: isnormal} {expr {isnormal(-1.0)}} 1 +test expr-57.2 {float classification: isnormal} {expr {isnormal(0.0)}} 0 +test expr-57.3 {float classification: isnormal} {expr {isnormal(-0.0)}} 0 +test expr-57.4 {float classification: isnormal} {expr {isnormal(1/Inf)}} 0 +test expr-57.5 {float classification: isnormal} {expr {isnormal(-1/Inf)}} 0 +test expr-57.6 {float classification: isnormal} {expr {isnormal(1e-314)}} 0 +test expr-57.7 {float classification: isnormal} {expr {isnormal(inf)}} 0 +test expr-57.8 {float classification: isnormal} {expr {isnormal(-inf)}} 0 +test expr-57.9 {float classification: isnormal} {expr {isnormal(NaN)}} 0 + +test expr-58.0 {float classification: issubnormal} {expr {issubnormal(1.0)}} 0 +test expr-58.1 {float classification: issubnormal} {expr {issubnormal(-1.0)}} 0 +test expr-58.2 {float classification: issubnormal} {expr {issubnormal(0.0)}} 0 +test expr-58.3 {float classification: issubnormal} {expr {issubnormal(-0.0)}} 0 +test expr-58.4 {float classification: issubnormal} {expr {issubnormal(1/Inf)}} 0 +test expr-58.5 {float classification: issubnormal} {expr {issubnormal(-1/Inf)}} 0 +test expr-58.6 {float classification: issubnormal} {expr {issubnormal(1e-314)}} 1 +test expr-58.7 {float classification: issubnormal} {expr {issubnormal(inf)}} 0 +test expr-58.8 {float classification: issubnormal} {expr {issubnormal(-inf)}} 0 +test expr-58.9 {float classification: issubnormal} {expr {issubnormal(NaN)}} 0 + +test expr-59.0 {float classification: fpclassify} {fpclassify 1.0} normal +test expr-59.1 {float classification: fpclassify} {fpclassify -1.0} normal +test expr-59.2 {float classification: fpclassify} {fpclassify 0.0} zero +test expr-59.3 {float classification: fpclassify} {fpclassify -0.0} zero +test expr-59.4 {float classification: fpclassify} {fpclassify [expr 1/Inf]} zero +test expr-59.5 {float classification: fpclassify} {fpclassify [expr -1/Inf]} zero +test expr-59.6 {float classification: fpclassify} {fpclassify 1e-314} subnormal +test expr-59.7 {float classification: fpclassify} {fpclassify inf} infinite +test expr-59.8 {float classification: fpclassify} {fpclassify -inf} infinite +test expr-59.9 {float classification: fpclassify} {fpclassify NaN} nan +test expr-59.10 {float classification: fpclassify} -returnCodes error -body { + fpclassify +} -result {wrong # args: should be "fpclassify floatValue"} +test expr-59.11 {float classification: fpclassify} -returnCodes error -body { + fpclassify a b +} -result {wrong # args: should be "fpclassify floatValue"} +test expr-59.12 {float classification: fpclassify} -returnCodes error -body { + fpclassify gorp +} -result {expected number but got "gorp"} + +test expr-60.1 {float classification: basic arg handling} -body { + expr isunordered() +} -returnCodes error -result {not enough arguments for math function "isunordered"} +test expr-60.2 {float classification: basic arg handling} -body { + expr isunordered(1) +} -returnCodes error -result {not enough arguments for math function "isunordered"} +test expr-60.3 {float classification: basic arg handling} -body { + expr {isunordered(1, 2, 3)} +} -returnCodes error -result {too many arguments for math function "isunordered"} +test expr-60.4 {float classification: basic arg handling} -body { + expr {isunordered(true, 1.0)} +} -returnCodes error -result {expected number but got "true"} +test expr-60.5 {float classification: basic arg handling} -body { + expr {isunordered("gorp", 1.0)} +} -returnCodes error -result {expected number but got "gorp"} +test expr-60.6 {float classification: basic arg handling} -body { + expr {isunordered(0x123, 1.0)} +} -match glob -result * +test expr-60.7 {float classification: basic arg handling} -body { + expr {isunordered(1.0, true)} +} -returnCodes error -result {expected number but got "true"} +test expr-60.8 {float classification: basic arg handling} -body { + expr {isunordered(1.0, "gorp")} +} -returnCodes error -result {expected number but got "gorp"} +test expr-60.9 {float classification: basic arg handling} -body { + expr {isunordered(1.0, 0x123)} +} -match glob -result * + +# Big matrix of comparisons, but it's just a binary isinf() +set values {1.0 -1.0 0.0 -0.0 1e-314 Inf -Inf NaN} +set results {0 0 0 0 0 0 0 1} +set ctr 0 +foreach v1 $values r1 $results { + foreach v2 $values r2 $results { + test expr-61.[incr ctr] "float classification: isunordered($v1,$v2)" { + expr {isunordered($v1, $v2)} + } [expr {$r1 || $r2}] + } +} +unset -nocomplain values results ctr + +test expr-62.1 {TIP 582: comments} -body { + expr {1 # + 2} +} -result 1 +test expr-62.2 {TIP 582: comments} -body { + expr "1 #\n+ 2" +} -result 3 +test expr-62.3 {TIP 582: comments} -setup { + set ctr 0 +} -body { + expr { + # This is a demonstration of a comment + 1 + 2 + 3 + # and another comment + + 4 + 5 + # + [incr ctr] + + [incr ctr] + } +} -result 16 +# Buggy because line breaks aren't tracked inside expressions at all +test expr-62.4 {TIP 582: comments don't hide line breaks} -setup { + proc getline {} { + dict get [info frame -1] line + } + set base [getline] +} -constraints knownBug -body { + expr { + 0 + # a comment + + [getline] - $base + } +} -cleanup { + rename getline "" +} -result 5 +test expr-62.5 {TIP 582: comments don't splice tokens} { + set a False + expr {$a#don't splice +ne#don't splice +false} +} 1 +test expr-62.6 {TIP 582: comments don't splice tokens} { + expr {0x2#don't splice +ne#don't splice +2} +} 1 +test expr-62.7 {TIP 582: comments can go inside function calls} { + expr {max(1,# comment + 2)} +} 2 +test expr-62.8 {TIP 582: comments can go inside function calls} { + expr {max(1# comment + ,2)} +} 2 +test expr-62.9 {TIP 582: comments can go inside function calls} { + expr {max(# comment + 1,2)} +} 2 +test expr-62.10 {TIP 582: comments can go inside function calls} { + expr {max# comment + (1,2)} +} 2 + +# cleanup +unset -nocomplain a +unset -nocomplain min +unset -nocomplain max ::tcltest::cleanupTests return diff --git a/tests/fCmd.test b/tests/fCmd.test index 325b374..6a909f8 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -4,26 +4,25 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1999 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] cd [temporaryDirectory] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testchmod [llength [info commands testchmod]] -testConstraint winVista 0 -testConstraint win2000orXP 0 +testConstraint winLessThan10 0 # Don't know how to determine this constraint correctly testConstraint notNetworkFilesystem 0 testConstraint reg 0 @@ -41,6 +40,7 @@ if {[testConstraint win]} { testConstraint reg 1 } } +testConstraint notInCIenv [expr {![info exists ::env(CI)] || !$::env(CI)}] set tmpspace /tmp;# default value # Find a group that exists on this Unix system, or else skip tests that @@ -64,23 +64,17 @@ if {[testConstraint unix]} { } # Also used in winFCmd... -if {[testConstraint win]} { - set major [string index $tcl_platform(osVersion) 0] - if {[testConstraint nt] && $major > 4} { - if {$major > 5} { - testConstraint winVista 1 - } elseif {$major == 5} { - testConstraint win2000orXP 1 - } - } +if {[testConstraint win] && $::tcl_platform(osVersion) < 10.0} { + testConstraint winLessThan10 1 } testConstraint darwin9 [expr { [testConstraint unix] && $tcl_platform(os) eq "Darwin" - && [package vsatisfies 1.$tcl_platform(osVersion) 1.9] + && [package vsatisfies 1.$::tcl_platform(osVersion) 1.9] }] testConstraint notDarwin9 [expr {![testConstraint darwin9]}] +testConstraint notContinuousIntegration [expr {![info exists ::env(CI)]}] testConstraint fileSharing 0 testConstraint notFileSharing 1 @@ -128,7 +122,7 @@ proc checkcontent {file matchString} { } proc openup {path} { - testchmod 777 $path + testchmod 0o777 $path if {[file isdirectory $path]} { catch { foreach p [glob -directory $path *] { @@ -279,7 +273,7 @@ test fCmd-3.14 {FileCopyRename: FileBasename fails} -setup { } -result {user "_totally_bogus_user" doesn't exist} test fCmd-3.15 {FileCopyRename: source[0] == '\0'} -setup { cleanup -} -constraints {notRoot unixOrPc} -returnCodes error -body { +} -constraints {notRoot unixOrWin} -returnCodes error -body { file mkdir td1 file rename / td1 } -result {error renaming "/" to "td1": file already exists} @@ -362,10 +356,10 @@ test fCmd-4.11 {TclFileMakeDirsCmd: doesn't exist: errno != ENOENT} -setup { cleanup } -constraints {unix notRoot testchmod} -returnCodes error -body { file mkdir td1/td2/td3 - testchmod 000 td1/td2 + testchmod 0 td1/td2 file mkdir td1/td2/td3/td4 } -cleanup { - testchmod 755 td1/td2 + testchmod 0o755 td1/td2 cleanup } -result {can't create directory "td1/td2/td3": permission denied} test fCmd-4.13 {TclFileMakeDirsCmd: doesn't exist: errno == ENOENT} -setup { @@ -419,7 +413,7 @@ test fCmd-5.4 {TclFileDeleteCmd: multiple files} -constraints notRoot -setup { } -cleanup {cleanup} -result {1 1 1 0 0 0} test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup { cleanup -} -constraints {notRoot unixOrPc} -body { +} -constraints {notRoot unixOrWin notWine} -body { createfile tf1 createfile tf2 file mkdir td1 @@ -505,18 +499,12 @@ test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} -setup { cleanup } -constraints {unix notRoot testchmod} -body { file mkdir td1 - testchmod 000 td1 + testchmod 0 td1 createfile tf1 file rename tf1 td1 } -returnCodes error -cleanup { - testchmod 755 td1 + testchmod 0o755 td1 } -result {error renaming "tf1" to "td1/tf1": permission denied} -test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} -setup { - cleanup -} -constraints {win 95} -returnCodes error -body { - createfile tf1 - file rename tf1 $long -} -result [subst {error renaming "tf1" to "$long": file name too long}] test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} -setup { cleanup } -constraints {unix notRoot} -body { @@ -572,7 +560,7 @@ test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} -setup { } -result 1 test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir [file join td1 td2] createfile [file join td1 td2 tf1] file mkdir td2 @@ -581,12 +569,12 @@ test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} -setup { [subst {error renaming "td2" to "[file join td1 td2]": file *}] test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} -setup { cleanup -} -constraints {notRoot} -returnCodes error -body { +} -constraints {notRoot notWine} -returnCodes error -body { file rename -force $root tf1 } -result [subst {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}] test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir [file join td1 td2] createfile [file join td1 td2 tf1] file mkdir td2 @@ -630,10 +618,10 @@ test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { cleanup $tmpspace } -constraints {xdev notRoot} -body { file mkdir td1/td2/td3 - file attributes td1 -permissions 0000 + file attributes td1 -permissions 0 file rename td1 $tmpspace } -returnCodes error -cleanup { - file attributes td1 -permissions 0755 + file attributes td1 -permissions 0o755 cleanup } -match regexp -result {^error renaming "td1"( to "/tmp/tcl\d+/td1")?: permission denied$} test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup { @@ -641,10 +629,10 @@ test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup { } -constraints {unix notRoot} -body { file mkdir ~/td1/td2 set td1name [file join [file dirname ~] [file tail ~] td1] - file attributes $td1name -permissions 0000 + file attributes $td1name -permissions 0 file copy ~/td1 td1 } -returnCodes error -cleanup { - file attributes $td1name -permissions 0755 + file attributes $td1name -permissions 0o755 file delete -force ~/td1 } -result {error copying "~/td1": permission denied} test fCmd-6.25 {CopyRenameOneFile: error uses original name} -setup { @@ -653,10 +641,10 @@ test fCmd-6.25 {CopyRenameOneFile: error uses original name} -setup { file mkdir td2 file mkdir ~/td1 set td1name [file join [file dirname ~] [file tail ~] td1] - file attributes $td1name -permissions 0000 + file attributes $td1name -permissions 0 file copy td2 ~/td1 } -returnCodes error -cleanup { - file attributes $td1name -permissions 0755 + file attributes $td1name -permissions 0o755 file delete -force ~/td1 } -result {error copying "td2" to "~/td1/td2": permission denied} test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} -setup { @@ -664,10 +652,10 @@ test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} -setup { } -constraints {unix notRoot} -body { file mkdir ~/td1/td2 set td2name [file join [file dirname ~] [file tail ~] td1 td2] - file attributes $td2name -permissions 0000 + file attributes $td2name -permissions 0 file copy ~/td1 td1 } -returnCodes error -cleanup { - file attributes $td2name -permissions 0755 + file attributes $td2name -permissions 0o755 file delete -force ~/td1 } -result "error copying \"~/td1\" to \"td1\": \"[file join $::env(HOME) td1 td2]\": permission denied" test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { @@ -682,10 +670,10 @@ test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { cleanup $tmpspace } -constraints {notRoot xdev} -body { file mkdir td1/td2/td3 - file attributes td1/td2/td3 -permissions 0000 + file attributes td1/td2/td3 -permissions 0 file rename td1 $tmpspace } -returnCodes error -cleanup { - file attributes td1/td2/td3 -permissions 0755 + file attributes td1/td2/td3 -permissions 0o755 cleanup $tmpspace } -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": "td1/td2/td3": permission denied} test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} -setup { @@ -791,27 +779,16 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup { } -constraints {notRoot testchmod} -body { createfile tf1 createfile tf2 - testchmod 444 tf2 + testchmod 0o444 tf2 file rename tf1 tf3 file rename tf2 tf4 list [lsort [glob tf*]] [file writable tf3] [file writable tf4] } -result {{tf3 tf4} 1 0} -test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup { - cleanup -} -constraints {win win2000orXP testchmod} -body { - file mkdir td1 td2 - testchmod 555 td2 - file rename td1 td3 - file rename td2 td4 - list [lsort [glob td*]] [file writable td3] [file writable td4] -} -cleanup { - cleanup -} -result {{td3 td4} 1 0} -test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup { +test fCmd-9.4 {file rename: comprehensive: dir to new name} -setup { cleanup } -constraints {unix notRoot testchmod notDarwin9} -body { file mkdir td1 td2 - testchmod 555 td2 + testchmod 0o555 td2 file rename td1 td3 file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] @@ -820,37 +797,27 @@ test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup { } -result {{td3 td4} 1 0} test fCmd-9.5 {file rename: comprehensive: file to self} -setup { cleanup -} -constraints {notRoot testchmod} -body { +} -constraints {notRoot testchmod notWine} -body { createfile tf1 tf1 createfile tf2 tf2 - testchmod 444 tf2 + testchmod 0o444 tf2 file rename -force tf1 tf1 file rename -force tf2 tf2 list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] } -result {tf1 tf2 1 0} -test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup { - cleanup -} -constraints {win win2000orXP testchmod} -body { - file mkdir td1 - file mkdir td2 - testchmod 555 td2 - file rename -force td1 . - file rename -force td2 . - list [lsort [glob td*]] [file writable td1] [file writable td2] -} -result {{td1 td2} 1 0} -test fCmd-9.6.b {file rename: comprehensive: dir to self} -setup { +test fCmd-9.6 {file rename: comprehensive: dir to self} -setup { cleanup } -constraints {unix notRoot testchmod} -body { file mkdir td1 file mkdir td2 - testchmod 555 td2 + testchmod 0o555 td2 file rename -force td1 . file rename -force td2 . list [lsort [glob td*]] [file writable td1] [file writable td2] } -result {{td1 td2} 1 0} test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup { cleanup -} -constraints {notRoot testchmod} -body { +} -constraints {notRoot testchmod notWine} -body { createfile tf1 createfile tf2 createfile tfs1 @@ -861,10 +828,10 @@ test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup { createfile tfd2 createfile tfd3 createfile tfd4 - testchmod 444 tfs3 - testchmod 444 tfs4 - testchmod 444 tfd2 - testchmod 444 tfd4 + testchmod 0o444 tfs3 + testchmod 0o444 tfs4 + testchmod 0o444 tfd2 + testchmod 0o444 tfd4 set msg [list [catch {file rename tf1 tf2} msg] $msg] file rename -force tfs1 tfd1 file rename -force tfs2 tfd2 @@ -888,11 +855,11 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { file mkdir [file join tdd3 tds3] file mkdir [file join tdd4 tds4] if {![testConstraint unix]} { - testchmod 555 tds3 - testchmod 555 tds4 + testchmod 0o555 tds3 + testchmod 0o555 tds4 } - testchmod 555 [file join tdd2 tds2] - testchmod 555 [file join tdd4 tds4] + testchmod 0o555 [file join tdd2 tds2] + testchmod 0o555 [file join tdd4 tds4] set msg [list [catch {file rename td1 td2} msg] $msg] file rename -force tds1 tdd1 file rename -force tds2 tdd2 @@ -911,21 +878,14 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { # Test can hit EEXIST or EBUSY, depending on underlying filesystem test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup { cleanup -} -constraints {notRoot testchmod} -body { +} -constraints {notRoot testchmod notWine} -body { file mkdir tds1 file mkdir tds2 file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] - if {!([testConstraint unix] || [testConstraint winVista])} { - testchmod 555 tds2 - } set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg] set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg] - if {[testConstraint unix] || [testConstraint winVista]} { - set w2 0 - } else { - set w2 [file writable tds2] - } + set w2 0 list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2 } -match glob -result \ [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file *}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file *}} 1 0}] @@ -935,7 +895,7 @@ test fCmd-9.10 {file rename: comprehensive: file to new name and dir} -setup { createfile tf1 createfile tf2 file mkdir td1 - testchmod 444 tf2 + testchmod 0o444 tf2 file rename tf1 [file join td1 tf3] file rename tf2 [file join td1 tf4] list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \ @@ -947,16 +907,9 @@ test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td1 file mkdir td2 file mkdir td3 - if {!([testConstraint unix] || [testConstraint winVista])} { - testchmod 555 td2 - } file rename td1 [file join td3 td3] file rename td2 [file join td3 td4] - if {[testConstraint unix] || [testConstraint winVista]} { - set w4 0 - } else { - set w4 [file writable [file join td3 td4]] - } + set w4 0 list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ [file writable [file join td3 td3]] $w4 } -result [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}] @@ -964,25 +917,25 @@ test fCmd-9.12 {file rename: comprehensive: target exists} -setup { cleanup } -constraints {notRoot testchmod notNetworkFilesystem} -body { file mkdir [file join td1 td2] [file join td2 td1] - testchmod 555 [file join td2 td1] + testchmod 0o555 [file join td2 td1] file mkdir [file join td3 td4] [file join td4 td3] file rename -force td3 td4 list [file exists td3] [file exists [file join td4 td3 td4]] \ [catch {file rename td1 td2} msg] $msg } -cleanup { - testchmod 755 [file join td2 td1] + testchmod 0o755 [file join td2 td1] } -result [subst {0 1 1 {error renaming "td1" to "[file join td2 td1]": file already exists}}] # Test can hit EEXIST or EBUSY, depending on underlying filesystem test fCmd-9.13 {file rename: comprehensive: can't overwrite target} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir [file join td1 td2] [file join td2 td1 td4] file rename -force td1 td2 } -returnCodes error -match glob -result \ [subst {error renaming "td1" to "[file join td2 td1]": file *}] test fCmd-9.14 {file rename: comprehensive: dir into self} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir td1 list [glob td*] [list [catch {file rename td1 td1} msg] $msg] } -result [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}] @@ -1041,7 +994,7 @@ test fCmd-10.2 {file copy: comprehensive: file to new name} -setup { } -constraints {notRoot testchmod} -body { createfile tf1 tf1 createfile tf2 tf2 - testchmod 444 tf2 + testchmod 0o444 tf2 file copy tf1 tf3 file copy tf2 tf4 list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4] @@ -1051,14 +1004,14 @@ test fCmd-10.3 {file copy: comprehensive: dir to new name} -setup { } -constraints {unix notRoot testchmod} -body { file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] - testchmod 555 td2 + testchmod 0o555 td2 file copy td1 td3 file copy td2 td4 list [lsort [glob td*]] [glob -directory td3 t*] \ [glob -directory td4 t*] [file writable td3] [file writable td4] } -cleanup { - testchmod 755 td2 - testchmod 755 td4 + testchmod 0o755 td2 + testchmod 0o755 td4 } -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0] test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup { cleanup @@ -1066,18 +1019,18 @@ test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup { # On Windows with ACLs, copying a directory is defined like this file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] - testchmod 555 td2 + testchmod 0o555 td2 file copy td1 td3 file copy td2 td4 list [lsort [glob td*]] [glob -directory td3 t*] \ [glob -directory td4 t*] [file writable td3] [file writable td4] } -cleanup { - testchmod 755 td2 - testchmod 755 td4 + testchmod 0o755 td2 + testchmod 0o755 td4 } -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1] test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup { cleanup -} -constraints {notRoot testchmod} -body { +} -constraints {notRoot testchmod notWine} -body { createfile tf1 createfile tf2 createfile tfs1 @@ -1088,10 +1041,10 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup { createfile tfd2 createfile tfd3 createfile tfd4 - testchmod 444 tfs3 - testchmod 444 tfs4 - testchmod 444 tfd2 - testchmod 444 tfd4 + testchmod 0o444 tfs3 + testchmod 0o444 tfs4 + testchmod 0o444 tfd2 + testchmod 0o444 tfd4 set msg [list [catch {file copy tf1 tf2} msg] $msg] file copy -force tfs1 tfd1 file copy -force tfs2 tfd2 @@ -1112,10 +1065,10 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup { file mkdir [file join tdd2 tds2] file mkdir [file join tdd3 tds3] file mkdir [file join tdd4 tds4] - testchmod 555 tds3 - testchmod 555 tds4 - testchmod 555 [file join tdd2 tds2] - testchmod 555 [file join tdd4 tds4] + testchmod 0o555 tds3 + testchmod 0o555 tds4 + testchmod 0o555 [file join tdd2 tds2] + testchmod 0o555 [file join tdd4 tds4] set a1 [list [catch {file copy td1 td2} msg] $msg] set a2 [list [catch {file copy -force tds1 tdd1} msg] $msg] set a3 [catch {file copy -force tds2 tdd2}] @@ -1125,12 +1078,12 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} -setup { } -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}] test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup { cleanup -} -constraints {notRoot unixOrPc testchmod} -body { +} -constraints {notRoot unixOrWin testchmod} -body { file mkdir tds1 file mkdir tds2 file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] - testchmod 555 tds2 + testchmod 0o555 tds2 set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg] set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg] list [lsort [glob td*]] $a1 $a2 [file writable tds1] [file writable tds2] @@ -1141,7 +1094,7 @@ test fCmd-10.7 {file rename: comprehensive: file to new name and dir} -setup { createfile tf1 createfile tf2 file mkdir td1 - testchmod 444 tf2 + testchmod 0o444 tf2 file copy tf1 [file join td1 tf3] file copy tf2 [file join td1 tf4] list [lsort [glob tf*]] [lsort [glob -directory td1 t*]] \ @@ -1153,7 +1106,7 @@ test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td1 file mkdir td2 file mkdir td3 - testchmod 555 td2 + testchmod 0o555 td2 file copy td1 [file join td3 td3] file copy td2 [file join td3 td4] list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ @@ -1166,7 +1119,7 @@ test fCmd-10.8.1 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td1 file mkdir td2 file mkdir td3 - testchmod 555 td2 + testchmod 0o555 td2 file copy td1 [file join td3 td3] file copy td2 [file join td3 td4] list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ @@ -1349,10 +1302,10 @@ test fCmd-12.8 {renamefile: generic error} -setup { } -constraints {unix notRoot} -body { file mkdir tfa file mkdir tfa/dir - file attributes tfa -permissions 0555 + file attributes tfa -permissions 0o555 catch {file rename tfa/dir tfa2} } -cleanup { - catch {file attributes tfa -permissions 0777} + catch {file attributes tfa -permissions 0o777} file delete -force tfa } -result {1} test fCmd-12.9 {renamefile: moving a file across volumes} -setup { @@ -1535,10 +1488,10 @@ test fCmd-14.8 {copyfile: copy directory failing} -setup { catch {file delete -force -- tfa} } -constraints {unix notRoot} -body { file mkdir tfa/dir/a/b/c - file attributes tfa/dir -permissions 0000 + file attributes tfa/dir -permissions 0 catch {file copy tfa tfa2} } -cleanup { - file attributes tfa/dir -permissions 0777 + file attributes tfa/dir -permissions 0o777 file delete -force tfa tfa2 } -result {1} @@ -1578,10 +1531,10 @@ test fCmd-15.4 {TclMakeDirsCmd - stat failing} -setup { } -constraints {unix notRoot} -body { file mkdir tfa createfile tfa/file - file attributes tfa -permissions 0000 + file attributes tfa -permissions 0 catch {file mkdir tfa/file} } -cleanup { - file attributes tfa -permissions 0777 + file attributes tfa -permissions 0o777 file delete -force tfa } -result {1} test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep} -setup { @@ -1678,7 +1631,7 @@ test fCmd-16.9 {error while deleting file} -setup { } -constraints {unix notRoot} -body { file mkdir tfa createfile tfa/a - file attributes tfa -permissions 0555 + file attributes tfa -permissions 0o555 catch {file delete tfa/a} ####### ####### If any directory in a tree that is being removed does not have @@ -1686,7 +1639,7 @@ test fCmd-16.9 {error while deleting file} -setup { ####### with "rm -rf" ####### } -cleanup { - file attributes tfa -permissions 0777 + file attributes tfa -permissions 0o777 file delete -force tfa } -result {1} test fCmd-16.10 {deleting multiple files} -constraints {notRoot} -setup { @@ -1708,10 +1661,10 @@ test fCmd-17.1 {mkdir stat failing on target but not ENOENT} -setup { catch {file delete -force -- tfa1} } -constraints {unix notRoot} -body { file mkdir tfa1 - file attributes tfa1 -permissions 0555 + file attributes tfa1 -permissions 0o555 catch {file mkdir tfa1/tfa2} } -cleanup { - file attributes tfa1 -permissions 0777 + file attributes tfa1 -permissions 0o777 file delete -force tfa1 } -result {1} test fCmd-17.2 {mkdir several levels deep - relative} -setup { @@ -1919,10 +1872,10 @@ test fCmd-19.2 {rmdir error besides EEXIST} -setup { } -constraints {unix notRoot} -body { file mkdir tfa file mkdir tfa/a - file attributes tfa -permissions 0555 + file attributes tfa -permissions 0o555 catch {file delete tfa/a} } -cleanup { - file attributes tfa -permissions 0777 + file attributes tfa -permissions 0o777 file delete -force tfa } -result {1} test fCmd-19.3 {recursive remove} -constraints {notRoot} -setup { @@ -1947,10 +1900,10 @@ test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory} -se } -constraints {unix notRoot} -body { file mkdir tfa file mkdir tfa/a - file attributes tfa/a -permissions 0000 + file attributes tfa/a -permissions 00000 catch {file delete -force tfa} } -cleanup { - file attributes tfa/a -permissions 0777 + file attributes tfa/a -permissions 0o777 file delete -force tfa } -result {1} test fCmd-20.2 {TraverseUnixTree : recursive delete of large directory: Bug 1034337} -setup { @@ -2315,7 +2268,7 @@ test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} -setup { if { [testConstraint win] && - ([string index $tcl_platform(osVersion) 0] < 5 + ($::tcl_platform(osVersion) < 5.0 || [lindex [file system [temporaryDirectory]] 1] ne "NTFS") } then { testConstraint linkDirectory 0 @@ -2330,10 +2283,10 @@ test fCmd-28.2 {file link} -returnCodes error -body { } -result {wrong # args: should be "file link ?-linktype? linkname ?target?"} test fCmd-28.3 {file link} -returnCodes error -body { file link abc b c -} -result {bad switch "abc": must be -symbolic or -hard} +} -result {bad option "abc": must be -symbolic or -hard} test fCmd-28.4 {file link} -returnCodes error -body { file link -abc b c -} -result {bad switch "-abc": must be -symbolic or -hard} +} -result {bad option "-abc": must be -symbolic or -hard} cd [workingDirectory] makeDirectory abc.dir makeDirectory abc2.dir @@ -2361,13 +2314,15 @@ test fCmd-28.7 {file link: source already exists} -setup { } -returnCodes error -cleanup { cd [workingDirectory] } -result {could not create new link "abc.file": that path already exists} -test fCmd-28.8 {file link} -constraints {linkFile win} -setup { +# In Windows 10 developer mode, we _can_ create symbolic links to files! +test fCmd-28.8 {file link} -constraints {linkFile winLessThan10} -setup { cd [temporaryDirectory] } -body { file link -symbolic abc.link abc.file -} -returnCodes error -cleanup { +} -cleanup { + file delete -force abc.link cd [workingDirectory] -} -result {could not create new link "abc.link" pointing to "abc.file": not a directory} +} -returnCodes error -result {could not create new link "abc.link" pointing to "abc.file": invalid argument} test fCmd-28.9 {file link: success with file} -constraints {linkFile} -setup { cd [temporaryDirectory] file delete -force abc.link @@ -2410,7 +2365,7 @@ test fCmd-28.10.1 {file link: linking to nonexistent path} -setup { test fCmd-28.11 {file link: success with directory} -setup { cd [temporaryDirectory] file delete -force abc.link -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { file link abc.link abc.dir } -cleanup { cd [workingDirectory] @@ -2418,7 +2373,7 @@ test fCmd-28.11 {file link: success with directory} -setup { test fCmd-28.12 {file link: cd into a link} -setup { cd [temporaryDirectory] file delete -force abc.link -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { file link abc.link abc.dir set orig [pwd] cd abc.link @@ -2441,14 +2396,17 @@ test fCmd-28.12 {file link: cd into a link} -setup { return "ok" } } -cleanup { + file delete -force abc.link cd [workingDirectory] } -result ok -test fCmd-28.13 {file link} -constraints {linkDirectory} -setup { +test fCmd-28.13 {file link} -constraints {linkDirectory notWine} -setup { cd [temporaryDirectory] + file link abc.link abc.dir } -body { # duplicate link throws error file link abc.link abc.dir } -returnCodes error -cleanup { + file delete -force abc.link cd [workingDirectory] } -result {could not create new link "abc.link": that path already exists} test fCmd-28.14 {file link: deletes link not dir} -setup { @@ -2469,16 +2427,18 @@ test fCmd-28.15.1 {file link: copies link not dir} -setup { # directory, not a link (links trace to endpoint). list [file type abc2.link] [file tail [file link abc.link]] } -cleanup { + file delete -force abc.link cd [workingDirectory] } -result {directory abc.dir} test fCmd-28.15.2 {file link: copies link not dir} -setup { cd [temporaryDirectory] file delete -force abc.link -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { file link abc.link abc.dir file copy abc.link abc2.link list [file type abc2.link] [file tail [file link abc2.link]] } -cleanup { + file delete -force abc.link cd [workingDirectory] } -result {link abc.dir} cd [temporaryDirectory] @@ -2494,29 +2454,34 @@ cd [workingDirectory] test fCmd-28.16 {file link: glob inside link} -setup { cd [temporaryDirectory] file delete -force abc.link -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { file link abc.link abc.dir lsort [glob -dir abc.link -tails *] } -cleanup { + file delete -force abc.link cd [workingDirectory] } -result {abc.file abc2.file} test fCmd-28.17 {file link: glob -type l} -setup { cd [temporaryDirectory] -} -constraints {linkDirectory} -body { + file link abc.link abc.dir +} -constraints {linkDirectory notWine} -body { glob -dir [pwd] -type l -tails abc* } -cleanup { + file delete -force abc.link cd [workingDirectory] } -result {abc.link} -test fCmd-28.18 {file link: glob -type d} -constraints linkDirectory -setup { +test fCmd-28.18 {file link: glob -type d} -constraints {linkDirectory notWine} -setup { cd [temporaryDirectory] + file link abc.link abc.dir } -body { lsort [glob -dir [pwd] -type d -tails abc*] } -cleanup { + file delete -force abc.link cd [workingDirectory] } -result [lsort [list abc.link abc.dir abc2.dir]] test fCmd-28.19 {file link: relative paths} -setup { cd [temporaryDirectory] -} -constraints {win linkDirectory} -body { +} -constraints {win linkDirectory notWine} -body { file mkdir d1/d2/d3 file link d1/l2 d1/d2 } -cleanup { @@ -2574,12 +2539,14 @@ test fCmd-30.1 {file writable on 'My Documents'} -setup { } -constraints {win reg} -body { file writable $mydocsname } -result 1 -test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win} -body { +test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win notWine} -body { expr {[info exists env(USERPROFILE)] && [file exists $env(USERPROFILE)/NTUSER.DAT] && [file readable $env(USERPROFILE)/NTUSER.DAT]} } -result {1} -test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win} -body { +# At least one CI environment (GitHub Actions) is set up with the page file in +# an unusual location; skip the test if that is so. +test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win notInCIenv} -body { set r {} if {[info exists env(SystemDrive)]} { set path $env(SystemDrive)/pagefile.sys diff --git a/tests/fileName.test b/tests/fileName.test index 539a6ef..d58651a 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -4,32 +4,34 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1999 by Scriptics Corporation. +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } + ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testtranslatefilename [llength [info commands testtranslatefilename]] testConstraint linkDirectory 1 testConstraint symbolicLinkFile 1 if {[testConstraint win]} { - if {[string index $tcl_platform(osVersion) 0] < 5 \ + if {$::tcl_platform(osVersion) < 5.0 \ || [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} { testConstraint linkDirectory 0 } testConstraint symbolicLinkFile 0 testConstraint sharedCdrive [expr {![catch {cd //[info hostname]/c}]}] } +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] # This match compares the first two words of the result. If the wanted result # is "equal", then this is successful if the words are equal. If the wanted # result is "not equal", then this is successful if the words are different. @@ -199,7 +201,7 @@ test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} { test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split //foo -} "// foo" +} "//foo" test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo//bar @@ -440,7 +442,10 @@ test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /// a b -} "//a/b" +} "/a/b" +test filename-7.19 {[Bug f34cf83dd0]} { + file join foo //bar +} //bar test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win @@ -749,7 +754,7 @@ test filename-11.13 {Tcl_GlobCmd} { } [file join $env(HOME)] set oldpwd [pwd] set oldhome $env(HOME) -cd [temporaryDirectory] +catch {cd [makeDirectory tcl[pid]]} set env(HOME) [pwd] file delete -force globTest file mkdir globTest/a1/b1 @@ -775,6 +780,8 @@ test filename-11.16 {Tcl_GlobCmd} { } {globTest} set globname "globTest" set horribleglobname "glob\[\{Test" +set tildeglobname "./~test.txt" + test filename-11.17 {Tcl_GlobCmd} {unix} { lsort [glob -directory $globname *] } [lsort [list [file join $globname a1] [file join $globname a2]\ @@ -783,7 +790,7 @@ test filename-11.17 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.17.1 {Tcl_GlobCmd} {win} { +test filename-11.17.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -directory $globname *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -794,7 +801,7 @@ test filename-11.17.1 {Tcl_GlobCmd} {win} { [file join $globname y1.c] [file join $globname z1.c]]] test filename-11.17.2 {Tcl_GlobCmd} -setup { set dir [pwd] -} -constraints {notRoot linkDirectory} -body { +} -constraints {notRoot linkDirectory notWine} -body { cd $globname file link -symbolic link a1 cd $dir @@ -807,7 +814,7 @@ test filename-11.17.2 {Tcl_GlobCmd} -setup { # Simpler version of the above test to illustrate a given bug. test filename-11.17.3 {Tcl_GlobCmd} -setup { set dir [pwd] -} -constraints {notRoot linkDirectory} -body { +} -constraints {notRoot linkDirectory notWine} -body { cd $globname file link -symbolic link a1 cd $dir @@ -822,7 +829,7 @@ test filename-11.17.3 {Tcl_GlobCmd} -setup { # Make sure the bugfix isn't too simple. We don't want to break 'glob -type l' test filename-11.17.4 {Tcl_GlobCmd} -setup { set dir [pwd] -} -constraints {notRoot linkDirectory} -body { +} -constraints {notRoot linkDirectory notWine} -body { cd $globname file link -symbolic link a1 cd $dir @@ -840,7 +847,7 @@ test filename-11.17.6 {Tcl_GlobCmd} { [list "weird name.c" x,z1.c x1.c y1.c z1.c]]] test filename-11.17.7 {Tcl_GlobCmd: broken link and glob -l} -setup { set dir [pwd] -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { cd $globname file mkdir nonexistent file link -symbolic link nonexistent @@ -872,7 +879,7 @@ test filename-11.18 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.18.1 {Tcl_GlobCmd} {win} { +test filename-11.18.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -path $globname/ *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -889,7 +896,7 @@ test filename-11.19 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.19.1 {Tcl_GlobCmd} {win} { +test filename-11.19.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -join -path [string range $globname 0 5] * *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -898,7 +905,7 @@ test filename-11.19.1 {Tcl_GlobCmd} {win} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.20 {Tcl_GlobCmd} { +test filename-11.20 {Tcl_GlobCmd} notWine { lsort [glob -type d -dir $globname *] } [lsort [list [file join $globname a1]\ [file join $globname a2]\ @@ -914,11 +921,12 @@ test filename-11.21.1 {Tcl_GlobCmd} -body { } -result {{[tcl].testremains}} # Get rid of file/dir if it exists, since it will have been left behind by a # previous failed run. -if {[file exists $horribleglobname]} { - file delete -force $horribleglobname -} +file delete -force $horribleglobname file rename globTest $horribleglobname set globname $horribleglobname +file delete -force $tildeglobname +close [open $tildeglobname w] + test filename-11.22 {Tcl_GlobCmd} {unix} { lsort [glob -dir $globname *] } [lsort [list [file join $globname a1] [file join $globname a2]\ @@ -927,7 +935,7 @@ test filename-11.22 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.22.1 {Tcl_GlobCmd} {win} { +test filename-11.22.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -dir $globname *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -944,7 +952,7 @@ test filename-11.23 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.23.1 {Tcl_GlobCmd} {win} { +test filename-11.23.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -path $globname/ *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -961,7 +969,7 @@ test filename-11.24 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.24.1 {Tcl_GlobCmd} {win} { +test filename-11.24.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -join -path [string range $globname 0 5] * *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -970,17 +978,17 @@ test filename-11.24.1 {Tcl_GlobCmd} {win} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.25 {Tcl_GlobCmd} { +test filename-11.25 {Tcl_GlobCmd} notWine { lsort [glob -type d -dir $globname *] } [lsort [list [file join $globname a1]\ [file join $globname a2]\ [file join $globname a3]]] -test filename-11.25.1 {Tcl_GlobCmd} { +test filename-11.25.1 {Tcl_GlobCmd} notWine { lsort [glob -type {d r} -dir $globname *] } [lsort [list [file join $globname a1]\ [file join $globname a2]\ [file join $globname a3]]] -test filename-11.25.2 {Tcl_GlobCmd} { +test filename-11.25.2 {Tcl_GlobCmd} notWine { lsort [glob -type {d r w} -dir $globname *] } [lsort [list [file join $globname a1]\ [file join $globname a2]\ @@ -1037,7 +1045,9 @@ test filename-11.41 {Tcl_GlobCmd} -body { test filename-11.42 {Tcl_GlobCmd} -body { set res [list] foreach f [glob -dir [pwd] *] { - lappend res [file tail $f] + set f [file tail $f] + regsub {^./} $f {} f; # until glob bug [2511011fff] don't fixed (tilde expansion prevention). + lappend res $f } list $res [glob *] } -match compareWords -result equal @@ -1075,18 +1085,25 @@ test filename-11.48 {Tcl_GlobCmd} -returnCodes error -body { test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body { glob -types abcde -path foo -join * * } -result {bad argument to "-types": abcde} +test filename-11.50 {Tcl_GlobCmd} -returnCodes error -body { + glob -path hello -path salut * +} -result {"-path" may only be used once} +test filename-11.51 {Tcl_GlobCmd} -returnCodes error -body { + glob -dir hello -dir salut * +} -result {"-directory" may only be used once} file rename $horribleglobname globTest +file delete -force $tildeglobname set globname globTest -unset horribleglobname +unset horribleglobname tildeglobname -test filename-12.1 {simple globbing} {unixOrPc} { +test filename-12.1 {simple globbing} {unixOrWin} { glob {} } {.} -test filename-12.1.1 {simple globbing} -constraints {unixOrPc} -body { +test filename-12.1.1 {simple globbing} -constraints {unixOrWin} -body { glob -types f {} } -returnCodes error -result {no files matched glob pattern ""} -test filename-12.1.2 {simple globbing} {unixOrPc} { +test filename-12.1.2 {simple globbing} {unixOrWin} { glob -types d {} } {.} test filename-12.1.3 {simple globbing} {unix} { @@ -1107,7 +1124,7 @@ test filename-12.3 {simple globbing} { set globPreResult globTest/ set x1 x1.c set y1 y1.c -test filename-12.4 {simple globbing} {unixOrPc} { +test filename-12.4 {simple globbing} {unixOrWin} { lsort [glob globTest/x1.c globTest/y1.c globTest/foo] } "$globPreResult$x1 $globPreResult$y1" test filename-12.5 {simple globbing} { @@ -1169,32 +1186,32 @@ test filename-13.9 {globbing with brace substitution} { test filename-13.10 {globbing with brace substitution} { lsort [glob globTest/\{x,,y\}1.c] } [list $globPreResult$x1 $globPreResult$y1] -test filename-13.11 {globbing with brace substitution} {unixOrPc} { +test filename-13.11 {globbing with brace substitution} {unixOrWin} { lsort [glob globTest/\{x,x\\,z,z\}1.c] } [lsort {globTest/x1.c globTest/x,z1.c globTest/z1.c}] test filename-13.13 {globbing with brace substitution} { lsort [glob globTest/{a,b,x,y}1.c] } [list $globPreResult$x1 $globPreResult$y1] -test filename-13.14 {globbing with brace substitution} {unixOrPc} { +test filename-13.14 {globbing with brace substitution} {unixOrWin} { lsort [glob {globTest/{x1,y2,weird name}.c}] } {{globTest/weird name.c} globTest/x1.c} -test filename-13.16 {globbing with brace substitution} {unixOrPc} { +test filename-13.16 {globbing with brace substitution} {unixOrWin} { lsort [glob globTest/{x1.c,a1/*}] } {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} -test filename-13.18 {globbing with brace substitution} {unixOrPc} { +test filename-13.18 {globbing with brace substitution} {unixOrWin} { lsort [glob globTest/{x1.c,{a},a1/*}] } {globTest/a1/b1 globTest/a1/b2 globTest/x1.c} -test filename-13.20 {globbing with brace substitution} {unixOrPc} { +test filename-13.20 {globbing with brace substitution} {unixOrWin} { lsort [glob globTest/{a,x}1/*/{x,y}*] } {globTest/a1/b1/x2.c globTest/a1/b2/y2.c} test filename-13.22 {globbing with brace substitution} -body { glob globTest/\{a,x\}1/*/\{ } -returnCodes error -result {unmatched open-brace in file name} -test filename-14.1 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.1 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob glo*/*.c] } {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} -test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.3 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob globTest/?1.c] } {globTest/x1.c globTest/y1.c globTest/z1.c} test filename-14.5 {asterisks, question marks, and brackets} -setup { @@ -1204,7 +1221,7 @@ test filename-14.5 {asterisks, question marks, and brackets} -setup { file rename globTest [file join globTestContext globTest] set savepwd [pwd] cd globTestContext -} -constraints {unixOrPc} -body { +} -constraints {unixOrWin} -body { lsort [glob */*/*/*.c] } -cleanup { # Reset to where we were @@ -1215,19 +1232,19 @@ test filename-14.5 {asterisks, question marks, and brackets} -setup { test filename-14.7 {asterisks, question marks, and brackets} {unix} { lsort [glob globTest/*] } {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} -test filename-14.7.1 {asterisks, question marks, and brackets} {win} { +test filename-14.7.1 {asterisks, question marks, and brackets} {win notWine} { lsort [glob globTest/*] } {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} -test filename-14.9 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.9 {asterisks, question marks, and brackets} {unixOrWin notWine} { lsort [glob globTest/.*] } {globTest/. globTest/.. globTest/.1} -test filename-14.11 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.11 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob globTest/*/*] } {globTest/a1/b1 globTest/a1/b2 globTest/a2/b3} -test filename-14.13 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.13 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob {globTest/[xyab]1.*}] } {globTest/x1.c globTest/y1.c} -test filename-14.15 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.15 {asterisks, question marks, and brackets} {unixOrWin notWine} { lsort [glob globTest/*/] } {globTest/a1/ globTest/a2/ globTest/a3/} test filename-14.17 {asterisks, question marks, and brackets} -setup { @@ -1239,7 +1256,7 @@ test filename-14.17 {asterisks, question marks, and brackets} -setup { } -cleanup { set env(HOME) $temp } -result [list [file join $env(HOME) globTest z1.c]] -test filename-14.18 {asterisks, question marks, and brackets} {unixOrPc} { +test filename-14.18 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob globTest/*.c goo/*] } {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} test filename-14.20 {asterisks, question marks, and brackets} { @@ -1267,7 +1284,7 @@ test filename-14.25 {type specific globbing} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-14.25.1 {type specific globbing} {win} { +test filename-14.25.1 {type specific globbing} {win notWine} { lsort [glob -dir globTest -types f *] } [lsort [list \ [file join $globname .1]\ @@ -1278,16 +1295,16 @@ test filename-14.25.1 {type specific globbing} {win} { test filename-14.26 {type specific globbing} { glob -nocomplain -dir globTest -types {readonly} * } {} -test filename-14.27 {Bug 2710920} {unixOrPc} { +test filename-14.27 {Bug 2710920} {unixOrWin} { file tail [lindex [lsort [glob globTest/*/]] 0] } a1 -test filename-14.28 {Bug 2710920} {unixOrPc} { +test filename-14.28 {Bug 2710920} {unixOrWin} { file dirname [lindex [lsort [glob globTest/*/]] 0] } globTest -test filename-14.29 {Bug 2710920} {unixOrPc} { +test filename-14.29 {Bug 2710920} {unixOrWin} { file extension [lindex [lsort [glob globTest/*/]] 0] } {} -test filename-14.30 {Bug 2710920} {unixOrPc} { +test filename-14.30 {Bug 2710920} {unixOrWin} { file rootname [lindex [lsort [glob globTest/*/]] 0] } globTest/a1/ @@ -1312,7 +1329,7 @@ unset globname # AFS, "000" protection doesn't prevent access by owner, so the following test # is not portable. -catch {file attributes globTest/a1 -permissions 0000} +catch {file attributes globTest/a1 -permissions 0} test filename-15.1 {unix specific globbing} {unix nonPortable} { string tolower [list [catch {glob globTest/a1/*} msg] $msg $errorCode] } {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}} @@ -1324,7 +1341,7 @@ test filename-15.3 {unix specific no complain: no errors, good result} \ # test fails because if an error occurs, the interp's result is reset... glob -nocomplain globTest/a2 globTest/a1/* globTest/a3 } {globTest/a2 globTest/a3} -catch {file attributes globTest/a1 -permissions 0755} +catch {file attributes globTest/a1 -permissions 0o755} test filename-15.4 {unix specific no complain: no errors, good result} \ {unix nonPortable} { # test fails because if an error occurs, the interp's result is reset... @@ -1468,14 +1485,16 @@ if {[testConstraint testsetplatform]} { } test filename-17.2 {windows specific glob with executable} -body { makeDirectory execglob - makeFile contents execglob/abc.exe - makeFile contents execglob/abc.notexecutable - glob -nocomplain -dir [temporaryDirectory]/execglob -tails -types x * + foreach ext {exe com cmd bat notexecutable} { + makeFile contents execglob/abc.$ext + } + lsort [glob -nocomplain -dir [temporaryDirectory]/execglob -tails -types x *] } -constraints {win} -cleanup { - removeFile execglob/abc.exe - removeFile execglob/abc.notexecutable + foreach ext {exe com cmd bat ps1 notexecutable} { + removeFile execglob/abc.$ext + } removeDirectory execglob -} -result {abc.exe} +} -result {abc.bat abc.cmd abc.com abc.exe} test filename-17.3 {Bug 2571597} win { set p /a file pathtype $p @@ -1616,6 +1635,7 @@ catch {file delete -force C:/globTest} cd [temporaryDirectory] file delete -force globTest cd $oldpwd +catch {removeDirectory tcl[pid]} set env(HOME) $oldhome if {[testConstraint testsetplatform]} { testsetplatform $platform diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 9469af0..8c00825 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -4,14 +4,17 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 2002 Vincent Darley. +# Copyright © 2002 Vincent Darley. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 namespace eval ::tcl::test::fileSystem { - namespace import ::tcltest::* + + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } catch { file delete -force link.file @@ -22,18 +25,21 @@ namespace eval ::tcl::test::fileSystem { testConstraint loaddll 0 catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] + package require -exact tcl::test [info patchlevel] set ::ddever [package require dde] - set ::ddelib [lindex [package ifneeded dde $::ddever] 1] + set ::ddelib [info loaded {} Dde] set ::regver [package require registry] - set ::reglib [lindex [package ifneeded registry $::regver] 1] - testConstraint loaddll 0 + set ::reglib [info loaded {} Registry] + testConstraint loaddll [expr {$::ddelib ne "" && $::reglib ne ""}] } -# Test for commands defined in Tcltest executable +# Test for commands defined in tcl::test package testConstraint testfilesystem [llength [info commands ::testfilesystem]] testConstraint testsetplatform [llength [info commands ::testsetplatform]] testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]] +# Some things fail under all Continuous Integration systems for subtle reasons +# such as CI often running with elevated privileges in a container. +testConstraint notInCIenv [expr {![info exists ::env(CI)]}] cd [tcltest::temporaryDirectory] makeFile "test file" gorp.file @@ -138,13 +144,18 @@ test filesystem-1.9 {link normalisation} -setup { testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ [file normalize [file join dir.link inside.file foo]] } -result ok -test filesystem-1.10 {link normalisation: double link} {unix hasLinks} { +test filesystem-1.10 {link normalisation: double link} -constraints { + unix hasLinks +} -body { file link dir2.link dir.link testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ [file normalize [file join dir2.link inside.file foo]] -} ok +} -cleanup { + file delete dir2.link +} -result ok makeDirectory dir2.file test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} { + file link dir2.link dir.link file link [file join dir2.file dir2.link] [file join .. dir2.link] testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ [file normalize [file join dir2.file dir2.link inside.file foo]] @@ -259,6 +270,12 @@ removeDirectory dir.dir test filesystem-1.30 {normalisation of nonexistent user} -body { file normalize ~noonewiththisname } -returnCodes error -result {user "noonewiththisname" doesn't exist} +test filesystem-1.30.1 {normalisation of existing user} -body { + catch {file normalize ~$::tcl_platform(user)} +} -result {0} +test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body { + file normalize ~nonexistentuser@nonexistentdomain +} -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar @@ -301,7 +318,7 @@ test filesystem-1.37 {file normalisation with '/./'} -body { } -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$} test filesystem-1.38 {file normalisation with volume relative} -setup { set dir [pwd] -} -constraints {win moreThanOneDrive} -body { +} -constraints {win moreThanOneDrive notInCIenv} -body { set path "[string range [lindex $drives 0] 0 1]foo" cd [lindex $drives 1] file norm $path @@ -362,6 +379,32 @@ test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} { testPathEqual [file norm /../../] [file norm /] } ok +test filesystem-1.52 {bug f9f390d0fa: file join where strep is not canonical} -body { + set x //foo + file normalize $x + file join $x bar +} -result //foo/bar +test filesystem-1.52.1 {bug f9f390d0fa: file join where strep is not canonical} -body { + set x //foo + file normalize $x + file join $x +} -result //foo +test filesystem-1.53 {[Bug 3559678] - normalize when tail is empty} { + string match */ [file normalize [lindex [glob -dir [pwd] {{}}] 0]] +} 0 +test filesystem-1.54 {[Bug ce3a211dcb] - normalize when tail is empty} -setup { + set save [pwd] + cd [set home [makeDirectory ce3a211dcb]] + makeDirectory A $home + cd [lindex [glob */] 0] +} -body { + string match */A [pwd] +} -cleanup { + cd $home + removeDirectory A $home + cd $save + removeDirectory ce3a211dcb +} -result 1 test filesystem-2.0 {new native path} {unix} { foreach f [lsort [glob -nocomplain /usr/bin/c*]] { @@ -373,7 +416,9 @@ test filesystem-2.0 {new native path} {unix} { # Make sure the testfilesystem hasn't been registered. if {[testConstraint testfilesystem]} { + proc resetfs {} { while {![catch {testfilesystem 0}]} {} + } } test filesystem-3.1 {Tcl_FSRegister & Tcl_FSUnregister} testfilesystem { @@ -388,12 +433,14 @@ test filesystem-3.3 {Tcl_FSRegister} testfilesystem { testfilesystem 0 testfilesystem 0 } {unregistered} -test filesystem-3.4 {Tcl_FSRegister} testfilesystem { +test filesystem-3.4 {Tcl_FSRegister} -constraints testfilesystem -body { testfilesystem 1 file system bar -} {reporting} -test filesystem-3.5 {Tcl_FSUnregister} testfilesystem { +} -cleanup { testfilesystem 0 +} -result {reporting} +test filesystem-3.5 {Tcl_FSUnregister} testfilesystem { + resetfs lindex [file system bar] 0 } {native} @@ -484,7 +531,7 @@ test filesystem-6.22 {empty file name} {file pathtype ""} relative test filesystem-6.23 {empty file name} {file readable ""} 0 test filesystem-6.24 {empty file name} -returnCodes error -body { file readlink "" -} -result {could not readlink "": no such file or directory} +} -result {could not read link "": no such file or directory} test filesystem-6.25 {empty file name} -returnCodes error -body { file rename "" "" } -result {error renaming "": no such file or directory} @@ -504,6 +551,9 @@ test filesystem-6.32 {empty file name} -returnCodes error -body { file type "" } -result {could not read "": no such file or directory} test filesystem-6.33 {empty file name} {file writable ""} 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]} { @@ -514,10 +564,10 @@ test filesystem-7.1.1 {load from vfs} -setup { set dir [pwd] } -constraints {win testsimplefilesystem loaddll} -body { # This may cause a crash on exit - cd [file dirname $::reglib] + cd [file dirname $::ddelib] testsimplefilesystem 1 # This loads dde via a complex copy-to-temp operation - load simplefs:/[file tail $::ddelib] dde + load simplefs:/[file tail $::ddelib] Dde testsimplefilesystem 0 return ok # The real result of this test is what happens when Tcl exits. @@ -632,7 +682,7 @@ test filesystem-7.4 {cross-filesystem file copy with -force} -setup { file delete -force simplefile file delete -force file2 cd $dir -} -result {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1} +} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1} test filesystem-7.5 {cross-filesystem file copy with -force} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] @@ -644,7 +694,7 @@ test filesystem-7.5 {cross-filesystem file copy with -force} -setup { # First copy should succeed set res [catch {file copy simplefs:/simplefile file2} err] lappend res $err - file attributes file2 -permissions 0000 + file attributes file2 -permissions 0 # Second copy should fail (no -force) lappend res [catch {file copy simplefs:/simplefile file2} err] lappend res $err @@ -657,7 +707,7 @@ test filesystem-7.5 {cross-filesystem file copy with -force} -setup { file delete -force simplefile file delete -force file2 cd $dir -} -result {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1} +} -result {0 {} 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 {} 1} test filesystem-7.6 {cross-filesystem dir copy with -force} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] @@ -862,7 +912,7 @@ test filesystem-9.5 {path objects and file tail and object rep} -setup { } return $res } -cleanup { - file delete -force dgp + file delete -force dgp cd $origdir } -result {test test} test filesystem-9.6 {path objects and file tail and object rep} win { diff --git a/tests/fileSystemEncoding.test b/tests/fileSystemEncoding.test new file mode 100644 index 0000000..848b570 --- /dev/null +++ b/tests/fileSystemEncoding.test @@ -0,0 +1,55 @@ +#! /usr/bin/env tclsh + +# Copyright © 2019 Poor Yorick + +if {[string equal $::tcl_platform(os) "Windows NT"]} { + return +} + +namespace eval ::tcl::test::fileSystemEncoding { + + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } + + variable fname1 \u767b\u9e1b\u9d72\u6a13 + + proc autopath {} { + global auto_path + set scriptpath [info script] + set scriptpathnorm [file dirname [file normalize $scriptpath/...]] + set dirnorm [file dirname $scriptpathnorm] + set idx [lsearch -exact $auto_path $dirnorm] + if {$idx >= 0} { + set auto_path [lreplace $auto_path[set auto_path {}] $idx $idx {}] + } + set auto_path [linsert $auto_path[set auto_path {}] 0 0 $dirnorm] + } + autopath + + package require tcltests + + test filesystemEncoding-1.0 { + issue bcd100410465 + } -body { + set dir [tcltests::tempdir] + set saved [encoding system] + encoding system iso8859-1 + set fname1a $dir/$fname1 + set utf8name [encoding convertto utf-8 $fname1a] + makeFile {} $utf8name + set globbed [lindex [glob -directory $dir *] 0] + encoding system utf-8 + set res [file exists $globbed] + encoding system iso8859-1 + lappend res [file exists $globbed] + return $res + } -cleanup { + removeFile $utf8name + file delete -force $dir + encoding system $saved + } -result {0 1} + + cleanupTests +} diff --git a/tests/for-old.test b/tests/for-old.test index a11a791..f5d1de9 100644 --- a/tests/for-old.test +++ b/tests/for-old.test @@ -6,14 +6,14 @@ # into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -22,23 +22,23 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch {unset a i} test for-old-1.1 {for tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { + for {set i 1} {$i<6} {incr i} { set a [concat $a $i] } set a } {1 2 3 4 5} test for-old-1.2 {for tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 continue + for {set i 1} {$i<6} {incr i} { + if {$i==4} continue set a [concat $a $i] } set a } {1 2 3 5} test for-old-1.3 {for tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break + for {set i 1} {$i<6} {incr i} { + if {$i==4} break set a [concat $a $i] } set a @@ -55,12 +55,12 @@ test for-old-1.7 {for tests} { } {wrong # args: should be "for start test next command"} test for-old-1.8 {for tests} { set a {xyz} - for {set i 1} {$i<6} {set i [expr $i+1]} {} + for {set i 1} {$i<6} {incr i} {} set a } xyz test for-old-1.9 {for tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} { + for {set i 1} {$i<6} {incr i; if {$i==4} break} { set a [concat $a $i] } set a diff --git a/tests/for.test b/tests/for.test index ff4dc0e..8284a09 100644 --- a/tests/for.test +++ b/tests/for.test @@ -4,16 +4,22 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright © 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } +# Used for constraining memory leak tests +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc meminfo {} {lindex [split [memory info] "\n"] 3 3} +} + # Basic "for" operation. test for-1.1 {TclCompileForCmd: missing initial command} { @@ -56,15 +62,15 @@ test for-1.8 {TclCompileForCmd: error compiling command body} -body { catch {unset a} test for-1.9 {TclCompileForCmd: simple command body} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break + for {set i 1} {$i<6} {incr i} { + if {$i==4} break set a [concat $a $i] } set a } {1 2 3} test for-1.10 {TclCompileForCmd: command body in quotes} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} "append a x" + for {set i 1} {$i<6} {incr i} "append a x" set a } {xxxxx} test for-1.11 {TclCompileForCmd: computed command body} { @@ -75,7 +81,7 @@ test for-1.11 {TclCompileForCmd: computed command body} { set bb {break} set x2 {; append a x2} set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 + for {set i 1} {$i<6} {incr i} $x1$bb$x2 set a } {x1} test for-1.12 {TclCompileForCmd: error in "next" command} -body { @@ -86,9 +92,9 @@ test for-1.12 {TclCompileForCmd: error in "next" command} -body { "set"*} test for-1.13 {TclCompileForCmd: long command body} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break - if $i>5 continue + for {set i 1} {$i<6} {incr i} { + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -123,7 +129,7 @@ test for-1.14 {TclCompileForCmd: for command result} { set a } {} test for-1.15 {TclCompileForCmd: for command result} { - set a [for {set i 0} {$i < 5} {incr i} {if $i==3 break}] + set a [for {set i 0} {$i < 5} {incr i} {if {$i==3} break}] set a } {} @@ -138,7 +144,7 @@ test for-2.2 {TclCompileContinueCmd: continue result} { } 4 test for-2.3 {continue tests} { set a {} - for {set i 1} {$i <= 4} {set i [expr $i+1]} { + for {set i 1} {$i <= 4} {incr i} { if {$i == 2} continue set a [concat $a $i] } @@ -146,7 +152,7 @@ test for-2.3 {continue tests} { } {1 3 4} test for-2.4 {continue tests} { set a {} - for {set i 1} {$i <= 4} {set i [expr $i+1]} { + for {set i 1} {$i <= 4} {incr i} { if {$i != 2} continue set a [concat $a $i] } @@ -164,10 +170,10 @@ test for-2.5 {continue tests, nested loops} { } {1.1 1.2 2.1 3.1 4.1} test for-2.6 {continue tests, long command body} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==2 continue - if $i==4 break - if $i>5 continue + for {set i 1} {$i<6} {incr i} { + if {$i==2} continue + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -240,10 +246,10 @@ test for-3.4 {break tests, nested loops} { } {1.1 1.2 2.1 3.1 4.1} test for-3.5 {break tests, long command body} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==2 continue - if $i==5 break - if $i>5 continue + for {set i 1} {$i<6} {incr i} { + if {$i==2} continue + if {$i==5} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -259,7 +265,7 @@ test for-3.5 {break tests, long command body} { catch {incr i 5} msg catch {incr i -5} msg } - if $i==4 break + if {$i==4} break if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -297,35 +303,35 @@ proc formatMail {} { 16 {This page contains information about Tcl 7.6 and Tk4.2, which are the most recent} \ 17 {releases of the Tcl scripting language and the Tk toolkit. The first beta versions of these} \ 18 {releases were released on August 30, 1996. These releases contain only minor changes,} \ - 19 {so we hope to have only a single beta release and to go final in early October, 1996. } \ + 19 {so we hope to have only a single beta release and to go final in early October, 1996.} \ 20 {} \ 21 {} \ - 22 {What's new } \ + 22 {What's new} \ 23 {} \ 24 {The most important changes in the releases are summarized below. See the README} \ 25 {and changes files in the distributions for more complete information on what has} \ - 26 {changed, including both feature changes and bug fixes. } \ + 26 {changed, including both feature changes and bug fixes.} \ 27 {} \ 28 { There are new options to the file command for copying files (file copy),} \ 29 { deleting files and directories (file delete), creating directories (file} \ - 30 { mkdir), and renaming files (file rename). } \ + 30 { mkdir), and renaming files (file rename).} \ 31 { The implementation of exec has been improved greatly for Windows 95 and} \ - 32 { Windows NT. } \ + 32 { Windows NT.} \ 33 { There is a new memory allocator for the Macintosh version, which should be} \ - 34 { more efficient than the old one. } \ + 34 { more efficient than the old one.} \ 35 { Tk's grid geometry manager has been completely rewritten. The layout} \ 36 { algorithm produces much better layouts than before, especially where rows or} \ - 37 { columns were stretchable. } \ + 37 { columns were stretchable.} \ 38 { There are new commands for creating common dialog boxes:} \ 39 { tk_chooseColor, tk_getOpenFile, tk_getSaveFile and} \ - 40 { tk_messageBox. These use native dialog boxes if they are available. } \ + 40 { tk_messageBox. These use native dialog boxes if they are available.} \ 41 { There is a new virtual event mechanism for handling events in a more portable} \ 42 { way. See the new command event. It also allows events (both physical and} \ - 43 { virtual) to be generated dynamically. } \ + 43 { virtual) to be generated dynamically.} \ 44 {} \ 45 {Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl 7.5 and Tk 4.1 except for} \ 46 {changes in the C APIs for custom channel drivers. Scripts written for earlier releases} \ - 47 {should work on these new releases as well. } \ + 47 {should work on these new releases as well.} \ 48 {} \ 49 {Obtaining The Releases} \ 50 {} \ @@ -336,7 +342,7 @@ proc formatMail {} { 55 { Windows 3.1, Windows 95, and Windows NT: Fetch} \ 56 { ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a} \ 57 { self-extracting executable. It will install the Tcl and Tk libraries, the wish and} \ - 58 { tclsh programs, and documentation. } \ + 58 { tclsh programs, and documentation.} \ 59 { Macintosh (both 68K and PowerPC): Fetch} \ 60 { ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format,} \ 61 { which is understood by Fetch, StuffIt, and many other Mac utilities. The} \ @@ -345,7 +351,6 @@ proc formatMail {} { 64 { UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install} \ 65 { binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out!} \ } - set result "" set NL " " @@ -365,7 +370,6 @@ proc formatMail {} { } else { set break 1 } - set xmailer 0 set inheaders 1 set last [array size lines] @@ -382,13 +386,11 @@ proc formatMail {} { continue } } - if $inheaders { + if {$inheaders} { set limit 55 } else { set limit 55 - # Decide whether or not to break the body line - if {$plen > 0} { if {[string first {> } $line] == 0} { # This is quoted text from previous message, don't reformat @@ -428,12 +430,12 @@ proc formatMail {} { continue } } - set climit [expr $limit-1] + set climit [expr {$limit-1}] set cutoff 50 set continuation 0 - + while {[string length $line] > $limit} { - for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} { + for {set c [expr {$limit-1}]} {$c >= $cutoff} {incr c -1} { set char [string index $line $c] if {$char == " " || $char == "\t"} { break @@ -444,12 +446,12 @@ proc formatMail {} { } if {$c < $cutoff} { if {! $inheaders} { - set c [expr $limit-1] + set c [expr {$limit-1}] } else { set c [string length $line] } } - set newline [string range $line 0 $c] + set newline [string trimright [string range $line 0 $c]] if {! $continuation} { append result $newline $NL } else { @@ -505,76 +507,76 @@ releases of the Tcl scripting language and the Tk toolk it. The first beta versions of these releases were released on August 30, 1996. These releas es contain only minor changes, -so we hope to have only a single beta release and to +so we hope to have only a single beta release and to go final in early October, 1996. -What's new +What's new The most important changes in the releases are summariz ed below. See the README and changes files in the distributions for more complet e information on what has -changed, including both feature changes and bug fixes. +changed, including both feature changes and bug fixes. - There are new options to the file command for + There are new options to the file command for copying files (file copy), - deleting files and directories (file delete), + deleting files and directories (file delete), creating directories (file - mkdir), and renaming files (file rename). + mkdir), and renaming files (file rename). The implementation of exec has been improved great ly for Windows 95 and - Windows NT. - There is a new memory allocator for the Macintosh + Windows NT. + There is a new memory allocator for the Macintosh version, which should be - more efficient than the old one. - Tk's grid geometry manager has been completely + more efficient than the old one. + Tk's grid geometry manager has been completely rewritten. The layout algorithm produces much better layouts than before , especially where rows or - columns were stretchable. - There are new commands for creating common dialog + columns were stretchable. + There are new commands for creating common dialog boxes: tk_chooseColor, tk_getOpenFile, tk_getSaveFile and - tk_messageBox. These use native dialog boxes if + tk_messageBox. These use native dialog boxes if they are available. There is a new virtual event mechanism for handlin g events in a more portable - way. See the new command event. It also allows + way. See the new command event. It also allows events (both physical and - virtual) to be generated dynamically. + virtual) to be generated dynamically. -Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl +Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl 7.5 and Tk 4.1 except for changes in the C APIs for custom channel drivers. Scrip ts written for earlier releases -should work on these new releases as well. +should work on these new releases as well. Obtaining The Releases Binary Releases -Pre-compiled releases are available for the following +Pre-compiled releases are available for the following platforms: Windows 3.1, Windows 95, and Windows NT: Fetch - ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then + ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a - self-extracting executable. It will install the + self-extracting executable. It will install the Tcl and Tk libraries, the wish and - tclsh programs, and documentation. + tclsh programs, and documentation. Macintosh (both 68K and PowerPC): Fetch - ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. + ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format, - which is understood by Fetch, StuffIt, and many + which is understood by Fetch, StuffIt, and many other Mac utilities. The - unpacked file is a self-installing executable: + unpacked file is a self-installing executable: double-click on it and it will create a - folder containing all that you need to run Tcl + folder containing all that you need to run Tcl and Tk. - UNIX (Solaris 2.* and SunOS, other systems + UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install - binary packages are now for sale at the Sun Labs + binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out! } @@ -583,7 +585,7 @@ Tcl/Tk Shop. Check it out! test for-4.1 {break must reset the interp result} { catch { set z GLOBTESTDIR/dir2/file2.c - if [string match GLOBTESTDIR/dir2/* $z] { + if {[string match GLOBTESTDIR/dir2/* $z]} { break } } j @@ -694,8 +696,8 @@ test for-6.9 {Tcl_ForObjCmd: error executing command body} -body { test for-6.10 {Tcl_ForObjCmd: simple command body} { set z for set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break + $z {set i 1} {$i<6} {incr i} { + if {$i==4} break set a [concat $a $i] } set a @@ -703,7 +705,7 @@ test for-6.10 {Tcl_ForObjCmd: simple command body} { test for-6.11 {Tcl_ForObjCmd: command body in quotes} { set z for set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} "append a x" + $z {set i 1} {$i<6} {incr i} "append a x" set a } {xxxxx} test for-6.12 {Tcl_ForObjCmd: computed command body} { @@ -715,7 +717,7 @@ test for-6.12 {Tcl_ForObjCmd: computed command body} { set bb {break} set x2 {; append a x2} set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 + $z {set i 1} {$i<6} {incr i} $x1$bb$x2 set a } {x1} test for-6.13 {Tcl_ForObjCmd: error in "next" command} -body { @@ -731,9 +733,9 @@ test for-6.13 {Tcl_ForObjCmd: error in "next" command} -body { test for-6.14 {Tcl_ForObjCmd: long command body} { set z for set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break - if $i>5 continue + $z {set i 1} {$i<6} {incr i} { + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -824,7 +826,535 @@ test for-6.18 {Tcl_ForObjCmd: for command result} { 1 {invoked "continue" outside of a loop} \ ] +test for-7.1 {Bug 3614226: ensure that break cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [break] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.2 {Bug 3614226: ensure that continue cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [continue] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.3 {Bug 3614226: ensure that break cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[break] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[continue] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.5 {Bug 3614226: ensure that break cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[break] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.6 {Bug 3614226: ensure that continue cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.7 {Bug 3614226: ensure that break only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[break] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.8 {Bug 3614226: ensure that continue only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.9 {Bug 3614226: ensure that break from invoked command cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [apply {{} {return -code break}}] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.10 {Bug 3614226: ensure that continue from invoked command cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [apply {{} {return -code continue}}] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.11 {Bug 3614226: ensure that break from invoked command cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[apply {{} {return -code break}}] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.12 {Bug 3614226: ensure that continue from invoked command cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[apply {{} { + return -code continue + }}] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.13 {Bug 3614226: ensure that break from invoked command cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code break + }}] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.14 {Bug 3614226: ensure that continue from invoked command cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code continue + }}] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.15 {Bug 3614226: ensure that break from invoked command only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code break + }}] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.16 {Bug 3614226: ensure that continue from invoked command only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code continue + }}] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.17 {Bug 3614226: ensure that break from expanded command cleans up the stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [{*}$op] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.18 {Bug 3614226: ensure that continue from expanded command cleans up the stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [{*}$op] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.19 {Bug 3614226: ensure that break from expanded command cleans up the expansion stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[{*}$op] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.20 {Bug 3614226: ensure that continue from expanded command cleans up the expansion stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[{*}$op] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.21 {Bug 3614226: ensure that break from expanded command cleans up the combination of main and expansion stack} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.22 {Bug 3614226: ensure that continue from expanded command cleans up the combination of main and expansion stack} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.23 {Bug 3614226: ensure that break from expanded command only cleans up the right amount} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.24 {Bug 3614226: ensure that continue from expanded command only cleans up the right amount} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +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} { + 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} { + 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} { + 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} { + 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} { + 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} { + 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: diff --git a/tests/foreach.test b/tests/foreach.test index a4b652a..85dc3da 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -4,14 +4,14 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -212,14 +212,16 @@ test foreach-6.4 {break tests} { set msg } {wrong # args: should be "break"} # Check for bug #406709 -test foreach-6.5 {break tests} { +test foreach-6.5 {break tests} -body { proc a {} { set a 1 foreach b b {list [concat a; break]; incr a} incr a } a -} {2} +} -cleanup { + rename a {} +} -result {2} # Test for incorrect "double evaluation" semantics test foreach-7.1 {delayed substitution of body} { @@ -254,6 +256,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} @@ -266,6 +279,15 @@ test foreach-10.1 {foreach: [Bug 1671087]} -setup { rename demo {} } -result {} +test foreach-11.1 {error then dereference loop var (dev bug)} { + catch { foreach a 0 b {1 2 3} { error x } } + set a +} 0 +test foreach-11.2 {error then dereference loop var (dev bug)} { + catch { foreach a 0 b {1 2 3} { incr a $b; error x } } + set a +} 1 + # cleanup catch {unset a} catch {unset x} diff --git a/tests/format.test b/tests/format.test index 2d53eba..c807c9e 100644 --- a/tests/format.test +++ b/tests/format.test @@ -4,30 +4,33 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1998 Sun Microsystems, Inc. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # %u output depends on word length, so this test is not portable. -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] -testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] -testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] +testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] +# MSVC uses a broken libc that gets sprintf("%g") wrong. This is a pain +# particularly in Continuous Integration, and there isn't anything much we can +# do about it. +testConstraint knownMsvcBug [expr {![info exists ::env(CI_BUILD_WITH_MSVC)]}] test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 } { 34 16923 -12 -1} test format-1.2 {integer formatting} { format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 -} { 6 34 16923 -12 -1 0xe 0XC} +} { 6 34 16923 -12 -1 0xe 0xC} test format-1.3 {integer formatting} longIs32bit { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 } { 6 34 16923 4294967284 -1 0} @@ -52,32 +55,42 @@ test format-1.7.1 {integer formatting} longIs64bit { format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffffffffffff4} test format-1.8 {integer formatting} longIs32bit { - format "%#x %#X %#X %#x" 6 34 16923 -12 -1 -} {0x6 0X22 0X421B 0xfffffff4} + format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 +} {0 0x6 0x22 0x421B 0xfffffff4} test format-1.8.1 {integer formatting} longIs64bit { - format "%#x %#X %#X %#x" 6 34 16923 -12 -1 -} {0x6 0X22 0X421B 0xfffffffffffffff4} + format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 +} {0 0x6 0x22 0x421B 0xfffffffffffffff4} test format-1.9 {integer formatting} longIs32bit { - format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 -} { 0x6 0x22 0x421b 0xfffffff4} + format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 +} { 0 0x6 0x22 0x421b 0xfffffff4} test format-1.9.1 {integer formatting} longIs64bit { - format "%#20x %#20x %#20x %#20x" 6 34 16923 -12 -1 -} { 0x6 0x22 0x421b 0xfffffffffffffff4} + format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 +} { 0 0x6 0x22 0x421b 0xfffffffffffffff4} test format-1.10 {integer formatting} longIs32bit { - format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 -} {0x6 0x22 0x421b 0xfffffff4 } + format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 +} {0 0x6 0x22 0x421b 0xfffffff4 } test format-1.10.1 {integer formatting} longIs64bit { - format "%-#20x %-#20x %-#20x %-#20x" 6 34 16923 -12 -1 -} {0x6 0x22 0x421b 0xfffffffffffffff4 } + format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 +} {0 0x6 0x22 0x421b 0xfffffffffffffff4 } test format-1.11 {integer formatting} longIs32bit { - format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1 -} {06 042 041033 037777777764 } + format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 +} {0 0o6 0o42 0o41033 0o37777777764 } test format-1.11.1 {integer formatting} longIs64bit { - format "%-#20o %#-20o %#-20o %#-20o" 6 34 16923 -12 -1 -} {06 042 041033 01777777777777777777764} + format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 +} {0 0o6 0o42 0o41033 0o1777777777777777777764} test format-1.12 {integer formatting} { - format "%b %#b %llb" 5 5 [expr {2**100}] -} {101 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} + format "%b %#b %#b %llb" 5 0 5 [expr {2**100}] +} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} +test format-1.13 {integer formatting} { + format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1 +} {0 0d6 0d34 0d16923 -0d12} +test format-1.14 {integer formatting} { + format "%#05d %#020d %#020d %#020d %#020d" 0 6 34 16923 -12 -1 +} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012} +test format-1.15 {integer formatting} { + format "%-#05d %-#020d %-#020d %-#020d %-#020d" 0 6 34 16923 -12 -1 +} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012} + test format-2.1 {string formatting} { format "%s %s %c %s" abcd {This is a very long test string.} 120 x @@ -254,13 +267,13 @@ test format-6.1 {floating-point zeroes} {eformat} { test format-6.2 {floating-point zeroes} {eformat} { format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0 } {0.0000e+00 0.0000 0} -test format-6.3 {floating-point zeroes} {eformat} { +test format-6.3 {floating-point zeroes} {eformat knownMsvcBug} { format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0 } {0.0000e+00 0.0000 0.000} test format-6.4 {floating-point zeroes} {eformat} { format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0 } {0e+00 0 0} -test format-6.5 {floating-point zeroes} {eformat} { +test format-6.5 {floating-point zeroes} {eformat knownMsvcBug} { format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0 } {0.e+00 0. 0.} test format-6.6 {floating-point zeroes} { @@ -349,9 +362,9 @@ test format-8.19 {error conditions} { catch {format %q x} } 1 test format-8.20 {error conditions} { - catch {format %q x} msg + catch {format %r x} msg set msg -} {bad field specifier "q"} +} {bad field specifier "r"} test format-8.21 {error conditions} { catch {format %d} } 1 @@ -363,6 +376,26 @@ test format-8.23 {error conditions} { catch {format "%d %d" 24 xyz} msg set msg } {expected integer but got "xyz"} +# Since "%zd" and "%td" are equivalent to "%lld" in 64-bit platforms and +# equivalent to "%d" in 32-bit platforms, they are really not useful in +# scripts, therefore they are not documented. It's intended use is through +# the function Tcl_AppendPrintfToObj (et al). +test format-8.24 {Undocumented formats} -body { + format "%zd %td %d" [expr 2**30] [expr 2**30] [expr 2**30] +} -result {1073741824 1073741824 1073741824} +test format-8.25 {Undocumented formats} -constraints pointerIs64bit -body { + format "%zd %td %lld" [expr 2**33] [expr 2**33] [expr 2**33] +} -result {8589934592 8589934592 8589934592} +# Since "%p" is equivalent to "%#llx" in 64-bit platforms and equivalent +# to "%#x" in 32-bit platforms, it are really not useful in scripts, +# therefore they are not documented. It's intended use is through the +# function Tcl_AppendPrintfToObj (et al). +test format-8.26 {Undocumented formats} -body { + format "%p %#x" [expr 2**31] [expr 2**31] +} -result {0x80000000 0x80000000} +test format-8.27 {Undocumented formats} -constraints pointerIs64bit -body { + format "%p %#llx" [expr 2**33] [expr 2**33] +} -result {0x200000000 0x200000000} test format-9.1 {long result} { set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} @@ -516,7 +549,7 @@ for {set i 290} {$i < 400} {incr i} { append b "x" } -test format-17.1 {testing %d with wide} {wideIs64bit wideBiggerThanInt} { +test format-17.1 {testing %d with wide} {longIs32bit wideIs64bit} { format %d 7810179016327718216 } 1819043144 test format-17.2 {testing %ld with wide} {wideIs64bit} { @@ -528,6 +561,12 @@ test format-17.3 {testing %ld with non-wide} {wideIs64bit} { test format-17.4 {testing %l with non-integer} { format %lf 1 } 1.000000 +test format-17.5 {testing %llu with positive bignum} -body { + format %llu 0xabcdef0123456789abcdef +} -result 207698809136909011942886895 +test format-17.6 {testing %llu with negative number} -body { + format %llu -1 +} -returnCodes 1 -result {unsigned bignum format is invalid} test format-18.1 {do not demote existing numeric values} { set a 0xaaaaaaaa @@ -543,16 +582,13 @@ test format-18.1 {do not demote existing numeric values} { format %08x $b lappend result [expr {$a == $b}] } {1 1 1 1} -test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} { +test format-18.2 {do not demote existing numeric values} {longIs32bit wideIs64bit} { set a [expr {0xaaaaaaaaaa + 1}] set b 0xaaaaaaaaab list [format %08x $a] [expr {$a == $b}] } {aaaaaaab 1} -test format-19.1 { - regression test - tcl-core message by Brian Griffin on - 26 0ctober 2004 -} -body { +test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body { set x 0x8fedc654 list [expr { ~ $x }] [format %08x [expr { ~$x }]] } -match regexp -result {-2414724693 f*701239ab} @@ -563,13 +599,30 @@ test format-19.3 {Bug 2830354} { string length [format %340f 0] } 340 +test format-19.4.1 {Bug d498578df4: width overflow should cause limit exceeded} \ +-constraints {longIs32bit} -body { + # in case of overflow into negative, it produces width -2 (and limit exceeded), + # in case of width will be unsigned, it will be outside limit (2GB for 32bit)... + # and it don't throw an error in case the bug is not fixed (and probably no segfault). + format %[expr {0xffffffff - 1}]g 0 +} -returnCodes error -result "max size for a Tcl value exceeded" + +test format-19.4.2 {Bug d498578df4: width overflow should cause limit exceeded} -body { + # limit should exceeds in any case, + # and it don't throw an error in case the bug is not fixed (and probably no segfault). + format %[expr {0xffffffffffffffff - 1}]g 0 +} -returnCodes error -result "max size for a Tcl value exceeded" + # Note that this test may fail in future versions test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body { set x [dict create a b c d] format %s $x - # After this, obj in $x should be a dict with a non-NULL bytes field + # After this, obj in $x should be a dict + # We are testing to make sure it has not been shimmered to a + # different intrep when that is not necessary. + # Whether or not there is a string rep - we should not care! tcl::unsupported::representation $x -} -match glob -result {value is a dict with *, string representation "*".} +} -match glob -result {value is a dict *} # cleanup catch {unset a} diff --git a/tests/get.test b/tests/get.test index d51ec6d..25f8d77 100644 --- a/tests/get.test +++ b/tests/get.test @@ -4,24 +4,25 @@ # file tclGet.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] - +testConstraint testdoubleobj [llength [info commands testdoubleobj]] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] + test get-1.1 {Tcl_GetInt procedure} testgetint { testgetint 44 { 22} } {66} @@ -44,14 +45,14 @@ test get-1.7 {Tcl_GetInt procedure} {testgetint longIs64bit} { list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} { - list [catch {testgetint 18446744073709551614} msg] $msg -} {0 -2} + testgetint 18446744073709551614 +} {-2} test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} { - list [catch {testgetint +18446744073709551614} msg] $msg -} {0 -2} + testgetint +18446744073709551614 +} {-2} test get-1.10 {Tcl_GetInt procedure} {testgetint longIs64bit} { - list [catch {testgetint -18446744073709551614} msg] $msg -} {0 2} + list [catch {testgetint -18446744073709551614} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test get-1.11 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint 44 4294967296} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} @@ -63,7 +64,7 @@ test get-1.13 {Tcl_GetInt procedure} {testgetint longIs32bit} { } {0 -2} test get-1.14 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint -4294967294} msg] $msg -} {0 2} +} {1 {integer value too large to represent}} test get-2.1 {Tcl_GetInt procedure} { format %g 1.23 @@ -95,7 +96,30 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} { } set result } {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}} - +# Bug 7114ac6141 +test get-3.3 {tcl_GetInt with iffy numbers} testgetint { + lmap x {0 " 0" "0 " " 0 " " 0xa " " 007 " " 0o10 " " 0b10 "} { + catch {testgetint 44 $x} x + set x + } +} {44 44 44 44 54 51 52 46} +test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj { + lmap x {0 0.0 " .0" ".0 " " 0e0 " "07" "- 0" "-0" "0o12" "0b10"} { + catch {testdoubleobj set 1 $x} x + set x + } +} {0.0 0.0 0.0 0.0 0.0 7.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0} +test get-3.5 {tcl_GetInt with numeric whitespace (i.e. '_')} testgetint { + lmap x {0_0 " 1_0" "0_2 " " 3_3 " 14__23__32___4 " 0x_a " 0b1111_1111 " 0_07 " " 0o_1_0 " " 0b_1_0 " " 0_b1_0 " _33 42_ 0_x15 0_o17 0_d19 } { + catch {testgetint $x} x + set x + } +} {0 10 2 33 1423324 10 255 7 8 2 {expected integer but got " 0_b1_0 "} {expected integer but got "_33"} {expected integer but got "42_"} {expected integer but got "0_x15"} {expected integer but got "0_o17"} {expected integer but got "0_d19"}} + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/history.test b/tests/history.test index c562796..557c856 100644 --- a/tests/history.test +++ b/tests/history.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -40,7 +40,7 @@ test history-1.1 {event option} history {history event -1} \ {set b [format {A test %s} string]} test history-1.2 {event option} history {history event $num} \ {set a 12345} -test history-1.3 {event option} history {history event [expr $num+2]} \ +test history-1.3 {event option} history {history event [expr {$num+2}]} \ {Another test} test history-1.4 {event option} history {history event set} \ {set b [format {A test %s} string]} @@ -149,11 +149,11 @@ test history-5.1 {info option} history {history info} [format {%6d set a {b %6d set b 1234 %6d set c {a b - c}} $num [expr $num+1] [expr $num+2]] + c}} $num [expr {$num+1}] [expr {$num+2}]] test history-5.2 {info option} history {history i 2} [format {%6d set b 1234 %6d set c {a b - c}} [expr $num+1] [expr $num+2]] + c}} [expr {$num+1}] [expr {$num+2}]] test history-5.3 {info option} history {catch {history i 2 3}} 1 test history-5.4 {info option} history { catch {history i 2 3} msg @@ -164,7 +164,7 @@ test history-5.5 {info option} history {history} [format {%6d set a {b %6d set b 1234 %6d set c {a b - c}} $num [expr $num+1] [expr $num+2]] + c}} $num [expr {$num+1}] [expr {$num+2}]] # "history keep" @@ -174,7 +174,9 @@ if {[testConstraint history]} { history add "foo3" history keep 2 } -test history-6.1 {keep option} history {history event [expr [history n]-1]} foo3 +test history-6.1 {keep option} history { + history event [expr {[history n]-1}] +} foo3 test history-6.2 {keep option} history {history event -1} foo2 test history-6.3 {keep option} history {catch {history event -3}} 1 test history-6.4 {keep option} history { @@ -216,7 +218,7 @@ if {[testConstraint history]} { history add "Testing2" } test history-7.1 {nextid option} history {history event} "Testing" -test history-7.2 {nextid option} history {history next} [expr $num+2] +test history-7.2 {nextid option} history {history next} [expr {$num+2}] test history-7.3 {nextid option} history {catch {history nextid garbage}} 1 test history-7.4 {nextid option} history { catch {history nextid garbage} msg @@ -233,6 +235,7 @@ if {[testConstraint history]} { test history-8.1 {clear option} history {catch {history clear junk}} 1 test history-8.2 {clear option} history {history clear} {} if {[testConstraint history]} { + history clear history add "Testing" } test history-8.3 {clear option} history {history} { 1 Testing} @@ -244,7 +247,65 @@ test history-9.2 {miscellaneous} history { catch {history gorp} msg set msg } {unknown or ambiguous subcommand "gorp": must be add, change, clear, event, info, keep, nextid, or redo} + +# History retains references; Bug 1ae12987cb +test history-10.1 {references kept by history} -constraints history -setup { + interp create histtest + histtest eval { + # Trigger any autoloading that might be present + catch {history} + proc refcount {x} { + set rep [::tcl::unsupported::representation $x] + regexp {with a refcount of (\d+)} $rep -> rc + # Ignore the references due to calling this procedure + return [expr {$rc - 3}] + } + } +} -body { + histtest eval { + # A fresh object, refcount 1 from the variable we write it to + set obj [expr {rand()}] + set baseline [refcount $obj] + lappend result [refcount $obj] + history add [list list $obj] + lappend result [refcount $obj] + history clear + lappend result [refcount $obj] + } +} -cleanup { + interp delete histtest +} -result {1 2 1} +test history-10.2 {references kept by history} -constraints history -setup { + interp create histtest + histtest eval { + # Trigger any autoloading that might be present + catch {history} + proc refcount {x} { + set rep [::tcl::unsupported::representation $x] + regexp {with a refcount of (\d+)} $rep -> rc + # Ignore the references due to calling this procedure + return [expr {$rc - 3}] + } + } +} -body { + histtest eval { + # A fresh object, refcount 1 from the variable we write it to + set obj [expr {rand()}] + set baseline [refcount $obj] + lappend result [refcount $obj] + history add [list list $obj] + lappend result [refcount $obj] + rename history {} + lappend result [refcount $obj] + } +} -cleanup { + interp delete histtest +} -result {1 2 1} # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/http.test b/tests/http.test index fe44b47..ff9fb78 100644 --- a/tests/http.test +++ b/tests/http.test @@ -4,22 +4,24 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} if {[catch {package require http 2} version]} { if {[info exists http2]} { catch {puts "Cannot load http 2.* package"} return } else { - catch {puts "Running http 2.* tests in slave interp"} + catch {puts "Running http 2.* tests in child interp"} set interp [interp create http2] $interp eval [list set http2 "running"] $interp eval [list set argv $argv] @@ -36,7 +38,10 @@ proc bgerror {args} { puts stderr $errorInfo } -set port 8010 +# Do not use [info hostname]. +# Name resolution is often a problem on OSX; not focus of HTTP package anyway. +# Also a problem on other platforms for http-4.14 (test with bad port number). +set HOST localhost set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" catch {unset data} @@ -51,13 +56,12 @@ if {![file exists $httpdFile]} { set removeHttpd 1 } -catch {package require Thread 2.6} +catch {package require Thread 2.7-} if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { set httpthread [thread::create -preserved] thread::send $httpthread [list source $httpdFile] - thread::send $httpthread [list set port $port] thread::send $httpthread [list set bindata $bindata] - thread::send $httpthread {httpd_init $port} + thread::send $httpthread {httpd_init 0; set port} port puts "Running httpd in thread $httpthread" } else { if {![file exists $httpdFile]} { @@ -69,17 +73,15 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { # Let the OS pick the port; that's much more flexible if {[catch {httpd_init 0} listen]} { puts "Cannot start http server, http test skipped" - unset port + catch {unset port} return - } else { - set port [lindex [fconfigure $listen -sockname] 2] } } test http-1.1 {http::config} { http::config -useragent UserAgent http::config -} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"] +} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1] test http-1.2 {http::config} { http::config -proxyfilter } http::ProxyRequired @@ -94,10 +96,10 @@ test http-1.4 {http::config} { set x [http::config] http::config {*}$savedconf set x -} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}} +} {-accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1} test http-1.5 {http::config} -returnCodes error -body { http::config -proxyhost {} -junk 8080 -} -result {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent} +} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip} test http-1.6 {http::config} -setup { set oldenc [http::config -urlencoding] } -body { @@ -118,8 +120,8 @@ test http-3.1 {http::geturl} -returnCodes error -body { test http-3.2 {http::geturl} -returnCodes error -body { http::geturl http:junk } -result {Unsupported URL: http:junk} -set url //[info hostname]:$port -set badurl //[info hostname]:6666 +set url //${::HOST}:$port +set badurl //${::HOST}:[expr {$port+1}] test http-3.3 {http::geturl} -body { set token [http::geturl $url] http::data $token @@ -130,11 +132,13 @@ test http-3.3 {http::geturl} -body { <h2>GET /</h2> </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 binurl //[info hostname]:$port/binary -set posturl //[info hostname]:$port/post -set badposturl //[info hostname]:$port/droppost +set url //${::HOST}:$port/a/b/c +set fullurl HTTP://user:pass@${::HOST}:$port/a/b/c +set binurl //${::HOST}:$port/binary +set xmlurl //${::HOST}:$port/xml +set posturl //${::HOST}:$port/post +set badposturl //${::HOST}:$port/droppost +set authorityurl //${::HOST}:$port set ipv6url http://\[::1\]:$port/ test http-3.4 {http::geturl} -body { set token [http::geturl $url] @@ -147,7 +151,7 @@ test http-3.4 {http::geturl} -body { </body></html>" proc selfproxy {host} { global port - return [list [info hostname] $port] + return [list ${::HOST} $port] } test http-3.5 {http::geturl} -body { http::config -proxyfilter selfproxy @@ -181,7 +185,7 @@ test http-3.7 {http::geturl} -body { <h2>GET $tail</h2> </body></html>" test http-3.8 {http::geturl} -body { - set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000] + set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 3000] http::data $token } -cleanup { http::cleanup $token @@ -305,7 +309,6 @@ test http-3.13 {http::geturl socket leak test} { for {set i 0} {$i < 3} {incr i} { catch {http::geturl $badurl -timeout 5000} } - # No extra channels should be taken expr {[llength [file channels]] == $chanCount} } 1 @@ -348,7 +351,7 @@ test http-3.24 {http::geturl parse failures} -body { test http-3.25 {http::meta} -setup { unset -nocomplain m token } -body { - set token [http::geturl $url -timeout 2000] + set token [http::geturl $url -timeout 3000] array set m [http::meta $token] lsort [array names m] } -cleanup { @@ -358,7 +361,7 @@ test http-3.25 {http::meta} -setup { test http-3.26 {http::meta} -setup { unset -nocomplain m token } -body { - set token [http::geturl $url -headers {X-Check 1} -timeout 2000] + set token [http::geturl $url -headers {X-Check 1} -timeout 3000] array set m [http::meta $token] lsort [array names m] } -cleanup { @@ -371,11 +374,11 @@ test http-3.27 {http::geturl: -headers override -type} -body { http::data $token } -cleanup { http::cleanup $token -} -match regexp -result {(?n)Accept \*/\* -Host .* +} -match regexp -result {(?n)Host .* User-Agent .* Connection close Content-Type {text/plain;charset=utf-8} +Accept \*/\* Accept-Encoding .* Content-Length 5} test http-3.28 {http::geturl: -headers override -type default} -body { @@ -384,19 +387,63 @@ test http-3.28 {http::geturl: -headers override -type default} -body { http::data $token } -cleanup { http::cleanup $token -} -match regexp -result {(?n)Accept \*/\* -Host .* +} -match regexp -result {(?n)Host .* User-Agent .* Connection close Content-Type {text/plain;charset=utf-8} +Accept \*/\* Accept-Encoding .* Content-Length 5} -test http-3.29 "http::geturl $ipv6url" -body { - set token [http::geturl $ipv6url -validate 1] - http::code $token +test http-3.29 {http::geturl IPv6 address} -body { + # We only want to see if the URL gets parsed correctly. This is + # the case if http::geturl succeeds or returns a socket related + # error. If the parsing is wrong, we'll get a parse error. + # It'd be better to separate the URL parser from http::geturl, so + # that it can be tested without also trying to make a connection. + set error [catch {http::geturl $ipv6url -validate 1} token] + if {$error && [string match "couldn't open socket: *" $token]} { + set error 0 + } + set error +} -cleanup { + catch { http::cleanup $token } +} -result 0 +test http-3.30 {http::geturl query without path} -body { + set token [http::geturl $authorityurl?var=val] + http::ncode $token +} -cleanup { + catch { http::cleanup $token } +} -result 200 +test http-3.31 {http::geturl fragment without path} -body { + set token [http::geturl "$authorityurl#fragment42"] + http::ncode $token +} -cleanup { + catch { http::cleanup $token } +} -result 200 +# Bug c11a51c482 +test http-3.32 {http::geturl: -headers override -accept default} -body { + set token [http::geturl $url/headers -query dummy \ + -headers [list "Accept" "text/plain,application/tcl-test-value"]] + http::data $token } -cleanup { http::cleanup $token -} -result "HTTP/1.0 200 OK" +} -match regexp -result {(?n)Host .* +User-Agent .* +Connection close +Accept text/plain,application/tcl-test-value +Accept-Encoding .* +Content-Type application/x-www-form-urlencoded +Content-Length 5} +# Bug 838e99a76d +test http-3.33 {http::geturl application/xml is text} -body { + set token [http::geturl "$xmlurl"] + scan [http::data $token] "<%\[^>]>%c<%\[^>]>" +} -cleanup { + catch { http::cleanup $token } +} -result {test 4660 /test} +test http-3.34 {http::geturl -headers not a dict} -returnCodes error -body { + http::geturl http://test/t -headers NoDict +} -result {Bad value for -headers (NoDict), must be dict} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] @@ -472,14 +519,10 @@ proc myProgress {token total current} { } set progress [list $total $current] } -if 0 { - # This test hangs on Windows95 because the client never gets EOF - set httpLog 1 - test http-4.6.1 {http::Event} knownBug { - set token [http::geturl $url -blocksize 50 -progress myProgress] - return $progress - } {111 111} -} +test http-4.6.1 {http::Event} knownBug { + set token [http::geturl $url -blocksize 50 -progress myProgress] + return $progress +} {111 111} test http-4.7 {http::Event} -body { set token [http::geturl $url -keepalive 0 -progress myProgress] return $progress @@ -539,22 +582,35 @@ test http-4.14 {http::Event} -body { error "bogus return from http::geturl" } http::wait $token - http::status $token - # error code varies among platforms. -} -returnCodes 1 -match regexp -cleanup { + lindex [http::error $token] 0 +} -cleanup { catch {http::cleanup $token} -} -result {(connect failed|couldn't open socket)} +} -result {connect failed connection refused} # Bogus host test http-4.15 {http::Event} -body { # This test may fail if you use a proxy server. That is to be # expected and is not a problem with Tcl. - set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command \#] + set token [http::geturl //not_a_host.tcl.tk -timeout 3000 -command \#] http::wait $token http::status $token # error codes vary among platforms. } -cleanup { catch {http::cleanup $token} } -returnCodes 1 -match glob -result "couldn't open socket*" +test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup { + proc list-difference {l1 l2} { + lmap item $l2 {if {$item in $l1} continue; set item} + } +} -body { + set before [chan names] + set token [http::geturl $url -headers {X-Connection keep-alive}] + http::cleanup $token + update + # Compute what channels have been unexpectedly leaked past cleanup + list-difference $before [chan names] +} -cleanup { + rename list-difference {} +} -result {} test http-5.1 {http::formatQuery} { http::formatQuery name1 value1 name2 "value two" @@ -575,7 +631,7 @@ test http-5.5 {http::formatQuery} { } {name1=~bwelch&name2=%A1%A2%A2} test http-6.1 {http::ProxyRequired} -body { - http::config -proxyhost [info hostname] -proxyport $port + http::config -proxyhost ${::HOST} -proxyport $port set token [http::geturl $url] http::wait $token upvar #0 $token data @@ -616,6 +672,451 @@ test http-7.4 {http::formatQuery} -setup { http::config -urlencoding $enc } -result {%3F} +package require tcl::idna 1.0 + +test http-idna-1.1 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna +} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"} +test http-idna-1.2 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna ? +} -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version} +test http-idna-1.3 {IDNA package: basics} -body { + ::tcl::idna version +} -result 1.0.1 +test http-idna-1.4 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna version what +} -result {wrong # args: should be "::tcl::idna version"} +test http-idna-1.5 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny +} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"} +test http-idna-1.6 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny ? +} -result {unknown or ambiguous subcommand "?": must be decode, or encode} +test http-idna-1.7 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny encode +} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} +test http-idna-1.8 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny encode a b c +} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} +test http-idna-1.9 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny decode +} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} +test http-idna-1.10 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny decode a b c +} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} +test http-idna-1.11 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna decode +} -result {wrong # args: should be "::tcl::idna decode hostname"} +test http-idna-1.12 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna encode +} -result {wrong # args: should be "::tcl::idna encode hostname"} + +test http-idna-2.1 {puny encode: functional test} { + ::tcl::idna puny encode abc +} abc- +test http-idna-2.2 {puny encode: functional test} { + ::tcl::idna puny encode a\u20acb\u20acc +} abc-k50ab +test http-idna-2.3 {puny encode: functional test} { + ::tcl::idna puny encode ABC +} ABC- +test http-idna-2.4 {puny encode: functional test} { + ::tcl::idna puny encode A\u20ACB\u20ACC +} ABC-k50ab +test http-idna-2.5 {puny encode: functional test} { + ::tcl::idna puny encode ABC 0 +} abc- +test http-idna-2.6 {puny encode: functional test} { + ::tcl::idna puny encode A\u20ACB\u20ACC 0 +} abc-k50ab +test http-idna-2.7 {puny encode: functional test} { + ::tcl::idna puny encode ABC 1 +} ABC- +test http-idna-2.8 {puny encode: functional test} { + ::tcl::idna puny encode A\u20ACB\u20ACC 1 +} ABC-k50ab +test http-idna-2.9 {puny encode: functional test} { + ::tcl::idna puny encode abc 0 +} abc- +test http-idna-2.10 {puny encode: functional test} { + ::tcl::idna puny encode a\u20ACb\u20ACc 0 +} abc-k50ab +test http-idna-2.11 {puny encode: functional test} { + ::tcl::idna puny encode abc 1 +} ABC- +test http-idna-2.12 {puny encode: functional test} { + ::tcl::idna puny encode a\u20ACb\u20ACc 1 +} ABC-k50ab +test http-idna-2.13 {puny encode: edge cases} { + ::tcl::idna puny encode "" +} "" +test http-idna-2.14-A {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 + u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F + }]] ""] +} egbpdaj6bu4bxfgehfvwxn +test http-idna-2.14-B {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587 + }]] ""] +} ihqwcrb4cv8a8dqg056pqjye +test http-idna-2.14-C {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587 + }]] ""] +} ihqwctvzc91f659drss3x8bo0yb +test http-idna-2.14-D {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074 + u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D + u+0065 u+0073 u+006B u+0079 + }]] ""] +} Proprostnemluvesky-uyb24dma41a +test http-idna-2.14-E {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 + u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 + u+05D1 u+05E8 u+05D9 u+05EA + }]] ""] +} 4dbcagdahymbxekheh6e0a7fei0b +test http-idna-2.14-F {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D + u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939 + u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947 + u+0939 u+0948 u+0902 + }]] ""] +} i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd +test http-idna-2.14-G {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092 + u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B + }]] ""] +} n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa +test http-idna-2.14-H {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 + u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 + u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C + }]] ""] +} 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c +test http-idna-2.14-I {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E + u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440 + u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A + u+0438 + }]] ""] +} b1abfaaepdrnnbgefbadotcwatmq2g4l +test http-idna-2.14-J {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 + u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 + u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061 + u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070 + u+0061 u+00F1 u+006F u+006C + }]] ""] +} PorqunopuedensimplementehablarenEspaol-fmd56a +test http-idna-2.14-K {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B + u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 + u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 + u+0056 u+0069 u+1EC7 u+0074 + }]] ""] +} TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g +test http-idna-2.14-L {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F + }]] ""] +} 3B-ww4c5e180e575a65lsy2b +test http-idna-2.14-M {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074 + u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D + u+004F u+004E u+004B u+0045 u+0059 u+0053 + }]] ""] +} -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n +test http-idna-2.14-N {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F + u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D + u+305D u+308C u+305E u+308C u+306E u+5834 u+6240 + }]] ""] +} Hello-Another-Way--fc4qua05auwb3674vfr0b +test http-idna-2.14-O {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032 + }]] ""] +} 2-u9tlzr9756bt3uc0v +test http-idna-2.14-P {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059 + u+308B u+0035 u+79D2 u+524D + }]] ""] +} MajiKoi5-783gue6qz075azm5e +test http-idna-2.14-Q {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0 + }]] ""] +} de-jg4avhby1noc0d +test http-idna-2.14-R {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067 + }]] ""] +} d9juau41awczczp +test http-idna-2.14-S {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode {-> $1.00 <-} +} {-> $1.00 <--} + +test http-idna-3.1 {puny decode: functional test} { + ::tcl::idna puny decode abc- +} abc +test http-idna-3.2 {puny decode: functional test} { + ::tcl::idna puny decode abc-k50ab +} a\u20acb\u20acc +test http-idna-3.3 {puny decode: functional test} { + ::tcl::idna puny decode ABC- +} ABC +test http-idna-3.4 {puny decode: functional test} { + ::tcl::idna puny decode ABC-k50ab +} A\u20ACB\u20ACC +test http-idna-3.5 {puny decode: functional test} { + ::tcl::idna puny decode ABC-K50AB +} A\u20ACB\u20ACC +test http-idna-3.6 {puny decode: functional test} { + ::tcl::idna puny decode abc-K50AB +} a\u20ACb\u20ACc +test http-idna-3.7 {puny decode: functional test} { + ::tcl::idna puny decode ABC- 0 +} abc +test http-idna-3.8 {puny decode: functional test} { + ::tcl::idna puny decode ABC-K50AB 0 +} a\u20ACb\u20ACc +test http-idna-3.9 {puny decode: functional test} { + ::tcl::idna puny decode ABC- 1 +} ABC +test http-idna-3.10 {puny decode: functional test} { + ::tcl::idna puny decode ABC-K50AB 1 +} A\u20ACB\u20ACC +test http-idna-3.11 {puny decode: functional test} { + ::tcl::idna puny decode abc- 0 +} abc +test http-idna-3.12 {puny decode: functional test} { + ::tcl::idna puny decode abc-k50ab 0 +} a\u20ACb\u20ACc +test http-idna-3.13 {puny decode: functional test} { + ::tcl::idna puny decode abc- 1 +} ABC +test http-idna-3.14 {puny decode: functional test} { + ::tcl::idna puny decode abc-k50ab 1 +} A\u20ACB\u20ACC +test http-idna-3.15 {puny decode: edge cases and errors} { + # Is this case actually correct? + binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]] +} c282c281c280 +test http-idna-3.16 {puny decode: edge cases and errors} -returnCodes error -body { + ::tcl::idna puny decode abc! +} -result {bad decode character "!"} +test http-idna-3.17 {puny decode: edge cases and errors} { + catch {::tcl::idna puny decode abc!} -> opt + dict get $opt -errorcode +} {PUNYCODE BAD_INPUT CHAR} +test http-idna-3.18 {puny decode: edge cases and errors} { + ::tcl::idna puny decode "" +} {} +# A helper so we don't get lots of crap in failures +proc hexify s {lmap c [split $s ""] {format u+%04X [scan $c %c]}} +test http-idna-3.19-A {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode egbpdaj6bu4bxfgehfvwxn] +} [list {*}{ + u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 + u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F +}] +test http-idna-3.19-B {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode ihqwcrb4cv8a8dqg056pqjye] +} {u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587} +test http-idna-3.19-C {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode ihqwctvzc91f659drss3x8bo0yb] +} {u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587} +test http-idna-3.19-D {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode Proprostnemluvesky-uyb24dma41a] +} [list {*}{ + u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074 + u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D + u+0065 u+0073 u+006B u+0079 +}] +test http-idna-3.19-E {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode 4dbcagdahymbxekheh6e0a7fei0b] +} [list {*}{ + u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 + u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 + u+05D1 u+05E8 u+05D9 u+05EA +}] +test http-idna-3.19-F {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd] +} [list {*}{ + u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D + u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939 + u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947 + u+0939 u+0948 u+0902 +}] +test http-idna-3.19-G {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa] +} [list {*}{ + u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092 + u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B +}] +test http-idna-3.19-H {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c] +} [list {*}{ + u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 + u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 + u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C +}] +test http-idna-3.19-I {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode b1abfaaepdrnnbgefbadotcwatmq2g4l] +} [list {*}{ + u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E + u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440 + u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A + u+0438 +}] +test http-idna-3.19-J {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + PorqunopuedensimplementehablarenEspaol-fmd56a] +} [list {*}{ + u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 + u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 + u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061 + u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070 + u+0061 u+00F1 u+006F u+006C +}] +test http-idna-3.19-K {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g] +} [list {*}{ + u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B + u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 + u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 + u+0056 u+0069 u+1EC7 u+0074 +}] +test http-idna-3.19-L {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode 3B-ww4c5e180e575a65lsy2b] +} {u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F} +test http-idna-3.19-M {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n] +} [list {*}{ + u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074 + u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D + u+004F u+004E u+004B u+0045 u+0059 u+0053 +}] +test http-idna-3.19-N {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode Hello-Another-Way--fc4qua05auwb3674vfr0b] +} [list {*}{ + u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F + u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D + u+305D u+308C u+305E u+308C u+306E u+5834 u+6240 +}] +test http-idna-3.19-O {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode 2-u9tlzr9756bt3uc0v] +} {u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032} +test http-idna-3.19-P {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode MajiKoi5-783gue6qz075azm5e] +} [list {*}{ + u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059 + u+308B u+0035 u+79D2 u+524D +}] +test http-idna-3.19-Q {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode de-jg4avhby1noc0d] +} {u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0} +test http-idna-3.19-R {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode d9juau41awczczp] +} {u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067} +test http-idna-3.19-S {puny decode: examples from RFC 3492} { + ::tcl::idna puny decode {-> $1.00 <--} +} {-> $1.00 <-} +rename hexify "" + +test http-idna-4.1 {IDNA encoding} { + ::tcl::idna encode abc.def +} abc.def +test http-idna-4.2 {IDNA encoding} { + ::tcl::idna encode a\u20acb\u20acc.def +} xn--abc-k50ab.def +test http-idna-4.3 {IDNA encoding} { + ::tcl::idna encode def.a\u20acb\u20acc +} def.xn--abc-k50ab +test http-idna-4.4 {IDNA encoding} { + ::tcl::idna encode ABC.DEF +} ABC.DEF +test http-idna-4.5 {IDNA encoding} { + ::tcl::idna encode A\u20acB\u20acC.def +} xn--ABC-k50ab.def +test http-idna-4.6 {IDNA encoding: invalid edge case} { + # Should this be an error? + ::tcl::idna encode abc..def +} abc..def +test http-idna-4.7 {IDNA encoding: invalid char} -returnCodes error -body { + ::tcl::idna encode abc.$.def +} -result {bad character "$" in DNS name} +test http-idna-4.7.1 {IDNA encoding: invalid char} { + catch {::tcl::idna encode abc.$.def} -> opt + dict get $opt -errorcode +} {IDNA INVALID_NAME_CHARACTER {$}} +test http-idna-4.8 {IDNA encoding: empty} { + ::tcl::idna encode "" +} {} +set overlong www.[join [subst [string map {u+ \\u} { + u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 + u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 + u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C +}]] ""].com +test http-idna-4.9 {IDNA encoding: max lengths from RFC 5890} -body { + ::tcl::idna encode $overlong +} -returnCodes error -result "hostname part too long" +test http-idna-4.9.1 {IDNA encoding: max lengths from RFC 5890} { + catch {::tcl::idna encode $overlong} -> opt + dict get $opt -errorcode +} {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c} +unset overlong +test http-idna-4.10 {IDNA encoding: edge cases} { + ::tcl::idna encode pass\u00e9.example.com +} xn--pass-epa.example.com + +test http-idna-5.1 {IDNA decoding} { + ::tcl::idna decode abc.def +} abc.def +test http-idna-5.2 {IDNA decoding} { + # Invalid entry that's just a wrapper + ::tcl::idna decode xn--abc-.def +} abc.def +test http-idna-5.3 {IDNA decoding} { + # Invalid entry that's just a wrapper + ::tcl::idna decode xn--abc-.xn--def- +} abc.def +test http-idna-5.4 {IDNA decoding} { + # Invalid entry that's just a wrapper + ::tcl::idna decode XN--abc-.XN--def- +} abc.def +test http-idna-5.5 {IDNA decoding: error cases} -returnCodes error -body { + ::tcl::idna decode xn--$$$.example.com +} -result {bad decode character "$"} +test http-idna-5.5.1 {IDNA decoding: error cases} { + catch {::tcl::idna decode xn--$$$.example.com} -> opt + dict get $opt -errorcode +} {PUNYCODE BAD_INPUT CHAR} +test http-idna-5.6 {IDNA decoding: error cases} -returnCodes error -body { + ::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def +} -result {exceeded input data} +test http-idna-5.6.1 {IDNA decoding: error cases} { + catch {::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def} -> opt + dict get $opt -errorcode +} {PUNYCODE BAD_INPUT LENGTH} + # cleanup catch {unset url} catch {unset badurl} diff --git a/tests/http11.test b/tests/http11.test index 230ce5a..f243e56 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -7,17 +7,19 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} -package require http 2.8 +package require http 2.9 # start the server variable httpd_output proc create_httpd {} { proc httpd_read {chan} { variable httpd_output - if {[gets $chan line] != -1} { + if {[gets $chan line] >= 0} { #puts stderr "read '$line'" set httpd_output $line } @@ -60,6 +62,20 @@ proc meta {tok {key ""}} { return $meta } +proc state {tok {key ""}} { + upvar 1 $tok state + if {$key ne ""} { + if {[array names state -exact $key] ne {}} { + return $state($key) + } else { + return "" + } + } + set res [array get state] + dict set res body <elided> + return $res +} + proc check_crc {tok args} { set crc [meta $tok x-crc32] set data [expr {[llength $args] ? [lindex $args 0] : [http::data $tok]}] @@ -70,11 +86,8 @@ proc check_crc {tok args} { return "ok" } -makeFile "<html><head><title>test</title></head>\ -<body><p>this is a test</p>\n\ -[string repeat {<p>This is a tcl test file.</p>} 4192]\n\ -</body></html>" testdoc.html - +makeFile "<html><head><title>test</title></head><body><p>this is a test</p>\n[string repeat {<p>This is a tcl test file.</p>} 4192]\n</body></html>" testdoc.html + # ------------------------------------------------------------------------- test http11-1.0 "normal request for document " -setup { @@ -244,8 +257,45 @@ test http11-1.12 "normal,identity,chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} chunked} +test http11-1.13 "normal, 1.1 and keepalive as server default, no zip" -setup { + variable httpd [create_httpd] + set zipTmp [http::config -zip] + http::config -zip 0 +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?transfer= \ + -protocol 1.1 -keepalive 1 -timeout 10000] + http::wait $tok + set res1 [list [http::status $tok] [http::code $tok] [check_crc $tok] \ + [meta $tok connection] [meta $tok transfer-encoding] [state $tok reusing] [state $tok connection]] + set toj [http::geturl http://localhost:$httpd_port/testdoc.html?transfer= \ + -protocol 1.1 -keepalive 1 -timeout 10000] + http::wait $toj + set res2 [list [http::status $toj] [http::code $toj] [check_crc $toj] \ + [meta $toj connection] [meta $toj transfer-encoding] [state $toj reusing] [state $toj connection]] + concat $res1 -- $res2 +} -cleanup { + http::cleanup $tok + http::cleanup $toj + halt_httpd + http::config -zip $zipTmp +} -result {ok {HTTP/1.1 200 OK} ok {} {} 0 keep-alive -- ok {HTTP/1.1 200 OK} ok {} {} 1 keep-alive} + # ------------------------------------------------------------------------- +proc progress {var token total current} { + upvar #0 $var log + set log [list $current $total] + return +} + +proc progressPause {var token total current} { + upvar #0 $var log + set log [list $current $total] + after 100 set ::WaitHere 0 + vwait ::WaitHere + return +} + test http11-2.0 "-channel" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] @@ -342,6 +392,58 @@ test http11-2.4 "-channel,encoding identity" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} chunked} +test http11-2.4.1 "-channel,encoding identity with -progress" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -timeout 5000 -channel $chan \ + -headers {accept-encoding identity} \ + -progress [namespace code [list progress logdata]]] + + http::wait $tok + seek $chan 0 + set data [read $chan] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $data]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd + unset -nocomplain logdata data +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} + +test http11-2.4.2 "-channel,encoding identity with -progress progressPause enters event loop" -constraints knownBug -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -timeout 5000 -channel $chan \ + -headers {accept-encoding identity} \ + -progress [namespace code [list progressPause logdata]]] + + http::wait $tok + seek $chan 0 + set data [read $chan] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $data]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd + unset -nocomplain logdata data ::WaitHere +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} + test http11-2.5 "-channel,encoding unsupported" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] @@ -447,7 +549,8 @@ test http11-2.10 "-channel,deflate,keepalive" -setup { set chan [open [makeFile {} testfile.tmp] wb+] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ - -timeout 5000 -channel $chan -keepalive 1] + -timeout 5000 -channel $chan -keepalive 1 \ + -headers {accept-encoding deflate}] http::wait $tok seek $chan 0 set data [read $chan] @@ -482,6 +585,27 @@ test http11-2.11 "-channel,identity,keepalive" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} {} chunked} +test http11-2.12 "-channel,negotiate,keepalive" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -timeout 5000 -channel $chan -keepalive 1] + http::wait $tok + seek $chan 0 + set data [read $chan] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] [meta $tok x-requested-encodings]\ + [expr {[file size testdoc.html]-[file size testfile.tmp]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok {} gzip chunked gzip,deflate,compress 0} + + # ------------------------------------------------------------------------- # # The following tests for the -handler option will require changes in @@ -496,10 +620,17 @@ proc handler {var sock token} { set chunk [read $sock] append data $chunk #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])" - if {[eof $sock]} { - #::http::Log "handler eof $sock" - chan event $sock readable {} - } + return [string length $chunk] +} + +proc handlerPause {var sock token} { + upvar #0 $var data + set chunk [read $sock] + append data $chunk + #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])" + after 100 set ::WaitHere 0 + vwait ::WaitHere + return [string length $chunk] } test http11-3.0 "-handler,close,identity" -setup { @@ -573,6 +704,135 @@ test http11-3.3 "-handler,keepalive,chunked" -setup { halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} +# http11-3.4 +# This test is a blatant attempt to confuse the client by instructing the server +# to send neither "Connection: close" nor "Content-Length" when in non-chunked +# mode. +# The client has no way to know the response-body is complete unless the +# server signals this by closing the connection. +# In an HTTP/1.1 response the absence of "Connection: close" means +# "Connection: keep-alive", i.e. the server will keep the connection +# open. In HTTP/1.0 this is not the case, and this is a test that +# the Tcl client assumes "Connection: close" by default in HTTP/1.0. +test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup { + variable httpd [create_httpd] + set testdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&nosendclose=any \ + -timeout 10000 -handler [namespace code [list handler testdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok {} {} {} 0} + +# It is not forbidden for a handler to enter the event loop. +test http11-3.5 "-handler,close,identity as http11-3.0 but handlerPause enters event loop" -setup { + variable httpd [create_httpd] + set testdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handlerPause testdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} + +test http11-3.6 "-handler,close,identity as http11-3.0 but with -progress" -setup { + variable httpd [create_httpd] + set testdata "" + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handler testdata]] \ + -progress [namespace code [list progress logdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} + +test http11-3.7 "-handler,close,identity as http11-3.0 but with -progress progressPause enters event loop" -setup { + variable httpd [create_httpd] + set testdata "" + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handler testdata]] \ + -progress [namespace code [list progressPause logdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} + +test http11-3.8 "close,identity no -handler but with -progress" -setup { + variable httpd [create_httpd] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 \ + -progress [namespace code [list progress logdata]] \ + -headers {accept-encoding {}}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length [http::data $tok]]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} + +test http11-3.9 "close,identity no -handler but with -progress progressPause enters event loop" -setup { + variable httpd [create_httpd] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 \ + -progress [namespace code [list progressPause logdata]] \ + -headers {accept-encoding {}}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length [http::data $tok]]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} + test http11-4.0 "normal post request" -setup { variable httpd [create_httpd] } -body { @@ -644,9 +904,16 @@ test http11-4.3 "normal post request, check channel query length" -setup { removeFile testfile.tmp halt_httpd } -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 122880} - + # ------------------------------------------------------------------------- +# Eliminate valgrind "still reachable" reports on outstanding "Detached" +# structures in the detached list which stem from PipeClose2Proc not waiting +# around for background processes to complete, meaning that previous calls to +# Tcl_ReapDetachedProcs might not have had a chance to reap all processes. +after 10 +exec [info nameofexecutable] << {} + foreach p {create_httpd httpd_read halt_httpd meta check_crc} { if {[llength [info proc $p]]} {rename $p {}} } diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test new file mode 100644 index 0000000..4306149 --- /dev/null +++ b/tests/httpPipeline.test @@ -0,0 +1,868 @@ +# httpPipeline.test +# +# Test HTTP/1.1 concurrent requests including +# queueing, pipelining and retries. +# +# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +package require http 2.9 + +set sourcedir [file normalize [file dirname [info script]]] +source [file join $sourcedir httpTest.tcl] +source [file join $sourcedir httpTestScript.tcl] + +# ------------------------------------------------------------------------------ +# (1) Define the test scripts that will be used to generate logs for analysis - +# and also define the "correct" results. +# ------------------------------------------------------------------------------ + +proc ReturnTestScriptAndResult {ca cb delay te} { + + switch -- $ca { + 1 {set start { + START + KEEPALIVE 0 + PIPELINE 0 + }} + + 2 {set start { + START + KEEPALIVE 0 + PIPELINE 1 + }} + + 3 {set start { + START + KEEPALIVE 1 + PIPELINE 0 + }} + + 4 {set start { + START + KEEPALIVE 1 + PIPELINE 1 + }} + + default { + return -code error {no matching script} + } + } + + set middle " + [list DELAY $delay] + " + + switch -- $cb { + 1 {set end { + GET a + GET b + GET c + GET a + STOP + } + set resShort {1 ? ? ?} + set resLong {1 2 3 4} + } + + 2 {set end { + GET a + HEAD b + GET c + HEAD a + HEAD c + STOP + } + set resShort {1 ? ? ? ?} + set resLong {1 2 3 4 5} + } + + 3 {set end { + HEAD a + GET b + HEAD c + HEAD b + GET a + GET b + STOP + } + set resShort {1 ? ? ? ? ?} + set resLong {1 2 3 4 5 6} + } + + 4 {set end { + GET a + GET b + GET c + GET a + POST b address=home code=brief paid=yes + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 ? ? ? 5 ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 5 {set end { + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + STOP + } + set resShort {1 2 3 4 5 6 7 8 9} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 6 {set end { + POST a address=home code=brief paid=yes + GET b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + GET a address=home code=brief paid=yes + GET b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + POST a address=home code=brief paid=yes + HEAD b address=home code=brief paid=yes + GET c address=home code=brief paid=yes + STOP + } + set resShort {1 ? 3 ? ? 6 7 ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 7 {set end { + GET b address=home code=brief paid=yes + POST a address=home code=brief paid=yes + GET a address=home code=brief paid=yes + POST c address=home code=brief paid=yes + GET b address=home code=brief paid=yes + HEAD b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + POST a address=home code=brief paid=yes + GET c address=home code=brief paid=yes + STOP + } + set resShort {1 2 ? 4 ? ? 7 8 ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 8 {set end { + # Telling the server to close the connection. + GET a + GET b close=y + GET c + GET a + GET b + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 ? 3 ? ? ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 9 {set end { + # Telling the server to close the connection. + GET a + POST b close=y address=home code=brief paid=yes + GET c + GET a + GET b + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 2 3 ? ? ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 10 {set end { + # Telling the server to close the connection. + GET a + GET b close=y + POST c address=home code=brief paid=yes + GET a + GET b + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 ? 3 ? ? ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 11 {set end { + # Telling the server to close the connection twice. + GET a + GET b close=y + GET c + GET a + GET b close=y + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 ? 3 ? ? 6 ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 12 {set end { + # Telling the server to delay before sending the response. + GET a + GET b delay=1 + GET c + GET a + GET b + STOP + } + set resShort {1 ? ? ? ?} + set resLong {1 2 3 4 5} + } + + 13 {set end { + # Making the server close the connection (time out). + GET a + WAIT 2000 + GET b + GET c + GET a + GET b + STOP + } + set resShort {1 2 ? ? ?} + set resLong {1 2 3 4 5} + } + + 14 {set end { + # Making the server close the connection (time out) twice. + GET a + WAIT 2000 + GET b + GET c + GET a + WAIT 2000 + GET b + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 2 ? ? 5 ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 15 {set end { + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes close=y delay=1 + POST c address=home code=brief paid=yes delay=1 + POST a address=home code=brief paid=yes close=y + WAIT 2000 + POST b address=home code=brief paid=yes delay=1 + POST c address=home code=brief paid=yes close=y + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes close=y + POST c address=home code=brief paid=yes + STOP + } + set resShort {1 2 3 4 5 6 7 8 9} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 16 {set end { + POST a address=home code=brief paid=yes + GET b address=home code=brief paid=yes + POST c address=home code=brief paid=yes close=y + GET a address=home code=brief paid=yes + GET b address=home code=brief paid=yes close=y + POST c address=home code=brief paid=yes + WAIT 2000 + POST a address=home code=brief paid=yes + HEAD b address=home code=brief paid=yes close=y + GET c address=home code=brief paid=yes + STOP + } + set resShort {1 ? 3 4 ? 6 7 ? 9} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 17 {set end { + GET b address=home code=brief paid=yes + POST a address=home code=brief paid=yes + GET a address=home code=brief paid=yes + POST c address=home code=brief paid=yes close=y + GET b address=home code=brief paid=yes + HEAD b address=home code=brief paid=yes close=y + POST c address=home code=brief paid=yes + WAIT 2000 + POST a address=home code=brief paid=yes + WAIT 2000 + GET c address=home code=brief paid=yes + STOP + } + set resShort {1 2 3 4 5 ? 7 8 9} + set resLong {1 2 3 4 5 6 7 8 9} + } + + + 18 {set end { + REPOST 0 + GET a + WAIT 2000 + POST b address=home code=brief paid=yes + GET c + GET a + STOP + } + set resShort {1 2 ? ?} + set resLong {1 2 3 4} + # resShort is overwritten below for the case ($te == 1). + } + + + 19 {set end { + REPOST 0 + GET a + WAIT 2000 + GET b address=home code=brief paid=yes + GET c + GET a + STOP + } + set resShort {1 2 ? ?} + set resLong {1 2 3 4} + } + + + 20 {set end { + POSTFRESH 1 + GET a + WAIT 2000 + POST b address=home code=brief paid=yes + GET c + GET a + STOP + } + set resShort {1 3 ?} + set resLong {1 3 4} + } + + + 21 {set end { + POSTFRESH 1 + GET a + WAIT 2000 + GET b address=home code=brief paid=yes + GET c + GET a + STOP + } + set resShort {1 2 ? ?} + set resLong {1 2 3 4} + } + + 22 {set end { + GET a + WAIT 2000 + KEEPALIVE 0 + POST b address=home code=brief paid=yes + KEEPALIVE 1 + GET c + GET a + STOP + } + set resShort {1 3 ?} + set resLong {1 3 4} + } + + + 23 {set end { + GET a + WAIT 2000 + KEEPALIVE 0 + GET b address=home code=brief paid=yes + KEEPALIVE 1 + GET c + GET a + STOP + } + set resShort {1 3 ?} + set resLong {1 3 4} + } + + 24 {set end { + GET a + KEEPALIVE 0 + POST b address=home code=brief paid=yes + KEEPALIVE 1 + GET c + GET a + STOP + } + set resShort {1 ? ?} + set resLong {1 3 4} + } + + + 25 {set end { + GET a + KEEPALIVE 0 + GET b address=home code=brief paid=yes + KEEPALIVE 1 + GET c + GET a + STOP + } + set resShort {1 ? ?} + set resLong {1 3 4} + } + + default { + return -code error {no matching script} + } + } + + + if {$ca < 3} { + # Not Keep-Alive. + set result "Passed all sanity checks." + + } elseif {$ca == 3} { + # Keep-Alive, not pipelined. + set result {} + append result "Passed all sanity checks.\n" + append result "Have overlaps including response body:\n" + + } else { + # Keep-Alive, pipelined: ($ca == 4) + set result {} + append result "Passed all sanity checks.\n" + append result "Overlap-free without response body:\n" + append result "$resShort" + } + + # - The special case of test *.18*-testEof needs test results to be + # individually written. + # - These test -repost 0 when there is a POST to apply it to, and the server + # timeout has not been detected. + if {($cb == 18) && ($te == 1)} { + if {$ca < 3} { + # Not Keep-Alive. + set result "Passed all sanity checks." + + } elseif {$ca == 3 && $delay == 0} { + # Keep-Alive, not pipelined. + set result [MakeMessage { + |Problems with sanity checks: + |Wrong sequence for token ::http::2 - {A B C D X X X} + |- and error(s) X + |Wrong sequence for token ::http::3 - {A X X} + |- and error(s) X + |Wrong sequence for token ::http::4 - {A X X X} + |- and error(s) X + | + |Have overlaps including response body: + | + }] + + } elseif {$ca == 3} { + # Keep-Alive, not pipelined. + set result [MakeMessage { + |Problems with sanity checks: + |Wrong sequence for token ::http::2 - {A B C D X X X} + |- and error(s) X + | + |Have overlaps including response body: + | + }] + + } elseif {$delay == 0} { + # Keep-Alive, pipelined: ($ca == 4) + set result [MakeMessage { + |Problems with sanity checks: + |Wrong sequence for token ::http::2 - {A B C D X X X} + |- and error(s) X + |Wrong sequence for token ::http::3 - {A X X} + |- and error(s) X + |Wrong sequence for token ::http::4 - {A X X X} + |- and error(s) X + | + |Overlap-free without response body: + | + }] + + } else { + set result [MakeMessage { + |Problems with sanity checks: + |Wrong sequence for token ::http::2 - {A B C D X X X} + |- and error(s) X + | + |Overlap-free without response body: + | + }] + + } + } + + return [list "$start$middle$end" $result] +} + +# ------------------------------------------------------------------------------ +# Proc MakeMessage +# ------------------------------------------------------------------------------ +# WHD's one-line command to generate multi-line strings from readable code. +# +# Example: +# set blurb [MakeMessage { +# |This command allows multi-line strings to be created with readable +# |code, and without breaking the rules for indentation. +# | +# |The command shifts the entire block of text to the left, omitting +# |the pipe character and the spaces to its left. +# }] +# ------------------------------------------------------------------------------ + +proc MakeMessage {in} { + regsub -all -line {^\s*\|} [string trim $in] {} + # N.B. Implicit Return. +} + + +proc ReturnTestScript {ca cb delay te} { + lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result + return $script +} + +proc ReturnTestResult {ca cb delay te} { + lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result + return $result +} + + +# ------------------------------------------------------------------------------ +# (2) Command to run a test script and use httpTest to analyse the logs. +# ------------------------------------------------------------------------------ + +namespace import httpTestScript::runHttpTestScript +namespace import httpTestScript::cleanupHttpTestScript +namespace import httpTest::cleanupHttpTest +namespace import httpTest::logAnalyse +namespace import httpTest::setHttpTestOptions + +proc RunTest {header footer delay te} { + set num [runHttpTestScript [ReturnTestScript $header $footer $delay $te]] + set skipOverlaps 0 + set notPiped {} + set notIncluded {} + + # -------------------------------------------------------------------------- + # Custom code for specific tests + # -------------------------------------------------------------------------- + if {$header < 3} { + set skipOverlaps 1 + for {set i 1} {$i <= $num} {incr i} { + lappend notPiped $i + } + } elseif {$header > 2 && $footer == 18 && $te == 1} { + set skipOverlaps 1 + if {$delay == 0} { + # Transaction 1 is conventional. + # Check that transactions 2,3,4 are cancelled. + set notPiped {1} + set notIncluded $notPiped + } else { + # Transaction 1 is conventional. + # Check that transaction 2 is cancelled. + # The timing of transactions 3 and 4 is uncertain. + set notPiped {1 3 4} + set notIncluded $notPiped + } + } elseif {$footer in {20 22 23 24 25}} { + # Transaction 2 uses its own socket. + set notPiped 2 + set notIncluded $notPiped + } else { + } + # -------------------------------------------------------------------------- + # End of custom code for specific tests + # -------------------------------------------------------------------------- + + + set Results [logAnalyse $num $skipOverlaps $notIncluded $notPiped] + lassign $Results msg cleanE cleanF dirtyE dirtyF + if {$msg eq {}} { + set msg "Passed all sanity checks." + } else { + set msg "Problems with sanity checks:\n$msg" + } + + if 0 { + puts $msg + puts "Overlap-free including response body:\n$cleanF" + puts "Have overlaps including response body:\n$dirtyF" + puts "Overlap-free without response body:\n$cleanE" + puts "Have overlaps without response body:\n$dirtyE" + } + + if {$header < 3} { + # No ordering, just check that transactions all finish + set result $msg + } elseif {$header == 3} { + # Not pipelined - check overlaps with response body. + set result "$msg\nHave overlaps including response body:\n$dirtyF" + } else { + # Pipelined - check overlaps without response body. Check that the + # first request, the first requests after replay, and POSTs are clean. + set result "$msg\nOverlap-free without response body:\n$cleanE" + } + set ::nTokens $num + return $result +} + + +# ------------------------------------------------------------------------------ +# (3) VERBOSITY CONTROL +# ------------------------------------------------------------------------------ +# If tests fail, run an individual test with -verbose 1 or 2 for diagnosis. +# If still obscure, uncomment #Log and ##Log lines in the http package. +# ------------------------------------------------------------------------------ + +setHttpTestOptions -verbose 0 + +# ------------------------------------------------------------------------------ +# (4) Define the base URLs used for testing. Each must have a query string. +# ------------------------------------------------------------------------------ +# - A HTTP/1.1 server is required. It should be configured to provide +# persistent connections when requested to do so, and to close these +# connections if they are idle for one second. +# - The resource must be served with status 200 in response to a valid GET or +# POST. +# - The value of "page" is always specified in the query-string. Different +# resources for the three values of "page" allow testing of both chunked and +# unchunked transfer encoding. +# - The variables "close" and "delay" may be specified in the query-string (for +# a GET) or the request body (for a POST). +# - "delay" is a numerical value in seconds, and causes the server to delay +# the response, including headers. +# - "close", if it has the value "y", instructs the server to close the +# connection ater the current request. +# - Any other variables should be ignored. +# ------------------------------------------------------------------------------ + +namespace eval ::httpTestScript { + variable URL + array set URL { + a http://test-tcl-http.kerlin.org/index.html?page=privacy + b http://test-tcl-http.kerlin.org/index.html?page=conditions + c http://test-tcl-http.kerlin.org/index.html?page=welcome + } +} + + +# ------------------------------------------------------------------------------ +# (5) Define the tests +# ------------------------------------------------------------------------------ +# Constraints: +# - serverNeeded - the URLs defined at (4) must be available, and must have the +# properties specified there. +# - duplicate - the value of -pipeline does not matter if -keepalive 0 +# - timeout1s - tests that work correctly only if the server closes +# persistent connections after one second. +# +# Server timeout of persistent connections should be 1s. Delays of 2s are +# intended to cause timeout. +# Servers are usually configured to use a longer timeout: this will cause the +# tests to fail. The "2000" could be replaced with a larger number, but the +# tests will then be inconveniently slow. +# ------------------------------------------------------------------------------ + +#testConstraint serverNeeded 1 +#testConstraint timeout1s 1 +#testConstraint duplicate 1 + +# ------------------------------------------------------------------------------ +# Proc SetTestEof - to edit the command ::http::KeepSocket +# ------------------------------------------------------------------------------ +# The usual line in command ::http::KeepSocket is " set TEST_EOF 0". +# Whether the value set in the file is 0 or 1, change it here to the value +# specified by the argument. +# +# It is worth doing all tests for both values of the argument. +# +# test 0 - ::http::KeepSocket is unchanged, detects server eof where possible +# and closes the connection. +# test 1 - ::http::KeepSocket is edited, does not detect server eof, so the +# reaction to finding server eof can be tested without the difficulty +# of testing in the few milliseconds of an asynchronous close event. +# ------------------------------------------------------------------------------ + +proc SetTestEof {test} { + set body [info body ::http::KeepSocket] + set subs " set TEST_EOF $test" + set count [regsub -line -all -- {^\s*set TEST_EOF .*$} $body $subs newBody] + if {$count != 1} { + return -code error {proc ::http::KeepSocket has unexpected form} + } + proc ::http::KeepSocket {token} $newBody + return +} + +for {set header 1} {$header <= 4} {incr header} { + if {$header == 4} { + setHttpTestOptions -dotted 1 + set match glob + } else { + setHttpTestOptions -dotted 0 + set match exact + } + + if {$header == 2} { + set cons0 {serverNeeded duplicate} + } else { + set cons0 serverNeeded + } + + for {set footer 1} {$footer <= 25} {incr footer} { + foreach {delay label} { + 0 a + 1 b + 2 c + 3 d + 5 e + 8 f + 12 g + 100 h + 500 i + 2000 j + } { + foreach te {0 1} { + if {$te} { + set tag testEof + } else { + set tag normal + } + set suffix {} + set cons $cons0 + + # ------------------------------------------------------------------ + # Custom code for individual tests + # ------------------------------------------------------------------ + if {$footer in {18}} { + # Custom code: + if {($label eq "j") && ($te == 1)} { + continue + } + if {$te == 1} { + # The test (of REPOST 0) is useful if tag is "testEof" + # (server timeout without client reaction). The same test + # has a different result if tag is "normal". + + set suffix " - extra test for -repost 0 - ::http::2 must be" + append suffix " cancelled" + if {($delay == 0)} { + append suffix ", along with ::http::3 ::http::4 if" + append suffix " the test creates these before ::http::2" + append suffix " is cancelled" + } + } else { + } + } elseif {$footer in {19}} { + set suffix " - extra test for -repost 0" + } elseif {$footer in {20 21}} { + set suffix " - extra test for -postfresh 1" + if {($footer == 20)} { + append suffix " - ::http::2 uses a separate socket" + append suffix ", other requests use a persistent connection" + } + } elseif {$footer in {22 23 24 25}} { + append suffix " - ::http::2 uses a separate socket" + append suffix ", other requests use a persistent connection" + } else { + } + + if {($footer >= 13 && $footer <= 23)} { + # Test use WAIT and depend on server timeout before this time. + lappend cons timeout1s + } + # ------------------------------------------------------------------ + # End of custom code. + # ------------------------------------------------------------------ + + set name "pipeline test header $header footer $footer delay $delay $tag$suffix" + + + # Here's the test: + test httpPipeline-${header}.${footer}${label}-${tag} $name \ + -constraints $cons \ + -setup [string map [list TE $te] { + # Restore default values for tests: + http::config -pipeline 1 -postfresh 0 -repost 1 + http::init + set http::http(uid) 0 + SetTestEof {TE} + }] -body [list RunTest $header $footer $delay $te] -cleanup { + # Restore default values for tests: + http::config -pipeline 1 -postfresh 0 -repost 1 + cleanupHttpTestScript + SetTestEof 0 + cleanupHttpTest + after 2000 + # Wait for persistent sockets on the server to time out. + } -result [ReturnTestResult $header $footer $delay $te] -match $match + + + } + + } + } +} + +# ------------------------------------------------------------------------------ +# (*) Notes on tests *.18*-testEof, *.19*-testEof - these test -repost 0 +# ------------------------------------------------------------------------------ +# These tests are a bit awkward because the main test kit analyses whether all +# requests are satisfied, with retries if necessary, and it has result analysis +# for processing retry logs. +# - *.18*-testEof tests that certain requests are NOT satisfied, so the analysis +# is a one-off. +# - Tests *.18a-testEof depend on client/server timing - the test needs to call +# http::geturl for all requests before the POST (request 2) is cancelled. +# We test that requests 2, 3, 4 are all cancelled. +# - Other tests *.18*-testEof may not request 3 and 4 in time for the to be +# added to the write queue before request 2 is completed. We simply check that +# request 2 is cancelled. +# - The behaviour is different if all connections are allowed to time out +# (label "j"). This case is not needed to test -repost 0, and is omitted. +# - Tests *.18*-normal and *.19* are conventional (-repost 0 should have no +# effect). +# ------------------------------------------------------------------------------ + + +unset header footer delay label suffix match cons name te +namespace delete ::httpTest +namespace delete ::httpTestScript + +::tcltest::cleanupTests diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl new file mode 100644 index 0000000..8a96d95 --- /dev/null +++ b/tests/httpTest.tcl @@ -0,0 +1,509 @@ +# httpTest.tcl +# +# Test HTTP/1.1 concurrent requests including +# queueing, pipelining and retries. +# +# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ------------------------------------------------------------------------------ +# "Package" httpTest for analysis of Log output of http requests. +# ------------------------------------------------------------------------------ +# This is a specialised test kit for examining the presence, ordering, and +# overlap of multiple HTTP transactions over a persistent ("Keep-Alive") +# connection; and also for testing reconnection in accordance with RFC 7230 when +# the connection is lost. +# +# This kit is probably not useful for other purposes. It depends on the +# presence of specific Log commands in the http library, and it interprets the +# logs that these commands create. +# ------------------------------------------------------------------------------ + +package require http + +namespace eval ::http { + variable TestStartTimeInMs [clock milliseconds] +# catch {puts stdout "Start time (zero ms) is $TestStartTimeInMs"} +} + +namespace eval ::httpTest { + variable testResults {} + variable testOptions + array set testOptions { + -verbose 0 + -dotted 1 + } + # -verbose - 0 quiet 1 write to stdout 2 write more + # -dotted - (boolean) use dots for absences in lists of transactions +} + +proc httpTest::Puts {txt} { + variable testOptions + if {$testOptions(-verbose) > 0} { + puts stdout $txt + flush stdout + } + return +} + +# http::Log +# +# A special-purpose logger used for running tests. +# - Processes Log calls that have "^" in their arguments, and records them in +# variable ::httpTest::testResults. +# - Also writes them to stdout (using Puts) if ($testOptions(-verbose) > 0). +# - Also writes Log calls that do not have "^", if ($testOptions(-verbose) > 1). + +proc http::Log {args} { + variable TestStartTimeInMs + set time [expr {[clock milliseconds] - $TestStartTimeInMs}] + set txt [list $time {*}$args] + if {[string first ^ $txt] >= 0} { + ::httpTest::LogRecord $txt + ::httpTest::Puts $txt + } elseif {$::httpTest::testOptions(-verbose) > 1} { + ::httpTest::Puts $txt + } + return +} +# The http::Log routine above needs the variable ::httpTest::testOptions +# Set up to destroy it when that variable goes away. +trace add variable ::httpTest::testOptions unset {apply {args { + proc ::http::Log args {} +}}} + +# Called by http::Log (the "testing" version) to record logs for later analysis. + +proc httpTest::LogRecord {txt} { + variable testResults + + set pos [string first ^ $txt] + set len [string length $txt] + if {$pos > $len - 3} { + puts stdout "Logging Error: $txt" + puts stdout "Fix this call to Log in http-*.tm so it has ^ then\ + a letter then a numeral." + flush stdout + } elseif {$pos < 0} { + # Called by mistake. + } else { + set letter [string index $txt [incr pos]] + set number [string index $txt [incr pos]] + # Max 9 requests! + lappend testResults [list $letter $number] + } + + return +} + + +# ------------------------------------------------------------------------------ +# Commands for analysing the logs recorded when calling http::geturl. +# ------------------------------------------------------------------------------ + +# httpTest::TestOverlaps -- +# +# The main test for correct behaviour of pipelined and sequential +# (non-pipelined) transactions. Other tests should be run first to detect +# any inconsistencies in the data (e.g. absence of the elements that are +# examined here). +# +# Examine the sequence $someResults for each transaction from 1 to $n, +# ignoring any that are listed in $badTrans. +# Determine whether the elements "B" to $term for one transaction overlap +# elements "B" to $term for the previous and following transactions. +# +# Transactions in the list $badTrans are not included in "clean" or +# "dirty", but their possible overlap with other transactions is noted. +# Transactions in the list $notPiped are a subset of $badTrans, and +# their possible overlap with other transactions is NOT noted. +# +# Arguments: +# someResults - list of results, each of the form {letter numeral} +# n - number of HTTP transactions +# term - letter that indicated end of search range. "E" for testing +# overlaps from start of request to end of response headers. +# "F" to extend to the end of the response body. +# msg - the cumulative message from sanity checks. Append to it only +# to report a test failure. +# badTrans - list of transaction numbers not to be assessed as "clean" or +# "dirty" +# notPiped - subset of badTrans. List of transaction numbers that cannot +# taint another transaction by overlapping with it, because it +# used a different socket. +# +# Return value: [list $msg $clean $dirty] +# msg - warning messages: nothing will be appended to argument $msg if there +# is an error with the test. +# clean - list of transactions that have no overlap with other transactions +# dirty - list of transactions that have YES overlap with other transactions + +proc httpTest::TestOverlaps {someResults n term msg badTrans notPiped} { + variable testOptions + + # Check whether transactions overlap: + set clean {} + set dirty {} + for {set i 1} {$i <= $n} {incr i} { + if {$i in $badTrans} { + continue + } + set myStart [lsearch -exact $someResults [list B $i]] + set myEnd [lsearch -exact $someResults [list $term $i]] + + if {($myStart < 0 || $myEnd < 0)} { + set res "Cannot find positions of transaction $i" + append msg $res \n + Puts $res + } + + set overlaps {} + for {set j $myStart} {$j <= $myEnd} {incr j} { + lassign [lindex $someResults $j] letter number + if {$number != $i && $letter ne "A" && $number ni $notPiped} { + lappend overlaps $number + } + } + + if {[llength $overlaps] == 0} { + set res "Transaction $i has no overlaps" + Puts $res + lappend clean $i + if {$testOptions(-dotted)} { + # N.B. results from different segments are concatenated. + lappend dirty . + } else { + } + } else { + set res "Transaction $i overlaps with [join $overlaps { }]" + Puts $res + lappend dirty $i + if {$testOptions(-dotted)} { + # N.B. results from different segments are concatenated. + lappend clean . + } else { + } + } + } + return [list $msg $clean $dirty] +} + +# httpTest::PipelineNext -- +# +# Test whether prevPair, pair are valid as consecutive elements of a pipelined +# sequence (Start 1), (End 1), (Start 2), (End 2) ... +# Numbers are integers increasing (by 1 if argument "any" is false), and need +# not begin with 1. +# The first element of the sequence has prevPair {} and is always passed as +# valid. +# +# Arguments; +# Start - string that labels the start of a segment +# End - string that labels the end of a segment +# prevPair - previous "pair" (list of string and number) element of a +# sequence, or {} if argument "pair" is the first in the +# sequence. +# pair - current "pair" (list of string and number) element of a +# sequence +# any - (boolean) iff true, accept any increasing sequence of integers. +# If false, integers must increase by 1. +# +# Return value - boolean, true iff the two pairs are valid consecutive elements. + +proc httpTest::PipelineNext {Start End prevPair pair any} { + if {$prevPair eq {}} { + return 1 + } + + lassign $prevPair letter number + lassign $pair newLetter newNumber + if {$letter eq $Start} { + return [expr {($newLetter eq $End) && ($newNumber == $number)}] + } elseif {$any} { + set nxt [list $Start [expr {$number + 1}]] + return [expr {($newLetter eq $Start) && ($newNumber > $number)}] + } else { + set nxt [list $Start [expr {$number + 1}]] + return [expr {($newLetter eq $Start) && ($newNumber == $number + 1)}] + } +} + +# httpTest::TestPipeline -- +# +# Given a sequence of "pair" elements, check that the elements whose string is +# $Start or $End form a valid pipeline. Ignore other elements. +# +# Return value: {} if valid pipeline, otherwise a non-empty error message. + +proc httpTest::TestPipeline {someResults n Start End msg desc badTrans} { + set sequence {} + set prevPair {} + set ok 1 + set any [llength $badTrans] + foreach pair $someResults { + lassign $pair letter number + if {($letter in [list $Start $End]) && ($number ni $badTrans)} { + lappend sequence $pair + if {![PipelineNext $Start $End $prevPair $pair $any]} { + set ok 0 + break + } + set prevPair $pair + } + } + + if {!$ok} { + set res "$desc are not pipelined: {$sequence}" + append msg $res \n + Puts $res + } + return $msg +} + +# httpTest::TestSequence -- +# +# Examine each transaction from 1 to $n, ignoring any that are listed +# in $badTrans. +# Check that each transaction has elements A to F, in alphabetical order. + +proc httpTest::TestSequence {someResults n msg badTrans} { + variable testOptions + + for {set i 1} {$i <= $n} {incr i} { + if {$i in $badTrans} { + continue + } + set sequence {} + foreach pair $someResults { + lassign $pair letter number + if {$number == $i} { + lappend sequence $letter + } + } + if {$sequence eq {A B C D E F}} { + } else { + set res "Wrong sequence for token ::http::$i - {$sequence}" + append msg $res \n + Puts $res + if {"X" in $sequence} { + set res "- and error(s) X" + append msg $res \n + Puts $res + } + if {"Y" in $sequence} { + set res "- and warnings(s) Y" + append msg $res \n + Puts $res + } + } + } + return $msg +} + +# +# Arguments: +# someResults - list of elements, each a list of a letter and a number +# n - (positive integer) the number of HTTP requests +# msg - accumulated warning messages +# skipOverlaps - (boolean) whether to skip testing of transaction overlaps +# badTrans - list of transaction numbers not to be assessed as "clean" or +# "dirty" by their overlaps +# for 1/2 includes all transactions +# for 3/4 includes an increasing (with recursion) set that will not be included in the list because they are already handled. +# notPiped - subset of badTrans. List of transaction numbers that cannot +# taint another transaction by overlapping with it, because it +# used a different socket. +# +# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF] +# msg - warning messages: nothing will be appended to argument $msg if there +# is no error with the test. +# cleanE - list of transactions that have no overlap with other transactions +# (not considering response body) +# dirtyE - list of transactions that have YES overlap with other transactions +# (not considering response body) +# cleanF - list of transactions that have no overlap with other transactions +# (including response body) +# dirtyF - list of transactions that have YES overlap with other transactions +# (including response body) + +proc httpTest::MostAnalysis {someResults n msg skipOverlaps badTrans notPiped} { + variable testOptions + + # Check that stages for "good" transactions are all present and correct: + set msg [TestSequence $someResults $n $msg $badTrans] + + # Check that requests are pipelined: + set msg [TestPipeline $someResults $n B C $msg Requests $notPiped] + + # Check that responses are pipelined: + set msg [TestPipeline $someResults $n D F $msg Responses $notPiped] + + if {$skipOverlaps} { + set cleanE {} + set dirtyE {} + set cleanF {} + set dirtyF {} + } else { + Puts "Overlaps including response body (test for non-pipelined case)" + lassign [TestOverlaps $someResults $n F $msg $badTrans $notPiped] msg cleanF dirtyF + + Puts "Overlaps without response body (test for pipelined case)" + lassign [TestOverlaps $someResults $n E $msg $badTrans $notPiped] msg cleanE dirtyE + } + + return [list $msg $cleanE $cleanF $dirtyE $dirtyF] +} + +# httpTest::ProcessRetries -- +# +# Command to examine results for socket-changing records [PQR], +# divide the results into segments for each connection, and analyse each segment +# individually. +# (Could add $sock to the logging to simplify this, but never mind.) +# +# In each segment, identify any transactions that are not included, and +# any that are aborted, to assist subsequent testing. +# +# Prepend A records (socket-independent) to each segment for transactions that +# were scheduled (by A) but not completed (by F). Pass each segment to +# MostAnalysis for processing. + +proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} { + variable testOptions + + set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}] + if {$nextRetry < 0} { + return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped] + } + set badTrans $notIncluded + set tryCount 0 + set try $nextRetry + incr tryCount + lassign [lindex $someResults $try] letter number + Puts "Processing retry [lindex $someResults $try]" + set beforeTry [lrange $someResults 0 $try-1] + Puts [join $beforeTry \n] + set afterTry [lrange $someResults $try+1 end] + + set dummyTry {} + for {set i 1} {$i <= $n} {incr i} { + set first [lsearch -exact $beforeTry [list A $i]] + set last [lsearch -exact $beforeTry [list F $i]] + if {$first < 0} { + set res "Transaction $i was not started in connection number $tryCount" + # So lappend it to badTrans and don't include it in the call below of MostAnalysis. + # append msg $res \n + Puts $res + if {$i ni $badTrans} { + lappend badTrans $i + } else { + } + } elseif {$last < 0} { + set res "Transaction $i was started but unfinished in connection number $tryCount" + # So lappend it to badTrans and don't include it in the call below of MostAnalysis. + # append msg $res \n + Puts $res + lappend badTrans $i + lappend dummyTry [list A $i] + } else { + set res "Transaction $i was started and finished in connection number $tryCount" + # So include it in the call below of MostAnalysis. + # So lappend it to notIncluded and don't include it in the recursive call of + # ProcessRetries which handles the later connections. + # append msg $res \n + Puts $res + lappend notIncluded $i + } + } + + # Analyse the part of the results before the first replay: + set HeadResults [MostAnalysis $beforeTry $n $msg $skipOverlaps $badTrans $notPiped] + lassign $HeadResults msg cleanE1 cleanF1 dirtyE1 dirtyF1 + + # Pass the rest of the results to be processed recursively. + set afterTry [concat $dummyTry $afterTry] + set TailResults [ProcessRetries $afterTry $n $msg $skipOverlaps $notIncluded $notPiped] + lassign $TailResults msg cleanE2 cleanF2 dirtyE2 dirtyF2 + + set cleanE [concat $cleanE1 $cleanE2] + set cleanF [concat $cleanF1 $cleanF2] + set dirtyE [concat $dirtyE1 $dirtyE2] + set dirtyF [concat $dirtyF1 $dirtyF2] + return [list $msg $cleanE $cleanF $dirtyE $dirtyF] +} + +# httpTest::logAnalyse -- +# +# The main command called to analyse logs for a single test. +# +# Arguments: +# n - (positive integer) the number of HTTP requests +# skipOverlaps - (boolean) whether to skip testing of transaction overlaps +# notIncluded - list of transaction numbers not to be assessed as "clean" or +# "dirty" by their overlaps +# notPiped - subset of notIncluded. List of transaction numbers that cannot +# taint another transaction by overlapping with it, because it +# used a different socket. +# +# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF] +# msg - warning messages: {} if there is no error with the test. +# cleanE - list of transactions that have no overlap with other transactions +# (not considering response body) +# dirtyE - list of transactions that have YES overlap with other transactions +# (not considering response body) +# cleanF - list of transactions that have no overlap with other transactions +# (including response body) +# dirtyF - list of transactions that have YES overlap with other transactions +# (including response body) + +proc httpTest::logAnalyse {n skipOverlaps notIncluded notPiped} { + variable testResults + variable testOptions + + # Check that each data item has the correct form {letter numeral}. + set ii 0 + set ok 1 + foreach pair $testResults { + lassign $pair letter number + if { [string match {[A-Z]} $letter] + && [string match {[0-9]} $number] + } { + # OK + } else { + set ok 0 + set res "Error: testResults has bad element {$pair} at position $ii" + append msg $res \n + Puts $res + } + incr ii + } + + if {!$ok} { + return $msg + } + set msg {} + + Puts [join $testResults \n] + ProcessRetries $testResults $n $msg $skipOverlaps $notIncluded $notPiped + # N.B. Implicit Return. +} + +proc httpTest::cleanupHttpTest {} { + variable testResults + set testResults {} + return +} + +proc httpTest::setHttpTestOptions {key args} { + variable testOptions + if {$key ni {-dotted -verbose}} { + return -code error {valid options are -dotted, -verbose} + } + set testOptions($key) {*}$args +} + +namespace eval httpTest { + namespace export cleanupHttpTest logAnalyse setHttpTestOptions +} diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl new file mode 100644 index 0000000..a40449a --- /dev/null +++ b/tests/httpTestScript.tcl @@ -0,0 +1,509 @@ +# httpTestScript.tcl +# +# Test HTTP/1.1 concurrent requests including +# queueing, pipelining and retries. +# +# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ------------------------------------------------------------------------------ +# "Package" httpTestScript for executing test scripts written in a convenient +# shorthand. +# ------------------------------------------------------------------------------ + +# ------------------------------------------------------------------------------ +# Documentation for "package" httpTestScript. +# ------------------------------------------------------------------------------ +# To use the package: +# (a) define URLs as the values of elements in the array ::httpTestScript +# (b) define a script in terms of the commands +# START STOP DELAY KEEPALIVE WAIT PIPELINE GET HEAD POST +# referring to URLs by the name of the corresponding array element. The +# script can include any other Tcl commands, and evaluates in the +# httpTestScript namespace. +# (c) Use the command httpTestScript::runHttpTestScript to evaluate the script. +# (d) For tcltest tests, wrap the runHttpTestScript call in a suitable "test" +# command. +# ------------------------------------------------------------------------------ +# START +# Must be the first command of the script. +# +# STOP +# Must be present in the script to avoid waiting for client timeout. +# Usually the last command, but can be elsewhere to end a script prematurely. +# Subsequent httpTestScript commands will have no effect. +# +# DELAY ms +# If there are no WAIT commands, this sets the delay in ms between subsequent +# calls to http::geturl. Default 500ms. +# +# KEEPALIVE +# Set the value passed to http::geturl for the -keepalive option. The command +# applies to subsequent requests in the script. Default 1. +# +# WAIT ms +# Pause for a time in ms before sending subsequent requests. +# +# PIPELINE boolean +# Set the value of -pipeline using http::config. The last PIPELINE command +# in the script applies to every request. Default 1. +# +# POSTFRESH boolean +# Set the value of -postfresh using http::config. The last POSTFRESH command +# in the script applies to every request. Default 0. +# +# REPOST boolean +# Set the value of -repost using http::config. The last REPOST command +# in the script applies to every request. Default 1 for httpTestScript. +# (Default value in http is 0). +# +# GET uriCode ?arg ...? +# Send a HTTP request using the GET method. +# Arguments: +# uriCode - the code for the base URI - the value must be stored in +# ::httpTestScript::URL($uriCode). +# args - strings that will be joined by "&" and appended to the query +# string with a preceding "&". +# +# HEAD uriCode ?arg ...? +# Send a HTTP request using the HEAD method. +# Arguments: as for GET +# +# POST uriCode ?arg ...? +# Send a HTTP request using the POST method. +# Arguments: +# uriCode - the code for the base URI - the value must be stored in +# ::httpTestScript::URL($uriCode). +# args - strings that will be joined by "&" and used as the request body. +# ------------------------------------------------------------------------------ + +namespace eval ::httpTestScript { + namespace export runHttpTestScript cleanupHttpTestScript +} + +# httpTestScript::START -- +# Initialise, and create a long-stop timeout. + +proc httpTestScript::START {} { + variable CountRequestedSoFar + variable RequestsWhenStopped + variable KeepAlive + variable Delay + variable TimeOutCode + variable TimeOutDone + variable StartDone + variable StopDone + variable CountFinishedSoFar + variable RequestList + variable RequestsMade + variable ExtraTime + variable ActualKeepAlive + + if {[info exists StartDone] && ($StartDone == 1)} { + set msg {START has been called twice without an intervening STOP} + return -code error $msg + } + + set StartDone 1 + set StopDone 0 + set TimeOutDone 0 + set CountFinishedSoFar 0 + set CountRequestedSoFar 0 + set RequestList {} + set RequestsMade {} + set ExtraTime 0 + set ActualKeepAlive 1 + + # Undefined until a STOP command: + unset -nocomplain RequestsWhenStopped + + # Default values: + set KeepAlive 1 + set Delay 500 + + # Default values for tests: + KEEPALIVE 1 + PIPELINE 1 + POSTFRESH 0 + REPOST 1 + + set TimeOutCode [after 30000 httpTestScript::TimeOutNow] +# set TimeOutCode [after 4000 httpTestScript::TimeOutNow] + return +} + +# httpTestScript::STOP -- +# Do not process any more commands. The commands will be executed but will +# silently do nothing. + +proc httpTestScript::STOP {} { + variable CountRequestedSoFar + variable CountFinishedSoFar + variable RequestsWhenStopped + variable TimeOutCode + variable StartDone + variable StopDone + variable RequestsMade + + if {$StopDone} { + # Don't do anything on a second call. + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + set StopDone 1 + set StartDone 0 + set RequestsWhenStopped $CountRequestedSoFar + unset -nocomplain StartDone + + if {$CountFinishedSoFar == $RequestsWhenStopped} { + if {[info exists TimeOutCode]} { + after cancel $TimeOutCode + } + set ::httpTestScript::FOREVER 0 + } + return +} + +# httpTestScript::DELAY -- +# If there are no WAIT commands, this sets the delay in ms between subsequent +# calls to http::geturl. Default 500ms. + +proc httpTestScript::DELAY {t} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + variable Delay + + set Delay $t + return +} + +# httpTestScript::KEEPALIVE -- +# Set the value passed to http::geturl for the -keepalive option. Default 1. + +proc httpTestScript::KEEPALIVE {b} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + variable KeepAlive + set KeepAlive $b + return +} + +# httpTestScript::WAIT -- +# Pause for a time in ms before processing any more commands. + +proc httpTestScript::WAIT {t} { + variable StartDone + variable StopDone + variable ExtraTime + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + if {(![string is integer -strict $t]) || $t < 0} { + return -code error {argument to WAIT must be a non-negative integer} + } + + incr ExtraTime $t + + return +} + +# httpTestScript::PIPELINE -- +# Pass a value to http::config -pipeline. + +proc httpTestScript::PIPELINE {b} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + ::http::config -pipeline $b + ##::http::Log http(-pipeline) is now [::http::config -pipeline] + return +} + +# httpTestScript::POSTFRESH -- +# Pass a value to http::config -postfresh. + +proc httpTestScript::POSTFRESH {b} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + ::http::config -postfresh $b + ##::http::Log http(-postfresh) is now [::http::config -postfresh] + return +} + +# httpTestScript::REPOST -- +# Pass a value to http::config -repost. + +proc httpTestScript::REPOST {b} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + ::http::config -repost $b + ##::http::Log http(-repost) is now [::http::config -repost] + return +} + +# httpTestScript::GET -- +# Send a HTTP request using the GET method. +# Arguments: +# uriCode - the code for the base URI - the value must be stored in +# ::httpTestScript::URL($uriCode). +# args - strings that will each be preceded by "&" and appended to the query +# string. + +proc httpTestScript::GET {uriCode args} { + variable RequestList + lappend RequestList GET + RequestAfter $uriCode 0 {} {*}$args + return +} + +# httpTestScript::HEAD -- +# Send a HTTP request using the HEAD method. +# Arguments: as for GET + +proc httpTestScript::HEAD {uriCode args} { + variable RequestList + lappend RequestList HEAD + RequestAfter $uriCode 1 {} {*}$args + return +} + +# httpTestScript::POST -- +# Send a HTTP request using the POST method. +# Arguments: +# uriCode - the code for the base URI - the value must be stored in +# ::httpTestScript::URL($uriCode). +# args - strings that will be joined by "&" and used as the request body. + +proc httpTestScript::POST {uriCode args} { + variable RequestList + lappend RequestList POST + RequestAfter $uriCode 0 {use} {*}$args + return +} + + +proc httpTestScript::RequestAfter {uriCode validate query args} { + variable CountRequestedSoFar + variable Delay + variable ExtraTime + variable StartDone + variable StopDone + variable KeepAlive + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + incr CountRequestedSoFar + set idelay [expr {($CountRequestedSoFar - 1) * $Delay + 10 + $ExtraTime}] + + # Could pass values of -pipeline, -postfresh, -repost if it were + # useful to change these mid-script. + after $idelay [list httpTestScript::Requester $uriCode $KeepAlive $validate $query {*}$args] + return +} + +proc httpTestScript::Requester {uriCode keepAlive validate query args} { + variable URL + + ::http::config -accept {*/*} + + set absUrl $URL($uriCode) + if {$query eq {}} { + if {$args ne {}} { + append absUrl & [join $args &] + } + set queryArgs {} + } elseif {$validate} { + return -code error {cannot have both -validate (HEAD) and -query (POST)} + } else { + set queryArgs [list -query [join $args &]] + } + + if {[catch { + ::http::geturl $absUrl \ + -validate $validate \ + -timeout 10000 \ + {*}$queryArgs \ + -keepalive $keepAlive \ + -command ::httpTestScript::WhenFinished + } token]} { + set msg $token + catch {puts stdout "Error: $msg"} + return + } else { + # Request will begin. + } + + return + +} + +proc httpTestScript::TimeOutNow {} { + variable TimeOutDone + + set TimeOutDone 1 + set ::httpTestScript::FOREVER 0 + return +} + +proc httpTestScript::WhenFinished {hToken} { + variable CountFinishedSoFar + variable RequestsWhenStopped + variable TimeOutCode + variable StopDone + variable RequestList + variable RequestsMade + variable ActualKeepAlive + + upvar #0 $hToken state + + if {[catch { + if { [info exists state(transfer)] + && ($state(transfer) eq "chunked") + } { + set Trans chunked + } else { + set Trans unchunked + } + + if { [info exists ::httpTest::testOptions(-verbose)] + && ($::httpTest::testOptions(-verbose) > 0) + } { + puts "Token $hToken +Response $state(http) +Status $state(status) +Method $state(method) +Transfer $Trans +Size $state(currentsize) +URL $state(url) +" + } + + if {!$state(-keepalive)} { + set ActualKeepAlive 0 + } + + if {[info exists state(method)]} { + lappend RequestsMade $state(method) + } else { + lappend RequestsMade UNKNOWN + } + set tk [namespace tail $hToken] + + if { ($state(http) != {HTTP/1.1 200 OK}) + || ($state(status) != {ok}) + || (($state(currentsize) == 0) && ($state(method) ne "HEAD")) + } { + ::http::Log ^X$tk unexpected result Response $state(http) Status $state(status) Size $state(currentsize) - token $hToken + } + } err]} { + ::http::Log ^X$tk httpTestScript::WhenFinished failed with error status: $err - token $hToken + } + + incr CountFinishedSoFar + if {$StopDone && ($CountFinishedSoFar == $RequestsWhenStopped)} { + if {[info exists TimeOutCode]} { + after cancel $TimeOutCode + } + if {$RequestsMade ne $RequestList && $ActualKeepAlive} { + ::http::Log ^X$tk unexpected result - Script asked for "{$RequestList}" but got "{$RequestsMade}" - token $hToken + } + set ::httpTestScript::FOREVER 0 + } + + return +} + + +proc httpTestScript::runHttpTestScript {scr} { + variable TimeOutDone + variable RequestsWhenStopped + + after idle [list namespace eval ::httpTestScript $scr] + vwait ::httpTestScript::FOREVER + # N.B. does not automatically execute in this namespace, unlike some other events. + # Release when all requests have been served or have timed out. + + if {$TimeOutDone} { + return -code error {test script timed out} + } + + return $RequestsWhenStopped +} + + +proc httpTestScript::cleanupHttpTestScript {} { + variable TimeOutDone + variable RequestsWhenStopped + + if {![info exists RequestsWhenStopped]} { + return -code error {Cleanup Failed: RequestsWhenStopped is undefined} + } + + for {set i 1} {$i <= $RequestsWhenStopped} {incr i} { + http::cleanup ::http::$i + } + + return +} diff --git a/tests/httpcookie.test b/tests/httpcookie.test new file mode 100644 index 0000000..329330d --- /dev/null +++ b/tests/httpcookie.test @@ -0,0 +1,875 @@ +# Commands covered: http::cookiejar +# +# This file contains a collection of tests for the cookiejar package. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright © 2014 Donal K. Fellows. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands + +testConstraint notMacCI [expr {![info exists ::env(MAC_CI)]}] +testConstraint sqlite3 [expr {[testConstraint notMacCI] && ![catch { + package require sqlite3 +}]}] +testConstraint cookiejar [expr {[testConstraint sqlite3] && ![catch { + package require cookiejar +}]}] + +set COOKIEJAR_VERSION 0.2.0 +test http-cookiejar-1.1 "cookie storage: packaging" {cookiejar} { + package require cookiejar +} $COOKIEJAR_VERSION +test http-cookiejar-1.2 "cookie storage: packaging" {cookiejar} { + package require cookiejar + package require cookiejar +} $COOKIEJAR_VERSION + +test http-cookiejar-2.1 "cookie storage: basics" -constraints { + cookiejar +} -returnCodes error -body { + http::cookiejar +} -result {wrong # args: should be "http::cookiejar method ?arg ...?"} +test http-cookiejar-2.2 "cookie storage: basics" -constraints { + cookiejar +} -returnCodes error -body { + http::cookiejar ? +} -result {unknown method "?": must be configure, create, destroy or new} +test http-cookiejar-2.3 "cookie storage: basics" -constraints { + cookiejar +} -body { + http::cookiejar configure +} -result {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger} +test http-cookiejar-2.4 "cookie storage: basics" -constraints { + cookiejar +} -returnCodes error -body { + http::cookiejar configure a b c d e +} -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} +test http-cookiejar-2.5 "cookie storage: basics" -constraints { + cookiejar +} -returnCodes error -body { + http::cookiejar configure a +} -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} +test http-cookiejar-2.6 "cookie storage: basics" -constraints { + cookiejar +} -returnCodes error -body { + http::cookiejar configure -d +} -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} +test http-cookiejar-2.7 "cookie storage: basics" -setup { + set old [http::cookiejar configure -loglevel] +} -constraints {cookiejar} -body { + list [http::cookiejar configure -loglevel] \ + [http::cookiejar configure -loglevel debug] \ + [http::cookiejar configure -loglevel] \ + [http::cookiejar configure -loglevel error] \ + [http::cookiejar configure -loglevel] +} -cleanup { + http::cookiejar configure -loglevel $old +} -result {info debug debug error error} +test http-cookiejar-2.8 "cookie storage: basics" -setup { + set old [http::cookiejar configure -loglevel] +} -constraints {cookiejar} -body { + list [http::cookiejar configure -loglevel] \ + [http::cookiejar configure -loglevel d] \ + [http::cookiejar configure -loglevel i] \ + [http::cookiejar configure -loglevel w] \ + [http::cookiejar configure -loglevel e] +} -cleanup { + http::cookiejar configure -loglevel $old +} -result {info debug info warn error} +test http-cookiejar-2.9 "cookie storage: basics" -body { + http::cookiejar configure -off +} -constraints {cookiejar} -match glob -result * +test http-cookiejar-2.10 "cookie storage: basics" -setup { + set oldval [http::cookiejar configure -offline] +} -constraints {cookiejar} -body { + http::cookiejar configure -offline true +} -cleanup { + catch {http::cookiejar configure -offline $oldval} +} -result 1 +test http-cookiejar-2.11 "cookie storage: basics" -setup { + set oldval [http::cookiejar configure -offline] +} -constraints {cookiejar} -body { + http::cookiejar configure -offline nonbool +} -cleanup { + catch {http::cookiejar configure -offline $oldval} +} -returnCodes error -result {expected boolean value but got "nonbool"} +test http-cookiejar-2.12 "cookie storage: basics" -setup { + set oldval [http::cookiejar configure -purgeold] +} -constraints {cookiejar} -body { + http::cookiejar configure -purge nonint +} -cleanup { + catch {http::cookiejar configure -purgeold $oldval} +} -returnCodes error -result {expected positive integer but got "nonint"} +test http-cookiejar-2.13 "cookie storage: basics" -setup { + set oldval [http::cookiejar configure -domainrefresh] +} -constraints {cookiejar} -body { + http::cookiejar configure -domainref nonint +} -cleanup { + catch {http::cookiejar configure -domainrefresh $oldval} +} -returnCodes error -result {expected positive integer but got "nonint"} +test http-cookiejar-2.14 "cookie storage: basics" -setup { + set oldval [http::cookiejar configure -domainrefresh] +} -constraints {cookiejar} -body { + http::cookiejar configure -domainref -42 +} -cleanup { + catch {http::cookiejar configure -domainrefresh $oldval} +} -returnCodes error -result {expected positive integer but got "-42"} +test http-cookiejar-2.15 "cookie storage: basics" -setup { + set oldval [http::cookiejar configure -domainrefresh] + set result unset + set tracer [http::cookiejar create tracer] +} -constraints {cookiejar} -body { + oo::objdefine $tracer method PostponeRefresh {} { + set ::result set + next + } + http::cookiejar configure -domainref 12345 + return $result +} -cleanup { + $tracer destroy + catch {http::cookiejar configure -domainrefresh $oldval} +} -result set + +test http-cookiejar-3.1 "cookie storage: class" {cookiejar} { + info object isa object http::cookiejar +} 1 +test http-cookiejar-3.2 "cookie storage: class" {cookiejar} { + info object isa class http::cookiejar +} 1 +test http-cookiejar-3.3 "cookie storage: class" {cookiejar} { + lsort [info object methods http::cookiejar] +} {configure} +test http-cookiejar-3.4 "cookie storage: class" {cookiejar} { + lsort [info object methods http::cookiejar -all] +} {configure create destroy new} +test http-cookiejar-3.5 "cookie storage: class" -setup { + catch {rename ::cookiejar ""} +} -constraints {cookiejar} -body { + namespace eval :: {http::cookiejar create cookiejar} +} -cleanup { + catch {rename ::cookiejar ""} +} -result ::cookiejar +test http-cookiejar-3.6 "cookie storage: class" -setup { + catch {rename ::cookiejar ""} +} -constraints {cookiejar} -body { + list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \ + [::cookiejar destroy] [info commands ::cookiejar] +} -cleanup { + catch {rename ::cookiejar ""} +} -result {::cookiejar ::cookiejar {} {}} +test http-cookiejar-3.7 "cookie storage: class" -setup { + catch {rename ::cookiejar ""} +} -constraints {cookiejar} -body { + http::cookiejar create ::cookiejar foo bar +} -returnCodes error -cleanup { + catch {rename ::cookiejar ""} +} -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"} +test http-cookiejar-3.8 "cookie storage: class" -setup { + catch {rename ::cookiejar ""} + set f [makeFile "" cookiejar] + file delete $f +} -constraints {cookiejar} -body { + list [file exists $f] [http::cookiejar create ::cookiejar $f] \ + [file exists $f] +} -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result {0 ::cookiejar 1} +test http-cookiejar-3.9 "cookie storage: class" -setup { + catch {rename ::cookiejar ""} + set f [makeFile "bogus content for a database" cookiejar] +} -constraints {cookiejar} -body { + http::cookiejar create ::cookiejar $f +} -returnCodes error -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -match glob -result * +test http-cookiejar-3.10 "cookie storage: class" -setup { + catch {rename ::cookiejar ""} + set dir [makeDirectory cookiejar] +} -constraints {cookiejar} -body { + http::cookiejar create ::cookiejar $dir +} -returnCodes error -cleanup { + catch {rename ::cookiejar ""} + removeDirectory $dir +} -match glob -result * + +test http-cookiejar-4.1 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar method ?arg ...?"} +test http-cookiejar-4.2 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar ? +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup, policyAllow or storeCookie} +test http-cookiejar-4.3 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + lsort [info object methods cookiejar -all] +} -cleanup { + ::cookiejar destroy +} -result {destroy forceLoadDomainData getCookies lookup policyAllow storeCookie} +test http-cookiejar-4.4 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar getCookies +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar getCookies proto host path"} +test http-cookiejar-4.5 "cookie storage" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar getCookies http www.example.com / +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.6 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar storeCookie +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar storeCookie options"} +test http-cookiejar-4.7 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.8 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM sessionCookies} +} -cleanup { + ::cookiejar destroy +} -result 1 +test http-cookiejar-4.9 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM persistentCookies} +} -cleanup { + ::cookiejar destroy +} -result 0 +test http-cookiejar-4.10 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.11 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints {cookiejar} -body { + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM sessionCookies} +} -cleanup { + ::cookiejar destroy +} -result 0 +test http-cookiejar-4.12 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints {cookiejar} -body { + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM persistentCookies} +} -cleanup { + ::cookiejar destroy +} -result 1 +test http-cookiejar-4.13 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + lappend result [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo bar}} +test http-cookiejar-4.14 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo bar}} +test http-cookiejar-4.15 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo bar}} +test http-cookiejar-4.16 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo1 + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie [dict replace { + key foo2 + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [lsort -stride 2 [cookiejar getCookies http www.example.com /]] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo1 bar foo2 bar}} +test http-cookiejar-4.17 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar +} -constraints {cookiejar} -body { + cookiejar lookup a b c d +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar lookup ?host? ?key?"} +test http-cookiejar-4.18 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + lappend result [cookiejar lookup] + lappend result [cookiejar lookup www.example.com] + lappend result [catch {cookiejar lookup www.example.com foo} value] $value + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + lappend result [cookiejar lookup] + lappend result [cookiejar lookup www.example.com] + lappend result [cookiejar lookup www.example.com foo] +} -cleanup { + ::cookiejar destroy +} -result {{} {} 1 {no such key for that host} www.example.com foo bar} +test http-cookiejar-4.19 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key bar + value foo + secure 0 + domain www.example.org + origin www.example.org + path / + hostonly 1 + } + lappend result [lsort [cookiejar lookup]] + lappend result [cookiejar lookup www.example.com] + lappend result [cookiejar lookup www.example.com foo] + lappend result [cookiejar lookup www.example.org] + lappend result [cookiejar lookup www.example.org bar] +} -cleanup { + ::cookiejar destroy +} -result {{www.example.com www.example.org} foo bar bar foo} +test http-cookiejar-4.20 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo1 + value bar1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie [dict replace { + key foo2 + value bar2 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [cookiejar lookup] + lappend result [lsort [cookiejar lookup www.example.com]] + lappend result [cookiejar lookup www.example.com foo1] + lappend result [cookiejar lookup www.example.com foo2] +} -cleanup { + ::cookiejar destroy +} -result {www.example.com {foo1 foo2} bar1 bar2} +test http-cookiejar-4.21 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo1 + value bar1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo2 + value bar2 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + lappend result [cookiejar lookup] + lappend result [lsort [cookiejar lookup www.example.com]] + lappend result [cookiejar lookup www.example.com foo1] + lappend result [cookiejar lookup www.example.com foo2] +} -cleanup { + ::cookiejar destroy +} -result {www.example.com {foo1 foo2} bar1 bar2} +test http-cookiejar-4.22 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + cookiejar forceLoadDomainData x y z +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar forceLoadDomainData"} +test http-cookiejar-4.23 "cookie storage: instance" -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints {cookiejar} -body { + cookiejar forceLoadDomainData +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.23.a {cookie storage: instance} -setup { + set off [http::cookiejar configure -offline] +} -constraints {cookiejar} -body { + http::cookiejar configure -offline 1 + [http::cookiejar create ::cookiejar] destroy +} -cleanup { + catch {::cookiejar destroy} + http::cookiejar configure -offline $off +} -result {} +test http-cookiejar-4.23.b {cookie storage: instance} -setup { + set off [http::cookiejar configure -offline] +} -constraints {cookiejar} -body { + http::cookiejar configure -offline 0 + [http::cookiejar create ::cookiejar] destroy +} -cleanup { + catch {::cookiejar destroy} + http::cookiejar configure -offline $off +} -result {} + +test http-cookiejar-5.1 "cookie storage: constraints" -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain com + origin com + path / + hostonly 1 + } + cookiejar lookup +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-5.2 "cookie storage: constraints" -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain foo.example.com + origin bar.example.org + path / + hostonly 1 + } + cookiejar lookup +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-5.3 "cookie storage: constraints" -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo1 + value bar + secure 0 + domain com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo2 + value bar + secure 0 + domain example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar lookup +} -cleanup { + ::cookiejar destroy +} -result {example.com} +test http-cookiejar-5.4 "cookie storage: constraints" -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo + value bar1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo + value bar2 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 1 + } + lsort [cookiejar lookup] +} -cleanup { + ::cookiejar destroy +} -result {example.com www.example.com} +test http-cookiejar-5.5 "cookie storage: constraints" -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints {cookiejar} -body { + cookiejar storeCookie { + key foo1 + value 1 + secure 0 + domain com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo2 + value 2 + secure 0 + domain com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo3 + value 3 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo4 + value 4 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo5 + value 5 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo6 + value 6 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo7 + value 7 + secure 1 + domain www.example.com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo8 + value 8 + secure 1 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo9 + value 9 + secure 0 + domain sub.www.example.com + origin www.example.com + path / + hostonly 1 + } + list [cookiejar getCookies http www.example.com /] \ + [cookiejar getCookies http www2.example.com /] \ + [cookiejar getCookies https www.example.com /] \ + [cookiejar getCookies http sub.www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{foo3 3 foo6 6} {foo3 3} {foo3 3 foo6 6 foo8 8} {foo3 3 foo5 5}} + +test http-cookiejar-6.1 "cookie storage: expiry and lookup" -setup { + http::cookiejar create ::cookiejar + oo::objdefine cookiejar export PurgeCookies + set result {} + proc values cookies { + global result + lappend result [lsort [lmap {k v} $cookies {set v}]] + } +} -constraints {cookiejar} -body { + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value session + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie [dict replace { + key foo + value cookie + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+1}]] + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value session-global + secure 0 + domain example.com + origin www.example.com + path / + hostonly 0 + } + values [cookiejar getCookies http www.example.com /] + after 2500 + update + values [cookiejar getCookies http www.example.com /] + cookiejar PurgeCookies + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value go-away + secure 0 + domain example.com + origin www.example.com + path / + hostonly 0 + expires 0 + } + values [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}} + +test http-cookiejar-7.1 "cookie storage: persistence of persistent cookies" -setup { + catch {rename ::cookiejar ""} + set f [makeFile "" cookiejar] + file delete $f +} -constraints {cookiejar} -body { + http::cookiejar create ::cookiejar $f + ::cookiejar destroy + http::cookiejar create ::cookiejar $f +} -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result ::cookiejar +test http-cookiejar-7.2 "cookie storage: persistence of persistent cookies" -setup { + catch {rename ::cookiejar ""} + set f [makeFile "" cookiejar] + file delete $f + set result {} +} -constraints {cookiejar} -body { + http::cookiejar create ::cookiejar $f + cookiejar storeCookie [dict replace { + key foo + value cookie + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+1}]] + lappend result [::cookiejar getCookies http www.example.com /] + ::cookiejar destroy + http::cookiejar create ::cookiejar + lappend result [::cookiejar getCookies http www.example.com /] + ::cookiejar destroy + http::cookiejar create ::cookiejar $f + lappend result [::cookiejar getCookies http www.example.com /] +} -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result {{foo cookie} {} {foo cookie}} + +::tcltest::cleanupTests + +# Local variables: +# mode: tcl +# End: diff --git a/tests/httpd b/tests/httpd index f810797..43e9372 100644 --- a/tests/httpd +++ b/tests/httpd @@ -2,16 +2,26 @@ # # The httpd_ procedures implement a stub http server. # -# Copyright (c) 1997-1998 Sun Microsystems, Inc. -# Copyright (c) 1999-2000 Scriptics Corporation +# Copyright © 1997-1998 Sun Microsystems, Inc. +# Copyright © 1999-2000 Scriptics Corporation # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #set httpLog 1 +# Do not use [info hostname]. +# Name resolution is often a problem on OSX; not focus of HTTP package anyway. +# Also a problem on other platforms for http-4.14 (test with bad port number). +set HOST localhost + proc httpd_init {{port 8015}} { - socket -server httpdAccept $port + set s [socket -server httpdAccept $port] + # Save the actual port number in a global variable. + # This is important when we're called with port 0 + # for picking an unused port at random. + set ::port [lindex [chan configure $s -sockname] 2] + return $s } proc httpd_log {args} { global httpLog @@ -40,7 +50,7 @@ proc httpdAccept {newsock ipaddr port} { fconfigure $newsock -blocking 0 -translation {auto crlf} httpd_log $newsock Connect $ipaddr $port set data(ipaddr) $ipaddr - fileevent $newsock readable [list httpdRead $newsock] + after 50 [list fileevent $newsock readable [list httpdRead $newsock]] } # read data from a client request @@ -168,9 +178,13 @@ proc httpdRespond { sock } { switch -glob -- $data(url) { *binary* { - set html "$bindata[info hostname]:$port$data(url)" + set html "$bindata${::HOST}:$port$data(url)" set type application/octet-stream } + *xml* { + set html [encoding convertto utf-8 "<test>\u1234</test>"] + set type "application/xml;charset=UTF-8" + } *post* { set html "Got [string length $data(query)] bytes" set type text/plain @@ -205,7 +219,7 @@ proc httpdRespond { sock } { } # Catch errors from premature client closes - + catch { if {$data(proto) == "HEAD"} { puts $sock "HTTP/1.0 200 OK" diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index 9c543dc..c7dde43 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.6 +package require tcl proc ::tcl::dict::get? {dict key} { if {[dict exists $dict $key]} { @@ -44,7 +44,7 @@ proc get-chunks {data {compression gzip}} { deflate { set data [zlib deflate $data] } compress { set data [zlib compress $data] } } - + set data "" set chunker [make-chunk-generator $data 512] while {[string length [set chunk [$chunker]]]} { @@ -59,7 +59,7 @@ proc blow-chunks {data {ochan stdout} {compression gzip}} { deflate { set data [zlib deflate $data] } compress { set data [zlib compress $data] } } - + set chunker [make-chunk-generator $data 512] while {[string length [set chunk [$chunker]]]} { puts -nonewline $ochan $chunk @@ -156,28 +156,33 @@ proc Service {chan addr port} { set code "200 OK" set close [expr {[dict get? $meta connection] eq "close"}] } - + if {$protocol eq "HTTP/1.1"} { - if {[string match "*deflate*" [dict get? $meta accept-encoding]]} { - set encoding deflate - } elseif {[string match "*gzip*" [dict get? $meta accept-encoding]]} { - set encoding gzip - } elseif {[string match "*compress*" [dict get? $meta accept-encoding]]} { - set encoding compress - } + foreach enc [split [dict get? $meta accept-encoding] ,] { + set enc [string trim $enc] + if {$enc in {deflate gzip compress}} { + set encoding $enc + break + } + } set transfer chunked } else { set close 1 } - + + set nosendclose 0 foreach pair [split $query &] { if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""} switch -exact -- $key { + nosendclose {set nosendclose 1} close {set close 1 ; set transfer 0} transfer {set transfer $val} content-type {set type $val} } } + if {$protocol eq "HTTP/1.1"} { + set nosendclose 0 + } chan configure $chan -buffering line -encoding iso8859-1 -translation crlf Puts $chan "$protocol $code" @@ -186,11 +191,16 @@ proc Service {chan addr port} { if {$req eq "POST"} { Puts $chan [format "x-query-length: %d" [string length $query]] } - if {$close} { + if {$close && (!$nosendclose)} { Puts $chan "connection: close" } - if {$encoding eq "identity"} { + Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]" + if {$encoding eq "identity" && (!$nosendclose)} { Puts $chan "content-length: [string length $data]" + } elseif {$encoding eq "identity"} { + # This is a blatant attempt to confuse the client by sending neither + # "Connection: close" nor "Content-Length" when in non-chunked mode. + # See test http11-3.4. } else { Puts $chan "content-encoding: $encoding" } @@ -208,7 +218,7 @@ proc Service {chan addr port} { } else { puts -nonewline $chan $data } - + if {$close} { chan event $chan readable {} close $chan @@ -227,7 +237,7 @@ proc Accept {chan addr port} { } proc Control {chan} { - if {[gets $chan line] != -1} { + if {[gets $chan line] >= 0} { if {[string trim $line] eq "quit"} { set ::forever 1 } diff --git a/tests/httpold.test b/tests/httpold.test deleted file mode 100644 index aeba311..0000000 --- a/tests/httpold.test +++ /dev/null @@ -1,293 +0,0 @@ -# Commands covered: http_config, http_get, http_wait, http_reset -# -# This file contains a collection of tests for the http script library. -# Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -if {[catch {package require http 1.0}]} { - if {[info exists httpold]} { - catch {puts "Cannot load http 1.0 package"} - ::tcltest::cleanupTests - return - } else { - catch {puts "Running http 1.0 tests in slave interp"} - set interp [interp create httpold] - $interp eval [list set httpold "running"] - $interp eval [list set argv $argv] - $interp eval [list source [info script]] - interp delete $interp - ::tcltest::cleanupTests - return - } -} - -set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" -catch {unset data} - -## -## The httpd script implement a stub http server -## -source [file join [file dirname [info script]] httpd] - -set port 8010 -if [catch {httpd_init $port} listen] { - puts "Cannot start http server, http test skipped" - unset port - ::tcltest::cleanupTests - return -} - -test httpold-1.1 {http_config} { - http_config -} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}} - -test httpold-1.2 {http_config} { - http_config -proxyfilter -} httpProxyRequired - -test httpold-1.3 {http_config} { - catch {http_config -junk} -} 1 - -test httpold-1.4 {http_config} { - http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite" - set x [http_config] - http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \ - -useragent "Tcl http client package 1.0" - set x -} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}} - -test httpold-1.5 {http_config} { - catch {http_config -proxyhost {} -junk 8080} -} 1 - -test httpold-2.1 {http_reset} { - catch {http_reset http#1} -} 0 - -test httpold-3.1 {http_get} { - catch {http_get -bogus flag} -} 1 -test httpold-3.2 {http_get} { - catch {http_get http:junk} err - set err -} {Unsupported URL: http:junk} - -set url [info hostname]:$port -test httpold-3.3 {http_get} { - set token [http_get $url] - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET /</h2> -</body></html>" - -set tail /a/b/c -set url [info hostname]:$port/a/b/c -set binurl [info hostname]:$port/binary - -test httpold-3.4 {http_get} { - set token [http_get $url] - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -proc selfproxy {host} { - global port - return [list [info hostname] $port] -} -test httpold-3.5 {http_get} { - http_config -proxyfilter selfproxy - set token [http_get $url] - http_config -proxyfilter httpProxyRequired - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET http://$url</h2> -</body></html>" - -test httpold-3.6 {http_get} { - http_config -proxyfilter bogus - set token [http_get $url] - http_config -proxyfilter httpProxyRequired - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -test httpold-3.7 {http_get} { - set token [http_get $url -headers {Pragma no-cache}] - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -test httpold-3.8 {http_get} { - set token [http_get $url -query Name=Value&Foo=Bar] - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>POST $tail</h2> -<h2>Query</h2> -<dl> -<dt>Name<dd>Value -<dt>Foo<dd>Bar -</dl> -</body></html>" - -test httpold-3.9 {http_get} { - set token [http_get $url -validate 1] - http_code $token -} "HTTP/1.0 200 OK" - - -test httpold-4.1 {httpEvent} { - set token [http_get $url] - upvar #0 $token data - array set meta $data(meta) - expr ($data(totalsize) == $meta(Content-Length)) -} 1 - -test httpold-4.2 {httpEvent} { - set token [http_get $url] - upvar #0 $token data - array set meta $data(meta) - string compare $data(type) [string trim $meta(Content-Type)] -} 0 - -test httpold-4.3 {httpEvent} { - set token [http_get $url] - http_code $token -} {HTTP/1.0 200 Data follows} - -test httpold-4.4 {httpEvent} { - set testfile [makeFile "" testfile] - set out [open $testfile w] - set token [http_get $url -channel $out] - close $out - set in [open $testfile] - set x [read $in] - close $in - removeFile $testfile - set x -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -test httpold-4.5 {httpEvent} { - set testfile [makeFile "" testfile] - set out [open $testfile w] - set token [http_get $url -channel $out] - close $out - upvar #0 $token data - removeFile $testfile - expr $data(currentsize) == $data(totalsize) -} 1 - -test httpold-4.6 {httpEvent} { - set testfile [makeFile "" testfile] - set out [open $testfile w] - set token [http_get $binurl -channel $out] - close $out - set in [open $testfile] - fconfigure $in -translation binary - set x [read $in] - close $in - removeFile $testfile - set x -} "$bindata$binurl" - -proc myProgress {token total current} { - global progress httpLog - if {[info exists httpLog] && $httpLog} { - puts "progress $total $current" - } - set progress [list $total $current] -} -if 0 { - # This test hangs on Windows95 because the client never gets EOF - set httpLog 1 - test httpold-4.6 {httpEvent} { - set token [http_get $url -blocksize 50 -progress myProgress] - set progress - } {111 111} -} -test httpold-4.7 {httpEvent} { - set token [http_get $url -progress myProgress] - set progress -} {111 111} -test httpold-4.8 {httpEvent} { - set token [http_get $url] - http_status $token -} {ok} -test httpold-4.9 {httpEvent} { - set token [http_get $url -progress myProgress] - http_code $token -} {HTTP/1.0 200 Data follows} -test httpold-4.10 {httpEvent} { - set token [http_get $url -progress myProgress] - http_size $token -} {111} -test httpold-4.11 {httpEvent} { - set token [http_get $url -timeout 1 -command {#}] - http_reset $token - http_status $token -} {reset} -test httpold-4.12 {httpEvent} { - update - set x {} - after 500 {lappend x ok} - set token [http_get $url -timeout 1 -command {lappend x fail}] - vwait x - list [http_status $token] $x -} {timeout ok} - -test httpold-5.1 {http_formatQuery} { - http_formatQuery name1 value1 name2 "value two" -} {name1=value1&name2=value+two} - -test httpold-5.2 {http_formatQuery} { - http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 -} {name1=%7ebwelch&name2=%a1%a2%a2} - -test httpold-5.3 {http_formatQuery} { - http_formatQuery lines "line1\nline2\nline3" -} {lines=line1%0d%0aline2%0d%0aline3} - -test httpold-6.1 {httpProxyRequired} { - update - http_config -proxyhost [info hostname] -proxyport $port - set token [http_get $url] - http_wait $token - http_config -proxyhost {} -proxyport {} - upvar #0 $token data - set data(body) -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET http://$url</h2> -</body></html>" - -# cleanup -catch {unset url} -catch {unset port} -catch {unset data} -close $listen -::tcltest::cleanupTests -return diff --git a/tests/if-old.test b/tests/if-old.test index fbcf56c..378c8a6 100644 --- a/tests/if-old.test +++ b/tests/if-old.test @@ -6,15 +6,15 @@ # into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/if.test b/tests/if.test index 040364a..c5babdd 100644 --- a/tests/if.test +++ b/tests/if.test @@ -4,14 +4,14 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -142,7 +142,7 @@ test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 @@ -165,7 +165,7 @@ test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 @@ -239,7 +239,7 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 @@ -262,7 +262,7 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 @@ -287,7 +287,7 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 5 @@ -310,7 +310,7 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 6 @@ -389,7 +389,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 @@ -412,7 +412,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 @@ -437,7 +437,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 5 @@ -460,7 +460,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 6 @@ -485,7 +485,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 8 @@ -508,7 +508,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 9 @@ -713,7 +713,7 @@ test if-5.16 {if cmd with computed command names: test jumpFalse instruction rep set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 @@ -736,7 +736,7 @@ test if-5.16 {if cmd with computed command names: test jumpFalse instruction rep set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 @@ -816,7 +816,7 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 @@ -839,7 +839,7 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 @@ -864,7 +864,7 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 5 @@ -887,7 +887,7 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 6 @@ -975,7 +975,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 @@ -998,7 +998,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 @@ -1023,7 +1023,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 5 @@ -1046,7 +1046,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 6 @@ -1071,7 +1071,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 8 @@ -1094,7 +1094,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 9 diff --git a/tests/incr-old.test b/tests/incr-old.test index ed457cf..818bccc 100644 --- a/tests/incr-old.test +++ b/tests/incr-old.test @@ -6,15 +6,15 @@ # into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/incr.test b/tests/incr.test index 9243be0..04c3652 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -4,14 +4,14 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -494,6 +494,18 @@ test incr-2.31 {incr command (compiled): bad increment} { (reading increment) invoked from within "incr x 1a"}} +test incr-2.32 {incr command (compiled): bad pure list increment} { + list [catch {incr x [list 1 2]} msg] $msg $::errorInfo +} {1 {expected integer but got "1 2"} {expected integer but got "1 2" + (reading increment) + invoked from within +"incr x [list 1 2]"}} +test incr-2.33 {incr command (compiled): bad pure dict increment} { + list [catch {incr x [dict create 1 2]} msg] $msg $::errorInfo +} {1 {expected integer but got "1 2"} {expected integer but got "1 2" + (reading increment) + invoked from within +"incr x [dict create 1 2]"}} test incr-3.1 {increment by wide amount: bytecode route} { set x 0 diff --git a/tests/indexObj.test b/tests/indexObj.test index 646cb02..bd6a2c2 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -2,19 +2,19 @@ # tkIndexObj.c, which implement indexed table lookups. The tests here are # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testindexobj [llength [info commands testindexobj]] testConstraint testparseargs [llength [info commands testparseargs]] @@ -109,7 +109,7 @@ test indexObj-5.6 {Tcl_WrongNumArgs} testindexobj { } "wrong # args: should be \"mycmd foo\"" # Contrast this with test proc-3.6; they have to be like this because # of [Bug 1066837] so Itcl won't break. -test indexObj-5.7 {Tcl_WrongNumArgs} testindexobj { +test indexObj-5.7 {Tcl_WrongNumArgs} {testindexobj obsolete} { testwrongnumargs 2 "fee fi" "fo fum" foo bar } "wrong # args: should be \"fo fum foo fee fi\"" diff --git a/tests/info.test b/tests/info.test index 7dd63b7..7aaffc1 100644 --- a/tests/info.test +++ b/tests/info.test @@ -5,10 +5,10 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2006 ActiveState +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2006 ActiveState # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -16,12 +16,12 @@ # DO NOT DELETE THIS LINE if {{::tcltest} ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } - ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] +testConstraint zlib [llength [info commands zlib]] # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. @@ -33,7 +33,7 @@ namespace eval test_ns_info1 { proc p {x} {return "x=$x"} proc q {{y 27} {z {}}} {return "y=$y"} } - + test info-1.1 {info args option} { proc t1 {a bbb c} {return foo} info args t1 @@ -110,7 +110,7 @@ test info-2.6 {info body option, returning list bodies} { proc testinfocmdcount {} { set x [info cmdcount] set y 12345 - set z [info cm] + set z [info cmdc] expr {$z-$x} } test info-3.1 {info cmdcount compiled} { @@ -119,7 +119,7 @@ test info-3.1 {info cmdcount compiled} { test info-3.2 {info cmdcount evaled} -body { set x [info cmdcount] set y 12345 - set z [info cm] + set z [info cmdc] expr {$z-$x} } -cleanup {unset x y z} -result 4 test info-3.3 {info cmdcount evaled} -body [info body testinfocmdcount] -cleanup {unset x y z} -result 4 @@ -325,7 +325,7 @@ test info-9.2 {info level option} { } {1 {t1 146 testString}} test info-9.3 {info level option} { proc t1 {a b} { - t2 [expr $a*2] $b + t2 [expr {$a*2}] $b } proc t2 {x y} { list [info level] [info level 1] [info level 2] [info level -1] \ @@ -397,8 +397,8 @@ test info-10.3 {info library option} -body { set tcl_library $savedLibrary; unset savedLibrary test info-11.1 {info loaded option} -body { - info loaded a b -} -returnCodes error -result {wrong # args: should be "info loaded ?interp?"} + info loaded a b c +} -returnCodes error -result {wrong # args: should be "info loaded ?interp? ?packageName?"} test info-11.2 {info loaded option} -body { info loaded {}; info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} @@ -655,7 +655,7 @@ test info-19.6 {info vars: Bug 1072654} -setup { namespace delete x } -result {} -set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isqrt log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} +set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isfinite isinf isnan isnormal isqrt issubnormal isunordered log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} # Check whether the extra testing functions are defined... if {!([catch {expr T1()} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"}))} { set functions "T1 T2 T3 $functions" ;# A lazy way of prepending! @@ -678,45 +678,45 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp -} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c -} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l -} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s -} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### ## info frame + ## Helper # For the more complex results we cut the file name down to remove path # dependencies, and we use only part of the first line of the reported # command. The latter is required because otherwise the whole test case may # appear in some results, but the result is part of the testcase. An infinite # string would be required to describe that. The cutting-down breaks this. + proc reduce {frame} { - set pos [lsearch -exact $frame cmd] - incr pos - set cmd [lindex $frame $pos] + set cmd [dict get $frame cmd] if {[regexp \n $cmd]} { - set first [string range [lindex [split $cmd \n] 0] 0 end-4] - set frame [lreplace $frame $pos $pos $first] + dict set frame cmd \ + [string range [lindex [split $cmd \n] 0] 0 end-4] } - set pos [lsearch -exact $frame file] - if {$pos >=0} { - incr pos - set tail [file tail [lindex $frame $pos]] - set frame [lreplace $frame $pos $pos $tail] + if {[dict exists $frame file]} { + dict set frame file \ + [file tail [dict get $frame file]] } - set frame + return $frame } + proc subinterp {} { interp create sub ; interp debug sub -frame 1; interp eval sub [list proc reduce [info args reduce] [info body reduce]] } + ## Helper # Generate a stacktrace from the current location to top. This code # not only depends on the exact location of things, but also on the @@ -768,26 +768,26 @@ test info-22.8 {info frame, basic trace} -match glob -body { * {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} unset -nocomplain msg -test info-23.0.0 {eval'd info frame} {!singleTestInterp} { - eval {info frame} -} 8 -test info-23.0.1 {eval'd info frame} -constraints {singleTestInterp} -match glob -body { - eval {info frame} -} -result {1[12]} ;# SingleTestInterp results changes depending on running the whole suite, or info.test alone. -test info-23.1.0 {eval'd info frame, semi-dynamic} {!singleTestInterp} { - eval info frame -} 8 -test info-23.1.1 {eval'd info frame, semi-dynamic} -constraints {singleTestInterp} -match glob -body { - eval info frame -} -result {1[12]} -test info-23.2.0 {eval'd info frame, dynamic} -constraints {!singleTestInterp} -body { - set script {info frame} - eval $script -} -cleanup {unset script} -result 8 -test info-23.2.1 {eval'd info frame, dynamic} -constraints {singleTestInterp} -match glob -body { - set script {info frame} - eval $script -} -cleanup {unset script} -result {1[12]} + + + + + + + + + +## The line 1967 is off by 5 from the true value of 1972. This is a knownBug, see testcase 30.0 +test info-23.0 {eval'd info frame} -constraints {!singleTestInterp} -body { + list [i eval {info frame}] [i eval {eval {info frame}}] +} -setup {interp create i} -cleanup {interp delete i} -result {1 2} +test info-23.1 {eval'd info frame, semi-dynamic} -constraints {!singleTestInterp} -body { + i eval {eval info frame} +} -setup {interp create i} -cleanup {interp delete i} -result 2 +test info-23.2 {eval'd info frame, dynamic} -constraints {!singleTestInterp} -body { + i eval { set script {info frame} + eval $script} +} -setup {interp create i} -cleanup {interp delete i} -result 2 test info-23.3 {eval'd info frame, literal} -match glob -body { eval { info frame 0 @@ -1454,9 +1454,9 @@ test info-30.1 {bs+nl in literal words, procedure body, compiled} -body { test info-30.2 {bs+nl in literal words, namespace script} { namespace eval xxx { variable res \ - [reduce [info frame 0]];# line 1457 + [info frame 0];# line 1457 } - return $xxx::res + return [reduce $xxx::res] } {type source line 1457 file info.test cmd {info frame 0} level 0} test info-30.3 {bs+nl in literal words, namespace multi-word script} { @@ -1955,9 +1955,634 @@ test info-38.2 {location information for uplevel, dl, direct-literal} -match glo * {type source line 1951 file info.test cmd etrace level 1} * {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub} +# This test at the end of this file _only_ to avoid disturbing above line +# numbers. It _belongs_ after info-9.12 +test info-9.13 {info level option, value in global context} -body { + uplevel #0 {info level 2} +} -returnCodes error -result {bad level "2"} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + catch {*}{ + {info frame 0} + res + } + return $res +} +test info-33.4 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + dict for {a b} {c d} {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.5 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set d {a b} + dict update d x y {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.6 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1998 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set d {} + dict with d {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.7 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2013 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {set res [info frame 0]} + {1} {} {break} + } + return $res +} +test info-33.8 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2027 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} {1} {} + {set res [info frame 0]; break} + } + return $res +} +test info-33.9 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2043 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} {1} + {return [info frame 0]} + {} + } +} +test info-33.10 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2058 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} + {[return [info frame 0]]} + {} {} + } +} +test info-33.11 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2073 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + foreach {*}{ + x + } [return [info frame 0]] {} +} +test info-33.12 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2088 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + foreach {*}{ + x y + {set res [info frame 0]} + } + return $res +} +test info-33.13 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + if {*}{ + {[return [info frame 0]]} + {} + } +} +test info-33.14 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2115 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + if 0 {*}{ + {} else + {return [info frame 0]} + } +} +test info-33.15 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2130 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + incr {*}{ + x + } [return [info frame 0]] +} +test info-33.16 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2144 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + info level {*}{ + } [return [info frame 0]] +} +test info-33.17 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string match {*}{ + } [return [info frame 0]] {} +} +test info-33.18 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2168 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string match {*}{ + {} + } [return [info frame 0]] +} +test info-33.19 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2181 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string length {*}{ + } [return [info frame 0]] +} +test info-33.20 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2193 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + while {*}{ + {[return [info frame 0]]} + } {} +} +test info-33.21 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2205 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + switch -- {*}{ + } [return [info frame 0]] {*}{ + } x y +} +test info-33.22 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2218 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.23 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2231 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } finally {} + return $res +} +test info-33.24 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2245 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } on ok {} {} + return $res +} +test info-33.25 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2259 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } on ok {} {} finally {} + return $res +} +test info-33.26 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2273 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + while 1 {*}{ + {return [info frame 0]} + } +} +test info-33.27 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2287 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} finally {*}{ + {return [info frame 0]} + } +} +test info-33.28 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2300 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {} finally {*}{ + {return [info frame 0]} + } +} +test info-33.29 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2313 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {*}{ + {return [info frame 0]} + } +} +test info-33.30 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2326 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {*}{ + {return [info frame 0]} + } finally {} +} +test info-33.31 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + binary format {*}{ + } [return [info frame 0]] +} +test info-33.32 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2352 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set format format + binary $format {*}{ + } [return [info frame 0]] +} +test info-33.33 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + append x {*}{ + } [return [info frame 0]] +} +test info-33.34 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2377 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + append {*}{ + } x([return [info frame 0]]) {*}{ + } a +} +test info-33.35 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval ::testinfocmdtype { + apply {cmds { + foreach c $cmds {rename $c {}} + } ::testinfocmdtype} [info commands ::testinfocmdtype::*] +} +test info-40.1 {info cmdtype: syntax} -body { + info cmdtype +} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"} +test info-40.2 {info cmdtype: syntax} -body { + info cmdtype foo bar +} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"} +test info-40.3 {info cmdtype: no such command} -body { + info cmdtype ::testinfocmdtype::foo +} -returnCodes error -result {unknown command "::testinfocmdtype::foo"} +test info-40.4 {info cmdtype: native commands} -body { + info cmdtype ::if +} -result native +test info-40.5 {info cmdtype: native commands} -body { + info cmdtype ::puts +} -result native +test info-40.6 {info cmdtype: native commands} -body { + info cmdtype ::yield +} -result native +test info-40.7 {info cmdtype: procedures} -setup { + proc ::testinfocmdtype::someproc {} {} +} -body { + info cmdtype ::testinfocmdtype::someproc +} -cleanup { + rename ::testinfocmdtype::someproc {} +} -result proc +test info-40.8 {info cmdtype: aliases} -setup { + interp alias {} ::testinfocmdtype::somealias {} ::puts +} -body { + info cmdtype ::testinfocmdtype::somealias +} -cleanup { + rename ::testinfocmdtype::somealias {} +} -result alias +test info-40.9 {info cmdtype: imports} -setup { + namespace eval ::testinfocmdtype { + namespace eval foo { + proc bar {} {} + namespace export bar + } + namespace import foo::bar + } +} -body { + info cmdtype ::testinfocmdtype::bar +} -cleanup { + rename ::testinfocmdtype::bar {} + namespace delete ::testinfocmdtype::foo +} -result import +test info-40.10 {info cmdtype: interps} -setup { + apply {i { + rename $i ::testinfocmdtype::child + variable ::testinfocmdtype::child $i + }} [interp create] +} -body { + info cmdtype ::testinfocmdtype::child +} -cleanup { + interp delete $::testinfocmdtype::child +} -result interp +test info-40.11 {info cmdtype: objects} -setup { + apply {{} { + oo::object create obj + } ::testinfocmdtype} +} -body { + info cmdtype ::testinfocmdtype::obj +} -cleanup { + ::testinfocmdtype::obj destroy +} -result object +test info-40.12 {info cmdtype: objects} -setup { + apply {{} { + oo::object create obj + } ::testinfocmdtype} +} -body { + info cmdtype [info object namespace ::testinfocmdtype::obj]::my +} -cleanup { + ::testinfocmdtype::obj destroy +} -result privateObject +test info-40.13 {info cmdtype: ensembles} -setup { + namespace eval ::testinfocmdtype { + namespace eval ensmbl { + proc bar {} {} + namespace export * + namespace ensemble create + } + } +} -body { + info cmdtype ::testinfocmdtype::ensmbl +} -cleanup { + namespace delete ::testinfocmdtype::ensmbl +} -result ensemble +test info-40.14 {info cmdtype: zlib streams} -constraints zlib -setup { + namespace eval ::testinfocmdtype { + rename [zlib stream gzip] zstream + } +} -body { + info cmdtype ::testinfocmdtype::zstream +} -cleanup { + ::testinfocmdtype::zstream close +} -result zlibStream +test info-40.15 {info cmdtype: coroutines} -setup { + coroutine ::testinfocmdtype::coro eval yield +} -body { + info cmdtype ::testinfocmdtype::coro +} -cleanup { + ::testinfocmdtype::coro +} -result coroutine +test info-40.16 {info cmdtype: dynamic behavior} -setup { + proc ::testinfocmdtype::foo {} {} +} -body { + namespace eval ::testinfocmdtype { + list [catch {info cmdtype foo}] [catch {info cmdtype bar}] \ + [namespace which foo] [rename foo bar] [namespace which bar] \ + [catch {info cmdtype foo}] [catch {info cmdtype bar}] + } +} -cleanup { + namespace eval ::testinfocmdtype { + catch {rename foo {}} + catch {rename bar {}} + } +} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0} +test info-40.17 {info cmdtype: aliases in child interpreters} -setup { + set i [interp create] +} -body { + $i alias foo gorp + $i eval { + info cmdtype foo + } +} -cleanup { + interp delete $i +} -result alias +test info-40.18 {info cmdtype: aliases in child interpreters} -setup { + set safe [interp create -safe] +} -body { + $safe alias foo gorp + $safe eval { + info cmdtype foo + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {not allowed to invoke subcommand cmdtype of info} +test info-40.19 {info cmdtype: aliases in child interpreters} -setup { + set safe [interp create -safe] +} -body { + set inner [interp create [list $safe bar]] + interp alias $inner foo $safe gorp + $safe eval { + bar eval { + info cmdtype foo + } + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {not allowed to invoke subcommand cmdtype of info} +test info-40.20 {info cmdtype: aliases in child interpreters} -setup { + set safe [interp create -safe] +} -body { + $safe eval { + interp alias {} foo {} gorp + info cmdtype foo + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {not allowed to invoke subcommand cmdtype of info} +namespace delete ::testinfocmdtype + # ------------------------------------------------------------------------- unset -nocomplain res +test info-39.2 {Bug 4b61afd660} -setup { + proc probe {} { + return [dict get [info frame -1] line] + } + set body { + set cmd probe + $cmd + } + proc demo {} $body +} -body { + demo +} -cleanup { + unset -nocomplain body + rename demo {} + rename probe {} +} -result 3 + # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests diff --git a/tests/init.test b/tests/init.test index 41b8624..0074625 100644 --- a/tests/init.test +++ b/tests/init.test @@ -4,20 +4,33 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.3.4 + package require tcltest 2.5 namespace import -force ::tcltest::* } # Clear out any namespaces called test_ns_* catch {namespace delete {*}[namespace children :: test_ns_*]} +test init-0.1 {no error on initialization phase (init.tcl)} -setup { + interp create child +} -body { + child eval { + list [set v [info exists ::errorInfo]] \ + [if {$v} {set ::errorInfo}] \ + [set v [info exists ::errorCode]] \ + [if {$v} {set ::errorCode}] + } +} -cleanup { + interp delete child +} -result {0 {} 0 {}} + # Six cases - white box testing test init-1.1 {auto_qualify - absolute cmd - namespace} { @@ -28,7 +41,7 @@ test init-1.2 {auto_qualify - absolute cmd - global} { } global test init-1.3 {auto_qualify - no colons cmd - global} { auto_qualify nocolons :: -} nocolons +} nocolons test init-1.4 {auto_qualify - no colons cmd - namespace} { auto_qualify nocolons ::sub } {::sub::nocolons nocolons} @@ -46,11 +59,11 @@ test init-1.8 {auto_qualify - multiple colons 2} { auto_qualify :::foo ::bar } foo -# We use a sub-interp and auto_reset and double the tests because there is 2 +# We use a child interp and auto_reset and double the tests because there is 2 # places where auto_loading occur (before loading the indexes files and after) set testInterp [interp create] -tcltest::loadIntoSlaveInterpreter $testInterp {*}$argv +tcltest::loadIntoChildInterpreter $testInterp {*}$argv interp eval $testInterp { namespace import -force ::tcltest::* customMatch pairwise {apply {{mode pair} { @@ -93,11 +106,11 @@ test init-2.5 {load safe:::setLogCmd - stage 2} { auto_reset catch {rename ::safe::setLogCmd {}} test init-2.6 {load setLogCmd from safe:: - stage 1} { - namespace eval safe setLogCmd + namespace eval safe setLogCmd rename ::safe::setLogCmd {} ;# should not fail } {} test init-2.7 {oad setLogCmd from safe:: - stage 2} { - namespace eval safe setLogCmd + namespace eval safe setLogCmd rename ::safe::setLogCmd {} ;# should not fail } {} test init-2.8 {load tcl::HistAdd} -setup { @@ -132,12 +145,12 @@ foreach arg [subst -nocommands -novariables { and is long enough to be truncated and " <- includes a false lead in the prune point search and must be longer still to force truncation} - {contrived example: rare circumstance + {contrived example: rare circumstance where the point at which to prune the error stack cannot be uniquely determined. foo bar foo "} - {contrived example: rare circumstance + {contrived example: rare circumstance where the point at which to prune the error stack cannot be uniquely determined. foo bar @@ -168,6 +181,16 @@ foreach arg [subst -nocommands -novariables { incr count } +test init-4.$count {[Bug 46f801ed5a]} -setup { + auto_reset + array set auto_index {demo {proc demo {} {tailcall error foo}}} +} -body { + demo +} -cleanup { + array unset auto_index demo + rename demo {} +} -returnCodes error -result foo + test init-5.0 {return options passed through ::unknown} -setup { catch {rename xxx {}} set ::auto_index(::xxx) {proc ::xxx {} { diff --git a/tests/internals.tcl b/tests/internals.tcl new file mode 100644 index 0000000..ff6c42b --- /dev/null +++ b/tests/internals.tcl @@ -0,0 +1,96 @@ +# This file contains internal facilities for Tcl tests. +# +# Source this file in the related tests to include from tcl-tests: +# +# source [file join [file dirname [info script]] internals.tcl] +# +# Copyright © 2020 Sergey G. Brester (sebres). +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {[namespace which -command ::tcltest::internals::scriptpath] eq ""} {namespace eval ::tcltest::internals { + +namespace path ::tcltest + +::tcltest::ConstraintInitializer testWithLimit { expr {[testConstraint macOrUnix] && ![catch { exec prlimit --version }]} } + +# test-with-limit -- +# +# Usage: test-with-limit ?-addmem bytes? ?-maxmem bytes? command +# Options: +# -addmem - set additional memory limit (in bytes) as difference (extra memory needed to run a test) +# -maxmem - set absolute maximum address space limit (in bytes) +# +proc testWithLimit args { + set body [lindex $args end] + array set in [lrange $args 0 end-1] + # test in child process (with limits): + set pipe {} + if {[catch { + # start new process: + set pipe [open |[list [interpreter]] r+] + set ppid [pid $pipe] + # create prlimit args: + set args {} + # with limited address space: + if {[info exists in(-addmem)] || [info exists in(-maxmem)]} { + if {[info exists in(-addmem)]} { + # as differnce to normal usage, so try to retrieve current memory usage: + if {[catch { + # using ps (vsz is in KB): + incr in(-addmem) [expr {[lindex [exec ps -hq $ppid -o vsz] end] * 1024}] + }]} { + # ps failed, use default size 20MB: + incr in(-addmem) 20000000 + # + size of locale-archive (may be up to 100MB): + incr in(-addmem) [expr { + [file exists /usr/lib/locale/locale-archive] ? + [file size /usr/lib/locale/locale-archive] : 0 + }] + } + if {![info exists in(-maxmem)]} { + set in(-maxmem) $in(-addmem) + } + set in(-maxmem) [expr { max($in(-addmem), $in(-maxmem)) }] + } + append args --as=$in(-maxmem) + } + # apply limits: + exec prlimit -p $ppid {*}$args + } msg opt]} { + catch {close $pipe} + tcltest::Warn "testWithLimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]" + tcltest::Skip testWithLimit + } + # execute body, close process and return: + set ret [catch { + chan configure $pipe -buffering line + puts $pipe "puts \[$body\]" + puts $pipe exit + set result [read $pipe] + close $pipe + set pipe {} + set result + } result opt] + if {$pipe ne ""} { catch { close $pipe } } + if {$ret && [dict get $opt -errorcode] eq "BYPASS-SKIPPED-TEST"} { + return {*}$opt $result + } + if { ( [info exists in(-warn-on-code)] && $ret in $in(-warn-on-code) ) + || ( $ret && [info exists in(-warn-on-alloc-error)] && $in(-warn-on-alloc-error) + && [regexp {\munable to (?:re)?alloc\M} $result] ) + } { + tcltest::Warn "testWithLimit: wrong limit, result: $result" + tcltest::Skip testWithLimit + } + return {*}$opt $result +} + +# export all routines starting with test +namespace export test* + +# for script path & as mark for loaded +proc scriptpath {} [list return [info script]] + +}}; # end of internals.
\ No newline at end of file diff --git a/tests/interp.test b/tests/interp.test index 0af9887..c19755f 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -4,25 +4,25 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} +set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } @@ -32,7 +32,7 @@ test interp-1.1 {options for interp command} -returnCodes error -body { } -result {wrong # args: should be "interp cmd ?arg ...?"} test interp-1.2 {options for interp command} -returnCodes error -body { interp frobox -} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} test interp-1.3 {options for interp command} { interp delete } "" @@ -46,17 +46,17 @@ test interp-1.5 {options for interp command} -returnCodes error -body { # test interp-0.6 was removed # test interp-1.6 {options for interp command} -returnCodes error -body { - interp slaves foo bar zop -} -result {wrong # args: should be "interp slaves ?path?"} + interp children foo bar zop +} -result {wrong # args: should be "interp children ?path?"} test interp-1.7 {options for interp command} -returnCodes error -body { interp hello -} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} test interp-1.8 {options for interp command} -returnCodes error -body { interp -froboz -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} test interp-1.9 {options for interp command} -returnCodes error -body { interp -froboz -safe -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} test interp-1.10 {options for interp command} -returnCodes error -body { interp target } -result {wrong # args: should be "interp target path alias"} @@ -70,10 +70,12 @@ test interp-2.2 {basic interpreter creation} { } 0 test interp-2.3 {basic interpreter creation} { catch {interp create -safe} -} 0 -test interp-2.4 {basic interpreter creation} { - list [catch {interp create a} msg] $msg -} {1 {interpreter named "a" already exists, cannot create}} +} 0 +test interp-2.4 {basic interpreter creation} -setup { + catch {interp create a} +} -returnCodes error -body { + interp create a +} -result {interpreter named "a" already exists, cannot create} test interp-2.5 {basic interpreter creation} { interp create b -safe } b @@ -89,11 +91,13 @@ test interp-2.8 {basic interpreter creation} { test interp-2.9 {basic interpreter creation} { interp create -safe -- -froboz1 } -froboz1 -test interp-2.10 {basic interpreter creation} { +test interp-2.10 {basic interpreter creation} -setup { + catch {interp create a} +} -body { interp create {a x1} interp create {a x2} interp create {a x3} -safe -} {a x3} +} -result {a x3} test interp-2.11 {anonymous interps vs existing procs} { set x [interp create] regexp "interp(\[0-9]+)" $x dummy thenum @@ -101,8 +105,8 @@ test interp-2.11 {anonymous interps vs existing procs} { proc interp$thenum {} {} set x [interp create] regexp "interp(\[0-9]+)" $x dummy anothernum - expr $anothernum > $thenum -} 1 + expr {$anothernum > $thenum} +} 1 test interp-2.12 {anonymous interps vs existing procs} { set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy thenum @@ -110,49 +114,56 @@ test interp-2.12 {anonymous interps vs existing procs} { proc interp$thenum {} {} set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy anothernum - expr $anothernum - $thenum + expr {$anothernum - $thenum} } 1 test interp-2.13 {correct default when no $path arg is given} -body { interp create -- } -match regexp -result {interp[0-9]+} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } -# Part 2: Testing "interp slaves" and "interp exists" -test interp-3.1 {testing interp exists and interp slaves} { - interp slaves +# Part 2: Testing "interp children" and "interp exists" +test interp-3.1 {testing interp exists and interp children} { + interp children } "" -test interp-3.2 {testing interp exists and interp slaves} { +test interp-3.2 {testing interp exists and interp children} { interp create a interp exists a } 1 -test interp-3.3 {testing interp exists and interp slaves} { +test interp-3.3 {testing interp exists and interp children} { interp exists nonexistent } 0 -test interp-3.4 {testing interp exists and interp slaves} -body { - interp slaves a b c -} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} -test interp-3.5 {testing interp exists and interp slaves} -body { +test interp-3.4 {testing interp exists and interp children} -body { + interp children a b c +} -returnCodes error -result {wrong # args: should be "interp children ?path?"} +test interp-3.5 {testing interp exists and interp children} -body { interp exists a b c } -returnCodes error -result {wrong # args: should be "interp exists ?path?"} -test interp-3.6 {testing interp exists and interp slaves} { +test interp-3.6 {testing interp exists and interp children} { interp exists } 1 -test interp-3.7 {testing interp exists and interp slaves} { - interp slaves -} a -test interp-3.8 {testing interp exists and interp slaves} -body { - interp slaves a b c -} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} -test interp-3.9 {testing interp exists and interp slaves} { +test interp-3.7 {testing interp exists and interp children} -setup { + catch {interp create a} +} -body { + interp children +} -result a +test interp-3.8 {testing interp exists and interp children} -body { + interp children a b c +} -returnCodes error -result {wrong # args: should be "interp children ?path?"} +test interp-3.9 {testing interp exists and interp children} -setup { + catch {interp create a} +} -body { interp create {a a2} -safe - expr {"a2" in [interp slaves a]} -} 1 -test interp-3.10 {testing interp exists and interp slaves} { + expr {"a2" in [interp children a]} +} -result 1 +test interp-3.10 {testing interp exists and interp children} -setup { + catch {interp create a} + catch {interp create {a a2}} +} -body { interp exists {a a2} -} 1 +} -result 1 # Part 3: Testing "interp delete" test interp-3.11 {testing interp delete} { @@ -175,7 +186,7 @@ test interp-4.5 {testing interp delete} { interp create a interp create {a x1} interp delete {a x1} - expr {"x1" in [interp slaves a]} + expr {"x1" in [interp children a]} } 0 test interp-4.6 {testing interp delete} { interp create c1 @@ -192,14 +203,14 @@ test interp-4.8 {testing interp delete} -returnCodes error -body { interp delete {} } -result {cannot delete the current interpreter} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } # Part 4: Consistency checking - all nondeleted interpreters should be # there: test interp-5.1 {testing consistency} { - interp slaves + interp children } "" test interp-5.2 {testing consistency} { interp exists a @@ -213,46 +224,50 @@ interp create a # Part 5: Testing eval in interpreter object command and with interp command test interp-6.1 {testing eval} { - a eval expr 3 + 5 + a eval expr {{3 + 5}} } 8 test interp-6.2 {testing eval} -returnCodes error -body { a eval foo } -result {invalid command name "foo"} test interp-6.3 {testing eval} { - a eval {proc foo {} {expr 3 + 5}} + a eval {proc foo {} {expr {3 + 5}}} a eval foo } 8 +catch {a eval {proc foo {} {expr {3 + 5}}}} test interp-6.4 {testing eval} { interp eval a foo } 8 test interp-6.5 {testing eval} { interp create {a x2} - interp eval {a x2} {proc frob {} {expr 4 * 9}} + interp eval {a x2} {proc frob {} {expr {4 * 9}}} interp eval {a x2} frob } 36 +catch {interp create {a x2}} test interp-6.6 {testing eval} -returnCodes error -body { interp eval {a x2} foo } -result {invalid command name "foo"} -# UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER: -proc in_master {args} { - return [list seen in master: $args] +# UTILITY PROCEDURE RUNNING IN PARENT INTERPRETER: +proc in_parent {args} { + return [list seen in parent: $args] } # Part 6: Testing basic alias creation test interp-7.1 {testing basic alias creation} { - a alias foo in_master + a alias foo in_parent } foo +catch {a alias foo in_parent} test interp-7.2 {testing basic alias creation} { - a alias bar in_master a1 a2 a3 + a alias bar in_parent a1 a2 a3 } bar +catch {a alias bar in_parent a1 a2 a3} # Test 6.3 has been deleted. test interp-7.3 {testing basic alias creation} { a alias foo -} in_master +} in_parent test interp-7.4 {testing basic alias creation} { a alias bar -} {in_master a1 a2 a3} +} {in_parent a1 a2 a3} test interp-7.5 {testing basic alias creation} { lsort [a aliases] } {bar foo} @@ -263,14 +278,14 @@ test interp-7.6 {testing basic aliases arg checking} -returnCodes error -body { # Part 7: testing basic alias invocation test interp-8.1 {testing basic alias invocation} { catch {interp create a} - a alias foo in_master + a alias foo in_parent a eval foo s1 s2 s3 -} {seen in master: {s1 s2 s3}} +} {seen in parent: {s1 s2 s3}} test interp-8.2 {testing basic alias invocation} { catch {interp create a} - a alias bar in_master a1 a2 a3 + a alias bar in_parent a1 a2 a3 a eval bar s1 s2 s3 -} {seen in master: {a1 a2 a3 s1 s2 s3}} +} {seen in parent: {a1 a2 a3 s1 s2 s3}} test interp-8.3 {testing basic alias invocation} -returnCodes error -body { catch {interp create a} a alias @@ -279,13 +294,13 @@ test interp-8.3 {testing basic alias invocation} -returnCodes error -body { # Part 8: Testing aliases for non-existent or hidden targets test interp-9.1 {testing aliases for non-existent targets} { catch {interp create a} - a alias zop nonexistent-command-in-master + a alias zop nonexistent-command-in-parent list [catch {a eval zop} msg] $msg -} {1 {invalid command name "nonexistent-command-in-master"}} +} {1 {invalid command name "nonexistent-command-in-parent"}} test interp-9.2 {testing aliases for non-existent targets} { catch {interp create a} - a alias zop nonexistent-command-in-master - proc nonexistent-command-in-master {} {return i_exist!} + a alias zop nonexistent-command-in-parent + proc nonexistent-command-in-parent {} {return i_exist!} a eval zop } i_exist! test interp-9.3 {testing aliases for hidden commands} { @@ -314,8 +329,8 @@ test interp-9.4 {testing aliases and namespace commands} { set res } {GLOBAL GLOBAL} -if {[info command nonexistent-command-in-master] != ""} { - rename nonexistent-command-in-master {} +if {[info command nonexistent-command-in-parent] != ""} { + rename nonexistent-command-in-parent {} } # Part 9: Aliasing between interpreters @@ -365,9 +380,9 @@ test interp-10.6 {testing aliasing between interpreters} { interp create a interp create b interp alias a a_command b b_command a1 a2 a3 - b alias b_command in_master b1 b2 b3 + b alias b_command in_parent b1 b2 b3 a eval a_command m1 m2 m3 -} {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} +} {seen in parent: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} test interp-10.7 {testing aliases between interpreters} { catch {interp delete a} interp create a @@ -476,9 +491,13 @@ test interp-13.4 {testing issafe arg checking} { } {1 {wrong # args: should be "a issafe"}} # part 14: testing interp aliases -test interp-14.1 {testing interp aliases} { - interp aliases -} "" +test interp-14.1 {testing interp aliases} -setup { + interp create abc +} -body { + interp eval abc {interp aliases} +} -cleanup { + interp delete abc +} -result "" test interp-14.2 {testing interp aliases} { catch {interp delete a} interp create a @@ -494,7 +513,7 @@ test interp-14.3 {testing interp aliases} { interp alias {a x3} froboz "" puts interp aliases {a x3} } froboz -test interp-14.4 {testing interp alias - alias over master} { +test interp-14.4 {testing interp alias - alias over parent} { # SF Bug 641195 catch {interp delete a} interp create a @@ -587,6 +606,19 @@ test interp-14.10 {testing interp-alias: error messages} -setup { invoked from within "a 1"} +test interp-14.11 {{interp alias} {target named the empty string} {bug 2bf56185}} -setup { + set interp [interp create [info cmdcount]] + interp eval $interp { + proc {} args {return $args} + } + +} -body { + interp alias {} p1 $interp {} + p1 one two three +} -cleanup { + interp delete $interp +} -result {one two three} + # part 15: testing file sharing test interp-15.1 {testing file sharing} { catch {interp delete z} @@ -714,7 +746,7 @@ test interp-16.5 {testing deletion order, bgerror} { xxx eval {proc bgerror {args} {exit}} xxx alias exit kill xxx proc kill {i} {interp delete $i} - xxx eval after 100 expr a + b + xxx eval after 100 expr {a + b} after 200 update interp exists xxx @@ -761,32 +793,32 @@ test interp-17.6 {alias loop prevention} { } {1 {cannot define or rename alias "b": would create a loop}} # -# Test robustness of Tcl_DeleteInterp when applied to a slave interpreter. +# Test robustness of Tcl_DeleteInterp when applied to a child interpreter. # If there are bugs in the implementation these tests are likely to expose # the bugs as a core dump. # -test interp-18.1 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.1 {testing Tcl_DeleteInterp vs children} testinterpdelete { list [catch {testinterpdelete} msg] $msg } {1 {wrong # args: should be "testinterpdelete path"}} -test interp-18.2 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.2 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a testinterpdelete a } "" -test interp-18.3 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.3 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete {a b} } "" -test interp-18.4 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.4 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete a } "" -test interp-18.5 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.5 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} @@ -794,7 +826,7 @@ test interp-18.5 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { proc dodel {x} {testinterpdelete $x} list [catch {interp eval {a b} {dodel {a b}}} msg] $msg } {0 {}} -test interp-18.6 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.6 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} @@ -844,12 +876,12 @@ test interp-18.9 {eval in deleted interp, bug 495830} { interp create tst interp alias tst suicide {} interp delete tst list [catch {tst eval {suicide; set a 5}} msg] $msg -} {1 {attempt to call eval in deleted interpreter}} +} {1 {attempt to call eval in deleted interpreter}} test interp-18.10 {eval in deleted interp, bug 495830} { interp create tst interp alias tst suicide {} interp delete tst list [catch {tst eval {set set set; suicide; $set a 5}} msg] $msg -} {1 {attempt to call eval in deleted interpreter}} +} {1 {attempt to call eval in deleted interpreter}} # Test alias deletion @@ -934,12 +966,12 @@ test interp-19.9 {alias deletion, renaming} { interp create a interp alias a foo a bar interp eval a rename foo blotz - interp eval a {proc foo {} {expr 34 * 34}} + interp eval a {proc foo {} {expr {34 * 34}}} interp alias a foo {} set l [interp eval a foo] interp delete a set l -} 1156 +} 1156 test interp-20.1 {interp hide, interp expose and interp invokehidden} { set a [interp create] @@ -1160,7 +1192,7 @@ test interp-20.21 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg interp delete a set l @@ -1169,7 +1201,7 @@ test interp-20.22 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg interp delete a set l @@ -1178,7 +1210,7 @@ test interp-20.23 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a eval {interp hide {} list}} msg] + lappend l [catch {a eval {interp hide {} list}} msg] lappend l $msg interp delete a set l @@ -1188,7 +1220,7 @@ test interp-20.24 {interp hide vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {a eval {interp hide b list}} msg] + lappend l [catch {a eval {interp hide b list}} msg] lappend l $msg interp delete a set l @@ -1207,7 +1239,7 @@ test interp-20.26 {interp expoose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg lappend l [catch {a expose list} msg] lappend l $msg @@ -1218,9 +1250,9 @@ test interp-20.27 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg - lappend l [catch {interp expose a list} msg] + lappend l [catch {interp expose a list} msg] lappend l $msg interp delete a set l @@ -1229,7 +1261,7 @@ test interp-20.28 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg lappend l [catch {a eval {interp expose {} list}} msg] lappend l $msg @@ -1240,9 +1272,9 @@ test interp-20.29 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg - lappend l [catch {a eval {interp expose {} list}} msg] + lappend l [catch {a eval {interp expose {} list}} msg] lappend l $msg interp delete a set l @@ -1252,9 +1284,9 @@ test interp-20.30 {interp expose vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {interp hide {a b} list} msg] + lappend l [catch {interp hide {a b} list} msg] lappend l $msg - lappend l [catch {a eval {interp expose b list}} msg] + lappend l [catch {a eval {interp expose b list}} msg] lappend l $msg interp delete a set l @@ -1264,7 +1296,7 @@ test interp-20.31 {interp expose vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {interp hide {a b} list} msg] + lappend l [catch {interp hide {a b} list} msg] lappend l $msg lappend l [catch {interp expose {a b} list} msg] lappend l $msg @@ -1583,22 +1615,36 @@ test interp-20.49 {interp invokehidden -namespace} -setup { set script [makeFile { set x [namespace current] } script] - interp create -safe slave + interp create -safe child } -body { - slave invokehidden -namespace ::foo source $script - slave eval {set ::foo::x} + child invokehidden -namespace ::foo source $script + child eval {set ::foo::x} } -cleanup { - interp delete slave + interp delete child removeFile script } -result ::foo test interp-20.50 {Bug 2486550} -setup { - interp create slave + interp create child } -body { - slave hide coroutine - slave invokehidden coroutine + child hide coroutine + child invokehidden coroutine } -cleanup { - interp delete slave + interp delete child } -returnCodes error -match glob -result * +test interp-20.50.1 {Bug 2486550} -setup { + interp create child +} -body { + child hide coroutine + catch {child invokehidden coroutine} m o + dict get $o -errorinfo +} -cleanup { + unset -nocomplain m 0 + interp delete child +} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" + while executing +"coroutine" + invoked from within +"child invokehidden coroutine"} test interp-21.1 {interp hidden} { interp hidden {} @@ -1630,7 +1676,7 @@ test interp-21.5 {interp hidden} -setup { lsort [interp hidden a] } -cleanup { interp delete a -} -result $hidden_cmds +} -result $hidden_cmds test interp-21.6 {interp hidden vs interp hide, interp expose} -setup { catch {interp delete a} set l "" @@ -1790,7 +1836,7 @@ test interp-23.1 {testing hiding vs aliases: unsafe interp} -setup { test interp-23.2 {testing hiding vs aliases: safe interp} -setup { catch {interp delete a} set l "" -} -constraints {unixOrPc} -body { +} -constraints {unixOrWin} -body { interp create a -safe lappend l [lsort [interp hidden a]] a alias bar bar @@ -1801,7 +1847,7 @@ test interp-23.2 {testing hiding vs aliases: safe interp} -setup { lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] } -cleanup { interp delete a -} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds] +} -result [list $hidden_cmds {bar clock} $hidden_cmds {bar clock} [lsort [concat $hidden_cmds bar]] {clock} $hidden_cmds] test interp-24.1 {result resetting on error} -setup { catch {interp delete a} @@ -2012,8 +2058,8 @@ test interp-25.1 {testing aliasing of string commands} -setup { test interp-26.1 {result code transmission : interp eval direct} { # Test that all the possibles error codes from Tcl get passed up - # from the slave interp's context to the master, even though the - # slave nominally thinks the command is running at the root level. + # from the child interp's context to the parent, even though the + # child nominally thinks the command is running at the root level. catch {interp delete a} interp create a set res {} @@ -2039,7 +2085,7 @@ test interp-26.2 {result code transmission : interp eval indirect} { } {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} test interp-26.3 {result code transmission : aliases} { # Test that all the possibles error codes from Tcl get passed up from the - # slave interp's context to the master, even though the slave nominally + # child interp's context to the parent, even though the child nominally # thinks the command is running at the root level. catch {interp delete a} interp create a @@ -2134,7 +2180,7 @@ test interp-26.8 {errorInfo transmission: safe interps--bug 1637} -setup { } -constraints knownBug -body { # this test fails because the errorInfo is fully transmitted whether the # interp is safe or not. The errorInfo should never report data from the - # master interpreter because it could contain sensitive information. + # parent interpreter because it could contain sensitive information. proc MyError {secret} { return -code error "msg" } @@ -2154,7 +2200,7 @@ test interp-27.1 {interp aliases & namespaces} -setup { set i [interp create] } -body { set aliasTrace {} - proc tstAlias {args} { + proc tstAlias {args} { global aliasTrace lappend aliasTrace [list [namespace current] $args] } @@ -2168,7 +2214,7 @@ test interp-27.2 {interp aliases & namespaces} -setup { set i [interp create] } -body { set aliasTrace {} - proc tstAlias {args} { + proc tstAlias {args} { global aliasTrace lappend aliasTrace [list [namespace current] $args] } @@ -2182,7 +2228,7 @@ test interp-27.3 {interp aliases & namespaces} -setup { set i [interp create] } -body { set aliasTrace {} - proc tstAlias {args} { + proc tstAlias {args} { global aliasTrace lappend aliasTrace [list [namespace current] $args] } @@ -2198,7 +2244,7 @@ test interp-27.4 {interp aliases & namespaces} -setup { } -body { namespace eval foo2 { variable aliasTrace {} - proc bar {args} { + proc bar {args} { variable aliasTrace lappend aliasTrace [list [namespace current] $args] } @@ -2229,22 +2275,22 @@ test interp-27.5 {interp hidden & namespaces} -setup { test interp-27.6 {interp hidden & aliases & namespaces} -setup { set i [interp create] } -constraints knownBug -body { - set v root-master + set v root-parent namespace eval foo { - variable v foo-master + variable v foo-parent proc bar {interp args} { variable v - list "master bar called ($v) ([namespace current]) ($args)"\ + list "parent bar called ($v) ([namespace current]) ($args)"\ [interp invokehidden $interp foo::bar $args] } } interp eval $i { namespace eval foo { namespace export * - variable v foo-slave + variable v foo-child proc bar {args} { variable v - return "slave bar called ($v) ([namespace current]) ($args)" + return "child bar called ($v) ([namespace current]) ($args)" } } } @@ -2252,7 +2298,7 @@ test interp-27.6 {interp hidden & aliases & namespaces} -setup { $i hide foo::bar $i alias foo::bar foo::bar $i set res [concat $res [interp eval $i { - set v root-slave + set v root-child namespace eval test { variable v foo-test namespace import ::foo::* @@ -2262,29 +2308,29 @@ test interp-27.6 {interp hidden & aliases & namespaces} -setup { } -cleanup { namespace delete foo interp delete $i -} -result {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}} +} -result {{child bar called (foo-child) (::foo) (test1)} {parent bar called (foo-parent) (::foo) (test2)} {child bar called (foo-child) (::foo) (test2)}} test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup { set i [interp create] } -constraints knownBug -body { - set v root-master + set v root-parent namespace eval mfoo { - variable v foo-master + variable v foo-parent proc bar {interp args} { variable v - list "master bar called ($v) ([namespace current]) ($args)"\ + list "parent bar called ($v) ([namespace current]) ($args)"\ [interp invokehidden $interp test::bar $args] } } interp eval $i { namespace eval foo { namespace export * - variable v foo-slave + variable v foo-child proc bar {args} { variable v - return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" + return "child bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" } } - set v root-slave + set v root-child namespace eval test { variable v foo-test namespace import ::foo::* @@ -2297,7 +2343,7 @@ test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup { } -cleanup { namespace delete mfoo interp delete $i -} -result {{slave bar called (foo-slave) (bar test1) (::tcltest) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}} +} -result {{child bar called (foo-child) (bar test1) (::tcltest) (::foo) (test1)} {parent bar called (foo-parent) (::mfoo) (test2)} {child bar called (foo-child) (test::bar test2) (::) (::foo) (test2)}} test interp-27.8 {hiding, namespaces and integrity} knownBug { namespace eval foo { variable v 3 @@ -2309,25 +2355,25 @@ test interp-27.8 {hiding, namespaces and integrity} knownBug { list [catch {interp invokehidden {} foo::bar} msg] $msg } {1 {invalid hidden command name "foo"}} -test interp-28.1 {getting fooled by slave's namespace ?} -setup { +test interp-28.1 {getting fooled by child's namespace ?} -setup { set i [interp create -safe] - proc master {interp args} {interp hide $interp list} + proc parent {interp args} {interp hide $interp list} } -body { - $i alias master master $i + $i alias parent parent $i set r [interp eval $i { namespace eval foo { proc list {args} { return "dummy foo::list" } - master + parent } info commands list }] } -cleanup { - rename master {} + rename parent {} interp delete $i } -result {} -test interp-28.2 {master's nsName cache should not cross} -setup { +test interp-28.2 {parent's nsName cache should not cross} -setup { set i [interp create] $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}} } -body { @@ -2386,31 +2432,31 @@ test interp-29.1.7 {interp recursionlimit argument checking} { interp delete moo list $result [string range $msg 0 35] } {1 {integer value too large to represent}} -test interp-29.1.8 {slave recursionlimit argument checking} { +test interp-29.1.8 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit foo bar} msg] interp delete moo list $result $msg } {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}} -test interp-29.1.9 {slave recursionlimit argument checking} { +test interp-29.1.9 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit foo} msg] interp delete moo list $result $msg } {1 {expected integer but got "foo"}} -test interp-29.1.10 {slave recursionlimit argument checking} { +test interp-29.1.10 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit 0} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} -test interp-29.1.11 {slave recursionlimit argument checking} { +test interp-29.1.11 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit -1} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} -test interp-29.1.12 {slave recursionlimit argument checking} { +test interp-29.1.12 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg] interp delete moo @@ -2503,8 +2549,8 @@ test interp-29.3.3 {recursion limit} { set r } {1 {too many nested evaluations (infinite loop?)} 49} test interp-29.3.4 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2518,13 +2564,13 @@ test interp-29.3.4 {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {falling back due to new recursion limit}} test interp-29.3.5 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2538,13 +2584,13 @@ test interp-29.3.5 {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {falling back due to new recursion limit}} test interp-29.3.6 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2558,8 +2604,8 @@ test interp-29.3.6 {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} # @@ -2567,9 +2613,9 @@ test interp-29.3.6 {recursion limit error reporting} { # level will only be verified when it invokes a non-bcc'd command. # test interp-29.3.7a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2583,14 +2629,14 @@ test interp-29.3.7a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.7b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2604,14 +2650,14 @@ test interp-29.3.7b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.7c {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2626,14 +2672,14 @@ test interp-29.3.7c {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.8a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 4} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2647,14 +2693,14 @@ test interp-29.3.8a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.8b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 4} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2668,14 +2714,14 @@ test interp-29.3.8b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.9a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 6} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2689,14 +2735,14 @@ test interp-29.3.9a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.9b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 6} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2710,14 +2756,14 @@ test interp-29.3.9b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.10a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 4} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2731,14 +2777,14 @@ test interp-29.3.10a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.10b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 4} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2752,14 +2798,14 @@ test interp-29.3.10b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.11a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 5} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2773,14 +2819,14 @@ test interp-29.3.11a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.11b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 5} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2795,14 +2841,14 @@ test interp-29.3.11b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.12a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 6} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2816,14 +2862,14 @@ test interp-29.3.12a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.12b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 6} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2838,8 +2884,8 @@ test interp-29.3.12b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.4.1 {recursion limit inheritance} { @@ -2870,121 +2916,121 @@ test interp-29.4.2 {recursion limit inheritance} { interp delete $i set r } 50 -test interp-29.5.1 {does slave recursion limit affect master?} { +test interp-29.5.1 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] interp recursionlimit $i 20000 set after [interp recursionlimit {}] - set slavelimit [interp recursionlimit $i] + set childlimit [interp recursionlimit $i] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} -test interp-29.5.2 {does slave recursion limit affect master?} { +test interp-29.5.2 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] interp recursionlimit $i 20000 set after [interp recursionlimit {}] - set slavelimit [$i recursionlimit] + set childlimit [$i recursionlimit] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} -test interp-29.5.3 {does slave recursion limit affect master?} { +test interp-29.5.3 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] $i recursionlimit 20000 set after [interp recursionlimit {}] - set slavelimit [interp recursionlimit $i] + set childlimit [interp recursionlimit $i] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} -test interp-29.5.4 {does slave recursion limit affect master?} { +test interp-29.5.4 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] $i recursionlimit 20000 set after [interp recursionlimit {}] - set slavelimit [$i recursionlimit] + set childlimit [$i recursionlimit] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} test interp-29.6.1 {safe interpreter recursion limit} { - interp create slave -safe - set n [interp recursionlimit slave] - interp delete slave + interp create child -safe + set n [interp recursionlimit child] + interp delete child set n } 1000 test interp-29.6.2 {safe interpreter recursion limit} { - interp create slave -safe - set n [slave recursionlimit] - interp delete slave + interp create child -safe + set n [child recursionlimit] + interp delete child set n } 1000 test interp-29.6.3 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [interp recursionlimit slave 42] - set n2 [interp recursionlimit slave] - interp delete slave + interp create child -safe + set n1 [interp recursionlimit child 42] + set n2 [interp recursionlimit child] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.4 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [interp recursionlimit slave] - interp delete slave + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [interp recursionlimit child] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.5 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [interp recursionlimit slave 42] - set n2 [slave recursionlimit] - interp delete slave + interp create child -safe + set n1 [interp recursionlimit child 42] + set n2 [child recursionlimit] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.6 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [slave recursionlimit] - interp delete slave + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [child recursionlimit] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.7 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [slave recursionlimit] - interp delete slave + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [child recursionlimit] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.8 {safe interpreter recursion limit} { - interp create slave -safe - set n [catch {slave eval {interp recursionlimit {} 42}} msg] - interp delete slave + interp create child -safe + set n [catch {child eval {interp recursionlimit {} 42}} msg] + interp delete child list $n $msg } {1 {permission denied: safe interpreters cannot change recursion limit}} test interp-29.6.9 {safe interpreter recursion limit} { - interp create slave -safe + interp create child -safe set result [ - slave eval { - interp create slave2 -safe + child eval { + interp create child2 -safe set n [catch { - interp recursionlimit slave2 42 + interp recursionlimit child2 42 } msg] list $n $msg } ] - interp delete slave + interp delete child set result } {1 {permission denied: safe interpreters cannot change recursion limit}} test interp-29.6.10 {safe interpreter recursion limit} { - interp create slave -safe + interp create child -safe set result [ - slave eval { - interp create slave2 -safe + child eval { + interp create child2 -safe set n [catch { - slave2 recursionlimit 42 + child2 recursionlimit 42 } msg] list $n $msg } ] - interp delete slave + interp delete child set result } {1 {permission denied: safe interpreters cannot change recursion limit}} @@ -3125,7 +3171,7 @@ test interp-34.3.1 {basic test of limits - pure inside-command loop} -body { } } # We use a time limit here; command limits don't trap this case - $i limit time -seconds [expr {[clock seconds]+2}] + $i limit time -seconds [expr {[clock seconds] + 2}] $i eval foobar } -returnCodes error -result {time limit exceeded} -cleanup { interp delete $i @@ -3147,8 +3193,8 @@ test interp-34.4 {limits with callbacks: extending limits} -setup { } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command "cb2 [expr $curlim+100]" \ - -value [expr {$curlim+10}] + $i limit command -command "cb2 [expr {$curlim + 100}]" \ + -value [expr {$curlim + 10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { @@ -3176,7 +3222,7 @@ test interp-34.5 {limits with callbacks: removing limits} -setup { } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command "cb2 {}" -value [expr {$curlim+10}] + $i limit command -command "cb2 {}" -value [expr {$curlim + 10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { @@ -3201,7 +3247,7 @@ test interp-34.6 {limits with callbacks: removing limits and handlers} -setup { } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command cb2 -value [expr {$curlim+10}] + $i limit command -command cb2 -value [expr {$curlim + 10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { @@ -3220,7 +3266,7 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { proc cb2 {args} { global c i curlim set c b - $i limit command -value [expr {$curlim+1000}] + $i limit command -value [expr {$curlim + 1000}] trapToParent } } @@ -3243,7 +3289,7 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { set c a interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command cb2 -value [expr {$curlim+10}] + $i limit command -command cb2 -value [expr {$curlim + 10}] } $i eval { $i eval { @@ -3258,7 +3304,7 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { # Bug 1085023 test interp-34.8 {time limits trigger in vwaits} -body { set i [interp create] - interp limit $i time -seconds [expr {[clock seconds]+1}] -granularity 1 + interp limit $i time -seconds [expr {[clock seconds] + 1}] -granularity 1 $i eval { set x {} vwait x @@ -3275,7 +3321,7 @@ test interp-34.9 {time limits trigger in blocking after} { } msg] set t1 [clock seconds] interp delete $i - list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] + list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] } {1 {time limit exceeded} OK} test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { set i [interp create] @@ -3306,8 +3352,8 @@ test interp-34.11 {time limit extension in callbacks} -setup { } -body { set i [interp create] set t0 [clock seconds] - $i limit time -seconds [expr {$t0+1}] -granularity 1 \ - -command "cb1 $i [expr {$t0+2}]" + $i limit time -seconds [expr {$t0 + 1}] -granularity 1 \ + -command "cb1 $i [expr {$t0 + 2}]" set ::result {} lappend ::result [catch { $i eval { @@ -3334,8 +3380,8 @@ test interp-34.12 {time limit extension in callbacks} -setup { } -body { set i [interp create] set t0 [clock seconds] - set ::times "[expr {$t0+2}] [expr {$t0+100}]" - $i limit time -seconds [expr {$t0+1}] -granularity 1 -command "cb1 $i" + set ::times "[expr {$t0 + 2}] [expr {$t0 + 100}]" + $i limit time -seconds [expr {$t0 + 1}] -granularity 1 -command "cb1 $i" set ::result {} lappend ::result [catch { $i eval { @@ -3509,48 +3555,48 @@ test interp-35.24 {interp time limits can't touch current interp} -body { test interp-36.1 {interp bgerror syntax} -body { interp bgerror } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} -test interp-36.2 {interp bgerror syntax} -body { +test interp-36.2 {interp bgerror syntax} -body { interp bgerror x y z } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} test interp-36.3 {interp bgerror syntax} -setup { - interp create slave + interp create child } -body { - slave bgerror x y + child bgerror x y } -cleanup { - interp delete slave -} -returnCodes error -result {wrong # args: should be "slave bgerror ?cmdPrefix?"} -test interp-36.4 {SlaveBgerror syntax} -setup { - interp create slave + interp delete child +} -returnCodes error -result {wrong # args: should be "child bgerror ?cmdPrefix?"} +test interp-36.4 {ChildBgerror syntax} -setup { + interp create child } -body { - slave bgerror \{ + child bgerror \{ } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {cmdPrefix must be list of length >= 1} -test interp-36.5 {SlaveBgerror syntax} -setup { - interp create slave +test interp-36.5 {ChildBgerror syntax} -setup { + interp create child } -body { - slave bgerror {} + child bgerror {} } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {cmdPrefix must be list of length >= 1} -test interp-36.6 {SlaveBgerror returns handler} -setup { - interp create slave +test interp-36.6 {ChildBgerror returns handler} -setup { + interp create child } -body { - slave bgerror {foo bar soom} + child bgerror {foo bar soom} } -cleanup { - interp delete slave + interp delete child } -result {foo bar soom} -test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { - interp create slave - slave alias handler handler - slave bgerror handler +test interp-36.7 {ChildBgerror sets error handler of child [1999035]} -setup { + interp create child + child alias handler handler + child bgerror handler variable result {untouched} proc handler {args} { variable result set result [lindex $args 0] } } -body { - slave eval { + child eval { variable done {} after 0 error foo after 10 [list ::set [namespace which -variable done] {}] @@ -3560,7 +3606,7 @@ test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { } -cleanup { variable result {} unset -nocomplain result - interp delete slave + interp delete child } -result foo test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { @@ -3569,8 +3615,8 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { set result {} } -body { interp create {a b} -safe - lappend result [interp eval a {expr min(5,2,3)*max(7,13,11)}] - lappend result [interp eval {a b} {expr min(5,2,3)*max(7,13,11)}] + lappend result [interp eval a {expr {min(5,2,3)*max(7,13,11)}}] + lappend result [interp eval {a b} {expr {min(5,2,3)*max(7,13,11)}}] } -cleanup { unset -nocomplain result interp delete a @@ -3601,10 +3647,10 @@ test interp-38.3 {interp debug wrong args} -body { } -returnCodes { error } -result {wrong # args: should be "interp debug path ?-frame ?bool??"} -test interp-38.4 {interp debug basic setup} -body { +test interp-38.4 {interp debug basic setup} -constraints {!singleTestInterp} -body { interp debug {} } -result {-frame 0} -test interp-38.5 {interp debug basic setup} -body { +test interp-38.5 {interp debug basic setup} -constraints {!singleTestInterp} -body { interp debug {} -f } -result {0} test interp-38.6 {interp debug basic setup} -body { @@ -3621,7 +3667,7 @@ test interp-38.8 {interp debug basic setup} -body { # cleanup unset -nocomplain hidden_cmds -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } ::tcltest::cleanupTests diff --git a/tests/io.test b/tests/io.test index 9621138..af778ef 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6,21 +6,17 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 } -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -33,19 +29,29 @@ namespace eval ::tcl::test::io { variable msg variable expected + catch { + ::tcltest::loadTestedCommands + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [info loaded {} Tcltest] + } + package require tcltests + +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint exec [llength [info commands exec]] -testConstraint openpipe 1 -testConstraint fileevent [llength [info commands fileevent]] -testConstraint fcopy [llength [info commands fcopy]] testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] -testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] +testConstraint testobj [llength [info commands testobj]] +testConstraint testservicemode [llength [info commands testservicemode]] +# Some things fail under Windows in Continuous Integration systems for subtle +# reasons such as CI often running with elevated privileges in a container. +testConstraint notWinCI [expr { + $::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] # 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. @@ -71,7 +77,7 @@ set path(cat) [makeFile { if {$argv != ""} { set f [open [lindex $argv 0]] } - fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a + fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A fconfigure stdout -encoding binary -translation lf -buffering none fileevent $f readable "foo $f" proc foo {f} { @@ -121,10 +127,10 @@ test io-1.8 {Tcl_WriteChars: WriteChars} { # applied to tcl will cause tcl, more specifically WriteChars, to # go into an infinite loop. - set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp - puts -nonewline $f [format %s%c [string repeat " " 4] 12399] - close $f + set f [open $path(test2) w] + fconfigure $f -encoding iso2022-jp + puts -nonewline $f [format %s%c [string repeat " " 4] 12399] + close $f contents $path(test2) } " \x1b\$B\$O\x1b(B" @@ -190,7 +196,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { test io-2.1 {WriteBytes} { # loop until all bytes are written - + set f [open $path(test1) w] fconfigure $f -encoding binary -buffersize 16 -translation crlf puts $f "abcdefghijklmnopqrstuvwxyz" @@ -212,7 +218,7 @@ test io-2.3 {WriteBytes: flush on line} { # Tcl "line" buffering has weird behavior: if current buffer contains # a \n, entire buffer gets flushed. Logical behavior would be to flush # only up to the \n. - + set f [open $path(test1) w] fconfigure $f -encoding binary -buffering line -translation crlf puts -nonewline $f "\n12" @@ -232,7 +238,7 @@ test io-2.4 {WriteBytes: reset sawLF after each buffer} { test io-3.1 {WriteChars: compatibility with WriteBytes} { # loop until all bytes are written - + set f [open $path(test1) w] fconfigure $f -encoding ascii -buffersize 16 -translation crlf puts $f "abcdefghijklmnopqrstuvwxyz" @@ -254,7 +260,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { # Tcl "line" buffering has weird behavior: if current buffer contains # a \n, entire buffer gets flushed. Logical behavior would be to flush # only up to the \n. - + set f [open $path(test1) w] fconfigure $f -encoding ascii -buffering line -translation crlf puts -nonewline $f "\n12" @@ -266,7 +272,7 @@ test io-3.4 {WriteChars: loop over stage buffer} { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 16 + fconfigure $f -encoding jis0208 -buffersize 16 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -278,7 +284,7 @@ test io-3.5 {WriteChars: saved != 0} { # requested buffersize. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + fconfigure $f -encoding jis0208 -buffersize 17 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -309,7 +315,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { # of the next channel buffer. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + fconfigure $f -encoding jis0208 -buffersize 17 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -379,7 +385,7 @@ test io-4.5 {TranslateOutputEOL: crlf} { test io-5.1 {CheckFlush: not full} { set f [open $path(test1) w] - fconfigure $f + fconfigure $f puts -nonewline $f "12345678901234567890" set x [list [contents $path(test1)]] close $f @@ -468,7 +474,7 @@ set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a test io-6.6 {Tcl_GetsObj: loop test} { - # if (dst >= dstEnd) + # if (dst >= dstEnd) set f [open $path(test1) w] puts $f $a @@ -479,7 +485,7 @@ test io-6.6 {Tcl_GetsObj: loop test} { close $f set x } [list 256 $a] -test io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} { +test io-6.7 {Tcl_GetsObj: error in input} stdio { # if (FilterInputBytes(chanPtr, &gs) != 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -493,10 +499,10 @@ test io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} { } {-1} test io-6.8 {Tcl_GetsObj: remember if EOF is seen} { set f [open $path(test1) w] - puts $f "abcdef\x1aghijk\nwombat" + puts $f "abcdef\x1Aghijk\nwombat" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1a + fconfigure $f -eofchar \x1A set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -506,7 +512,7 @@ test io-6.9 {Tcl_GetsObj: remember if EOF is seen} { puts $f "abcdefghijk\nwom\u001abat" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1a + fconfigure $f -eofchar \x1A set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -739,7 +745,7 @@ test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} { close $f set x } [list 15 "123456789012345" 15] -test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} { +test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel fileevent} { # (FilterInputBytes() != 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -767,7 +773,7 @@ test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} } [list 15 "123456789012345" 17 3] test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { # eol still equals dstEnd - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456789012345\r" @@ -779,8 +785,8 @@ test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { set x } [list 16 "123456789012345\r" 1] test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} { - # not (*eol == '\n') - + # not (*eol == '\n') + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456789012345\rabcd\r\nefg" @@ -878,7 +884,7 @@ test io-6.42 {Tcl_GetsObj: auto mode: several chars} { close $f set x } [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] -test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} { +test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel fileevent} { # if (chanPtr->flags & INPUT_SAW_CR) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -887,16 +893,16 @@ test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} fconfigure $f -buffersize 16 set x [list [gets $f]] fconfigure $f -blocking 0 - lappend x [gets $f line] $line [testchannel queuedcr $f] + lappend x [gets $f line] $line [testchannel queuedcr $f] fconfigure $f -blocking 1 - puts -nonewline $f "\nabcd\refg\x1a" + puts -nonewline $f "\nabcd\refg\x1A" lappend x [gets $f line] $line [testchannel queuedcr $f] lappend x [gets $f line] $line close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} { - # not (*eol == '\n') +test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel fileevent} { + # not (*eol == '\n') set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none @@ -904,20 +910,20 @@ test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel fconfigure $f -buffersize 16 set x [list [gets $f]] fconfigure $f -blocking 0 - lappend x [gets $f line] $line [testchannel queuedcr $f] + lappend x [gets $f line] $line [testchannel queuedcr $f] fconfigure $f -blocking 1 - puts -nonewline $f "abcd\refg\x1a" + puts -nonewline $f "abcd\refg\x1A" lappend x [gets $f line] $line [testchannel queuedcr $f] lappend x [gets $f line] $line close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} { +test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel fileevent} { # Tcl_ExternalToUtf() set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none - fconfigure $f -encoding unicode + fconfigure $f -encoding utf-16 puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" fconfigure $f -buffersize 16 gets $f @@ -929,7 +935,7 @@ test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio test close $f set x } [list 15 "123456789abcdef" 1 4 "abcd" 0] -test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} { +test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel fileevent} { # memmove() set f [open "|[list [interpreter] $path(cat)]" w+] @@ -940,7 +946,7 @@ test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {s fconfigure $f -blocking 0 set x [list [gets $f line] $line [testchannel queuedcr $f]] fconfigure $f -blocking 1 - puts -nonewline $f "\n\x1a" + puts -nonewline $f "\n\x1A" lappend x [gets $f line] $line [testchannel queuedcr $f] close $f set x @@ -957,10 +963,10 @@ test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testcha set x [list [gets $f] [testchannel inputbuffered $f]] close $f set x -} [list "123456789012345" 15] +} [list "123456789012345" 15] test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} { # PeekAhead() did not get any, so (eol >= dstEnd) - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456789012345\r" @@ -973,7 +979,7 @@ test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testc } [list "123456789012345" 1] test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { # if (*eol == '\n') {skip++} - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456\r\n78901" @@ -984,8 +990,8 @@ test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { set x } [list "123456" 0 8 "78901"] test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { - # not (*eol == '\n') - + # not (*eol == '\n') + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456\r78901" @@ -997,7 +1003,7 @@ test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { } [list "123456" 0 7 "78901"] test io-6.51 {Tcl_GetsObj: auto mode: \n} { # else if (*eol == '\n') {goto gotoeol;} - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456\n78901" @@ -1012,10 +1018,10 @@ test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { set f [open $path(test1) w] fconfigure $f -translation lf - puts -nonewline $f "123456\x1ak9012345\r" + puts -nonewline $f "123456\x1Ak9012345\r" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1a + fconfigure $f -eofchar \x1A set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] close $f set x @@ -1054,7 +1060,7 @@ test io-6.55 {Tcl_GetsObj: overconverted} { close $f set x } [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] -test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} { +test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio fileevent} { update set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -buffering none @@ -1090,7 +1096,7 @@ test io-7.1 {FilterInputBytes: split up character at end of buffer} { } "1234567890123\uff10\uff11\uff12\uff13\uff14" test io-7.2 {FilterInputBytes: split up character in middle of buffer} { # (bufPtr->nextAdded < bufPtr->bufLength) - + set f [open $path(test1) w] fconfigure $f -encoding binary puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" @@ -1114,7 +1120,7 @@ test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { close $f set x } [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] -test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} { +test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent} { set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -encoding binary -buffering none puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" @@ -1149,7 +1155,7 @@ test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} close $f set x } "7" -test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} { +test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel fileevent} { # not (bufPtr->nextPtr == NULL) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1161,7 +1167,7 @@ test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testcha variable x lappend x [gets $f line] $line [testchannel inputbuffered $f] } - fconfigure $f -encoding unicode -buffersize 16 -blocking 0 + fconfigure $f -encoding utf-16 -buffersize 16 -blocking 0 vwait [namespace which -variable x] fconfigure $f -translation auto -encoding ascii -blocking 1 # here @@ -1169,7 +1175,7 @@ test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testcha close $f set x } [list -1 "" 42 15 "123456789012345" 25] -test io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} { +test io-8.3 {PeekAhead: no cached data available} {stdio testchannel fileevent} { # (bytesLeft == 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1199,10 +1205,10 @@ test io-8.4 {PeekAhead: cached data available in this buffer} { set x [gets $f] close $f - set x + set x } $a unset a -test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} { +test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel fileevent} { # (bufPtr->nextAdded < bufPtr->length) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1214,8 +1220,8 @@ test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel op close $f set x } {15 abcdefghijklmno 1} -test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} { - # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) +test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel fileevent} { + # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto binary} -buffersize 16 @@ -1226,7 +1232,7 @@ test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe close $f set x } {15 abcdefghijklmno 1} -test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} { +test io-8.7 {PeekAhead: cleanup} {stdio testchannel fileevent} { # Make sure bytes are removed from buffer. set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1234,7 +1240,7 @@ test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} { puts -nonewline $f "abcdefghijklmno\r" # here set x [list [gets $f line] $line [testchannel queuedcr $f]] - puts -nonewline $f "\x1a" + puts -nonewline $f "\x1A" lappend x [gets $f line] $line close $f set x @@ -1391,7 +1397,7 @@ test io-12.3 {ReadChars: allocate more space} { close $f set x } {abcdefghijklmnopqrstuvwxyz} -test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} { +test io-12.4 {ReadChars: split-up char} {stdio testchannel fileevent} { # (srcRead == 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1416,7 +1422,7 @@ test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} { close $f set x } [list "123456789012345" 1 "\u672c" 0] -test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe fileevent} { +test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} { set path(test1) [makeFile { fconfigure stdout -encoding binary -buffering none gets stdin; puts -nonewline "\xe7" @@ -1449,6 +1455,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] @@ -1473,7 +1578,7 @@ test io-13.2 {TranslateInputEOL: crlf mode} { set x } "abcd\ndef\n" test io-13.3 {TranslateInputEOL: crlf mode: naked cr} { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf @@ -1486,7 +1591,7 @@ test io-13.3 {TranslateInputEOL: crlf mode: naked cr} { set x } "abcd\ndef\r" test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf @@ -1499,7 +1604,7 @@ test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { set x } "abcd\ndef\rfgh" test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf @@ -1511,7 +1616,7 @@ test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { close $f set x } "abcd\ndef\nfgh" -test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} { +test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel fileevent} { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. @@ -1537,7 +1642,7 @@ test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testc close $f set x } [list "abcdefghj\n" 1 "01234" 0] -test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} { +test io-13.7 {TranslateInputEOL: auto mode: naked \r} testchannel { # (src >= srcMax) set f [open $path(test1) w] @@ -1563,6 +1668,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 @@ -1575,7 +1719,7 @@ test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { set x } "abcd\ndef" test io-13.10 {TranslateInputEOL: auto mode: \n} { - # not (*src == '\r') + # not (*src == '\r') set f [open $path(test1) w] fconfigure $f -translation lf @@ -1643,7 +1787,7 @@ test io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { set l } {line line none} set path(test3) [makeFile {} test3] -test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} { +test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} exec { set f [open $path(test1) w] puts -nonewline $f { close stdin @@ -1733,7 +1877,7 @@ test io-14.7 {Tcl_GetChannel: stdio name translation} { set result } {{} {} {can not find channel named "stderr"}} set path(script) [makeFile {} script] -test io-14.8 {reuse of stdio special channels} {stdio openpipe} { +test io-14.8 {reuse of stdio special channels} stdio { file delete $path(script) file delete $path(test1) set f [open $path(script) w] @@ -1755,7 +1899,7 @@ test io-14.8 {reuse of stdio special channels} {stdio openpipe} { close $f set c } hello -test io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} { +test io-14.9 {reuse of stdio special channels} {stdio fileevent} { file delete $path(script) file delete $path(test1) set f [open $path(script) w] @@ -1924,13 +2068,13 @@ test io-20.1 {Tcl_CreateChannel: initial settings} { encoding system $old close $a set x -} {ascii} +} {ascii} test io-20.2 {Tcl_CreateChannel: initial settings} {win} { set f [open $path(test1) w+] set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] close $f set x -} [list [list \x1a ""] {auto crlf}] +} [list [list \x1A ""] {auto crlf}] test io-20.3 {Tcl_CreateChannel: initial settings} {unix} { set f [open $path(test1) w+] set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] @@ -1938,7 +2082,7 @@ test io-20.3 {Tcl_CreateChannel: initial settings} {unix} { set x } {{{} {}} {auto lf}} set path(stdout) [makeFile {} stdout] -test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} { +test io-20.5 {Tcl_CreateChannel: install channel in empty slot} stdio { set f [open $path(script) w] puts -nonewline $f { close stdout @@ -2012,14 +2156,14 @@ test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} { set l } {6 6 0 6} -test io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} { +test io-26.1 {Tcl_GetChannelInstanceData} stdio { # "pid" command uses Tcl_GetChannelInstanceData # Don't care what pid is (but must be a number), just want to exercise it. set f [open "|[list [interpreter] << exit]"] expr [pid $f] close $f -} {} +} {} # Test flushing. The functions tested here are FlushChannel. @@ -2072,7 +2216,7 @@ test io-27.4 {FlushChannel, implicit flush when buffer fills} { set l } {0 60 72} test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \ - {unixOrPc} { + {unixOrWin} { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -translation lf -buffersize 60 -eofchar {} @@ -2089,7 +2233,7 @@ test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \ set path(pipe) [makeFile {} pipe] set path(output) [makeFile {} output] test io-27.6 {FlushChannel, async flushing, async close} \ - {stdio asyncPipeClose openpipe} { + {stdio asyncPipeClose notWinCI} { # This test may fail on old Unix systems (seen on IRIX64 6.5) with # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) @@ -2158,7 +2302,7 @@ test io-28.2 {CloseChannel called when all references are dropped} { set l } abcdef test io-28.3 {CloseChannel, not called before output queue is empty} \ - {stdio asyncPipeClose nonPortable openpipe} { + {stdio asyncPipeClose nonPortable} { file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] @@ -2215,7 +2359,7 @@ test io-28.4 {Tcl_Close} {testchannel} { $consoleFileNames] string compare $l $x } 0 -test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel openpipe} { +test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} { file delete $path(script) set f [open $path(script) w] puts $f { @@ -2354,7 +2498,7 @@ test io-29.11 {Tcl_WriteChars, no newline, implicit flush} { close $f2 file size $path(test1) } 377 -test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { +test io-29.12 {Tcl_WriteChars on a pipe} stdio { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] @@ -2379,7 +2523,7 @@ test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { close $f2 set y } ok -test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} { +test io-29.13 {Tcl_WriteChars to a pipe, line buffered} stdio { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] @@ -2430,7 +2574,7 @@ test io-29.15 {Tcl_Flush, channel not open for writing} { string compare $x \ [list 1 "channel \"$fd\" wasn't opened for writing"] } 0 -test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} { +test io-29.16 {Tcl_Flush on pipe opened only for reading} stdio { set fd [open "|[list [interpreter] cat longfile]" r] set x [list [catch {flush $fd} msg] $msg] catch {close $fd} @@ -2504,7 +2648,7 @@ test io-29.20 {Implicit flush when buffer is full} { lappend z [file size $path(test1)] set z } {4096 12288 12600} -test io-29.21 {Tcl_Flush to pipe} {stdio openpipe} { +test io-29.21 {Tcl_Flush to pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {set x [read stdin 6]} @@ -2518,7 +2662,7 @@ test io-29.21 {Tcl_Flush to pipe} {stdio openpipe} { catch {close $f1} set x } "read 6 characters" -test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { +test io-29.22 {Tcl_Flush called at other end of pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { @@ -2541,7 +2685,7 @@ test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { close $f1 set x } {hello hello bye} -test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe} { +test io-29.23 {Tcl_Flush and line buffering at end of pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { @@ -2576,7 +2720,7 @@ test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} { close $f set x } "{} {Line 1\nLine 2}" -test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} { +test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio fileevent} { file delete $path(test3) set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w] puts $f "Line 1" @@ -2588,7 +2732,7 @@ test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpi close $f set x } "Line 1\nLine 2\n" -test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs openpipe} { +test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs} { set f [open "|[list cat -u]" r+] puts $f "Line1" flush $f @@ -2596,7 +2740,7 @@ test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs close $f set x } {Line1} -test io-29.27 {Tcl_Flush on closed pipeline} {stdio openpipe} { +test io-29.27 {Tcl_Flush on closed pipeline} stdio { file delete $path(pipe) set f [open $path(pipe) w] puts $f {exit} @@ -2650,7 +2794,7 @@ test io-29.30 {Tcl_WriteChars, crlf mode} { close $f file size $path(test1) } 25 -test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { +test io-29.31 {Tcl_WriteChars, background flush} stdio { # This test may fail on old Unix systems (seen on IRIX64 6.5) with # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) @@ -2687,13 +2831,13 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { set result ok } # allow a little time for the background process to close. - # otherwise, the following test fails on the [file delete $path(output) + # otherwise, the following test fails on the [file delete $path(output)] # on Windows because a process still has the file open. after 100 set v 1; vwait v set result } ok test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ - {stdio asyncPipeClose openpipe} { + {stdio asyncPipeClose notWinCI} { # This test may fail on old Unix systems (seen on IRIX64 6.5) with # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) @@ -2771,7 +2915,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 } } @@ -2802,7 +2946,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(). @@ -2917,7 +3061,7 @@ test io-30.6 {Tcl_Write cr, Tcl_Read crlf} { fconfigure $f -translation crlf set x [read $f] close $f - set x + set x } "hello\rthere\rand\rhere\r" test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { file delete $path(test1) @@ -3055,10 +3199,10 @@ test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -translation lf - puts -nonewline $f hello\nthere\nand\rhere\n\x1a + puts -nonewline $f hello\nthere\nand\rhere\n\x1A close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -eofchar \x1A -translation auto set c [read $f] close $f set c @@ -3070,11 +3214,11 @@ here test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -eofchar \x1a -translation lf + fconfigure $f -eofchar \x1A -translation lf puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -eofchar \x1A -translation auto set c [read $f] close $f set c @@ -3091,7 +3235,7 @@ test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -eofchar \x1A -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3111,7 +3255,7 @@ test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -eofchar \x1A -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3144,7 +3288,7 @@ test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { lappend l [eof $f] close $f set l -} "abc def 0 \x1aghi 0 qrs 0 {} 1" +} "abc def 0 \x1Aghi 0 qrs 0 {} 1" test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { file delete $path(test1) set f [open $path(test1) w] @@ -3156,7 +3300,7 @@ test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { fconfigure $f -translation cr -eofchar {} set l "" set x [gets $f] - lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] + lappend l [string compare $x "abc\ndef\n\x1Aghi\nqrs\n"] lappend l [eof $f] lappend l [gets $f] lappend l [eof $f] @@ -3174,7 +3318,7 @@ test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { fconfigure $f -translation crlf -eofchar {} set l "" set x [gets $f] - lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] + lappend l [string compare $x "abc\ndef\n\x1Aghi\nqrs\n"] lappend l [eof $f] lappend l [gets $f] lappend l [eof $f] @@ -3189,7 +3333,7 @@ test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3203,7 +3347,7 @@ test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3217,7 +3361,7 @@ test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3231,7 +3375,7 @@ test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3245,7 +3389,7 @@ test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3259,7 +3403,7 @@ test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3592,7 +3736,7 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -eofchar \x1A -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3607,11 +3751,11 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -eofchar \x1a -translation lf + fconfigure $f -eofchar \x1A -translation lf puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -eofchar \x1A -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3631,7 +3775,7 @@ test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a + fconfigure $f -eofchar \x1A fconfigure $f -translation auto set l "" lappend l [gets $f] @@ -3650,7 +3794,7 @@ test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -eofchar \x1A -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3681,7 +3825,7 @@ test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { lappend l [eof $f] close $f set l -} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +} "abc def 0 \x1Aqrs 0 tuv 0 {} 1" test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { file delete $path(test1) set f [open $path(test1) w] @@ -3703,7 +3847,7 @@ test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { lappend l [eof $f] close $f set l -} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +} "abc def 0 \x1Aqrs 0 tuv 0 {} 1" test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] @@ -3725,7 +3869,7 @@ test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { lappend l [eof $f] close $f set l -} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +} "abc def 0 \x1Aqrs 0 tuv 0 {} 1" test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] @@ -3734,7 +3878,7 @@ test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3752,7 +3896,7 @@ test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3770,7 +3914,7 @@ test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3788,7 +3932,7 @@ test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3806,7 +3950,7 @@ test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3824,7 +3968,7 @@ test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3845,7 +3989,7 @@ test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { } close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + fconfigure $f -translation crlf set c "" while {[gets $f line] >= 0} { append c $line\n @@ -3953,7 +4097,7 @@ test io-32.9 {Tcl_Read, read to end of file} { } set x } ok -test io-32.10 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.10 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {puts [gets stdin]} @@ -3965,9 +4109,49 @@ test io-32.10 {Tcl_Read from a pipe} {stdio openpipe} { close $f1 set x } "hello\n" -test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.11 {Tcl_Read from a pipe} stdio { + file delete $path(pipe) + set f1 [open $path(pipe) w] + 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.1 {Tcl_Read from a pipe} stdio { 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 { + 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 @@ -4075,7 +4259,7 @@ test io-33.2 {Tcl_Gets into variable} { close $f1 set z } ok -test io-33.3 {Tcl_Gets from pipe} {stdio openpipe} { +test io-33.3 {Tcl_Gets from pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {puts [gets stdin]} @@ -4105,6 +4289,13 @@ test io-33.4 {Tcl_Gets with long line} { close $f set x } {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +set f [open $path(test3) w] +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +close $f test io-33.5 {Tcl_Gets with long line} { set f [open $path(test3)] set x [gets $f y] @@ -4178,6 +4369,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. @@ -4272,7 +4567,7 @@ test io-34.7 {Tcl_Seek to offset from end of file, then to current position} { close $f1 list $c1 $r1 $c2 } {44 rstuv 49} -test io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} { +test io-34.8 {Tcl_Seek on pipes: not supported} stdio { set f1 [open "|[list [interpreter]]" r+] set x [list [catch {seek $f1 0 current} msg] $msg] close $f1 @@ -4380,13 +4675,13 @@ test io-34.15 {Tcl_Tell combined with seeking} { close $f1 list $c1 $c2 } {10 20} -test io-34.16 {Tcl_Tell on pipe: always -1} {stdio openpipe} { +test io-34.16 {Tcl_Tell on pipe: always -1} stdio { set f1 [open "|[list [interpreter]]" r+] set c [tell $f1] close $f1 set c } -1 -test io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { +test io-34.17 {Tcl_Tell on pipe: always -1} stdio { set f1 [open "|[list [interpreter]]" r+] puts $f1 {puts hello} flush $f1 @@ -4457,10 +4752,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} @@ -4485,7 +4780,7 @@ test io-35.1 {Tcl_Eof} { close $f set x } {0 0 0 0 1 1} -test io-35.2 {Tcl_Eof with pipe} {stdio openpipe} { +test io-35.2 {Tcl_Eof with pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {gets stdin} @@ -4503,7 +4798,7 @@ test io-35.2 {Tcl_Eof with pipe} {stdio openpipe} { close $f1 set x } {0 0 0 1} -test io-35.3 {Tcl_Eof with pipe} {stdio openpipe} { +test io-35.3 {Tcl_Eof with pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {gets stdin} @@ -4537,7 +4832,7 @@ test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { close $f set l } {{} 1} -test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} { +test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} stdio { file delete $path(pipe) set f [open $path(pipe) w] puts $f { @@ -4554,12 +4849,12 @@ test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} { test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4568,12 +4863,12 @@ test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4582,12 +4877,12 @@ test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar \x1a + 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 auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4596,12 +4891,12 @@ test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar \x1a + 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 cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4610,12 +4905,12 @@ test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4624,12 +4919,12 @@ test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -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 + fconfigure $f -translation crlf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4644,7 +4939,7 @@ test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4659,7 +4954,7 @@ test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4674,7 +4969,7 @@ test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4689,7 +4984,7 @@ test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4704,7 +4999,7 @@ test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4719,16 +5014,102 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A set l [string length [read $f]] set e [eof $f] 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 -test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { +test io-36.1 {Tcl_InputBlocked on nonblocking pipe} stdio { set f1 [open "|[list [interpreter]]" r+] puts $f1 {puts hello_from_pipe} flush $f1 @@ -4747,7 +5128,30 @@ test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { close $f1 set x } {{} 1 hello 0 {} 1} -test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} { +test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} stdio { + 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 { set f1 [open "|[list [interpreter]]" r+] fconfigure $f1 -buffering line puts $f1 {puts hello_from_pipe} @@ -5011,7 +5415,7 @@ test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { close $f1 set x } {1 0 {} {} 0 1} -test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { +test io-39.10 {Tcl_SetChannelOption, blocking mode} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { @@ -5074,7 +5478,7 @@ test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -encoding {} + fconfigure $f -encoding {} puts -nonewline $f \xe7\x89\xa6 close $f set f [open $path(test1) r] @@ -5102,7 +5506,7 @@ test io-39.16 {Tcl_SetChannelOption: -encoding, errors} { close $f set result } {1 {unknown encoding "foobar"}} -test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} { +test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio fileevent} { set f [open "|[list [interpreter] $path(cat)]" r+] fconfigure $f -encoding binary puts -nonewline $f "\xe7" @@ -5237,7 +5641,7 @@ test io-40.2 {POSIX open access modes: CREAT} {unix} { file delete $path(test3) set f [open $path(test3) {WRONLY CREAT} 0o600] file stat $path(test3) stats - set x [format "0o%o" [expr $stats(mode)&0o777]] + set x [format "%#o" [expr $stats(mode)&0o777]] puts $f "line 1" close $f set f [open $path(test3) r] @@ -5251,8 +5655,8 @@ test io-40.3 {POSIX open access modes: CREAT} {unix umask} { set f [open $path(test3) {WRONLY CREAT}] close $f file stat $path(test3) stats - format "0%o" [expr $stats(mode)&0o777] -} [format %04o [expr {0o666 & ~ $umaskValue}]] + format 0o%03o [expr $stats(mode)&0o777] +} [format 0o%03o [expr {0o666 & ~ $umaskValue}]] test io-40.4 {POSIX open access modes: CREAT} { file delete $path(test3) set f [open $path(test3) w] @@ -5451,7 +5855,7 @@ test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs f test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { set result {} lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] fileevent $f r "read f" @@ -5472,7 +5876,7 @@ test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { test io-44.1 {FileEventProc procedure: normal read event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { fileevent $f2 readable [namespace code { set x [gets $f2]; fileevent $f2 readable {} }] @@ -5485,7 +5889,7 @@ test io-44.1 {FileEventProc procedure: normal read event} -setup { catch {close $f3} } -result {text} test io-44.2 {FileEventProc procedure: error in read event} -constraints { - stdio unixExecs fileevent openpipe + stdio unixExecs fileevent } -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] @@ -5508,7 +5912,7 @@ test io-44.2 {FileEventProc procedure: error in read event} -constraints { test io-44.3 {FileEventProc procedure: normal write event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { fileevent $f2 writable [namespace code { lappend x "triggered" incr count -1 @@ -5527,7 +5931,7 @@ test io-44.3 {FileEventProc procedure: normal write event} -setup { catch {close $f3} } -result {initial triggered triggered triggered} test io-44.4 {FileEventProc procedure: eror in write event} -constraints { - stdio unixExecs fileevent openpipe + stdio unixExecs fileevent } -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] @@ -5546,7 +5950,9 @@ test io-44.4 {FileEventProc procedure: eror in write event} -constraints { catch {close $f2} catch {close $f3} } -result {bad-write {}} -test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { +test io-44.5 {FileEventProc procedure: end of file} -constraints { + stdio unixExecs fileevent +} -body { set f4 [open "|[list [interpreter] $path(cat) << foo]" r] fileevent $f4 readable [namespace code { if {[gets $f4 line] < 0} { @@ -5559,11 +5965,76 @@ test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fi variable x initial vwait [namespace which -variable x] vwait [namespace which -variable x] - close $f4 set x -} {initial foo eof} +} -cleanup { + close $f4 +} -result {initial foo eof} close $f + +test io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup { +} -constraints {stdio fileevent openpipe} -body { + + namespace eval refchan { + namespace ensemble create + namespace export * + + + proc finalize {chan args} { + namespace delete c_$chan + } + + proc initialize {chan args} { + namespace eval c_$chan {} + namespace upvar c_$chan watching watching + set watching {} + list finalize initialize seek watch write + } + + + proc watch {chan args} { + namespace upvar c_$chan watching watching + foreach arg $args { + switch $arg { + write { + if {$arg ni $watching} { + lappend watching $arg + } + chan postevent $chan $arg + } + } + } + } + + + proc write {chan args} { + chan postevent $chan write + return 1 + } + } + set f [chan create w [namespace which refchan]] + chan configure $f -blocking 0 + set data "some data" + set x 0 + chan event $f writable [namespace code { + puts $f $data + incr count [string length $data] + if {$count > 262144} { + chan event $f writable {} + set x done + } + }] + set token [after 10000 [namespace code { + set x timeout + }]] + vwait [namespace which -variable x] + return $x +} -cleanup { + after cancel $token + catch {chan close $f} +} -result done + + makeFile "foo bar" foo test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} { @@ -5620,7 +6091,7 @@ test io-45.3 {DeleteFileEvent, cleanup on close} {fileevent} { # Execute these tests only if the "testfevent" command is present. -test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { +test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent notOSX} { testfevent create set script "set f \[[list open $path(foo) r]]\n" append script { @@ -5630,9 +6101,10 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { fileevent $f readable {} }] } + set timer [after 10 lappend x timeout] testfevent cmd $script - after 1 ;# We must delay because Windows takes a little time to notice - update + vwait x + after cancel $timer testfevent cmd {close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} @@ -5762,6 +6234,8 @@ test io-47.6 {file events on shared files, deleting file events} {testfevent fil close $f set x } {{script 1} {}} +unset path(foo) +removeFile foo set path(bar) [makeFile {} bar] @@ -5819,7 +6293,7 @@ test io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { list $x $l } {done {called called called called called called called}} set path(my_script) [makeFile {} my_script] -test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe fileevent} { +test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles fileevent} { set f [open $path(bar) w] puts $f abcdefg puts $f abcdefg @@ -5864,6 +6338,9 @@ test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe close $f list $x $l } {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} +unset path(bar) +removeFile bar + test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] @@ -5886,7 +6363,7 @@ test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -5914,7 +6391,7 @@ test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -eofchar \x1A -translation auto fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -5942,7 +6419,7 @@ test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -5970,7 +6447,7 @@ test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -eofchar \x1A -translation auto fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -5998,7 +6475,7 @@ test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} { set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6026,7 +6503,7 @@ test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -eofchar \x1A -translation auto fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6054,7 +6531,7 @@ test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation lf + fconfigure $f -eofchar \x1A -translation lf fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6082,7 +6559,7 @@ test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fil set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6110,7 +6587,7 @@ test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation cr + fconfigure $f -eofchar \x1A -translation cr fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6138,7 +6615,7 @@ test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fil set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6166,7 +6643,7 @@ test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {f set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation crlf + fconfigure $f -eofchar \x1A -translation crlf fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6194,7 +6671,7 @@ test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6314,47 +6791,57 @@ test io-49.5 {testing crlf reading, leftover cr disgorgment} { set l } [list 7 a\rb\rc 7 {} 7 1] -test io-50.1 {testing handler deletion} {testchannelevent} { +test io-50.1 {testing handler deletion} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f]] + update proc delhandler {f} { variable z set z called testchannelevent $f delete 0 } set z not_called - update - close $f + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f]] + testservicemode 1 + vwait z + after cancel $timer set z -} called -test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} { +} -cleanup { + close $f +} -result called +test io-50.2 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] proc delhandler {f i} { variable z - lappend z "called delhandler $f $i" + lappend z "called delhandler $i" testchannelevent $f delete 0 } set z "" - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z +} -cleanup { close $f - string compare [string tolower $z] \ - [list [list called delhandler $f 0] [list called delhandler $f 1]] -} 0 -test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} { +} -result {{called delhandler 0} {called delhandler 1}} +test io-50.3 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] set z "" proc notcalled {f i} { variable z @@ -6363,23 +6850,30 @@ test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent proc delhandler {f i} { variable z testchannelevent $f delete 1 - lappend z "delhandler $f $i called" + lappend z "delhandler $i called" testchannelevent $f delete 0 - lappend z "delhandler $f $i deleted myself" + lappend z "delhandler $i deleted myself" } set z "" - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z +} -cleanup { close $f - string compare [string tolower $z] \ - [list [list delhandler $f 0 called] \ - [list delhandler $f 0 deleted myself]] -} 0 -test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -result {{delhandler 0 called} {delhandler 0 deleted myself}} +test io-50.4 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) + update +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delrecursive $f]] + update proc delrecursive {f} { variable z variable u @@ -6394,18 +6888,22 @@ test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} { } variable u toplevel variable z "" - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delrecursive $f]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z +} -cleanup { close $f - string compare [string tolower $z] \ - {{delrecursive calling recursive} {delrecursive deleting recursive}} -} 0 -test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -result {{delrecursive calling recursive} {delrecursive deleting recursive}} +test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode notOSX} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f]] - testchannelevent $f add readable [namespace code [list del $f]] proc notcalled {f} { variable z lappend z "notcalled was called!! $f" @@ -6415,39 +6913,50 @@ test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} { variable z if {"$u" == "recursive"} { testchannelevent $f delete 1 - testchannelevent $f delete 0 lappend z "del deleted notcalled" + testchannelevent $f delete 0 lappend z "del deleted myself" } else { set u recursive lappend z "del calling recursive" - update - lappend z "del after update" + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + lappend z "del after recursive" } } set z "" set u toplevel - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f]] + testchannelevent $f add readable [namespace code [list del $f]] + testservicemode 1 + set timer [after 50 set z timeout] + vwait z + after cancel $timer + set z +} -cleanup { close $f - string compare [string tolower $z] \ - [list {del calling recursive} {del deleted notcalled} \ - {del deleted myself} {del after update}] -} 0 -test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -result [list {del calling recursive} {del deleted notcalled} \ + {del deleted myself} {del after recursive}] +test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list second $f]] - testchannelevent $f add readable [namespace code [list first $f]] proc first {f} { variable u variable z + variable done if {"$u" == "toplevel"} { lappend z "first called" set u first - update - lappend z "first after update" + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + lappend z "first after toplevel" + set done 1 } else { lappend z "first called not toplevel" } @@ -6469,14 +6978,24 @@ test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} { } set z "" set u toplevel + set done 0 + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list second $f]] + testchannelevent $f add readable [namespace code [list first $f]] + testservicemode 1 update + if {!$done} { + set timer2 [after 200 set done 1] + vwait done + after cancel $timer2 + } + set z +} -cleanup { close $f - string compare [string tolower $z] \ - [list {first called} {first called not toplevel} \ - {second called, first time} {second called, second time} \ - {first after update}] -} 0 - +} -result [list {first called} {first called not toplevel} \ + {second called, first time} {second called, second time} \ + {first after toplevel}] test io-51.1 {Test old socket deletion on Macintosh} {socket} { set x 0 set result "" @@ -6564,11 +7083,23 @@ test io-52.4 {TclCopyChannel} {fcopy} { fconfigure $f1 -translation lf -blocking 0 fconfigure $f2 -translation cr -blocking 0 fcopy $f1 $f2 -size 40 - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + close $f1 + close $f2 + lappend result [file size $path(test1)] +} {0 0 0 40} +test io-52.4.1 {TclCopyChannel} {fcopy} { + file delete $path(test1) + set f1 [open $thisScript] + set f2 [open $path(test1) w] + fconfigure $f1 -translation lf -blocking 0 -buffersize 10000000 + fconfigure $f2 -translation cr -blocking 0 + fcopy $f1 $f2 -size 40 + set result [list [fblocked $f1] [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 close $f2 lappend result [file size $path(test1)] -} {0 0 40} +} {0 0 0 40} test io-52.5 {TclCopyChannel, all} {fcopy} { file delete $path(test1) set f1 [open $thisScript] @@ -6654,7 +7185,7 @@ test io-52.7 {TclCopyChannel} {fcopy} { } set result } {0 0 ok} -test io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { +test io-52.8 {TclCopyChannel} {stdio fcopy} { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] @@ -6736,7 +7267,12 @@ test io-52.10 {TclCopyChannel & encodings} {fcopy} { file size $path(utf8-fcopy.txt) } 5 -test io-52.11 {TclCopyChannel & encodings} {fcopy} { +test io-52.11 {TclCopyChannel & encodings} -setup { + set out [open $path(utf8-fcopy.txt) w] + fconfigure $out -encoding utf-8 -translation lf + puts $out "\u0410\u0410" + close $out +} -constraints {fcopy} -body { # binary to encoding => the input has to be # in utf-8 to make sense to the encoder @@ -6752,7 +7288,151 @@ test io-52.11 {TclCopyChannel & encodings} {fcopy} { close $out file size $path(kyrillic.txt) +} -result 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) @@ -6785,7 +7465,7 @@ test io-53.2 {CopyData} {fcopy} { } set result } {0 0 ok} -test io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} { +test io-53.3 {CopyData: background read underflow} {stdio unix fcopy} { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] @@ -6817,23 +7497,18 @@ test io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} { close $f set result } "ready line1 line2 {done\n}" -test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileevent fcopy} { +test io-53.4 {CopyData: background write overflow} {stdio fileevent fcopy} { set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n variable x for {set x 0} {$x < 12} {incr x} { append big $big } - 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 } close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] @@ -6841,11 +7516,10 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven fconfigure $f1 -blocking 0 puts $f1 $big flush $f1 - after 500 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 } }] @@ -6854,6 +7528,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" @@ -6875,14 +7581,14 @@ test io-53.5 {CopyData: error during fcopy} {socket fcopy} { close $listen ;# This means the socket open never really succeeds fcopy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g. } close $in close $out set fcopyTestDone ;# 1 for error condition } 1 -test io-53.6 {CopyData: error during fcopy} {stdio openpipe fcopy} { +test io-53.6 {CopyData: error during fcopy} {stdio fcopy} { variable fcopyTestDone file delete $path(pipe) file delete $path(test1) @@ -6894,7 +7600,7 @@ test io-53.6 {CopyData: error during fcopy} {stdio openpipe fcopy} { set out [open $path(test1) w] fcopy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] } catch {close $in} @@ -6915,7 +7621,7 @@ proc doFcopy {in out {bytes 0} {error {}}} { -command [namespace code [list doFcopy $in $out]]] } } -test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} { +test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} { variable fcopyTestDone file delete $path(pipe) catch {unset fcopyTestDone} @@ -6941,7 +7647,7 @@ test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} { set out [open $path(test1) w] doFcopy $in $out variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] } catch {close $in} @@ -6967,7 +7673,7 @@ test io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. @@ -7008,7 +7714,7 @@ test io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Initialize and force eof on the input. seek $f 0 end ; read $f 1 set ::RES [eof $f] @@ -7048,7 +7754,7 @@ test io-53.8b {CopyData: async callback and -size 0} -setup { # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set ::RES {} # Run the copy. Should not invoke -command now. fcopy $f $g -size 0 -command ::cmd @@ -7105,7 +7811,7 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { } set ::forever {} set out [open $out w] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { fcopy $pipe $out -size 6 -command ::done set token [after 5000 { set ::forever {fcopy hangs} @@ -7175,7 +7881,7 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { fconfigure $b -translation binary -buffering none fileevent $a readable [list ::done $a] fileevent $b readable [list ::done $b] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Now pass data through the server in both directions. set ::forever {} puts $a AB @@ -7223,8 +7929,213 @@ test io-53.11 {Bug 2895565} -setup { removeFile out removeFile in } -result {40 bytes copied} +test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix fcopy} { + file delete $path(pipe) + set f1 [open $path(pipe) w] + puts -nonewline $f1 { + fconfigure stdin -translation binary -blocking 0 + fconfigure stdout -buffering none -translation binary + fcopy stdin stdout + } + close $f1 + set f1 [open "|[list [interpreter] $path(pipe)]" r+] + fconfigure $f1 -translation binary -buffering none + puts -nonewline $f1 A + after 2000 {set ::done timeout} + fileevent $f1 readable {set ::done ok} + vwait ::done + set ch [read $f1 1] + close $f1 + list $::done $ch +} {ok A} +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-53.16 {[ed29c4da21] MBRead: 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 -translation lf + set out [makeFile {} out] + set outChan [open $out w] + chan configure $outChan -encoding utf-8 -translation lf +} -body { + chan copy $c $outChan +} -cleanup { + close $outChan + close $c + removeFile out +} -result 100 +test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup { + 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 \ + line\n[string repeat a 100]line\n] + 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 -translation lf -buffersize 107 + set out [makeFile {} out] + set outChan [open $out w] + chan configure $outChan -encoding utf-8 -translation lf +} -body { + list [gets $c] [chan copy $c $outChan -size 100] [gets $c] +} -cleanup { + close $outChan + close $c + removeFile out +} -result {line 100 line} -test io-54.1 {Recursive channel events} {socket fileevent} { +test io-54.1 {Recursive channel events} {socket fileevent notWinCI} { # This test checks to see if file events are delivered during recursive # event loops when there is buffered data on the channel. @@ -7433,7 +8344,7 @@ test io-57.2 {buffered data and file events, read} {fileevent} { set result } {1 readable 234567890 timer} -test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} { +test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} { set out [open $path(script) w] puts $out { puts "normal message from pipe" @@ -7473,12 +8384,13 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} { string equal $result [testmainthread] } {1} -test io-60.1 {writing illegal utf sequences} {openpipe fileevent} { +test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] + puts $out "catch {load $::tcltestlib Tcltest}" puts $out { - puts [encoding convertfrom identity \xe2] + puts [testbytestring \xe2] exit 1 } proc readit {pipe} { @@ -7788,6 +8700,82 @@ test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} -setup { close $f } -result {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] + +test io-74.1 {[104f2885bb] improper cache validity check} -setup { + set fn [makeFile {} io-74.1] + set rfd [open $fn r] + testobj freeallvars + interp create child +} -constraints testobj -body { + teststringobj set 1 [string range $rfd 0 end] + read [teststringobj get 1] + testobj duplicate 1 2 + interp transfer {} $rfd child + catch {read [teststringobj get 1]} + read [teststringobj get 2] +} -cleanup { + interp delete child + testobj freeallvars + removeFile io-74.1 +} -returnCodes error -match glob -result {can not find channel named "*"} + # ### ### ### ######### ######### ######### # cleanup diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 5eb0206..bdf162d 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -6,25 +6,25 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] + +package require tcltests # Custom constraints used in this file -testConstraint fcopy [llength [info commands fcopy]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] #---------------------------------------------------------------------- @@ -154,10 +154,10 @@ test iocmd-4.11 {read command} { test iocmd-4.12 {read command} -setup { set f [open $path(test1)] } -body { - list [catch {read $f 12z} msg] $msg $::errorCode + read $f 12z } -cleanup { close $f -} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}} +} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER} test iocmd-5.1 {seek command} -returnCodes error -body { seek @@ -206,83 +206,95 @@ test iocmd-7.5 {close command} -setup { close $chan } -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed" -test iocmd-8.1 {fconfigure command} { - list [catch {fconfigure} msg] $msg -} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} -test iocmd-8.2 {fconfigure command} { - list [catch {fconfigure a b c d e f} msg] $msg -} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} -test iocmd-8.3 {fconfigure command} { - list [catch {fconfigure a b} msg] $msg -} {1 {can not find channel named "a"}} -test iocmd-8.4 {fconfigure command} { +proc expectedOpts {got extra} { + set basicOpts { + -blocking -buffering -buffersize -encoding -eofchar -translation + } + set opts [list {*}$basicOpts {*}$extra] + lset opts end [string cat "or " [lindex $opts end]] + return [format {bad option "%s": should be one of %s} $got [join $opts ", "]] +} +test iocmd-8.1 {fconfigure command} -returnCodes error -body { + fconfigure +} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"} +test iocmd-8.2 {fconfigure command} -returnCodes error -body { + fconfigure a b c d e f +} -result {wrong # args: should be "fconfigure channelId ?-option value ...?"} +test iocmd-8.3 {fconfigure command} -returnCodes error -body { + fconfigure a b +} -result {can not find channel named "a"} +test iocmd-8.4 {fconfigure command} -setup { file delete $path(test1) set f1 [open $path(test1) w] - set x [list [catch {fconfigure $f1 froboz} msg] $msg] +} -body { + fconfigure $f1 froboz +} -returnCodes error -cleanup { close $f1 - set x -} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.5 {fconfigure command} { - list [catch {fconfigure stdin -buffering froboz} msg] $msg -} {1 {bad value for -buffering: must be one of full, line, or none}} -test iocmd-8.6 {fconfigure command} { - list [catch {fconfigure stdin -translation froboz} msg] $msg -} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} -test iocmd-8.7 {fconfigure command} { +} -result [expectedOpts "froboz" {}] +test iocmd-8.5 {fconfigure command} -returnCodes error -body { + fconfigure stdin -buffering froboz +} -result {bad value for -buffering: must be one of full, line, or none} +test iocmd-8.6 {fconfigure command} -returnCodes error -body { + fconfigure stdin -translation froboz +} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform} +test iocmd-8.7 {fconfigure command} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} -encoding unicode - set x [fconfigure $f1] - close $f1 - set x -} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} -test iocmd-8.8 {fconfigure command} { + fconfigure $f1 -translation lf -eofchar {} -encoding utf-16 + fconfigure $f1 +} -cleanup { + catch {close $f1} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -translation lf} +test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) + set x {} +} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ - -eofchar {} -encoding unicode - set x "" + -eofchar {} -encoding utf-16 lappend x [fconfigure $f1 -buffering] lappend x [fconfigure $f1] - close $f1 - set x -} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} -test iocmd-8.9 {fconfigure command} { +} -cleanup { + catch {close $f1} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -translation lf}} +test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ -eofchar {} -encoding binary - set x [fconfigure $f1] - close $f1 - set x -} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} -test iocmd-8.10 {fconfigure command} { - list [catch {fconfigure a b} msg] $msg -} {1 {can not find channel named "a"}} + fconfigure $f1 +} -cleanup { + catch {close $f1} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} +test iocmd-8.10 {fconfigure command} -returnCodes error -body { + fconfigure a b +} -result {can not find channel named "a"} set path(fconfigure.dummy) [makeFile {} fconfigure.dummy] -test iocmd-8.11 {fconfigure command} { +test iocmd-8.11 {fconfigure command} -body { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg] - close $chan - set res -} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.12 {fconfigure command} { + fconfigure $chan -froboz blarfo +} -returnCodes error -cleanup { + catch {close $chan} +} -result [expectedOpts "-froboz" {}] +test iocmd-8.12 {fconfigure command} -body { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -b blarfo} msg] $msg] - close $chan - set res -} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.13 {fconfigure command} { + fconfigure $chan -b blarfo +} -returnCodes error -cleanup { + catch {close $chan} +} -result [expectedOpts "-b" {}] +test iocmd-8.13 {fconfigure command} -body { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg] - close $chan - set res -} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} + fconfigure $chan -buffer blarfo +} -returnCodes error -cleanup { + catch {close $chan} +} -result [expectedOpts "-buffer" {}] removeFile fconfigure.dummy test iocmd-8.14 {fconfigure command} { fconfigure stdin -buffers } 4096 -test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrPc} -setup { +test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] proc iocmdSRV {sock ip port} {close $sock} @@ -294,7 +306,7 @@ test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOr close $srv unset cli srv port rename iocmdSRV {} -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -peername, or -sockname} +} -returnCodes error -result [expectedOpts "-blah" {-connecting -peername -sockname}] test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] @@ -337,7 +349,7 @@ test iocmd-8.18 {fconfigure command / unix tty channel} -constraints {nonPortabl if {$tty ne ""} { close $tty } -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode} +} -returnCodes error -result [expectedOpts "-blah" {-closemode -inputmode -mode -queue -ttystatus -xchar}] test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup { set tty "" } -body { @@ -348,8 +360,14 @@ test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable if {$tty ne ""} { close $tty } -} -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -mode, -handshake, -pollinterval, -sysbuffer, -timeout, -ttycontrol, or -xchar} -# TODO: Test parsing of serial channel options (nonportable, since requires an +} -returnCodes error -result [expectedOpts "-blah" {-closemode -mode -handshake -pollinterval -sysbuffer -timeout -ttycontrol -xchar}] +test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPortable win} -setup { + # I don't know how else to open the console, but this is non-portable + set console stdin +} -body { + fconfigure $console -blah blih +} -returnCodes error -result [expectedOpts "-blah" {-inputmode}] +# TODO: Test parsing of serial channel options (nonPortable, since requires an # open channel to work with). test iocmd-9.1 {eof command} { @@ -384,19 +402,18 @@ test iocmd-10.5 {fblocked command} { set path(test4) [makeFile {} test4] set path(test5) [makeFile {} test5] -file delete $path(test5) -test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { +test iocmd-11.1 {I/O to command pipelines} {unixOrWin unixExecs} { set f [open $path(test4) w] close $f list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode } {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}} -test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { +test iocmd-11.2 {I/O to command pipelines} {unixOrWin unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode } {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} -test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} { +test iocmd-11.3 {I/O to command pipelines} {unixOrWin unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode } {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} -test iocmd-11.4 {I/O to command pipelines} unixOrPc { +test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrWin} { list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode } {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}} @@ -639,7 +656,7 @@ test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} { } "1 {channel \"$rfile\" wasn't opened for writing}" test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile foo bar} msg] $msg -} {1 {bad switch "foo": must be -size or -command}} +} {1 {bad option "foo": must be -size or -command}} test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile -size foo} msg] $msg } {1 {expected integer but got "foo"}} @@ -793,6 +810,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 { + chan configure $ch -blocking 0 +} -cleanup { + close $ch + rename foo {} +} -match glob -returnCodes 1 -result {*(infinite loop?)*} +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. @@ -829,6 +930,17 @@ proc onfinal {} { if {[lindex $hargs 0] ne "finalize"} {return} return -code return "" } + +proc onwatch {} { + upvar args hargs + lassign $hargs watch chan eventspec + if {$watch ne "watch"} return + foreach spec $eventspec { + chan postevent $chan $spec + } + return +} + } # Set everything up in the main thread. @@ -1051,6 +1163,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 @@ -1887,28 +2013,29 @@ test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c readable {note TOCK}] - set stop [after 10000 {note TIMEOUT}] + set tock {} + note [fileevent $c readable {lappend res TOCK; set tock 1}] + set stop [after 15000 {lappend res TIMEOUT; set tock 1}] after 1000 {note [chan postevent $c r]} - vwait ::res + vwait ::tock catch {after cancel $stop} close $c rename foo {} set res -} -result {{watch rc* read} {} TOCK {} {watch rc* {}}} +} -result {{watch rc* read} {} {} TOCK {watch rc* {}}} test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c writable {note TOCK}] - set stop [after 10000 {note TIMEOUT}] + note [fileevent $c writable {lappend res TOCK; set tock 1}] + set stop [after 15000 {lappend res TIMEOUT; set tock 1}] after 1000 {note [chan postevent $c w]} - vwait ::res + vwait ::tock catch {after cancel $stop} close $c rename foo {} set res -} -result {{watch rc* write} {} TOCK {} {watch rc* {}}} +} -result {{watch rc* write} {} {} TOCK {watch rc* {}}} test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { proc foo {args} {oninit; onfinal; track; return} proc dummy args { return } @@ -1921,6 +2048,31 @@ test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { rename foo {} rename dummy {} } -returnCodes error -result {can not find reflected channel named "rc*"} +test iocmd-31.9 { + chan postevent + + call to current coroutine + + see 67a5eabbd3d1 +} -match glob -body { + set res {} + proc foo {args} {oninit; onwatch; onfinal; track; return} + set c [chan create {r w} foo] + after 0 [list ::apply [list c { + coroutine c1 ::apply [list c { + chan event $c readable [list [info coroutine]] + yield + set ::done READING + } [namespace current]] $c + } [namespace current]] $c] + set stop [after 10000 {set done TIMEOUT}] + vwait ::done + catch {after cancel $stop} + lappend res $done + close $c + rename foo {} + set res +} -result {{watch rc* read} READING {watch rc* {}}} # --- === *** ########################### # 'Pull the rug' tests. Create channel in a interpreter A, move to @@ -1932,7 +2084,7 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb @@ -1960,6 +2112,8 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { lappend res [catch {interp eval $idb [list close $chan]} msg] $msg set res +} -cleanup { + interp delete $idb } -constraints {testchannel} \ -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} @@ -1968,7 +2122,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb @@ -1978,13 +2132,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] @@ -2002,20 +2156,21 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m set res }] set res -} -constraints {testchannel impossible} \ - -result {Owner lost} +} -cleanup { + interp delete $idb +} -constraints {testchannel} -result {Owner lost} test iocmd-32.2 {delete interp of reflected chan} { # Bug 3034840 # Run this test in an interp with memory debugging to panic # on the double free - interp create slave - slave eval { + interp create child + child eval { proc no-op args {} proc driver {sub args} {return {initialize finalize watch read}} chan event [chan create read driver] readable no-op } - interp delete slave + interp delete child } {} # ### ### ### ######### ######### ######### @@ -2651,10 +2806,9 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ init* {set ret {initialize finalize watch read}} watch { set l [lindex $args 0] + catch {after cancel $::timer} if {[llength $l]} { set ::timer [after $::drive [list POST $ch]] - } else { - after cancel $::timer } } finalize { @@ -2717,7 +2871,9 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ update } LOG THREAD-LOOP-DONE - thread::exit + #thread::exit + # Thread exits cause leaks; Use clean thread shutdown + set forever yourGirl } LOG MAIN_WAITING @@ -2726,10 +2882,11 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ set res } -cleanup { + after cancel $::timer rename LOG {} rename POST {} rename HANDLER {} - unset beat drive data forever res tid ch + unset beat drive data forever res tid ch timer } -match glob \ -result {{initialize rc* read} {watch rc* read} {read rc* 4096} {watch rc* {}} {watch rc* read} {read rc* 4096} {watch rc* {}} {finalize rc*}} @@ -3671,7 +3828,7 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { # The test iocmd.tf-32.1 unavoidably exhibits a memory leak. We are testing # the ability of the reflected channel system to react to the situation where # the thread in which the driver routines runs exits during driver operations. -# In this case, thread exit handlers signal back to the owner thread so that the +# In this case, thread exit handlers signal back to the owner thread so that the # channel operation does not hang. There's no way to test this without actually # exiting a thread in mid-operation, and that action is unavoidably leaky (which # is why [thread::exit] is advised against). @@ -3679,7 +3836,6 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { # Use constraints to skip this test while valgrinding so this expected leak # doesn't prevent a finding of "leak-free". # -testConstraint notValgrind [expr {![testConstraint valgrind]}] test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body { #puts <<$tcltest::mainThread>>main @@ -3732,13 +3888,21 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat rename track {} # cleanup + + +# Eliminate valgrind "still reachable" reports on outstanding "Detached" +# structures in the detached list which stem from PipeClose2Proc not waiting +# around for background processes to complete, meaning that previous calls to +# Tcl_ReapDetachedProcs might not have had a chance to reap all processes. +after 10 +exec [info nameofexecutable] << {} + + foreach file [list test1 test2 test3 test4] { removeFile $file } # delay long enough for background processes to finish after 500 -foreach file [list test5] { - removeFile $file -} +removeFile test5 cleanupTests return diff --git a/tests/ioTrans.test b/tests/ioTrans.test index db9a2cb..79493e0 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -5,23 +5,23 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2007 Andreas Kupries <andreask@activestate.com> +# Copyright © 2007 Andreas Kupries <andreask@activestate.com> # <akupries@shaw.ca> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Custom constraints used in this file testConstraint testchannel [llength [info commands testchannel]] -testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # testchannel cut|splice Both needed to test the reflection in threads. # thread::send @@ -36,8 +36,8 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] # can access this variable. set helperscript { - if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -283,6 +283,8 @@ test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} lappend res [catch {close $c} msg] $msg lappend res [file channels file*] lappend res [file channels rt*] +} -cleanup { + tempdone } -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}} test iortrans-3.2 {chan finalize, for close} -setup { set res {} @@ -300,6 +302,7 @@ test iortrans-3.2 {chan finalize, for close} -setup { lappend res [info command foo] } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} test iortrans-3.3 {chan finalize, for close, error, close error} -setup { set res {} @@ -315,6 +318,7 @@ test iortrans-3.3 {chan finalize, for close, error, close error} -setup { lappend res [file channels rt*] } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} test iortrans-3.4 {chan finalize, for close, error, close error} -setup { set res {} @@ -328,6 +332,7 @@ test iortrans-3.4 {chan finalize, for close, error, close error} -setup { lappend res [catch {close $c} msg] $msg $::errorInfo } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO *"close $c"}} test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup { @@ -342,6 +347,7 @@ test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup { lappend res [catch {close $c} msg] $msg } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} test iortrans-3.6 {chan finalize, for close, break, close error} -setup { set res {} @@ -355,6 +361,7 @@ test iortrans-3.6 {chan finalize, for close, break, close error} -setup { lappend res [catch {close $c} msg] $msg } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} test iortrans-3.7 {chan finalize, for close, continue, close error} -setup { set res {} @@ -368,6 +375,7 @@ test iortrans-3.7 {chan finalize, for close, continue, close error} -setup { lappend res [catch {close $c} msg] $msg } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup { set res {} @@ -381,6 +389,7 @@ test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup { lappend res [catch {close $c} msg] $msg } -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup { set res {} @@ -395,6 +404,7 @@ test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup { noteOpts $opt } -match glob -cleanup { rename foo {} + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} # --- === *** ########################### @@ -529,7 +539,46 @@ test iortrans-4.8 {chan read, read, bug 2921116} -setup { tempdone rename foo {} } -result {{read rt* {test data -}} file*} +}} {}} +test iortrans-4.8.1 {chan read, bug 721ec69271} -setup { + set res {} +} -match glob -body { + proc foo {fd args} { + handle.initialize + handle.finalize + lappend ::res $args + # Kill and recreate transform while it is operating + chan pop $fd + chan push $fd [list foo $fd] + } + set c [chan push [set c [tempchan]] [list foo $c]] + chan configure $c -buffersize 2 + lappend res [read $c] +} -cleanup { + tempdone + rename foo {} +} -result {{read rt* te} {read rt* st} {read rt* { d}} {read rt* at} {read rt* {a +}} {}} +test iortrans-4.8.2 {chan read, bug 721ec69271} -setup { + set res {} +} -match glob -body { + proc foo {fd args} { + handle.initialize + handle.finalize + lappend ::res $args + # Kill and recreate transform while it is operating + chan pop $fd + chan push $fd [list foo $fd] + return x + } + set c [chan push [set c [tempchan]] [list foo $c]] + chan configure $c -buffersize 1 + lappend res [read $c] +} -cleanup { + tempdone + rename foo {} +} -result {{read rt* t} {read rt* e} {read rt* s} {read rt* t} {read rt* { }} {read rt* d} {read rt* a} {read rt* t} {read rt* a} {read rt* { +}} {}} test iortrans-4.9 {chan read, gets, bug 2921116} -setup { set res {} } -match glob -body { @@ -547,7 +596,180 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -setup { tempdone rename foo {} } -result {{read rt* {test data -}} file*} +}} {}} + +# Driver for a base channel that emits several short "files" +# with each terminated by a fleeting EOF + proc driver {cmd args} { + variable ::tcl::buffer + variable ::tcl::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) + array unset index + array unset buffer + 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 + } + } + } + +# Channel read transform that is just the identity - pass all through + proc idxform {cmd handle args} { + switch -- $cmd { + initialize { + return {initialize finalize read} + } + finalize { + return + } + read { + lassign $args buffer + return $buffer + } + } + } + +# Test that all EOFs pass through full xform stack. Proper data boundaries. +# Check robustness against buffer sizes. +test iortrans-4.10 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] idxform] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.10.1 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] idxform] + chan configure $chan -buffersize 3 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.10.2 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] idxform] + chan configure $chan -buffersize 5 + 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 idxform {} + +# Channel read transform that delays the data and always returns something + proc delayxform {cmd handle args} { + variable store + switch -- $cmd { + initialize { + set store($handle) {} + return {initialize finalize read drain} + } + finalize { + unset store($handle) + return + } + read { + lassign $args buffer + if {$store($handle) eq {}} { + set reply [string index $buffer 0] + set store($handle) [string range $buffer 1 end] + } else { + set reply $store($handle) + set store($handle) $buffer + } + return $reply + } + drain { + delayxform read $handle {} + } + } + } + +# Test that all EOFs pass through full xform stack. Proper data boundaries. +# Check robustness against buffer sizes. +test iortrans-4.11 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delayxform] + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.11.1 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delayxform] + chan configure $chan -buffersize 3 + list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ + [read $chan] [eof $chan] +} -cleanup { + close $chan +} -result {0 ..... 1 {} 0 ..... 1} +test iortrans-4.11.2 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delayxform] + chan configure $chan -buffersize 5 + 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 delayxform {} + +# Channel read transform that delays the data and may return {} + proc delay2xform {cmd handle args} { + variable store + switch -- $cmd { + initialize { + set store($handle) {} + return {initialize finalize read drain} + } + finalize { + unset store($handle) + return + } + read { + lassign $args buffer + set reply $store($handle) + set store($handle) $buffer + return $reply + } + drain { + delay2xform read $handle {} + } + } + } + +test iortrans-4.12 {[5adbc350683] chan read, handle fleeting EOF} -body { + set chan [chan push [chan create read driver] delay2xform] + 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 delay2xform {} + rename driver {} + # --- === *** ########################### # method write (via puts) @@ -940,7 +1162,7 @@ test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup { test iortrans-11.0 {origin interpreter of moved transform gone} -setup { set ida [interp create]; #puts <<$ida>> set idb [interp create]; #puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb } -constraints {testchannel} -match glob -body { @@ -978,29 +1200,32 @@ test iortrans-11.0 {origin interpreter of moved transform gone} -setup { # without invoking the transform handler. } -cleanup { tempdone + interp delete $idb } -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup { set ida [interp create]; #puts <<$ida>> set idb [interp create]; #puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb -} -constraints {testchannel impossible} -match glob -body { +} -constraints {testchannel} -match glob -body { # Set up channel in thread set chan [interp eval $ida $helperscript] + interp eval $ida [list ::variable tempchan [tempchan]] + interp transfer {} $::tempchan $ida set chan [interp eval $ida { proc foo {args} { handle.initialize clear drain flush limit? read write handle.finalize lappend ::res $args - # Destroy interpreter during channel access. Actually not - # possible for an interp to destroy itself. - interp delete {} - return} - set chan [chan push [tempchan] foo] + # Destroy interpreter during channel access. + suicide + } + set chan [chan push $tempchan foo] fconfigure $chan -buffering none set chan }] + interp alias $ida suicide {} interp delete $ida # Move channel to 2nd thread, transform goes with it. interp eval $ida [list testchannel cut $chan] interp eval $idb [list testchannel splice $chan] @@ -1015,19 +1240,20 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces set res }] } -cleanup { + interp delete $idb tempdone } -result {Owner lost} test iortrans-11.2 {delete interp of reflected transform} -setup { - interp create slave - # Magic to get the test* commands into the slave - load {} Tcltest slave + interp create child + # Magic to get the test* commands into the child + load {} Tcltest child } -constraints {testchannel} -body { - # Get base channel into the slave + # Get base channel into the child set c [tempchan] testchannel cut $c - interp eval slave [list testchannel splice $c] - interp eval slave [list set c $c] - slave eval { + interp eval child [list testchannel splice $c] + interp eval child [list set c $c] + child eval { proc no-op args {} proc driver {c sub args} { return {initialize finalize read write} @@ -1035,7 +1261,9 @@ test iortrans-11.2 {delete interp of reflected transform} -setup { set t [chan push $c [list driver $c]] chan event $c readable no-op } - interp delete slave + interp delete child +} -cleanup { + tempdone } -result {} # ### ### ### ######### ######### ######### @@ -1092,7 +1320,7 @@ proc inthread {chan script args} { # forwarded channel operations. set ::tres "" - thread::send -async $tid { + thread::send -async $tid { after 50 catch {s} res; # This runs the script, 's' was defined at (*) thread::send -async $mid [list set ::tres $res] diff --git a/tests/iogt.test b/tests/iogt.test index d4c31d2..d397ccb 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -5,18 +5,18 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# Copyright (c) 2000 Ajuba Solutions. -# Copyright (c) 2000 Andreas Kupries. +# +# Copyright © 2000 Ajuba Solutions. +# Copyright © 2000 Andreas Kupries. # All rights reserved. -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] namespace eval ::tcl::test::iogt { namespace import ::tcltest::* @@ -220,6 +220,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} { namespace upvar [namespace current] $var n @@ -280,7 +310,7 @@ proc counter_audit {var vtrail op data} { } proc rblocks {var vtrail n op data} { - namespace upvar [namespace current] $var n $vtrail trail + namespace upvar [namespace current] $var buf $vtrail trail set res {} @@ -326,6 +356,11 @@ proc audit_ops {var -attach channel} { 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} { namespace upvar [namespace current] $var vn set vn $n @@ -445,6 +480,7 @@ query/maxRead read query/maxRead flush/read +query/maxRead delete/read -------- create/write @@ -491,6 +527,7 @@ read { } query/maxRead {} -1 flush/read {} {} +query/maxRead {} -1 delete/read {} *ignored* -------- create/write {} *ignored* @@ -542,16 +579,36 @@ write %^&*()_+-= %^&*()_+-= write { } { } +query/maxRead {} -1 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} -setup { proc DoneCopy {n {err {}}} { variable copy 1 } -} -constraints {testchannel hangs} -body { - # This test to check the validity of aquired Tcl_Channel references is not +} -constraints {testchannel knownBug} -body { + # This test to check the validity of acquired Tcl_Channel references is not # possible because even a backgrounded fcopy will immediately start to # copy data, without waiting for the event loop. This is done only in case # of an underflow on the read size!. So stacking transforms after the @@ -561,6 +618,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { # delay, causing the fcopy to underflow immediately. set fin [open $path(dummy) r] fevent 1000 500 {20 20 20 10 1 1} { + variable copy close $fin set fout [open dummyout w] flush $sock; # now, or fcopy will error us out @@ -594,23 +652,30 @@ test iogt-4.0 {fileevent readable, after transform} -setup { proc Done {args} { variable stop 1 } -} -constraints {testchannel hangs} -body { + proc Get {sock} { + variable trail + variable got + if {[eof $sock]} { + Done + lappend trail "xxxxxxxxxxxxx" + close $sock + return + } + lappend trail "vvvvvvvvvvvvv" + lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]" + lappend trail "=============" + #puts stdout $__ ; flush stdout + #read $sock + } + +} -constraints {testchannel knownBug} -body { 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 [namespace code { - if {[eof $sock]} { - Done - lappend trail "xxxxxxxxxxxxx" - close $sock - } else { - lappend trail "vvvvvvvvvvvvv" - lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]" - lappend trail "=============" - #puts stdout $__; flush stdout - #read $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 initialize everything # else here. @@ -619,6 +684,7 @@ test iogt-4.0 {fileevent readable, after transform} -setup { join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n } -cleanup { rename Done {} + rename Get {} } -result {[[]] [[abcdefghijklmnopqrstuvw]] [[xyz0123456789,./?><;'\|]] @@ -706,7 +772,7 @@ test iogt-5.0 {EOF simulation} -setup { set fin [open $path(dummy) r] set fout [open $path(dummyout) w] set trail [list] -} -constraints {testchannel unknownFailure} -result { +} -constraints {testchannel knownBug} -result { audit_flow trail -attach $fin stopafter_audit d trail 20 -attach $fin audit_flow trail -attach $fout @@ -785,6 +851,15 @@ test iogt-6.0 {Push back} -constraints testchannel -body { close $f } -result {xxx} test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body { + + # 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..." read $f 3; # skip behind "abc" @@ -796,6 +871,80 @@ test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body { close $f } -result {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] { removeFile $file diff --git a/tests/join.test b/tests/join.test index 4abe233..3573fbd 100644 --- a/tests/join.test +++ b/tests/join.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -45,6 +45,11 @@ test join-3.1 {joinString is binary ok} { test join-3.2 {join is binary ok} { string length [join "a\0b a\0b a\0b"] } 11 + +test join-4.1 {shimmer segfault prevention} { + set l {0 0} + join $l $l +} {00 00} # cleanup ::tcltest::cleanupTests diff --git a/tests/lindex.test b/tests/lindex.test index b86e2e0..ffe0d9e 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -4,21 +4,21 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2001 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] set minus - testConstraint testevalex [llength [info commands testevalex]] @@ -51,22 +51,22 @@ test lindex-2.4 {malformed index list} testevalex { # Indices that are integers or convertible to integers -test lindex-3.1 {integer -1} testevalex { +test lindex-3.1 {integer -1} -constraints testevalex -body { set x ${minus}1 list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] -} {{} {}} -test lindex-3.2 {integer 0} testevalex { +} -result {{} {}} +test lindex-3.2 {integer 0} -constraints testevalex -body { set x [string range 00 0 0] list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] -} {a a} -test lindex-3.3 {integer 2} testevalex { +} -result {a a} +test lindex-3.3 {integer 2} -constraints testevalex -body { set x [string range 22 0 0] list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] -} {c c} -test lindex-3.4 {integer 3} testevalex { +} -result {c c} +test lindex-3.4 {integer 3} -constraints testevalex -body { set x [string range 33 0 0] list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] -} {{} {}} +} -result {{} {}} test lindex-3.5 {bad octal} -constraints testevalex -body { set x 0o8 list [catch { testevalex {lindex {a b c} $x} } result] $result @@ -75,10 +75,19 @@ test lindex-3.6 {bad octal} -constraints testevalex -body { set x -0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result } -match glob -result {1 {*invalid octal number*}} -test lindex-3.7 {indexes don't shimmer wide ints} { +test lindex-3.7 {indexes don't shimmer wide ints} -body { set x [expr {(wide(1)<<31) - 2}] list $x [lindex {1 2 3} $x] [incr x] [incr x] -} {2147483646 {} 2147483647 2147483648} +} -result {2147483646 {} 2147483647 2147483648} +test lindex-3.8 {compiled with static indices out of range, negative} -body { + list [lindex {a b c} -1] [lindex {a b c} -2] [lindex {a b c} -3] +} -result [lrepeat 3 {}] +test lindex-3.9 {compiled with calculated indices out of range, negative constant} -body { + list [lindex {a b c} -1-1] [lindex {a b c} -2+0] [lindex {a b c} -2+1] +} -result [lrepeat 3 {}] +test lindex-3.10 {compiled with calculated indices out of range, after end} -body { + list [lindex {a b c} end+1] [lindex {a b c} end+2] [lindex {a b c} end+3] +} -result [lrepeat 3 {}] # Indices relative to end @@ -156,34 +165,38 @@ test lindex-7.4 {quoted elements} { lindex {a b {c d "e} {f g"}} 2 } {c d "e} -test lindex-8.1 {data reuse} testevalex { +test lindex-8.1 {data reuse} -constraints testevalex -body { set x 0 testevalex {lindex $x $x} -} {0} -test lindex-8.2 {data reuse} testevalex { +} -result 0 +test lindex-8.2 {data reuse} -constraints testevalex -body { set a 0 testevalex {lindex $a $a $a} -} 0 -test lindex-8.3 {data reuse} testevalex { +} -result 0 +test lindex-8.3 {data reuse} -constraints { + testevalex +} -body { set a 1 testevalex {lindex $a $a $a} -} {} -test lindex-8.4 {data reuse} testevalex { +} -result {} +test lindex-8.4 {data reuse} -constraints testevalex -body { set x [list 0 0] testevalex {lindex $x $x} -} {0} -test lindex-8.5 {data reuse} testevalex { +} -result 0 +test lindex-8.5 {data reuse} -constraints testevalex -body { set x 0 testevalex {lindex $x [list $x $x]} -} {0} -test lindex-8.6 {data reuse} testevalex { +} -result 0 +test lindex-8.6 {data reuse} -constraints testevalex -body { set x [list 1 1] testevalex {lindex $x $x} -} {} -test lindex-8.7 {data reuse} testevalex { +} -result {} +test lindex-8.7 {data reuse} -constraints { + testevalex +} -body { set x 1 testevalex {lindex $x [list $x $x]} -} {} +} -result {} #---------------------------------------------------------------------- @@ -372,79 +385,76 @@ test lindex-15.3 {quoted elements} { } result set result } {c d " x} -test lindex-15.4 {quoted elements} { +test lindex-15.4 {quoted elements} -body { catch { lindex {a b {c d "e} {f g"}} 2 } result set result -} {c d "e} +} -result {c d "e} -test lindex-16.1 {data reuse} { +test lindex-16.1 {data reuse} -body { set x 0 catch { lindex $x $x } result set result -} {0} -test lindex-16.2 {data reuse} { +} -result {0} +test lindex-16.2 {data reuse} -body { set a 0 catch { lindex $a $a $a } result set result -} 0 -test lindex-16.3 {data reuse} { +} -result 0 +test lindex-16.3 {data reuse} -body { set a 1 catch { lindex $a $a $a } result set result -} {} -test lindex-16.4 {data reuse} { +} -result {} +test lindex-16.4 {data reuse} -body { set x [list 0 0] catch { lindex $x $x } result set result -} {0} -test lindex-16.5 {data reuse} { +} -result {0} +test lindex-16.5 {data reuse} -body { set x 0 catch { lindex $x [list $x $x] } result set result -} {0} -test lindex-16.6 {data reuse} { +} -result {0} +test lindex-16.6 {data reuse} -body { set x [list 1 1] catch { lindex $x $x } result set result -} {} -test lindex-16.7 {data reuse} { +} -result {} +test lindex-16.7 {data reuse} -body { set x 1 catch { lindex $x [list $x $x] } result set result -} {} - -test lindex-17.0 {Bug 1718580} {*}{ - -body { - lindex {} end foo - } - -match glob - -result {bad index "foo"*} - -returnCodes 1 -} - -test lindex-17.1 {Bug 1718580} {*}{ - -body { - lindex a end foo - } - -match glob - -result {bad index "foo"*} - -returnCodes 1 +} -result {} + +test lindex-17.0 {Bug 1718580} -body { + lindex {} end foo +} -match glob -result {bad index "foo"*} -returnCodes 1 +test lindex-17.1 {Bug 1718580} -body { + lindex a end foo +} -match glob -result {bad index "foo"*} -returnCodes 1 + +test lindex-18.0 {nested bytecode execution} -setup { + proc demo {i} {lindex {a b c} $i} +} -body { + demo 0+0x10000000000000000 +} -cleanup { + rename demo {} } catch { unset minus } diff --git a/tests/link.test b/tests/link.test index 00e490c..eba359c 100644 --- a/tests/link.test +++ b/tests/link.test @@ -4,27 +4,38 @@ # procedures. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testlink [llength [info commands testlink]] +testConstraint testlinkarray [llength [info commands testlinkarray]] foreach i {int real bool string} { unset -nocomplain $i } +test link-0.1 {leak test} {testlink} { + interp create i + load {} Tcltest i + i eval { + testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0 + namespace delete :: + } + interp delete i +} {} + test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup { testlink delete } -body { @@ -88,7 +99,112 @@ test link-2.5 {writing bad values into variables} -setup { testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set wide gorp} msg] $msg $bool -} -result {1 {can't set "wide": variable must have integer value} 1} +} -result {1 {can't set "wide": variable must have wide integer value} 1} +test link-2.6 {writing C variables from Tcl} -constraints {testlink} -setup { + testlink delete +} -body { + testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + set int "+" + set real "+" + set bool 1 + set string "+" + set wide "+" + set char "+" + set uchar "+" + set short "+" + set ushort "+" + set uint "+" + set long "+" + set ulong "+" + set float "+" + set uwide "+" + concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide +} -result {1 1.0 1 + 1 1 1 1 1 1 1 1 1.0 1 | + + 1 + + + + + + + + + + +} +test link-2.7 {writing C variables from Tcl} -constraints {testlink} -setup { + testlink delete +} -body { + testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + set int "-" + set real "-" + set bool 0 + set string "-" + set wide "-" + set char "-" + set uchar "-" + set short "-" + set ushort "-" + set uint "-" + set long "-" + set ulong "-" + set float "-" + set uwide "-" + concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide +} -result {0 0.0 0 - 0 0 0 0 0 0 0 0 0.0 0 | - - 0 - - - - - - - - - - -} +test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup { + testlink delete +} -body { + testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + set int "0x" + set real "0b" + set bool 0 + set string "0" + set wide "0O" + set char "0X" + set uchar "0B" + set short "0O" + set ushort "0x" + set uint "0b" + set long "0o" + set ulong "0X" + set float "0B" + set uwide "0O" + concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide +} -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0O 0X 0B 0O 0x 0b 0o 0X 0B 0O} +test link-2.9 {writing C variables from Tcl} -constraints {testlink} -setup { + testlink delete +} -body { + testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + set int 0 + set real 5000e + set bool 0 + set string 0 + set wide 0 + set char 0 + set uchar 0 + set short 0 + set ushort 0 + set uint 0 + set long 0 + set ulong 0 + set float -60.00e+ + set uwide 0 + concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide +} -result {0 5000.0 0 0 0 0 0 0 0 0 0 0 -60.0 0 | 0 5000e 0 0 0 0 0 0 0 0 0 0 -60.00e+ 0} +test link-2.10 {writing C variables from Tcl} -constraints {testlink} -setup { + testlink delete +} -body { + testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + set int "0x" + set real "0b" + set bool 0 + set string "0" + set wide "0D" + set char "0X" + set uchar "0B" + set short "0D" + set ushort "0x" + set uint "0b" + set long "0d" + set ulong "0X" + set float "0B" + set uwide "0D" + concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide +} -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0D 0X 0B 0D 0x 0b 0d 0X 0B 0D} test link-3.1 {read-only variables} -constraints {testlink} -setup { testlink delete @@ -258,7 +374,7 @@ test link-7.7 {access to linked variables via upvar} -setup { testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set -4 16.3 1 {} 778899 {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $wide -} -result {1 {can't set "y": variable must have integer value} 778899} +} -result {1 {can't set "y": variable must have wide integer value} 778899} test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { @@ -293,6 +409,477 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {} } msg] $msg $int } {0 {} 47} + +test link-9.1 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body { + testlinkarray +} -result {wrong # args: should be "testlinkarray option args"} +test link-9.2 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body { + testlinkarray x +} -result {bad option "x": must be update, remove, or create} +test link-9.3 {linkarray usage messages} -constraints testlinkarray -body { + testlinkarray update +} -result {} +test link-9.4 {linkarray usage messages} -constraints testlinkarray -body { + testlinkarray remove +} -result {} +test link-9.5 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body { + testlinkarray create +} -result {wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?"} +test link-9.6 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body { + testlinkarray create xx 1 my +} -result {bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary} +test link-9.7 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body { + testlinkarray create char* 0 my +} -result {wrong array size given} + +test link-10.1 {linkarray char*} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create char* 1 ::my(var) + lappend mylist [set ::my(var) ""] + catch {set ::my(var) x} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{} {can't set "::my(var)": wrong size of char* value}} +test link-10.2 {linkarray char*} -constraints testlinkarray -body { + testlinkarray create char* 4 ::my(var) + set ::my(var) x + catch {set ::my(var) xyzz} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": wrong size of char* value} +test link-10.3 {linkarray char*} -constraints testlinkarray -body { + testlinkarray create -r char* 4 ::my(var) + catch {set ::my(var) x} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-11.1 {linkarray char} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create char 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1234} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have char value} 120 {can't set "::my(var)": variable must have char value}} +test link-11.2 {linkarray char} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create char 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-11.3 {linkarray char} -constraints testlinkarray -body { + testlinkarray create -r char 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-12.1 {linkarray unsigned char} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create uchar 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1234} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned char value} 120 {can't set "::my(var)": variable must have unsigned char value} {can't set "::my(var)": variable must have unsigned char value}} +test link-12.2 {linkarray unsigned char} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create uchar 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-12.3 {linkarray unsigned char} -constraints testlinkarray -body { + testlinkarray create -r uchar 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-13.1 {linkarray short} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create short 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 123456} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have short value} 120 {can't set "::my(var)": variable must have short value}} +test link-13.2 {linkarray short} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create short 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-13.3 {linkarray short} -constraints testlinkarray -body { + testlinkarray create -r short 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-14.1 {linkarray unsigned short} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create ushort 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 123456} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned short value} 120 {can't set "::my(var)": variable must have unsigned short value} {can't set "::my(var)": variable must have unsigned short value}} +test link-14.2 {linkarray unsigned short} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create ushort 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-14.3 {linkarray unsigned short} -constraints testlinkarray -body { + testlinkarray create -r ushort 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-15.1 {linkarray int} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create int 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1e3} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have integer value} 120 {can't set "::my(var)": variable must have integer value}} +test link-15.2 {linkarray int} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create int 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-15.3 {linkarray int} -constraints testlinkarray -body { + testlinkarray create -r int 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-16.1 {linkarray unsigned int} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create uint 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1e33} msg + lappend mylist $msg + catch {set ::my(var) -1} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain ::my +} -result {{can't set "::my(var)": variable must have unsigned int value} 120 {can't set "::my(var)": variable must have unsigned int value} {can't set "::my(var)": variable must have unsigned int value}} +test link-16.2 {linkarray unsigned int} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create uint 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain ::my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-16.3 {linkarray unsigned int} -constraints testlinkarray -body { + testlinkarray create -r uint 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-17.1 {linkarray long} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create long 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1e33} msg + lappend mylist $msg +} -match glob -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have * value} 120 {can't set "::my(var)": variable must have * value}} +test link-17.2 {linkarray long} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create long 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-17.3 {linkarray long} -constraints testlinkarray -body { + testlinkarray create -r long 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-18.1 {linkarray unsigned long} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create ulong 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1e33} msg + lappend mylist $msg +} -match glob -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned * value} 120 {can't set "::my(var)": variable must have unsigned * value}} +test link-18.2 {linkarray unsigned long} -constraints testlinkarray -body { + testlinkarray create ulong 1 ::my(var) + set ::my(var) 120 + catch {set ::my(var) -1} msg + return $msg +} -match glob -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned * value} +test link-18.3 {linkarray unsigned long} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create ulong 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-18.4 {linkarray unsigned long} -constraints testlinkarray -body { + testlinkarray create -r ulong 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-19.1 {linkarray wide} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create wide 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1e33} msg + lappend mylist $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have wide integer value} 120 {can't set "::my(var)": variable must have wide integer value}} +test link-19.2 {linkarray wide} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create wide 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-19.3 {linkarray wide} -constraints testlinkarray -body { + testlinkarray create -r wide 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-20.1 {linkarray unsigned wide} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create uwide 1 ::my(var) + catch {set ::my(var) x} msg + lappend mylist $msg + lappend mylist [set ::my(var) 120] + catch {set ::my(var) 1e33} msg + lappend mylist $msg + lappend mylist [set ::my(var) 0xbabed00dbabed00d] +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value} 0xbabed00dbabed00d} +test link-20.2 {linkarray unsigned wide} -constraints testlinkarray -body { + testlinkarray create uwide 1 ::my(var) + set ::my(var) 120 + catch {set ::my(var) -1} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": variable must have unsigned wide int value} +test link-20.3 {linkarray unsigned wide} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create uwide 4 ::my(var) + catch {set ::my(var) {1 2 3}} msg + lappend mylist $msg + set ::my(var) {1 2 3 4} + lappend mylist $my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}} +test link-20.4 {linkarray unsigned wide} -constraints testlinkarray -body { + testlinkarray create -r uwide 2 ::my(var) + catch {set ::my(var) {1 2}} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-21.1 {linkarray string} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create string 1 ::my(var) + lappend mylist [set ::my(var) ""] + lappend mylist [set ::my(var) "xyz"] + lappend mylist $::my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{} xyz xyz} +test link-21.2 {linkarray string} -constraints testlinkarray -body { + testlinkarray create -r string 4 ::my(var) + catch {set ::my(var) x} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} + +test link-22.1 {linkarray binary} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create binary 1 ::my(var) + set ::my(var) x + catch {set ::my(var) xy} msg + lappend mylist $msg + lappend mylist $::my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong size of binary value} x} +test link-22.2 {linkarray binary} -constraints testlinkarray -setup { + set mylist [list] +} -body { + testlinkarray create binary 4 ::my(var) + catch {set ::my(var) abc} msg + lappend mylist $msg + catch {set ::my(var) abcde} msg + lappend mylist $msg + set ::my(var) abcd + lappend mylist $::my(var) +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {{can't set "::my(var)": wrong size of binary value} {can't set "::my(var)": wrong size of binary value} abcd} +test link-22.3 {linkarray binary} -constraints testlinkarray -body { + testlinkarray create -r binary 4 ::my(var) + catch {set ::my(var) xyzv} msg + return $msg +} -cleanup { + testlinkarray remove ::my(var) + unset -nocomplain my +} -result {can't set "::my(var)": linked variable is read-only} catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0} catch {testlink delete} diff --git a/tests/linsert.test b/tests/linsert.test index 4939e5c..16ade39 100644 --- a/tests/linsert.test +++ b/tests/linsert.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/list.test b/tests/list.test index dff5d50..4cd3a75 100644 --- a/tests/list.test +++ b/tests/list.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -98,26 +98,26 @@ concat {} proc slowsort list { set result {} - set last [expr [llength $list] - 1] + set last [expr {[llength $list] - 1}] while {$last > 0} { - set minIndex [expr [llength $list] - 1] + set minIndex [expr {[llength $list] - 1}] set min [lindex $list $last] - set i [expr $minIndex-1] + set i [expr {$minIndex - 1}] while {$i >= 0} { if {[string compare [lindex $list $i] $min] < 0} { set minIndex $i set min [lindex $list $i] } - set i [expr $i-1] + incr i -1 } set result [concat $result [list $min]] if {$minIndex == 0} { set list [lrange $list 1 end] } else { - set list [concat [lrange $list 0 [expr $minIndex-1]] \ - [lrange $list [expr $minIndex+1] end]] + set list [concat [lrange $list 0 [expr {$minIndex - 1}]] \ + [lrange $list [expr {$minIndex + 1}] end]] } - set last [expr $last-1] + set last [expr {$last - 1}] } return [concat $result $list] } @@ -128,6 +128,24 @@ test list-3.1 {SetListFromAny and lrange/concat results} { test list-4.1 {Bug 3173086} { string is list "{[list \\\\\}]}" } 1 +test list-4.2 {Bug 35a8f1c04a, check correct str-rep} { + set result {} + foreach i { + {#"} {#"""} {#"""""""""""""""} + "#\"{" "#\"\"\"{" "#\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\{" + "#\"}" "#\"\"\"}" "#\"\"\"\"\"\"\"\"\"\"\"\"\"\"\"\}" + } { + set list [list $i] + set list [string trim " $list "] + if {[llength $list] > 1 || $i ne [lindex $list 0]} { + lappend result "wrong string-representation of list by '$i', length: [llength $list], list: '$list'" + } + } + set result [join $result \n] +} {} +test list-4.3 {Bug 35a8f1c04a, check correct string length} { + string length [list #""] +} 5 # cleanup ::tcltest::cleanupTests diff --git a/tests/listObj.test b/tests/listObj.test index 8b24aa9..f17f085 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -5,19 +5,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] @@ -196,6 +196,10 @@ test listobj-10.1 {Bug [2971669]} {*}{ -result {{a b c d e} {} {a b c d e f}} } +test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj { + testobj bug3598580 +} 123 + # cleanup ::tcltest::cleanupTests return diff --git a/tests/llength.test b/tests/llength.test index 169c7ca..1122341 100644 --- a/tests/llength.test +++ b/tests/llength.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lmap.test b/tests/lmap.test new file mode 100644 index 0000000..7a802a8 --- /dev/null +++ b/tests/lmap.test @@ -0,0 +1,471 @@ +# Commands covered: lmap, continue, break +# +# 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 +# generates output for errors. No output means no errors were found. +# +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 2011 Trevor Davel +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: $ + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +unset -nocomplain a b i x + +# ----- Non-compiled operation ----------------------------------------------- + +# Basic "lmap" operation (non-compiled) +test lmap-1.1 {basic lmap tests} { + set a {} + lmap i {a b c d} { + set a [concat $a $i] + } +} {a {a b} {a b c} {a b c d}} +test lmap-1.2 {basic lmap tests} { + lmap i {a b {{c d} e} {123 {{x}}}} { + set i + } +} {a b {{c d} e} {123 {{x}}}} +test lmap-1.2a {basic lmap tests} { + lmap i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } +} {a b {{c d} e} {123 {{x}}}} +test lmap-1.4 {basic lmap tests} -returnCodes error -body { + lmap +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.6 {basic lmap tests} -returnCodes error -body { + lmap i +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.8 {basic lmap tests} -returnCodes error -body { + lmap i j +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.10 {basic lmap tests} -returnCodes error -body { + lmap i j k l +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-1.11 {basic lmap tests} { + lmap i {} { + set i + } +} {} +test lmap-1.12 {basic lmap tests} { + lmap i {} { + return -level 0 x + } +} {} +test lmap-1.13 {lmap errors} -returnCodes error -body { + lmap {{a}{b}} {1 2 3} {} +} -result {list element in braces followed by "{b}" instead of space} +test lmap-1.14 {lmap errors} -returnCodes error -body { + lmap a {{1 2}3} {} +} -result {list element in braces followed by "3" instead of space} +unset -nocomplain a +test lmap-1.15 {lmap errors} -setup { + unset -nocomplain a +} -body { + set a(0) 44 + list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo +} -result {1 {can't set "a": variable is array} {can't set "a": variable is array + (setting lmap loop variable "a") + invoked from within +"lmap a {1 2 3} {}"}} +test lmap-1.16 {lmap errors} -returnCodes error -body { + lmap {} {} {} +} -result {lmap varlist is empty} +unset -nocomplain a + +# Parallel "lmap" operation (non-compiled) +test lmap-2.1 {parallel lmap tests} { + lmap {a b} {1 2 3 4} { + list $b $a + } +} {{2 1} {4 3}} +test lmap-2.2 {parallel lmap tests} { + lmap {a b} {1 2 3 4 5} { + list $b $a + } +} {{2 1} {4 3} {{} 5}} +test lmap-2.3 {parallel lmap tests} { + lmap a {1 2 3} b {4 5 6} { + list $b $a + } +} {{4 1} {5 2} {6 3}} +test lmap-2.4 {parallel lmap tests} { + lmap a {1 2 3} b {4 5 6 7 8} { + list $b $a + } +} {{4 1} {5 2} {6 3} {7 {}} {8 {}}} +test lmap-2.5 {parallel lmap tests} { + lmap {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } +} {{a b c} {A B C} {aa bb cc} {{} {} CC}} +test lmap-2.6 {parallel lmap tests} { + lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } +} {11111 22222 33333} +test lmap-2.7 {parallel lmap tests} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } +} {{1111 2} 222 33 4} +test lmap-2.8 {parallel lmap tests} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } +} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} +test lmap-2.9 {lmap only sets vars if repeating loop} { + namespace eval ::lmap_test { + set rgb {65535 0 0} + lmap {r g b} [set rgb] {} + set ::x "r=$r, g=$g, b=$b" + } + namespace delete ::lmap_test + set x +} {r=65535, g=0, b=0} +test lmap-2.10 {lmap only supports local scalar variables} -setup { + unset -nocomplain a +} -body { + lmap {a(3)} {1 2 3 4} {set {a(3)}} +} -result {1 2 3 4} +unset -nocomplain a + +# "lmap" with "continue" and "break" (non-compiled) +test lmap-3.1 {continue tests} { + lmap i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } +} {a c d} +test lmap-3.2 {continue tests} { + set x 0 + list [lmap i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x +} {b 4} +test lmap-3.3 {break tests} { + set x 0 + list [lmap i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x +} {{a b} 3} +# Check for bug similar to #406709 +test lmap-3.4 {break tests} { + set a 1 + lmap b b {list [concat a; break]; incr a} + incr a +} {2} + +# ----- Compiled operation --------------------------------------------------- + +# Basic "lmap" operation (compiled) +test lmap-4.1 {basic lmap tests} { + apply {{} { + set a {} + lmap i {a b c d} { + set a [concat $a $i] + } + }} +} {a {a b} {a b c} {a b c d}} +test lmap-4.2 {basic lmap tests} { + apply {{} { + lmap i {a b {{c d} e} {123 {{x}}}} { + set i + } + }} +} {a b {{c d} e} {123 {{x}}}} +test lmap-4.2a {basic lmap tests} { + apply {{} { + lmap i {a b {{c d} e} {123 {{x}}}} { + return -level 0 $i + } + }} +} {a b {{c d} e} {123 {{x}}}} +test lmap-4.4 {basic lmap tests} -returnCodes error -body { + apply {{} { lmap }} +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.6 {basic lmap tests} -returnCodes error -body { + apply {{} { lmap i }} +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.8 {basic lmap tests} -returnCodes error -body { + apply {{} { lmap i j }} +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.10 {basic lmap tests} -returnCodes error -body { + apply {{} { lmap i j k l }} +} -result {wrong # args: should be "lmap varList list ?varList list ...? command"} +test lmap-4.11 {basic lmap tests} { + apply {{} { lmap i {} { set i } }} +} {} +test lmap-4.12 {basic lmap tests} { + apply {{} { lmap i {} { return -level 0 x } }} +} {} +test lmap-4.13 {lmap errors} -returnCodes error -body { + apply {{} { lmap {{a}{b}} {1 2 3} {} }} +} -result {list element in braces followed by "{b}" instead of space} +test lmap-4.14 {lmap errors} -returnCodes error -body { + apply {{} { lmap a {{1 2}3} {} }} +} -result {list element in braces followed by "3" instead of space} +unset -nocomplain a +test lmap-4.15 {lmap errors} { + apply {{} { + set a(0) 44 + list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo + }} +} {1 {can't set "a": variable is array} {can't set "a": variable is array + while executing +"lmap a {1 2 3} {}"}} +test lmap-4.16 {lmap errors} -returnCodes error -body { + apply {{} { + lmap {} {} {} + }} +} -result {lmap varlist is empty} +unset -nocomplain a + +# Parallel "lmap" operation (compiled) +test lmap-5.1 {parallel lmap tests} { + apply {{} { + lmap {a b} {1 2 3 4} { + list $b $a + } + }} +} {{2 1} {4 3}} +test lmap-5.2 {parallel lmap tests} { + apply {{} { + lmap {a b} {1 2 3 4 5} { + list $b $a + } + }} +} {{2 1} {4 3} {{} 5}} +test lmap-5.3 {parallel lmap tests} { + apply {{} { + lmap a {1 2 3} b {4 5 6} { + list $b $a + } + }} +} {{4 1} {5 2} {6 3}} +test lmap-5.4 {parallel lmap tests} { + apply {{} { + lmap a {1 2 3} b {4 5 6 7 8} { + list $b $a + } + }} +} {{4 1} {5 2} {6 3} {7 {}} {8 {}}} +test lmap-5.5 {parallel lmap tests} { + apply {{} { + lmap {a b} {a b A B aa bb} c {c C cc CC} { + list $a $b $c + } + }} +} {{a b c} {A B C} {aa bb cc} {{} {} CC}} +test lmap-5.6 {parallel lmap tests} { + apply {{} { + lmap a {1 2 3} b {1 2 3} c {1 2 3} d {1 2 3} e {1 2 3} { + list $a$b$c$d$e + } + }} +} {11111 22222 33333} +test lmap-5.7 {parallel lmap tests} { + apply {{} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + set x $a$b$c$d$e + } + }} +} {{1111 2} 222 33 4} +test lmap-5.8 {parallel lmap tests} { + apply {{} { + lmap a {} b {1 2 3} c {1 2} d {1 2 3 4} e {{1 2}} { + join [list $a $b $c $d $e] . + } + }} +} {{.1.1.1.1 2} .2.2.2. .3..3. ...4.} +test lmap-5.9 {lmap only sets vars if repeating loop} { + apply {{} { + set rgb {65535 0 0} + lmap {r g b} [set rgb] {} + return "r=$r, g=$g, b=$b" + }} +} {r=65535, g=0, b=0} +test lmap-5.10 {lmap only supports local scalar variables} { + apply {{} { + lmap {a(3)} {1 2 3 4} {set {a(3)}} + }} +} {1 2 3 4} + +# "lmap" with "continue" and "break" (compiled) +test lmap-6.1 {continue tests} { + apply {{} { + lmap i {a b c d} { + if {[string compare $i "b"] == 0} continue + set i + } + }} +} {a c d} +test lmap-6.2 {continue tests} { + apply {{} { + list [lmap i {a b c d} { + incr x + if {[string compare $i "b"] != 0} continue + set i + }] $x + }} +} {b 4} +test lmap-6.3 {break tests} { + apply {{} { + list [lmap i {a b c d} { + incr x + if {[string compare $i "c"] == 0} break + set i + }] $x + }} +} {{a b} 3} +# Check for bug similar to #406709 +test lmap-6.4 {break tests} { + apply {{} { + set a 1 + lmap b b {list [concat a; break]; incr a} + incr a + }} +} {2} + +# ----- Special cases and bugs ----------------------------------------------- +test lmap-7.1 {compiled lmap backward jump works correctly} -setup { + unset -nocomplain x +} -body { + array set x {0 zero 1 one 2 two 3 three} + lsort [apply {{arrayName} { + upvar 1 $arrayName a + lmap member [array names a] { + list $member [set a($member)] + } + }} x] +} -result [lsort {{0 zero} {1 one} {2 two} {3 three}}] +test lmap-7.2 {noncompiled lmap and shared variable or value list objects that are converted to another type} -setup { + unset -nocomplain x +} -body { + lmap {12.0} {a b c} { + set x 12.0 + set x [expr $x + 1] + } +} -result {13.0 13.0 13.0} +# Test for incorrect "double evaluation" semantics +test lmap-7.3 {delayed substitution of body} { + apply {{} { + set a 0 + lmap a [list 1 2 3] " + set x $a + " + return $x + }} +} {0} +# Related to "foreach" test for [Bug 1189274]; crash on failure +test lmap-7.4 {empty list handling} { + proc crash {} { + rename crash {} + set a "x y z" + set b "" + lmap aa $a bb $b { set x "aa = $aa bb = $bb" } + } + crash +} {{aa = x bb = } {aa = y bb = } {aa = z bb = }} +# Related to [Bug 1671138]; infinite loop with empty var list in bytecompiled +# version. +test lmap-7.5 {compiled empty var list} -returnCodes error -body { + proc foo {} { + lmap {} x { + error "reached body" + } + } + foo +} -cleanup { + catch {rename foo ""} +} -result {lmap varlist is empty} +test lmap-7.6 {lmap: related to "foreach" [Bug 1671087]} -setup { + proc demo {} { + set vals {1 2 3 4} + trace add variable x write {string length $vals ;# } + lmap {x y} $vals {format $y} + } +} -body { + demo +} -cleanup { + rename demo {} +} -result {2 4} +# Huge lists must not overflow the bytecode interpreter (development bug) +test lmap-7.7 {huge list non-compiled} -setup { + unset -nocomplain a b x +} -body { + set x [lmap a [lrepeat 1000000 x] { set b y$a }] + list $b [llength $x] [string length $x] +} -result {yx 1000000 2999999} +test lmap-7.8 {huge list compiled} -setup { + unset -nocomplain a b x +} -body { + set x [apply {{times} { + global b + lmap a [lrepeat $times x] { set b Y$a } + }} 1000000] + list $b [llength $x] [string length $x] +} -result {Yx 1000000 2999999} +test lmap-7.9 {error then dereference loop var (dev bug)} { + catch { lmap a 0 b {1 2 3} { error x } } + set a +} 0 +test lmap-7.9a {error then dereference loop var (dev bug)} { + catch { lmap a 0 b {1 2 3} { incr a $b; error x } } + set a +} 1 + +# ----- Coroutines ----------------------------------------------------------- +test lmap-8.1 {lmap non-compiled with coroutines} -body { + coroutine coro apply {{} { + set values [yield [info coroutine]] + eval lmap i [list $values] {{ yield $i }} + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} -cleanup { + catch {rename coro ""} +} -result {{1 2 3 4 5 6} {}} +test lmap-8.2 {lmap compiled with coroutines} -body { + coroutine coro apply {{} { + set values [yield [info coroutine]] + lmap i $values { yield $i } + }} ;# returns 'coro' + coro {a b c d e f} ;# -> a + coro 1 ;# -> b + coro 2 ;# -> c + coro 3 ;# -> d + coro 4 ;# -> e + coro 5 ;# -> f + list [coro 6] [info commands coro] +} -cleanup { + catch {rename coro ""} +} -result {{1 2 3 4 5 6} {}} + +# cleanup +unset -nocomplain a x +catch {rename foo {}} +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/load.test b/tests/load.test index 78bf64c..7978f64 100644 --- a/tests/load.test +++ b/tests/load.test @@ -4,19 +4,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Figure out what extension is used for shared libraries on this # platform. @@ -45,34 +45,40 @@ testConstraint teststaticpkg [llength [info commands teststaticpkg]] testConstraint testsimplefilesystem \ [llength [info commands testsimplefilesystem]] -test load-1.1 {basic errors} {} { - list [catch {load} msg] $msg -} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}" -test load-1.2 {basic errors} {} { - list [catch {load a b c d} msg] $msg -} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}" -test load-1.3 {basic errors} {} { - list [catch {load a b foobar} msg] $msg -} {1 {could not find interpreter "foobar"}} -test load-1.4 {basic errors} {} { - list [catch {load {}} msg] $msg -} {1 {must specify either file name or package name}} -test load-1.5 {basic errors} {} { - list [catch {load {} {}} msg] $msg -} {1 {must specify either file name or package name}} -test load-1.6 {basic errors} {} { - list [catch {load {} Unknown} msg] $msg -} {1 {package "Unknown" isn't loaded statically}} +test load-1.1 {basic errors} -returnCodes error -body { + load +} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"} +test load-1.2 {basic errors} -returnCodes error -body { + load a b c d +} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?packageName? ?interp?"} +test load-1.3 {basic errors} -returnCodes error -body { + load a b foobar +} -result {could not find interpreter "foobar"} +test load-1.4 {basic errors} -returnCodes error -body { + load -global {} +} -result {must specify either file name or package name} +test load-1.5 {basic errors} -returnCodes error -body { + load -lazy {} {} +} -result {must specify either file name or package name} +test load-1.6 {basic errors} -returnCodes error -body { + load {} Unknown +} -result {package "Unknown" isn't loaded statically} +test load-1.7 {basic errors} -returnCodes error -body { + load -abc foo +} -result {bad option "-abc": must be -global, -lazy, or --} +test load-1.8 {basic errors} -returnCodes error -body { + load -global +} -result {couldn't figure out package name for -global} test load-2.1 {basic loading, with guess for package name} \ [list $dll $loaded] { - load [file join $testDir pkga$ext] + load -global [file join $testDir pkga$ext] list [pkga_eq abc def] [lsort [info commands pkga_*]] } {0 {pkga_eq pkga_quote}} interp create -safe child test load-2.2 {loading into a safe interpreter, with package name conversion} \ [list $dll $loaded] { - load [file join $testDir pkgb$ext] pKgB child + load -lazy [file join $testDir pkgb$ext] Pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} @@ -97,7 +103,7 @@ test load-3.1 {error in _Init procedure, same interpreter} \ "if 44 {open non_existent}" invoked from within "load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} -test load-3.2 {error in _Init procedure, slave interpreter} \ +test load-3.2 {error in _Init procedure, child interpreter} \ [list $dll $loaded] { catch {interp delete x} interp create x @@ -118,20 +124,22 @@ test load-3.2 {error in _Init procedure, slave interpreter} \ test load-4.1 {reloading package into same interpreter} [list $dll $loaded] { list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg } {0 {}} -test load-4.2 {reloading package into same interpreter} [list $dll $loaded] { - list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg -} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""] +test load-4.2 {reloading package into same interpreter} -setup { + catch {load [file join $testDir pkga$ext] Pkga} +} -constraints [list $dll $loaded] -returnCodes error -body { + load [file join $testDir pkga$ext] Pkgb +} -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\"" -test load-5.1 {file name not specified and no static package: pick default} \ - [list $dll $loaded] { +test load-5.1 {file name not specified and no static package: pick default} -setup { catch {interp delete x} interp create x - load [file join $testDir pkga$ext] pkga - load {} pkga x - set result [info loaded x] +} -constraints [list $dll $loaded] -body { + load -global [file join $testDir pkga$ext] Pkga + load {} Pkga x + info loaded x +} -cleanup { interp delete x - set result -} [list [list [file join $testDir pkga$ext] Pkga]] +} -result [list [list [file join $testDir pkga$ext] Pkga]] # On some platforms, like SunOS 4.1.3, these tests can't be run because # they cause the process to exit. @@ -145,8 +153,8 @@ test load-6.1 {errors loading file} [list $dll $loaded] { test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] { set x "not loaded" teststaticpkg Test 1 0 - load {} Test - load {} Test child + load {} test + load {} test child list [set x] [child eval set x] } {loaded loaded} test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] { @@ -160,55 +168,84 @@ test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] { test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] { set x "not loaded" teststaticpkg More 0 1 - load {} More + load {} more set x } {not loaded} -test load-7.4 {Tcl_StaticPackage procedure, redundant calls} \ - [list teststaticpkg $dll $loaded] { - teststaticpkg Double 0 1 +catch {load [file join $testDir pkga$ext] Pkga} +catch {load [file join $testDir pkgb$ext] Pkgb} +catch {load [file join $testDir pkge$ext] Pkge} +set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] +test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup { + teststaticpkg Test 1 0 + teststaticpkg Another 0 0 + teststaticpkg More 0 1 +} -constraints [list teststaticpkg $dll $loaded] -body { + teststaticpkg Double 0 1 + teststaticpkg Double 0 1 + info loaded +} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded] + +testConstraint teststaticpkg_8.x 0 +if {[testConstraint teststaticpkg]} { + catch { + teststaticpkg Test 1 1 + teststaticpkg Another 0 1 + teststaticpkg More 0 1 teststaticpkg Double 0 1 - info loaded - } [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded] + testConstraint teststaticpkg_8.x 1 + } +} -test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] { - info loaded -} [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded] -test load-8.2 {TclGetLoadedPackages procedure} [list teststaticpkg] { - list [catch {info loaded gorp} msg] $msg -} {1 {could not find interpreter "gorp"}} -test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] { - list [info loaded {}] [info loaded child] -} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] -test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] { - load [file join $testDir pkgb$ext] pkgb - list [info loaded {}] [lsort [info commands pkgb_*]] -} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_sub pkgb_unsafe}] +test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { + lsort -index 1 [info loaded] +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]] +test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body { + info loaded gorp +} -returnCodes error -result {could not find interpreter "gorp"} +test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { + lsort -index 1 [info loaded {}] +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] +test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { + lsort -index 1 [info loaded child] +} [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] +test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { + load [file join $testDir pkgb$ext] Pkgb + list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] +} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child -test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \ - -constraints {teststaticpkg} \ - -setup { - interp create child1 - interp create child2 - load {} Tcltest child1 - load {} Tcltest child2 - } \ - -body { - child1 eval { teststaticpkg Loadninepointone 0 1 } - child2 eval { teststaticpkg Loadninepointone 0 1 } - list \ - [child1 eval { info loaded {} }] \ - [child2 eval { info loaded {} }] - } \ - -match glob -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} \ - -cleanup { interp delete child1 ; interp delete child2 } - -test load-10.1 {load from vfs} \ - -constraints [list $dll $loaded testsimplefilesystem] \ - -setup {set dir [pwd]; cd $testDir; testsimplefilesystem 1} \ - -body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \ - -result {0 {}} \ - -cleanup {testsimplefilesystem 0; cd $dir; unset dir} +test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} -setup { + interp create child1 + interp create child2 + load {} Tcltest child1 + load {} Tcltest child2 +} -constraints {teststaticpkg} -body { + child1 eval { teststaticpkg Loadninepointone 0 1 } + child2 eval { teststaticpkg Loadninepointone 0 1 } + list [child1 eval { info loaded {} }] \ + [child2 eval { info loaded {} }] +} -match glob -cleanup { + interp delete child1 + interp delete child2 +} -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} + +test load-10.1 {load from vfs} -setup { + set dir [pwd] + cd $testDir + testsimplefilesystem 1 +} -constraints [list $dll $loaded testsimplefilesystem] -body { + list [catch {load simplefs:/pkgd$ext PKGD} msg] $msg +} -result {0 {}} -cleanup { + testsimplefilesystem 0 + cd $dir + unset dir +} + +test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \ + [list $dll $loaded] { + load [file join $testDir pkgooa$ext] + list [pkgooa_stubsok] [lsort [info commands pkgooa_*]] +} {1 pkgooa_stubsok} # cleanup unset ext diff --git a/tests/lpop.test b/tests/lpop.test new file mode 100644 index 0000000..272c82f --- /dev/null +++ b/tests/lpop.test @@ -0,0 +1,145 @@ +# Commands covered: lpop +# +# 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 +# generates output for errors. No output means no errors were found. +# +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +unset -nocomplain no; # following tests expecting var "no" does not exists +test lpop-1.1 {error conditions} -returnCodes error -body { + lpop no +} -result {can't read "no": no such variable} +test lpop-1.2 {error conditions} -returnCodes error -body { + lpop no 0 +} -result {can't read "no": no such variable} +test lpop-1.3 {error conditions} -returnCodes error -body { + set l "x {}x" + lpop l +} -result {list element in braces followed by "x" instead of space} +test lpop-1.4 {error conditions} -returnCodes error -body { + set l "x y" + lpop l -1 +} -result {index "-1" out of range} +test lpop-1.4b {error conditions (also check SF on empty list variable, bug [234d6c811d])} -body { + set l "x y" + list [lpop l] [lpop l] [catch {lpop l} v] $v [catch {lpop l 0} v] $v $l +} -result {y x 1 {index "end" out of range} 1 {index "0" out of range} {}} +test lpop-1.5 {error conditions} -returnCodes error -body { + set l "x y z" + lpop l 3 +} -result {index "3" out of range} ;#-errorCode {TCL OPERATION LPOP BADINDEX} +test lpop-1.6 {error conditions} -returnCodes error -body { + set l "x y" + lpop l end+1 +} -result {index "end+1" out of range} +test lpop-1.7 {error conditions} -returnCodes error -body { + set l "x y" + lpop l {} +} -match glob -result {bad index *} +test lpop-1.8 {error conditions} -returnCodes error -body { + set l "x y" + lpop l 0 0 0 0 1 +} -result {index "1" out of range} +test lpop-1.9 {error conditions} -returnCodes error -body { + set l "x y" + lpop l {1 0} +} -match glob -result {bad index *} + +test lpop-2.1 {basic functionality} -body { + set l "x y z" + list [lpop l 0] $l +} -result {x {y z}} +test lpop-2.2 {basic functionality} -body { + set l "x y z" + list [lpop l 1] $l +} -result {y {x z}} +test lpop-2.3 {basic functionality} -body { + set l "x y z" + list [lpop l] $l +} -result {z {x y}} +test lpop-2.4 {basic functionality} -body { + set l "x y z" + set l2 $l + list [lpop l] $l $l2 +} -result {z {x y} {x y z}} + +test lpop-3.1 {nested} -body { + set l "x y" + set l2 $l + list [lpop l 0 0 0 0] $l $l2 +} -result {x {{{{}}} y} {x y}} +test lpop-3.2 {nested} -body { + set l "{x y} {a b}" + list [lpop l 0 1] $l +} -result {y {x {a b}}} +test lpop-3.3 {nested} -body { + set l "{x y} {a b}" + list [lpop l 1 0] $l +} -result {a {{x y} b}} + + + + + +test lpop-99.1 {performance} -constraints perf -body { + set l [lrepeat 10000 x] + set l2 $l + set t1 [time { + while {[llength $l] >= 2} { + lpop l end + } + }] + set l [lrepeat 30000 x] + set l2 $l + set t2 [time { + while {[llength $l] >= 2} { + lpop l end + } + }] + regexp {\d+} $t1 ms1 + regexp {\d+} $t2 ms2 + set ratio [expr {double($ms2)/$ms1}] + # Deleting from end should have linear performance + expr {$ratio > 4 ? $ratio : 4} +} -result {4} + +test lpop-99.2 {performance} -constraints perf -body { + set l [lrepeat 10000 x] + set l2 $l + set t1 [time { + while {[llength $l] >= 2} { + lpop l 1 + } + }] + set l [lrepeat 30000 x] + set l2 $l + set t2 [time { + while {[llength $l] >= 2} { + lpop l 1 + } + }] + regexp {\d+} $t1 ms1 + regexp {\d+} $t2 ms2 + set ratio [expr {double($ms2)/$ms1}] + expr {$ratio > 10 ? $ratio : 10} +} -result {10} + + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/lrange.test b/tests/lrange.test index 6c81872..695c370 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -4,18 +4,23 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] + +testConstraint testpurebytesobj [llength [info commands testpurebytesobj]] + test lrange-1.1 {range of list elements} { lrange {a b c d} 1 2 } {b c} @@ -61,9 +66,11 @@ test lrange-1.14 {range of list elements} { test lrange-1.15 {range of list elements} { concat \"[lrange {a b \{\ } 0 2]" } {"a b \{\ "} +# emacs highlighting bug workaround --> " test lrange-1.16 {list element quoting} { - lrange {[append a .b]} 0 end + lrange {[append a .b]} 0 end } {{[append} a .b\]} + test lrange-2.1 {error conditions} { list [catch {lrange a b} msg] $msg } {1 {wrong # args: should be "lrange list first last"}} @@ -83,6 +90,168 @@ test lrange-2.6 {error conditions} { list [catch {lrange "a b c \{ d e" 1 4} msg] $msg } {1 {unmatched open brace in list}} +test lrange-3.1 {Bug 3588366: end-offsets before start} { + apply {l { + lrange $l 0 end-5 + }} {1 2 3 4 5} +} {} +test lrange-3.2 {compiled with static indices out of range, negative} { + list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3] +} [lrepeat 4 {}] +test lrange-3.3 {compiled with calculated indices out of range, negative constant} { + list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1] +} [lrepeat 4 {}] +test lrange-3.4 {compiled with calculated indices out of range, after end} -body { + list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2] +} -result [lrepeat 4 {}] + +test lrange-3.5 {compiled with calculated indices, start out of range (negative)} { + list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1] +} [lrepeat 4 {a b}] +test lrange-3.6 {compiled with calculated indices, end out of range (after end)} { + list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1] +} [lrepeat 4 {b c}] + +test lrange-3.7a {compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} { + list [lrange { } 0 1] [lrange [format %c 32] 0 1] [lrange [set a { }] 0 1] \ + [lrange { } 0-1 end+1] [lrange [format %c 32] 0-1 end+1] [lrange $a 0-1 end+1] +} [lrepeat 6 {}] +test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} -body { + set cmd lrange + list [$cmd { } 0 1] [$cmd [format %c 32] 0 1] [$cmd [set a { }] 0 1] \ + [$cmd { } 0-1 end+1] [$cmd [format %c 32] 0-1 end+1] [$cmd $a 0-1 end+1] +} -result [lrepeat 6 {}] +# following 4 tests could cause a segfault on empty non-lists with tclEmptyStringRep +# (as before the fix [58c46e74b931d3a1]): +test lrange-3.7a.2 {compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} { + list [lrange {} 0 1] [lrange [lindex a -1] 0 1] [lrange [set a {}] 0 1] \ + [lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1] +} [lrepeat 6 {}] +test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} -body { + set cmd lrange + list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \ + [$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1] +} -result [lrepeat 6 {}] +test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints { + testpurebytesobj +} -body { + list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \ + [lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1] +} -result [lrepeat 6 {}] +test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints { + testpurebytesobj +} -body { + set cmd lrange + list [$cmd [testpurebytesobj] 0 1] [$cmd [testpurebytesobj { }] 0 1] [$cmd [set a [testpurebytesobj {}]] 0 1] \ + [$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1] +} -result [lrepeat 6 {}] + +test lrange-4.1 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # Shared + set ll2 $ll1 + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get new pure object + set x [lrange $ll1 0 end] + set rep2 [tcl::unsupported::representation $x] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Check for a new clean object +} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} + +test lrange-4.2 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # Shared + set ll2 $ll1 + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get new pure object, not compiled + set x [[string cat l range] $ll1 0 end] + set rep2 [tcl::unsupported::representation $x] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Check for a new clean object +} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} + +test lrange-4.3 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get pure object, unshared + set ll2 [lrange $ll1[set ll1 {}] 0 end] + set rep2 [tcl::unsupported::representation $ll2] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Internal optimisations should keep the same object +} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} + +test lrange-4.4 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get pure object, unshared, not compiled + set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end] + set rep2 [tcl::unsupported::representation $ll2] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Internal optimisations should keep the same object +} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} + +# Testing for compiled vs non-compiled behaviour, and shared vs non-shared. +# Far too many variations to check with spelt-out tests. +# Note that this *just* checks whether the different versions are the same +# not whether any of them is correct. +apply {{} { + set lss {{} {a} {a b c} {a b c d}} + set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2} + set lrange lrange + + foreach ls $lss { + foreach a $idxs { + foreach b $idxs { + # Shared, uncompiled + set ls2 $ls + set expected [list [catch {$lrange $ls $a $b} m] $m] + # Shared, compiled + set tester [list lrange $ls $a $b] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lrange-5.[incr n].1 {lrange shared compiled} -body \ + [list apply [list {} $script]] -result $expected + # Unshared, uncompiled + set tester [string map [list %l [list $ls] %a $a %b $b] { + [string cat l range] [lrange %l 0 end] %a %b + }] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lrange-5.$n.2 {lrange unshared uncompiled} -body \ + [list apply [list {} $script]] -result $expected + # Unshared, compiled + set tester [string map [list %l [list $ls] %a $a %b $b] { + lrange [lrange %l 0 end] %a %b + }] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lrange-5.$n.3 {lrange unshared compiled} -body \ + [list apply [list {} $script]] -result $expected + } + } + } +}} + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/lrepeat.test b/tests/lrepeat.test index 788bb9b..c1c8b02 100644 --- a/tests/lrepeat.test +++ b/tests/lrepeat.test @@ -4,13 +4,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2003 by Simon Geard. +# Copyright © 2003 Simon Geard. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -40,7 +40,7 @@ test lrepeat-1.4 {error cases} { lrepeat -3 1 } -returnCodes 1 - -result {bad count "-3": must be integer >= 0} + -result {bad count "-3": must be integer >= 0} } test lrepeat-1.5 {Accept zero repetitions (TIP 323)} { -body { @@ -53,7 +53,7 @@ test lrepeat-1.6 {error cases} { lrepeat 3.5 1 } -returnCodes 1 - -result {expected integer but got "3.5"} + -result {expected integer but got "3.5"} } test lrepeat-1.7 {Accept zero repetitions (TIP 323)} { -body { diff --git a/tests/lreplace.test b/tests/lreplace.test index 5f675bc..0b26e86 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -4,18 +4,18 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } - + test lreplace-1.1 {lreplace command} { lreplace {1 2 3 4 5} 0 0 a } {a 2 3 4 5} @@ -98,29 +98,40 @@ test lreplace-1.26 {lreplace command} { [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] } {a {} {}} +test lreplace-1.27 {lreplace command} -body { + lreplace x 1 1 +} -result x +test lreplace-1.28 {lreplace command} -body { + lreplace x 1 1 y +} -result {x y} +test lreplace-1.29 {lreplace command} -body { + lreplace x 1 1 [error foo] +} -returnCodes 1 -result {foo} +test lreplace-1.30 {lreplace command} -body { + lreplace {not {}alist} 0 0 [error foo] +} -returnCodes 1 -result {foo} - -test lreplace-2.1 {lreplace errors} { +test lreplace-2.1 {lreplace errors} -body { list [catch lreplace msg] $msg -} {1 {wrong # args: should be "lreplace list first last ?element ...?"}} -test lreplace-2.2 {lreplace errors} { +} -result {1 {wrong # args: should be "lreplace list first last ?element ...?"}} +test lreplace-2.2 {lreplace errors} -body { list [catch {lreplace a b} msg] $msg -} {1 {wrong # args: should be "lreplace list first last ?element ...?"}} -test lreplace-2.3 {lreplace errors} { +} -result {1 {wrong # args: should be "lreplace list first last ?element ...?"}} +test lreplace-2.3 {lreplace errors} -body { list [catch {lreplace x a 10} msg] $msg -} {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}} -test lreplace-2.4 {lreplace errors} { +} -result {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}} +test lreplace-2.4 {lreplace errors} -body { list [catch {lreplace x 10 x} msg] $msg -} {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}} -test lreplace-2.5 {lreplace errors} { +} -result {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}} +test lreplace-2.5 {lreplace errors} -body { list [catch {lreplace x 10 1x} msg] $msg -} {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} -test lreplace-2.6 {lreplace errors} { +} -result {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} +test lreplace-2.6 {lreplace errors} -body { list [catch {lreplace x 3 2} msg] $msg -} {1 {list doesn't contain element 3}} -test lreplace-2.7 {lreplace errors} { - list [catch {lreplace x 1 1} msg] $msg -} {1 {list doesn't contain element 1}} +} -result {0 x} +test lreplace-2.7 {lreplace errors} -body { + list [catch {lreplace x 2 2} msg] $msg +} -result {0 x} test lreplace-3.1 {lreplace won't modify shared argument objects} { proc p {} { @@ -130,7 +141,106 @@ 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} +test lreplace-4.13 {lreplace empty list} { + lreplace {} 1 1 1 +} 1 +test lreplace-4.14 {lreplace empty list} { + lreplace {} 2 2 2 +} 2 + +test lreplace-5.1 {compiled lreplace: Bug 47ac84309b} { + apply {x { + lreplace $x end 0 + }} {a b c} +} {a b c} +test lreplace-5.2 {compiled lreplace: Bug 47ac84309b} { + apply {x { + lreplace $x end 0 A + }} {a b c} +} {a b A c} + +# Testing for compiled behaviour. Far too many variations to check with +# spelt-out tests. Note that this *just* checks whether the compiled version +# and the interpreted version are the same, not whether the interpreted +# version is correct. +apply {{} { + set lss {{} {a} {a b c} {a b c d}} + set ins {{} A {A B}} + set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2} + set lreplace lreplace + + foreach ls $lss { + foreach a $idxs { + foreach b $idxs { + foreach i $ins { + set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m] + set tester [list lreplace $ls $a $b {*}$i] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lreplace-6.[incr n] {lreplace battery} -body \ + [list apply [list {} $script]] -result $expected + } + } + } + } +}} + # cleanup catch {unset foo} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/lsearch.test b/tests/lsearch.test index f36e987..06f3ae4 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -59,7 +59,7 @@ test lsearch-2.9 {search modes} { } 1 test lsearch-2.10 {search modes} -returnCodes error -body { lsearch -glib {b.x bx xy bcx} b.x -} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} test lsearch-2.11 {search modes with -nocase} { lsearch -exact -nocase {a b c A B C} A } 0 @@ -87,10 +87,10 @@ test lsearch-3.2 {lsearch errors} -returnCodes error -body { } -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} test lsearch-3.3 {lsearch errors} -returnCodes error -body { lsearch a b c -} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} test lsearch-3.4 {lsearch errors} -returnCodes error -body { lsearch a b c d -} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} test lsearch-3.5 {lsearch errors} -returnCodes error -body { lsearch "\{" b } -result {unmatched open brace in list} @@ -149,14 +149,14 @@ test lsearch-5.2 {binary search} { } set res } $decreasingIntegers -test lsearch-5.3 {binary search finds leftmost occurances} { +test lsearch-5.3 {binary search finds leftmost occurrences} { set res {} for {set i 0} {$i < 10} {incr i} { lappend res [lsearch -integer -sorted $repeatingIncreasingIntegers $i] } set res } [list 0 5 10 15 20 25 30 35 40 45] -test lsearch-5.4 {binary search -decreasing finds leftmost occurances} { +test lsearch-5.4 {binary search -decreasing finds leftmost occurrences} { set res {} for {set i 9} {$i >= 0} {incr i -1} { lappend res [lsearch -sorted -integer -decreasing \ @@ -384,7 +384,7 @@ test lsearch-14.8 {combinations: -start, -inline and -not} { } {c4} test lsearch-15.1 {make sure no shimmering occurs} { - set x [expr int(sin(0))] + set x [expr {int(sin(0))}] lsearch -start $x $x $x } 0 @@ -404,20 +404,48 @@ test lsearch-17.2 {lsearch -index option, basic functionality} { lsearch -index 1 -exact {{a c} {a b} {a a}} a } 2 test lsearch-17.3 {lsearch -index option, basic functionality} { - lsearch -index 1 -glob {{ab cb} {ab bb} {ab ab}} b* + lsearch -index 1 -glob {{ab cb} {ab bb} {ab ab}} b* } 1 test lsearch-17.4 {lsearch -index option, basic functionality} { lsearch -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b} -} 0 +} 0 test lsearch-17.5 {lsearch -index option, basic functionality} { lsearch -all -index 0 -exact {{a c} {a b} {d a}} a } {0 1} test lsearch-17.6 {lsearch -index option, basic functionality} { - lsearch -all -index 1 -glob {{ab cb} {ab bb} {db bx}} b* + lsearch -all -index 1 -glob {{ab cb} {ab bb} {db bx}} b* } {1 2} test lsearch-17.7 {lsearch -index option, basic functionality} { lsearch -all -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b} } {0 1} +test lsearch-17.8 {lsearch -index option, empty argument} { + lsearch -index {} a a +} 0 +test lsearch-17.9 {lsearch -index option, empty argument} { + lsearch -index {} a a +} [lsearch a a] +test lsearch-17.10 {lsearch -index option, empty argument} { + lsearch -index {} [list \{] \{ +} 0 +test lsearch-17.11 {lsearch -index option, empty argument} { + lsearch -index {} [list \{] \{ +} [lsearch [list \{] \{] +test lsearch-17.12 {lsearch -index option, encoding aliasing} -body { + lsearch -index -2 a a +} -returnCodes error -result {index "-2" out of range} +test lsearch-17.13 {lsearch -index option, encoding aliasing} -body { + lsearch -index -1-1 a a +} -returnCodes error -result {index "-1-1" out of range} +test lsearch-17.14 {lsearch -index option, encoding aliasing} -body { + lsearch -index end--1 a a +} -returnCodes error -result {index "end--1" out of range} +test lsearch-17.15 {lsearch -index option, encoding aliasing} -body { + lsearch -index end+1 a a +} -returnCodes error -result {index "end+1" out of range} +test lsearch-17.16 {lsearch -index option, encoding aliasing} -body { + lsearch -index end+2 a a +} -returnCodes error -result {index "end+2" out of range} + test lsearch-18.1 {lsearch -index option, list as index basic functionality} { lsearch -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a @@ -426,30 +454,39 @@ test lsearch-18.2 {lsearch -index option, list as index basic functionality} { lsearch -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } 0 test lsearch-18.3 {lsearch -index option, list as index basic functionality} { - lsearch -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* + lsearch -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* } 0 test lsearch-18.4 {lsearch -index option, list as index basic functionality} { lsearch -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} -} 0 +} 0 test lsearch-18.5 {lsearch -index option, list as index basic functionality} { lsearch -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {0 1} -test lsearch-19.1 {lsearch -sunindices option} { +test lsearch-19.1 {lsearch -subindices option} { lsearch -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } {1 0 0} -test lsearch-19.2 {lsearch -sunindices option} { +test lsearch-19.2 {lsearch -subindices option} { lsearch -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } {0 2 0} -test lsearch-19.3 {lsearch -sunindices option} { - lsearch -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* +test lsearch-19.3 {lsearch -subindices option} { + lsearch -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* } {0 1 1} -test lsearch-19.4 {lsearch -sunindices option} { +test lsearch-19.4 {lsearch -subindices option} { lsearch -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} -} {0 0 1} -test lsearch-19.5 {lsearch -sunindices option} { +} {0 0 1} +test lsearch-19.5 {lsearch -subindices option} { lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {{0 0 0} {1 0 0}} +test lsearch-19.6 {lsearch -subindices option} { + lsearch -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a +} {{0 1 0} {1 1 0}} +test lsearch-19.7 {lsearch -subindices option} { + lsearch -subindices -index end {{1 a}} a +} {0 1} +test lsearch-19.8 {lsearch -subindices option} { + lsearch -subindices -all -index end {{1 a}} a +} {{0 1}} test lsearch-20.1 {lsearch -index option, index larger than sublists} -body { lsearch -index 2 {{a c} {a b} {a a}} a @@ -509,6 +546,149 @@ test lsearch-22.5 {lsearch -bisect, all equal} { test lsearch-22.6 {lsearch -sorted, all equal} { lsearch -sorted -integer {5 5 5 5} 5 } {0} + +test lsearch-23.1 {lsearch -stride option, errors} -body { + lsearch -stride {a b} a +} -returnCodes error -result {"-stride" option must be followed by stride length} +test lsearch-23.2 {lsearch -stride option, errors} -body { + lsearch -stride 0 {a b} a +} -returnCodes error -result {stride length must be at least 1} +test lsearch-23.3 {lsearch -stride option, errors} -body { + lsearch -stride 2 {a b c} a +} -returnCodes error -result {list size must be a multiple of the stride length} +test lsearch-23.4 {lsearch -stride option, errors} -body { + lsearch -stride 5 {a b c} a +} -returnCodes error -result {list size must be a multiple of the stride length} +test lsearch-23.5 {lsearch -stride option, errors} -body { + # Stride equal to length is ok + lsearch -stride 3 {a b c} a +} -result 0 + +test lsearch-24.1 {lsearch -stride option} -body { + lsearch -stride 2 {a b c d e f g h} d +} -result -1 +test lsearch-24.2 {lsearch -stride option} -body { + lsearch -stride 2 {a b c d e f g h} e +} -result 4 +test lsearch-24.3 {lsearch -stride option} -body { + lsearch -stride 3 {a b c d e f g h i} e +} -result -1 +test lsearch-24.4 {lsearch -stride option} -body { + # Result points first in group + lsearch -stride 3 -index 1 {a b c d e f g h i} e +} -result 3 +test lsearch-24.5 {lsearch -stride option} -body { + lsearch -inline -stride 2 {a b c d e f g h} d +} -result {} +test lsearch-24.6 {lsearch -stride option} -body { + # Inline result is a "single element" strided list + lsearch -inline -stride 2 {a b c d e f g h} e +} -result "e f" +test lsearch-24.7 {lsearch -stride option} -body { + lsearch -inline -stride 3 {a b c d e f g h i} e +} -result {} +test lsearch-24.8 {lsearch -stride option} -body { + lsearch -inline -stride 3 -index 1 {a b c d e f g h i} e +} -result "d e f" +test lsearch-24.9 {lsearch -stride option} -body { + lsearch -all -inline -stride 3 -index 1 {a b c d e f g e i} e +} -result "d e f g e i" +test lsearch-24.10 {lsearch -stride option} -body { + lsearch -all -inline -stride 3 -index 0 {a b c d e f a e i} a +} -result "a b c a e i" +test lsearch-24.11 {lsearch -stride option} -body { + # Stride 1 is same as no stride + lsearch -stride 1 {a b c d e f g h} d +} -result 3 + +# 25* mimics 19* but with -inline added to -subindices +test lsearch-25.1 {lsearch -subindices option} { + lsearch -inline -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a +} {a} +test lsearch-25.2 {lsearch -subindices option} { + lsearch -inline -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a +} {a} +test lsearch-25.3 {lsearch -subindices option} { + lsearch -inline -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* +} {bb} +test lsearch-25.4 {lsearch -subindices option} { + lsearch -inline -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} +} {cb} +test lsearch-25.5 {lsearch -subindices option} { + lsearch -inline -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a +} {a a} +test lsearch-25.6 {lsearch -subindices option} { + lsearch -inline -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a +} {a a} + +# 26* mimics 19* but with -stride added +test lsearch-26.1 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a +} {3 0} +test lsearch-26.2 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a +} {2 0} +test lsearch-26.3 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b* +} {1 1} +test lsearch-26.4 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b} +} {0 1} +test lsearch-26.5 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a +} {{0 0} {3 0}} +test lsearch-26.6 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a +} {{1 0} {4 0}} + +# 27* mimics 25* but with -stride added +test lsearch-27.1 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a +} {a} +test lsearch-27.2 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a +} {a} +test lsearch-27.3 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b* +} {bb} +test lsearch-27.4 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b} +} {cb} +test lsearch-27.5 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a +} {a a} +test lsearch-27.6 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a +} {a a} + +test lsearch-28.1 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 5 +} -result 0 +test lsearch-28.2 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 3 +} -result -1 +test lsearch-28.3 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 7 +} -result 2 +test lsearch-28.4 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 8 +} -result -1 +test lsearch-28.5 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 9 +} -result 4 +test lsearch-28.6 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 2 +} -result -1 +test lsearch-28.7 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 -index 0 -subindices {5 3 7 8 9 2} 9 +} -result 4 +test lsearch-28.8 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 -index 1 -subindices {3 5 8 7 2 9} 9 +} -result 5 +test lsearch-28.9 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 -index 1 -subindices -inline {3 5 8 7 2 9} 9 +} -result 9 + # cleanup catch {unset res} diff --git a/tests/lset.test b/tests/lset.test index 1c1300b..5093369 100644 --- a/tests/lset.test +++ b/tests/lset.test @@ -6,18 +6,18 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. +# Copyright © 2001 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] proc failTrace {name1 name2 op} { error "trace failed" @@ -97,31 +97,31 @@ test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex { list [catch { testevalex {lset a [list -1] w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "-1" out of range}} test lset-4.4 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a [list 4] w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "4" out of range}} test lset-4.5a {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a [list end--2] w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "end--2" out of range}} test lset-4.5b {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a [list end+2] w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "end+2" out of range}} test lset-4.6 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a [list end-3] w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "end-3" out of range}} test lset-4.7 {lset, not compiled, 3 args, not a list} testevalex { set a "x \{" list [catch { @@ -139,31 +139,31 @@ test lset-4.9 {lset, not compiled, 3 args, index out of range} testevalex { list [catch { testevalex {lset a -1 w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "-1" out of range}} test lset-4.10 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a 4 w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "4" out of range}} test lset-4.11a {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a end--2 w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "end--2" out of range}} test lset-4.11 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a end+2 w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "end+2" out of range}} test lset-4.12 {lset, not compiled, 3 args, index out of range} testevalex { set a {x y z} list [catch { testevalex {lset a end-3 w} } msg] $msg -} {1 {list index out of range}} +} {1 {index "end-3" out of range}} test lset-5.1 {lset, not compiled, 3 args, can't set variable} testevalex { list [catch { @@ -281,43 +281,43 @@ test lset-8.4 {lset, not compiled, bad second index} testevalex { test lset-8.5 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a 2 -1 h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "-1" out of range}} test lset-8.6 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a {2 -1} h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "-1" out of range}} test lset-8.7 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a 2 3 h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "3" out of range}} test lset-8.8 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a {2 3} h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "3" out of range}} test lset-8.9a {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a 2 end--2 h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "end--2" out of range}} test lset-8.9b {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a 2 end+2 h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "end+2" out of range}} test lset-8.10a {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a {2 end--2} h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "end--2" out of range}} test lset-8.10b {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a {2 end+2} h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "end+2" out of range}} test lset-8.11 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a 2 end-2 h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "end-2" out of range}} test lset-8.12 {lset, not compiled, second index out of range} testevalex { set a {{b c} {d e} {f g}} list [catch {testevalex {lset a {2 end-2} h}} msg] $msg -} {1 {list index out of range}} +} {1 {index "end-2" out of range}} test lset-9.1 {lset, not compiled, entire variable} testevalex { set a x diff --git a/tests/lsetComp.test b/tests/lsetComp.test index 6846cbf..a719fe4 100755 --- a/tests/lsetComp.test +++ b/tests/lsetComp.test @@ -6,13 +6,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. +# Copyright © 2001 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -22,7 +22,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { proc evalInProc { script } { proc testProc {} $script set status [catch { - testProc + testProc } result] rename testProc {} return [list $status $result] @@ -60,69 +60,69 @@ test lsetComp-2.3 {lset, compiled, list of args, scalar, one-byte offset} { test lsetComp-2.4 {lset, compiled, list of args, scalar, four-byte offset} { evalInProc { - set x0 0; set x1 0; set x2 0; set x3 0; - set x4 0; set x5 0; set x6 0; set x7 0; - set x8 0; set x9 0; set x10 0; set x11 0; - set x12 0; set x13 0; set x14 0; set x15 0; - set x16 0; set x17 0; set x18 0; set x19 0; - set x20 0; set x21 0; set x22 0; set x23 0; - set x24 0; set x25 0; set x26 0; set x27 0; - set x28 0; set x29 0; set x30 0; set x31 0; - set x32 0; set x33 0; set x34 0; set x35 0; - set x36 0; set x37 0; set x38 0; set x39 0; - set x40 0; set x41 0; set x42 0; set x43 0; - set x44 0; set x45 0; set x46 0; set x47 0; - set x48 0; set x49 0; set x50 0; set x51 0; - set x52 0; set x53 0; set x54 0; set x55 0; - set x56 0; set x57 0; set x58 0; set x59 0; - set x60 0; set x61 0; set x62 0; set x63 0; - set x64 0; set x65 0; set x66 0; set x67 0; - set x68 0; set x69 0; set x70 0; set x71 0; - set x72 0; set x73 0; set x74 0; set x75 0; - set x76 0; set x77 0; set x78 0; set x79 0; - set x80 0; set x81 0; set x82 0; set x83 0; - set x84 0; set x85 0; set x86 0; set x87 0; - set x88 0; set x89 0; set x90 0; set x91 0; - set x92 0; set x93 0; set x94 0; set x95 0; - set x96 0; set x97 0; set x98 0; set x99 0; - set x100 0; set x101 0; set x102 0; set x103 0; - set x104 0; set x105 0; set x106 0; set x107 0; - set x108 0; set x109 0; set x110 0; set x111 0; - set x112 0; set x113 0; set x114 0; set x115 0; - set x116 0; set x117 0; set x118 0; set x119 0; - set x120 0; set x121 0; set x122 0; set x123 0; - set x124 0; set x125 0; set x126 0; set x127 0; - set x128 0; set x129 0; set x130 0; set x131 0; - set x132 0; set x133 0; set x134 0; set x135 0; - set x136 0; set x137 0; set x138 0; set x139 0; - set x140 0; set x141 0; set x142 0; set x143 0; - set x144 0; set x145 0; set x146 0; set x147 0; - set x148 0; set x149 0; set x150 0; set x151 0; - set x152 0; set x153 0; set x154 0; set x155 0; - set x156 0; set x157 0; set x158 0; set x159 0; - set x160 0; set x161 0; set x162 0; set x163 0; - set x164 0; set x165 0; set x166 0; set x167 0; - set x168 0; set x169 0; set x170 0; set x171 0; - set x172 0; set x173 0; set x174 0; set x175 0; - set x176 0; set x177 0; set x178 0; set x179 0; - set x180 0; set x181 0; set x182 0; set x183 0; - set x184 0; set x185 0; set x186 0; set x187 0; - set x188 0; set x189 0; set x190 0; set x191 0; - set x192 0; set x193 0; set x194 0; set x195 0; - set x196 0; set x197 0; set x198 0; set x199 0; - set x200 0; set x201 0; set x202 0; set x203 0; - set x204 0; set x205 0; set x206 0; set x207 0; - set x208 0; set x209 0; set x210 0; set x211 0; - set x212 0; set x213 0; set x214 0; set x215 0; - set x216 0; set x217 0; set x218 0; set x219 0; - set x220 0; set x221 0; set x222 0; set x223 0; - set x224 0; set x225 0; set x226 0; set x227 0; - set x228 0; set x229 0; set x230 0; set x231 0; - set x232 0; set x233 0; set x234 0; set x235 0; - set x236 0; set x237 0; set x238 0; set x239 0; - set x240 0; set x241 0; set x242 0; set x243 0; - set x244 0; set x245 0; set x246 0; set x247 0; - set x248 0; set x249 0; set x250 0; set x251 0; + set x0 0; set x1 0; set x2 0; set x3 0; + set x4 0; set x5 0; set x6 0; set x7 0; + set x8 0; set x9 0; set x10 0; set x11 0; + set x12 0; set x13 0; set x14 0; set x15 0; + set x16 0; set x17 0; set x18 0; set x19 0; + set x20 0; set x21 0; set x22 0; set x23 0; + set x24 0; set x25 0; set x26 0; set x27 0; + set x28 0; set x29 0; set x30 0; set x31 0; + set x32 0; set x33 0; set x34 0; set x35 0; + set x36 0; set x37 0; set x38 0; set x39 0; + set x40 0; set x41 0; set x42 0; set x43 0; + set x44 0; set x45 0; set x46 0; set x47 0; + set x48 0; set x49 0; set x50 0; set x51 0; + set x52 0; set x53 0; set x54 0; set x55 0; + set x56 0; set x57 0; set x58 0; set x59 0; + set x60 0; set x61 0; set x62 0; set x63 0; + set x64 0; set x65 0; set x66 0; set x67 0; + set x68 0; set x69 0; set x70 0; set x71 0; + set x72 0; set x73 0; set x74 0; set x75 0; + set x76 0; set x77 0; set x78 0; set x79 0; + set x80 0; set x81 0; set x82 0; set x83 0; + set x84 0; set x85 0; set x86 0; set x87 0; + set x88 0; set x89 0; set x90 0; set x91 0; + set x92 0; set x93 0; set x94 0; set x95 0; + set x96 0; set x97 0; set x98 0; set x99 0; + set x100 0; set x101 0; set x102 0; set x103 0; + set x104 0; set x105 0; set x106 0; set x107 0; + set x108 0; set x109 0; set x110 0; set x111 0; + set x112 0; set x113 0; set x114 0; set x115 0; + set x116 0; set x117 0; set x118 0; set x119 0; + set x120 0; set x121 0; set x122 0; set x123 0; + set x124 0; set x125 0; set x126 0; set x127 0; + set x128 0; set x129 0; set x130 0; set x131 0; + set x132 0; set x133 0; set x134 0; set x135 0; + set x136 0; set x137 0; set x138 0; set x139 0; + set x140 0; set x141 0; set x142 0; set x143 0; + set x144 0; set x145 0; set x146 0; set x147 0; + set x148 0; set x149 0; set x150 0; set x151 0; + set x152 0; set x153 0; set x154 0; set x155 0; + set x156 0; set x157 0; set x158 0; set x159 0; + set x160 0; set x161 0; set x162 0; set x163 0; + set x164 0; set x165 0; set x166 0; set x167 0; + set x168 0; set x169 0; set x170 0; set x171 0; + set x172 0; set x173 0; set x174 0; set x175 0; + set x176 0; set x177 0; set x178 0; set x179 0; + set x180 0; set x181 0; set x182 0; set x183 0; + set x184 0; set x185 0; set x186 0; set x187 0; + set x188 0; set x189 0; set x190 0; set x191 0; + set x192 0; set x193 0; set x194 0; set x195 0; + set x196 0; set x197 0; set x198 0; set x199 0; + set x200 0; set x201 0; set x202 0; set x203 0; + set x204 0; set x205 0; set x206 0; set x207 0; + set x208 0; set x209 0; set x210 0; set x211 0; + set x212 0; set x213 0; set x214 0; set x215 0; + set x216 0; set x217 0; set x218 0; set x219 0; + set x220 0; set x221 0; set x222 0; set x223 0; + set x224 0; set x225 0; set x226 0; set x227 0; + set x228 0; set x229 0; set x230 0; set x231 0; + set x232 0; set x233 0; set x234 0; set x235 0; + set x236 0; set x237 0; set x238 0; set x239 0; + set x240 0; set x241 0; set x242 0; set x243 0; + set x244 0; set x245 0; set x246 0; set x247 0; + set x248 0; set x249 0; set x250 0; set x251 0; set x252 0; set x253 0; set x254 0; set x255 0; set x {{1 2} {3 4}} lset x {1 1} 5 @@ -145,69 +145,69 @@ test lsetComp-2.6 {lset, compiled, list of args, array, one-byte offset} { test lsetComp-2.7 {lset, compiled, list of args, array, four-byte offset} { evalInProc { - set x0 0; set x1 0; set x2 0; set x3 0; - set x4 0; set x5 0; set x6 0; set x7 0; - set x8 0; set x9 0; set x10 0; set x11 0; - set x12 0; set x13 0; set x14 0; set x15 0; - set x16 0; set x17 0; set x18 0; set x19 0; - set x20 0; set x21 0; set x22 0; set x23 0; - set x24 0; set x25 0; set x26 0; set x27 0; - set x28 0; set x29 0; set x30 0; set x31 0; - set x32 0; set x33 0; set x34 0; set x35 0; - set x36 0; set x37 0; set x38 0; set x39 0; - set x40 0; set x41 0; set x42 0; set x43 0; - set x44 0; set x45 0; set x46 0; set x47 0; - set x48 0; set x49 0; set x50 0; set x51 0; - set x52 0; set x53 0; set x54 0; set x55 0; - set x56 0; set x57 0; set x58 0; set x59 0; - set x60 0; set x61 0; set x62 0; set x63 0; - set x64 0; set x65 0; set x66 0; set x67 0; - set x68 0; set x69 0; set x70 0; set x71 0; - set x72 0; set x73 0; set x74 0; set x75 0; - set x76 0; set x77 0; set x78 0; set x79 0; - set x80 0; set x81 0; set x82 0; set x83 0; - set x84 0; set x85 0; set x86 0; set x87 0; - set x88 0; set x89 0; set x90 0; set x91 0; - set x92 0; set x93 0; set x94 0; set x95 0; - set x96 0; set x97 0; set x98 0; set x99 0; - set x100 0; set x101 0; set x102 0; set x103 0; - set x104 0; set x105 0; set x106 0; set x107 0; - set x108 0; set x109 0; set x110 0; set x111 0; - set x112 0; set x113 0; set x114 0; set x115 0; - set x116 0; set x117 0; set x118 0; set x119 0; - set x120 0; set x121 0; set x122 0; set x123 0; - set x124 0; set x125 0; set x126 0; set x127 0; - set x128 0; set x129 0; set x130 0; set x131 0; - set x132 0; set x133 0; set x134 0; set x135 0; - set x136 0; set x137 0; set x138 0; set x139 0; - set x140 0; set x141 0; set x142 0; set x143 0; - set x144 0; set x145 0; set x146 0; set x147 0; - set x148 0; set x149 0; set x150 0; set x151 0; - set x152 0; set x153 0; set x154 0; set x155 0; - set x156 0; set x157 0; set x158 0; set x159 0; - set x160 0; set x161 0; set x162 0; set x163 0; - set x164 0; set x165 0; set x166 0; set x167 0; - set x168 0; set x169 0; set x170 0; set x171 0; - set x172 0; set x173 0; set x174 0; set x175 0; - set x176 0; set x177 0; set x178 0; set x179 0; - set x180 0; set x181 0; set x182 0; set x183 0; - set x184 0; set x185 0; set x186 0; set x187 0; - set x188 0; set x189 0; set x190 0; set x191 0; - set x192 0; set x193 0; set x194 0; set x195 0; - set x196 0; set x197 0; set x198 0; set x199 0; - set x200 0; set x201 0; set x202 0; set x203 0; - set x204 0; set x205 0; set x206 0; set x207 0; - set x208 0; set x209 0; set x210 0; set x211 0; - set x212 0; set x213 0; set x214 0; set x215 0; - set x216 0; set x217 0; set x218 0; set x219 0; - set x220 0; set x221 0; set x222 0; set x223 0; - set x224 0; set x225 0; set x226 0; set x227 0; - set x228 0; set x229 0; set x230 0; set x231 0; - set x232 0; set x233 0; set x234 0; set x235 0; - set x236 0; set x237 0; set x238 0; set x239 0; - set x240 0; set x241 0; set x242 0; set x243 0; - set x244 0; set x245 0; set x246 0; set x247 0; - set x248 0; set x249 0; set x250 0; set x251 0; + set x0 0; set x1 0; set x2 0; set x3 0; + set x4 0; set x5 0; set x6 0; set x7 0; + set x8 0; set x9 0; set x10 0; set x11 0; + set x12 0; set x13 0; set x14 0; set x15 0; + set x16 0; set x17 0; set x18 0; set x19 0; + set x20 0; set x21 0; set x22 0; set x23 0; + set x24 0; set x25 0; set x26 0; set x27 0; + set x28 0; set x29 0; set x30 0; set x31 0; + set x32 0; set x33 0; set x34 0; set x35 0; + set x36 0; set x37 0; set x38 0; set x39 0; + set x40 0; set x41 0; set x42 0; set x43 0; + set x44 0; set x45 0; set x46 0; set x47 0; + set x48 0; set x49 0; set x50 0; set x51 0; + set x52 0; set x53 0; set x54 0; set x55 0; + set x56 0; set x57 0; set x58 0; set x59 0; + set x60 0; set x61 0; set x62 0; set x63 0; + set x64 0; set x65 0; set x66 0; set x67 0; + set x68 0; set x69 0; set x70 0; set x71 0; + set x72 0; set x73 0; set x74 0; set x75 0; + set x76 0; set x77 0; set x78 0; set x79 0; + set x80 0; set x81 0; set x82 0; set x83 0; + set x84 0; set x85 0; set x86 0; set x87 0; + set x88 0; set x89 0; set x90 0; set x91 0; + set x92 0; set x93 0; set x94 0; set x95 0; + set x96 0; set x97 0; set x98 0; set x99 0; + set x100 0; set x101 0; set x102 0; set x103 0; + set x104 0; set x105 0; set x106 0; set x107 0; + set x108 0; set x109 0; set x110 0; set x111 0; + set x112 0; set x113 0; set x114 0; set x115 0; + set x116 0; set x117 0; set x118 0; set x119 0; + set x120 0; set x121 0; set x122 0; set x123 0; + set x124 0; set x125 0; set x126 0; set x127 0; + set x128 0; set x129 0; set x130 0; set x131 0; + set x132 0; set x133 0; set x134 0; set x135 0; + set x136 0; set x137 0; set x138 0; set x139 0; + set x140 0; set x141 0; set x142 0; set x143 0; + set x144 0; set x145 0; set x146 0; set x147 0; + set x148 0; set x149 0; set x150 0; set x151 0; + set x152 0; set x153 0; set x154 0; set x155 0; + set x156 0; set x157 0; set x158 0; set x159 0; + set x160 0; set x161 0; set x162 0; set x163 0; + set x164 0; set x165 0; set x166 0; set x167 0; + set x168 0; set x169 0; set x170 0; set x171 0; + set x172 0; set x173 0; set x174 0; set x175 0; + set x176 0; set x177 0; set x178 0; set x179 0; + set x180 0; set x181 0; set x182 0; set x183 0; + set x184 0; set x185 0; set x186 0; set x187 0; + set x188 0; set x189 0; set x190 0; set x191 0; + set x192 0; set x193 0; set x194 0; set x195 0; + set x196 0; set x197 0; set x198 0; set x199 0; + set x200 0; set x201 0; set x202 0; set x203 0; + set x204 0; set x205 0; set x206 0; set x207 0; + set x208 0; set x209 0; set x210 0; set x211 0; + set x212 0; set x213 0; set x214 0; set x215 0; + set x216 0; set x217 0; set x218 0; set x219 0; + set x220 0; set x221 0; set x222 0; set x223 0; + set x224 0; set x225 0; set x226 0; set x227 0; + set x228 0; set x229 0; set x230 0; set x231 0; + set x232 0; set x233 0; set x234 0; set x235 0; + set x236 0; set x237 0; set x238 0; set x239 0; + set x240 0; set x241 0; set x242 0; set x243 0; + set x244 0; set x245 0; set x246 0; set x247 0; + set x248 0; set x249 0; set x250 0; set x251 0; set x252 0; set x253 0; set x254 0; set x255 0; set y(0) {{1 2} {3 4}} lset y(0) {1 1} 5 @@ -219,7 +219,7 @@ test lsetComp-2.8 {lset, compiled, list of args, error } { set x { {1 2} {3 4} } lset x {1 5} 5 } -} "1 {list index out of range}" +} {1 {index "5" out of range}} test lsetComp-2.9 {lset, compiled, list of args, error - is string preserved} { set ::x { { 1 2 } { 3 4 } } @@ -253,69 +253,69 @@ test lsetComp-3.3 {lset, compiled, flat args, scalar, one-byte offset} { test lsetComp-3.4 {lset, compiled, scalar, four-byte offset} { evalInProc { - set x0 0; set x1 0; set x2 0; set x3 0; - set x4 0; set x5 0; set x6 0; set x7 0; - set x8 0; set x9 0; set x10 0; set x11 0; - set x12 0; set x13 0; set x14 0; set x15 0; - set x16 0; set x17 0; set x18 0; set x19 0; - set x20 0; set x21 0; set x22 0; set x23 0; - set x24 0; set x25 0; set x26 0; set x27 0; - set x28 0; set x29 0; set x30 0; set x31 0; - set x32 0; set x33 0; set x34 0; set x35 0; - set x36 0; set x37 0; set x38 0; set x39 0; - set x40 0; set x41 0; set x42 0; set x43 0; - set x44 0; set x45 0; set x46 0; set x47 0; - set x48 0; set x49 0; set x50 0; set x51 0; - set x52 0; set x53 0; set x54 0; set x55 0; - set x56 0; set x57 0; set x58 0; set x59 0; - set x60 0; set x61 0; set x62 0; set x63 0; - set x64 0; set x65 0; set x66 0; set x67 0; - set x68 0; set x69 0; set x70 0; set x71 0; - set x72 0; set x73 0; set x74 0; set x75 0; - set x76 0; set x77 0; set x78 0; set x79 0; - set x80 0; set x81 0; set x82 0; set x83 0; - set x84 0; set x85 0; set x86 0; set x87 0; - set x88 0; set x89 0; set x90 0; set x91 0; - set x92 0; set x93 0; set x94 0; set x95 0; - set x96 0; set x97 0; set x98 0; set x99 0; - set x100 0; set x101 0; set x102 0; set x103 0; - set x104 0; set x105 0; set x106 0; set x107 0; - set x108 0; set x109 0; set x110 0; set x111 0; - set x112 0; set x113 0; set x114 0; set x115 0; - set x116 0; set x117 0; set x118 0; set x119 0; - set x120 0; set x121 0; set x122 0; set x123 0; - set x124 0; set x125 0; set x126 0; set x127 0; - set x128 0; set x129 0; set x130 0; set x131 0; - set x132 0; set x133 0; set x134 0; set x135 0; - set x136 0; set x137 0; set x138 0; set x139 0; - set x140 0; set x141 0; set x142 0; set x143 0; - set x144 0; set x145 0; set x146 0; set x147 0; - set x148 0; set x149 0; set x150 0; set x151 0; - set x152 0; set x153 0; set x154 0; set x155 0; - set x156 0; set x157 0; set x158 0; set x159 0; - set x160 0; set x161 0; set x162 0; set x163 0; - set x164 0; set x165 0; set x166 0; set x167 0; - set x168 0; set x169 0; set x170 0; set x171 0; - set x172 0; set x173 0; set x174 0; set x175 0; - set x176 0; set x177 0; set x178 0; set x179 0; - set x180 0; set x181 0; set x182 0; set x183 0; - set x184 0; set x185 0; set x186 0; set x187 0; - set x188 0; set x189 0; set x190 0; set x191 0; - set x192 0; set x193 0; set x194 0; set x195 0; - set x196 0; set x197 0; set x198 0; set x199 0; - set x200 0; set x201 0; set x202 0; set x203 0; - set x204 0; set x205 0; set x206 0; set x207 0; - set x208 0; set x209 0; set x210 0; set x211 0; - set x212 0; set x213 0; set x214 0; set x215 0; - set x216 0; set x217 0; set x218 0; set x219 0; - set x220 0; set x221 0; set x222 0; set x223 0; - set x224 0; set x225 0; set x226 0; set x227 0; - set x228 0; set x229 0; set x230 0; set x231 0; - set x232 0; set x233 0; set x234 0; set x235 0; - set x236 0; set x237 0; set x238 0; set x239 0; - set x240 0; set x241 0; set x242 0; set x243 0; - set x244 0; set x245 0; set x246 0; set x247 0; - set x248 0; set x249 0; set x250 0; set x251 0; + set x0 0; set x1 0; set x2 0; set x3 0; + set x4 0; set x5 0; set x6 0; set x7 0; + set x8 0; set x9 0; set x10 0; set x11 0; + set x12 0; set x13 0; set x14 0; set x15 0; + set x16 0; set x17 0; set x18 0; set x19 0; + set x20 0; set x21 0; set x22 0; set x23 0; + set x24 0; set x25 0; set x26 0; set x27 0; + set x28 0; set x29 0; set x30 0; set x31 0; + set x32 0; set x33 0; set x34 0; set x35 0; + set x36 0; set x37 0; set x38 0; set x39 0; + set x40 0; set x41 0; set x42 0; set x43 0; + set x44 0; set x45 0; set x46 0; set x47 0; + set x48 0; set x49 0; set x50 0; set x51 0; + set x52 0; set x53 0; set x54 0; set x55 0; + set x56 0; set x57 0; set x58 0; set x59 0; + set x60 0; set x61 0; set x62 0; set x63 0; + set x64 0; set x65 0; set x66 0; set x67 0; + set x68 0; set x69 0; set x70 0; set x71 0; + set x72 0; set x73 0; set x74 0; set x75 0; + set x76 0; set x77 0; set x78 0; set x79 0; + set x80 0; set x81 0; set x82 0; set x83 0; + set x84 0; set x85 0; set x86 0; set x87 0; + set x88 0; set x89 0; set x90 0; set x91 0; + set x92 0; set x93 0; set x94 0; set x95 0; + set x96 0; set x97 0; set x98 0; set x99 0; + set x100 0; set x101 0; set x102 0; set x103 0; + set x104 0; set x105 0; set x106 0; set x107 0; + set x108 0; set x109 0; set x110 0; set x111 0; + set x112 0; set x113 0; set x114 0; set x115 0; + set x116 0; set x117 0; set x118 0; set x119 0; + set x120 0; set x121 0; set x122 0; set x123 0; + set x124 0; set x125 0; set x126 0; set x127 0; + set x128 0; set x129 0; set x130 0; set x131 0; + set x132 0; set x133 0; set x134 0; set x135 0; + set x136 0; set x137 0; set x138 0; set x139 0; + set x140 0; set x141 0; set x142 0; set x143 0; + set x144 0; set x145 0; set x146 0; set x147 0; + set x148 0; set x149 0; set x150 0; set x151 0; + set x152 0; set x153 0; set x154 0; set x155 0; + set x156 0; set x157 0; set x158 0; set x159 0; + set x160 0; set x161 0; set x162 0; set x163 0; + set x164 0; set x165 0; set x166 0; set x167 0; + set x168 0; set x169 0; set x170 0; set x171 0; + set x172 0; set x173 0; set x174 0; set x175 0; + set x176 0; set x177 0; set x178 0; set x179 0; + set x180 0; set x181 0; set x182 0; set x183 0; + set x184 0; set x185 0; set x186 0; set x187 0; + set x188 0; set x189 0; set x190 0; set x191 0; + set x192 0; set x193 0; set x194 0; set x195 0; + set x196 0; set x197 0; set x198 0; set x199 0; + set x200 0; set x201 0; set x202 0; set x203 0; + set x204 0; set x205 0; set x206 0; set x207 0; + set x208 0; set x209 0; set x210 0; set x211 0; + set x212 0; set x213 0; set x214 0; set x215 0; + set x216 0; set x217 0; set x218 0; set x219 0; + set x220 0; set x221 0; set x222 0; set x223 0; + set x224 0; set x225 0; set x226 0; set x227 0; + set x228 0; set x229 0; set x230 0; set x231 0; + set x232 0; set x233 0; set x234 0; set x235 0; + set x236 0; set x237 0; set x238 0; set x239 0; + set x240 0; set x241 0; set x242 0; set x243 0; + set x244 0; set x245 0; set x246 0; set x247 0; + set x248 0; set x249 0; set x250 0; set x251 0; set x252 0; set x253 0; set x254 0; set x255 0; set x {{1 2} {3 4}} lset x 1 1 5 @@ -338,69 +338,69 @@ test lsetComp-3.6 {lset, compiled, flat args, array, one-byte offset} { test lsetComp-3.7 {lset, compiled, flat args, array, four-byte offset} { evalInProc { - set x0 0; set x1 0; set x2 0; set x3 0; - set x4 0; set x5 0; set x6 0; set x7 0; - set x8 0; set x9 0; set x10 0; set x11 0; - set x12 0; set x13 0; set x14 0; set x15 0; - set x16 0; set x17 0; set x18 0; set x19 0; - set x20 0; set x21 0; set x22 0; set x23 0; - set x24 0; set x25 0; set x26 0; set x27 0; - set x28 0; set x29 0; set x30 0; set x31 0; - set x32 0; set x33 0; set x34 0; set x35 0; - set x36 0; set x37 0; set x38 0; set x39 0; - set x40 0; set x41 0; set x42 0; set x43 0; - set x44 0; set x45 0; set x46 0; set x47 0; - set x48 0; set x49 0; set x50 0; set x51 0; - set x52 0; set x53 0; set x54 0; set x55 0; - set x56 0; set x57 0; set x58 0; set x59 0; - set x60 0; set x61 0; set x62 0; set x63 0; - set x64 0; set x65 0; set x66 0; set x67 0; - set x68 0; set x69 0; set x70 0; set x71 0; - set x72 0; set x73 0; set x74 0; set x75 0; - set x76 0; set x77 0; set x78 0; set x79 0; - set x80 0; set x81 0; set x82 0; set x83 0; - set x84 0; set x85 0; set x86 0; set x87 0; - set x88 0; set x89 0; set x90 0; set x91 0; - set x92 0; set x93 0; set x94 0; set x95 0; - set x96 0; set x97 0; set x98 0; set x99 0; - set x100 0; set x101 0; set x102 0; set x103 0; - set x104 0; set x105 0; set x106 0; set x107 0; - set x108 0; set x109 0; set x110 0; set x111 0; - set x112 0; set x113 0; set x114 0; set x115 0; - set x116 0; set x117 0; set x118 0; set x119 0; - set x120 0; set x121 0; set x122 0; set x123 0; - set x124 0; set x125 0; set x126 0; set x127 0; - set x128 0; set x129 0; set x130 0; set x131 0; - set x132 0; set x133 0; set x134 0; set x135 0; - set x136 0; set x137 0; set x138 0; set x139 0; - set x140 0; set x141 0; set x142 0; set x143 0; - set x144 0; set x145 0; set x146 0; set x147 0; - set x148 0; set x149 0; set x150 0; set x151 0; - set x152 0; set x153 0; set x154 0; set x155 0; - set x156 0; set x157 0; set x158 0; set x159 0; - set x160 0; set x161 0; set x162 0; set x163 0; - set x164 0; set x165 0; set x166 0; set x167 0; - set x168 0; set x169 0; set x170 0; set x171 0; - set x172 0; set x173 0; set x174 0; set x175 0; - set x176 0; set x177 0; set x178 0; set x179 0; - set x180 0; set x181 0; set x182 0; set x183 0; - set x184 0; set x185 0; set x186 0; set x187 0; - set x188 0; set x189 0; set x190 0; set x191 0; - set x192 0; set x193 0; set x194 0; set x195 0; - set x196 0; set x197 0; set x198 0; set x199 0; - set x200 0; set x201 0; set x202 0; set x203 0; - set x204 0; set x205 0; set x206 0; set x207 0; - set x208 0; set x209 0; set x210 0; set x211 0; - set x212 0; set x213 0; set x214 0; set x215 0; - set x216 0; set x217 0; set x218 0; set x219 0; - set x220 0; set x221 0; set x222 0; set x223 0; - set x224 0; set x225 0; set x226 0; set x227 0; - set x228 0; set x229 0; set x230 0; set x231 0; - set x232 0; set x233 0; set x234 0; set x235 0; - set x236 0; set x237 0; set x238 0; set x239 0; - set x240 0; set x241 0; set x242 0; set x243 0; - set x244 0; set x245 0; set x246 0; set x247 0; - set x248 0; set x249 0; set x250 0; set x251 0; + set x0 0; set x1 0; set x2 0; set x3 0; + set x4 0; set x5 0; set x6 0; set x7 0; + set x8 0; set x9 0; set x10 0; set x11 0; + set x12 0; set x13 0; set x14 0; set x15 0; + set x16 0; set x17 0; set x18 0; set x19 0; + set x20 0; set x21 0; set x22 0; set x23 0; + set x24 0; set x25 0; set x26 0; set x27 0; + set x28 0; set x29 0; set x30 0; set x31 0; + set x32 0; set x33 0; set x34 0; set x35 0; + set x36 0; set x37 0; set x38 0; set x39 0; + set x40 0; set x41 0; set x42 0; set x43 0; + set x44 0; set x45 0; set x46 0; set x47 0; + set x48 0; set x49 0; set x50 0; set x51 0; + set x52 0; set x53 0; set x54 0; set x55 0; + set x56 0; set x57 0; set x58 0; set x59 0; + set x60 0; set x61 0; set x62 0; set x63 0; + set x64 0; set x65 0; set x66 0; set x67 0; + set x68 0; set x69 0; set x70 0; set x71 0; + set x72 0; set x73 0; set x74 0; set x75 0; + set x76 0; set x77 0; set x78 0; set x79 0; + set x80 0; set x81 0; set x82 0; set x83 0; + set x84 0; set x85 0; set x86 0; set x87 0; + set x88 0; set x89 0; set x90 0; set x91 0; + set x92 0; set x93 0; set x94 0; set x95 0; + set x96 0; set x97 0; set x98 0; set x99 0; + set x100 0; set x101 0; set x102 0; set x103 0; + set x104 0; set x105 0; set x106 0; set x107 0; + set x108 0; set x109 0; set x110 0; set x111 0; + set x112 0; set x113 0; set x114 0; set x115 0; + set x116 0; set x117 0; set x118 0; set x119 0; + set x120 0; set x121 0; set x122 0; set x123 0; + set x124 0; set x125 0; set x126 0; set x127 0; + set x128 0; set x129 0; set x130 0; set x131 0; + set x132 0; set x133 0; set x134 0; set x135 0; + set x136 0; set x137 0; set x138 0; set x139 0; + set x140 0; set x141 0; set x142 0; set x143 0; + set x144 0; set x145 0; set x146 0; set x147 0; + set x148 0; set x149 0; set x150 0; set x151 0; + set x152 0; set x153 0; set x154 0; set x155 0; + set x156 0; set x157 0; set x158 0; set x159 0; + set x160 0; set x161 0; set x162 0; set x163 0; + set x164 0; set x165 0; set x166 0; set x167 0; + set x168 0; set x169 0; set x170 0; set x171 0; + set x172 0; set x173 0; set x174 0; set x175 0; + set x176 0; set x177 0; set x178 0; set x179 0; + set x180 0; set x181 0; set x182 0; set x183 0; + set x184 0; set x185 0; set x186 0; set x187 0; + set x188 0; set x189 0; set x190 0; set x191 0; + set x192 0; set x193 0; set x194 0; set x195 0; + set x196 0; set x197 0; set x198 0; set x199 0; + set x200 0; set x201 0; set x202 0; set x203 0; + set x204 0; set x205 0; set x206 0; set x207 0; + set x208 0; set x209 0; set x210 0; set x211 0; + set x212 0; set x213 0; set x214 0; set x215 0; + set x216 0; set x217 0; set x218 0; set x219 0; + set x220 0; set x221 0; set x222 0; set x223 0; + set x224 0; set x225 0; set x226 0; set x227 0; + set x228 0; set x229 0; set x230 0; set x231 0; + set x232 0; set x233 0; set x234 0; set x235 0; + set x236 0; set x237 0; set x238 0; set x239 0; + set x240 0; set x241 0; set x242 0; set x243 0; + set x244 0; set x245 0; set x246 0; set x247 0; + set x248 0; set x249 0; set x250 0; set x251 0; set x252 0; set x253 0; set x254 0; set x255 0; set y(0) {{1 2} {3 4}} lset y(0) 1 1 5 @@ -412,7 +412,7 @@ test lsetComp-3.8 {lset, compiled, flat args, error } { set x { {1 2} {3 4} } lset x 1 5 5 } -} "1 {list index out of range}" +} {1 {index "5" out of range}} test lsetComp-3.9 {lset, compiled, flat args, error - is string preserved} { set ::x { { 1 2 } { 3 4 } } diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index 071f11b..5a62a2a 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -4,13 +4,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2003 Tcl Core Team. +# Copyright © 2003 Tcl Core Team. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -99,7 +99,7 @@ test macOSXFCmd-2.6 {MacOSXSetFileAttribute - hidden} {macosxFileAttr notRoot} { [catch {file attributes foo.test -hidden} msg] $msg \ [file delete -force -- foo.test] } {0 {} 0 1 {}} -test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot} { +test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot nonPortable} { catch {file delete -force -- foo.test} close [open foo.test w] catch { @@ -151,16 +151,16 @@ test macOSXFCmd-4.1 {TclMacOSXMatchType} {macosxFileAttr notRoot} { file attributes dir.test -hidden 1 } set res [list \ - [catch {glob *.test} msg] $msg \ - [catch {glob -types FOOT *.test} msg] $msg \ - [catch {glob -types {{macintosh type FOOT}} *.test} msg] $msg \ - [catch {glob -types FOOTT *.test} msg] $msg \ - [catch {glob -types {{macintosh type FOOTT}} *.test} msg] $msg \ - [catch {glob -types {{macintosh type {}}} *.test} msg] $msg \ - [catch {glob -types {{macintosh creator FOOC}} *.test} msg] $msg \ - [catch {glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test} msg] $msg \ - [catch {glob -types hidden *.test} msg] $msg \ - [catch {glob -types {hidden FOOT} *.test} msg] $msg \ + [catch {lsort [glob *.test]} msg] $msg \ + [catch {lsort [glob -types FOOT *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type FOOT}} *.test]} msg] $msg \ + [catch {lsort [glob -types FOOTT *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type FOOTT}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type {}}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh creator FOOC}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test]} msg] $msg \ + [catch {lsort [glob -types hidden *.test]} msg] $msg \ + [catch {lsort [glob -types {hidden FOOT} *.test]} msg] $msg \ ] cd .. file delete -force globtest diff --git a/tests/macOSXLoad.test b/tests/macOSXLoad.test index 12c77e0..df35b8d 100644 --- a/tests/macOSXLoad.test +++ b/tests/macOSXLoad.test @@ -4,14 +4,14 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } set oldTSF $::tcltest::testSingleFile diff --git a/tests/main.test b/tests/main.test index f1dc7fd..37f87b4 100644 --- a/tests/main.test +++ b/tests/main.test @@ -1,8 +1,8 @@ # This file contains a collection of tests for generic/tclMain.c. -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcl::test::main { @@ -11,12 +11,10 @@ namespace eval ::tcl::test::main { # Is [exec] defined? testConstraint exec [llength [info commands exec]] - # Is the Tcltest package loaded? - # - that is, the special C-coded testing commands in tclTest.c - # - tests use testing commands introduced in Tcltest 8.4 - testConstraint Tcltest [expr { - [llength [package provide Tcltest]] - && [package vsatisfies [package provide Tcltest] 8.4]}] + # Is the tcl::test package loaded? + testConstraint tcl::test [expr { + [llength [package provide tcl::test]] + && [package vsatisfies [package provide tcl::test] 8.5-]}] # Procedure to simulate interactive typing of commands, line by line proc type {chan script} { @@ -129,7 +127,7 @@ namespace eval ::tcl::test::main { set script [makeFile {} script] file delete $script set f [open $script w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" @@ -150,7 +148,7 @@ namespace eval ::tcl::test::main { set script [makeFile {} script] file delete $script set f [open $script w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" @@ -171,7 +169,7 @@ namespace eval ::tcl::test::main { set script [makeFile {} script] file delete $script set f [open $script w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } puts $f "\u20ac]" @@ -192,7 +190,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.1 { Tcl_Main: appInitProc returns error } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile {puts "In script"} script } -body { @@ -208,7 +206,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.2 { Tcl_Main: appInitProc returns error } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << {puts "In script"} -appinitprocerror >& result set f [open result] @@ -221,7 +219,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.3 { Tcl_Main: appInitProc deletes interp } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile {puts "In script"} script } -body { @@ -237,7 +235,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.4 { Tcl_Main: appInitProc deletes interp } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << {puts "In script"} \ -appinitprocdeleteinterp >& result @@ -251,7 +249,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.5 { Tcl_Main: appInitProc closes stderr } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << {puts "In script"} \ -appinitprocclosestderr >& result @@ -336,7 +334,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-3.5 { Tcl_Main: startup script sets main loop } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile { rename exit _exit @@ -364,7 +362,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-3.6 { Tcl_Main: startup script sets main loop and closes stdin } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile { close stdin @@ -393,7 +391,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-3.7 { Tcl_Main: startup script deletes interp } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile { rename exit _exit @@ -417,7 +415,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-3.8 { Tcl_Main: startup script deletes interp and sets mainloop } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile { testsetmainloop @@ -461,7 +459,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.1 { Tcl_Main: rcFile evaluation deletes interp } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile {testinterpdelete {}} rc] } -body { @@ -478,7 +476,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.2 { Tcl_Main: rcFile evaluation closes stdin } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile {close stdin} rc] } -body { @@ -495,7 +493,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.3 { Tcl_Main: rcFile evaluation closes stdin and sets main loop } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile { close stdin @@ -523,7 +521,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.4 { Tcl_Main: rcFile evaluation sets main loop } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile { testsetmainloop @@ -550,7 +548,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.5 { Tcl_Main: Bug 1481986 } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile { testsetmainloop @@ -592,7 +590,7 @@ namespace eval ::tcl::test::main { catch {set f [open "|[list [interpreter]]" w+]} } -body { type $f { - fconfigure stdin -blocking 0 + chan configure stdin -blocking 0 puts SUCCESS } list [catch {gets $f} line] $line @@ -606,19 +604,19 @@ namespace eval ::tcl::test::main { exec } -setup { catch {set f [open "|[list [interpreter]]" w+]} - catch {fconfigure $f -blocking 0} + catch {chan configure $f -blocking 0} } -body { - type $f "fconfigure stdin -eofchar \\032 + type $f "chan configure stdin -eofchar \"\\032 {}\" if 1 \{\n\032" variable wait - fileevent $f readable \ + chan event $f readable \ [list set [namespace which -variable wait] "child exit"] - set id [after 2000 [list set [namespace which -variable wait] timeout]] + set id [after 5000 [list set [namespace which -variable wait] timeout]] vwait [namespace which -variable wait] after cancel $id set wait } -cleanup { - if {[string equal timeout $wait] && [testConstraint unix]} { + if {$wait eq "timeout" && [testConstraint unix]} { exec kill [pid $f] } close $f @@ -631,17 +629,17 @@ namespace eval ::tcl::test::main { } -setup { set cmd {makeFile "if 1 \{" script} catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]} - catch {fconfigure $f -blocking 0} + catch {chan configure $f -blocking 0} } -body { variable wait - fileevent $f readable \ + chan event $f readable \ [list set [namespace which -variable wait] "child exit"] - set id [after 2000 [list set [namespace which -variable wait] timeout]] + set id [after 5000 [list set [namespace which -variable wait] timeout]] vwait [namespace which -variable wait] after cancel $id set wait } -cleanup { - if {[string equal timeout $wait] && [testConstraint unix]} { + if {$wait eq "timeout" && [testConstraint unix]} { exec kill [pid $f] } close $f @@ -698,7 +696,7 @@ namespace eval ::tcl::test::main { Tcl_Main: interactive mode: close stdin -> main loop & [exit] & exit handlers } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { rename exit _exit @@ -719,10 +717,10 @@ namespace eval ::tcl::test::main { } -result "Exit MainLoop\nIn exit\neven 0\n" test Tcl_Main-5.9 { - Tcl_Main: interactive mode: delete interp + Tcl_Main: interactive mode: delete interp -> main loop & exit handlers, but no [exit] } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { rename exit _exit @@ -745,10 +743,10 @@ namespace eval ::tcl::test::main { test Tcl_Main-5.10 { Tcl_Main: exit main loop in mid-interactive command } -constraints { - exec Tcltest + exec tcl::test } -setup { catch {set f [open "|[list [interpreter]]" w+]} - catch {fconfigure $f -blocking 0} + catch {chan configure $f -blocking 0} } -body { type $f "testsetmainloop after 2000 testexitmainloop @@ -766,7 +764,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-5.11 { Tcl_Main: EOF in interactive main loop } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { rename exit _exit @@ -788,7 +786,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-5.12 { Tcl_Main: close stdin in interactive main loop } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { rename exit _exit @@ -841,7 +839,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-6.2 { Tcl_Main: prompt deletes interp } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { set tcl_prompt1 {testinterpdelete {}} @@ -893,7 +891,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-6.5 { Tcl_Main: interactive entry to main loop } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { set tcl_interactive 1 @@ -943,7 +941,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-7.1 { Tcl_Main: [exit] defined as no-op -> still have exithandlers } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { proc exit args {} @@ -959,7 +957,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-7.2 { Tcl_Main: [exit] defined as no-op -> still have exithandlers } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { proc exit args {} @@ -979,11 +977,11 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.1 { StdinProc: handles non-blocking stdin } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop - fconfigure stdin -blocking 0 + chan configure stdin -blocking 0 testexitmainloop } >& result set f [open result] @@ -996,7 +994,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.2 { StdinProc: handles stdin EOF } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1018,7 +1016,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.3 { StdinProc: handles interactive stdin EOF } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1039,7 +1037,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.4 { StdinProc: handles stdin close } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1062,7 +1060,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.5 { StdinProc: handles interactive stdin close } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1086,7 +1084,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.6 { StdinProc: handles event loop re-entry } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1105,7 +1103,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.7 { StdinProc: handling of errors } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1122,7 +1120,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.8 { StdinProc: handling of errors, closed stderr } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1140,7 +1138,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.9 { StdinProc: interactive output } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1156,7 +1154,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.10 { StdinProc: interactive output, closed stdout } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1174,7 +1172,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.11 { StdinProc: prompt deletes interp } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1190,7 +1188,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.12 { StdinProc: prompt closes stdin } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1209,9 +1207,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.13 { Bug 1775878 } -constraints { - exec Tcltest - } -setup { - catch {set f [open "|[list [interpreter]]" w+]} + exec tcl::test } -body { exec [interpreter] << "testsetmainloop\nputs \\\npwd\ntestexitmainloop" >& result set f [open result] diff --git a/tests/mathop.test b/tests/mathop.test index f122b7b..e38001d 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -4,14 +4,14 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 2006 Donal K. Fellows -# Copyright (c) 2006 Peter Spjuth +# Copyright © 2006 Donal K. Fellows +# Copyright © 2006 Peter Spjuth # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.1 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -95,7 +95,7 @@ proc TestOp {op args} { } return [lindex $results 0] } - + # start of tests namespace eval ::testmathop { @@ -901,10 +901,10 @@ test mathop-22.2 { bitwise ops on bignums } { set exp {} foreach d {5 7 2 1 D C 1 F E 0 -D -D 8 -9 -1 -0 -E E} { if {[string match "-*" $d]} { - set d [format %X [expr 15-0x[string range $d 1 end]]] - set val [expr -0x[string repeat $d $dig]-1] + set d [format %X [expr {15-"0x[string range $d 1 end]"}]] + set val [expr {-"0x[string repeat $d $dig]"-1}] } else { - set val [expr 0x[string repeat $d $dig]] + set val [expr {"0x[string repeat $d $dig]"}] } lappend exp $val } @@ -1206,6 +1206,8 @@ test mathop-25.5 { exp operator } {TestOp ** 1 5} 1 test mathop-25.6 { exp operator } {TestOp ** 5 1} 5 test mathop-25.7 { exp operator } {TestOp ** 4 3 2 1} 262144 test mathop-25.8 { exp operator } {TestOp ** 5.5 4} 915.0625 +test mathop-25.8a { exp operator } {TestOp ** 4.0 -1} 0.25 +test mathop-25.8b { exp operator } {TestOp ** 2.0 -2} 0.25 test mathop-25.9 { exp operator } {TestOp ** 16 3.5} 16384.0 test mathop-25.10 { exp operator } {TestOp ** 3.5 0} 1.0 test mathop-25.11 { exp operator } {TestOp ** 378 0} 1 @@ -1219,8 +1221,32 @@ test mathop-25.18 { exp operator } {TestOp ** -1 -2} 1 test mathop-25.19 { exp operator } {TestOp ** -1 3} -1 test mathop-25.20 { exp operator } {TestOp ** -1 4} 1 test mathop-25.21 { exp operator } {TestOp ** 2 63} 9223372036854775808 -test mathop-25.22 { exp operator } {TestOp ** 83756485763458746358734658473567847567473 2} 7015148907444467657897585474493757781161998914521537835809623408157343003287605729 -test mathop-25.23 { exp operator errors } { +test mathop-25.22 { exp operator } {TestOp ** 2 256} 115792089237316195423570985008687907853269984665640564039457584007913129639936 +set big 83756485763458746358734658473567847567473 +test mathop-25.23 { exp operator } {TestOp ** $big 2} 7015148907444467657897585474493757781161998914521537835809623408157343003287605729 +test mathop-25.24 { exp operator } {TestOp ** $big 0} 1 +test mathop-25.25 { exp operator } {TestOp ** $big 1} $big +test mathop-25.26 { exp operator } {TestOp ** $big -1} 0 +test mathop-25.27 { exp operator } {TestOp ** $big -2} 0 +test mathop-25.28 { exp operator } {TestOp ** $big -$big} 0 +test mathop-25.29 { exp operator } {expr {[set res [TestOp ** $big -1.0]] > 0 && $res < 1.2e-41}} 1 +test mathop-25.30 { exp operator } {expr {[set res [TestOp ** $big -1e-18]] > 0 && $res < 1}} 1 +test mathop-25.31 { exp operator } {expr {[set res [TestOp ** -$big -1.0]] > -1 && $res < 0}} 1 +test mathop-25.32 { exp operator } {expr {[set res [TestOp ** -$big -2.0]] > 0 && $res < 1}} 1 +test mathop-25.33 { exp operator } {expr {[set res [TestOp ** -$big -3.0]] > -1 && $res < 0}} 1 +test mathop-25.34 { exp operator } {TestOp ** $big -1e-30} 1.0 +test mathop-25.35 { exp operator } {TestOp ** $big -1e+30} 0.0 +test mathop-25.36 { exp operator } {TestOp ** 0 $big} 0 +test mathop-25.37 { exp operator } {TestOp ** 1 $big} 1 +test mathop-25.38 { exp operator } {TestOp ** -1 $big} -1 +test mathop-25.39 { exp operator } {TestOp ** -1 [expr {$big+1}]} 1 +test mathop-25.40 { exp operator (small exponent power helper and its boundaries) } { + set pwr 0 + set res 1 + while {[incr pwr] <= 17 && [set i [TestOp ** 15 $pwr]] == [set res [expr {$res * 15}]]} {} + list [incr pwr -1] $res +} {17 98526125335693359375} +test mathop-25.41 { exp operator errors } { set res {} set exp {} @@ -1316,6 +1342,46 @@ test mathop-26.2 { misc ops, corner cases } { set res } [list 2147483648 9223372036854775808 9223372036854775808 4294967296 18446744073709551616] +test mathop-27.1 {lt operator} {::tcl::mathop::lt} 1 +test mathop-27.2 {lt operator} {::tcl::mathop::lt a} 1 +test mathop-27.3 {lt operator} {::tcl::mathop::lt a b} 1 +test mathop-27.4 {lt operator} {::tcl::mathop::lt b a} 0 +test mathop-27.5 {lt operator} {::tcl::mathop::lt a a} 0 +test mathop-27.6 {lt operator} {::tcl::mathop::lt a b c} 1 +test mathop-27.7 {lt operator} {::tcl::mathop::lt b a c} 0 +test mathop-27.8 {lt operator} {::tcl::mathop::lt a c b} 0 +test mathop-27.9 {lt operator} {::tcl::mathop::lt 012 0x0} 1 + +test mathop-28.1 {le operator} {::tcl::mathop::le} 1 +test mathop-28.2 {le operator} {::tcl::mathop::le a} 1 +test mathop-28.3 {le operator} {::tcl::mathop::le a b} 1 +test mathop-28.4 {le operator} {::tcl::mathop::le b a} 0 +test mathop-28.5 {le operator} {::tcl::mathop::le a a} 1 +test mathop-28.6 {le operator} {::tcl::mathop::le a b c} 1 +test mathop-28.7 {le operator} {::tcl::mathop::le b a c} 0 +test mathop-28.8 {le operator} {::tcl::mathop::le a c b} 0 +test mathop-28.9 {le operator} {::tcl::mathop::le 012 0x0} 1 + +test mathop-29.1 {gt operator} {::tcl::mathop::gt} 1 +test mathop-29.2 {gt operator} {::tcl::mathop::gt a} 1 +test mathop-29.3 {gt operator} {::tcl::mathop::gt a b} 0 +test mathop-29.4 {gt operator} {::tcl::mathop::gt b a} 1 +test mathop-29.5 {gt operator} {::tcl::mathop::gt a a} 0 +test mathop-29.6 {gt operator} {::tcl::mathop::gt c b a} 1 +test mathop-29.7 {gt operator} {::tcl::mathop::gt b a c} 0 +test mathop-29.8 {gt operator} {::tcl::mathop::gt a c b} 0 +test mathop-29.9 {gt operator} {::tcl::mathop::gt 0x0 012} 1 + +test mathop-30.1 {ge operator} {::tcl::mathop::ge} 1 +test mathop-30.2 {ge operator} {::tcl::mathop::ge a} 1 +test mathop-30.3 {ge operator} {::tcl::mathop::ge a b} 0 +test mathop-30.4 {ge operator} {::tcl::mathop::ge b a} 1 +test mathop-30.5 {ge operator} {::tcl::mathop::ge a a} 1 +test mathop-30.6 {ge operator} {::tcl::mathop::ge c b a} 1 +test mathop-30.7 {ge operator} {::tcl::mathop::ge b a c} 0 +test mathop-30.8 {ge operator} {::tcl::mathop::ge a c b} 0 +test mathop-30.9 {ge operator} {::tcl::mathop::ge 0x0 012} 1 + if 0 { # Compare ops to expr bytecodes namespace import ::tcl::mathop::* @@ -1328,7 +1394,7 @@ if 0 { _X 3 4 5 set ::tcl_traceCompile 0 } - + # cleanup namespace delete ::testmathop namespace delete ::testmathop2 diff --git a/tests/misc.test b/tests/misc.test index 6ddc718..3fce454 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -5,27 +5,27 @@ # tests are pathological cases that caused bugs in earlier Tcl # releases. # -# Copyright (c) 1992-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1992-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testhashsystemhash [llength [info commands testhashsystemhash]] test misc-1.1 {error in variable ref. in command in array reference} { proc tstProc {} { global a - + set tst $a([winfo name $zz]) # this is a bogus comment # this is a bogus comment @@ -42,7 +42,7 @@ test misc-1.1 {error in variable ref. in command in array reference} { test misc-1.2 {error in variable ref. in command in array reference} { proc tstProc {} " global a - + set tst \$a(\[winfo name \$\{zz) # this is a bogus comment # this is a bogus comment @@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} { missing close-brace for variable name missing close-brace for variable name while executing -"set tst $a([winfo name $\{zz) - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a ..." +"set tst $a([winfo name $\{" (procedure "tstProc" line 4) invoked from within "tstProc"}] diff --git a/tests/msgcat.test b/tests/msgcat.test index bbcd023..4549cee 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -2,8 +2,8 @@ # Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1998 Mark Harrison. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998 Mark Harrison. +# Copyright © 1998-1999 Scriptics Corporation. # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # # See the file "license.terms" for information on usage and redistribution @@ -12,13 +12,12 @@ # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. -package require Tcl 8.2 -if {[catch {package require tcltest 2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } -if {[catch {package require msgcat 1.4.5}]} { - puts stderr "Skipping tests in [info script]. No msgcat 1.4.5 found to test." +if {[catch {package require msgcat 1.6}]} { + puts stderr "Skipping tests in [info script]. No msgcat 1.6 found to test." return } @@ -32,6 +31,8 @@ namespace eval ::msgcat::test { # Tests msgcat-0.*: locale initialization + # Calculate set of all permutations of a list + # PowerSet {1 2 3} -> {1 2 3} {2 3} {1 3} 3 {1 2} 2 1 {} proc PowerSet {l} { if {[llength $l] == 0} {return [list [list]]} set element [lindex $l 0] @@ -49,23 +50,36 @@ namespace eval ::msgcat::test { variable body variable result variable setVars - foreach setVars [PowerSet $envVars] { + foreach setVars [PowerSet $envVars] { set result [string tolower [lindex $setVars 0]] if {[string length $result] == 0} { if {[info exists ::tcl::mac::locale]} { +if {[package vsatisfies [package provide msgcat] 1.7]} { + set result [string tolower \ + [msgcat::mcutil::ConvertLocale $::tcl::mac::locale]] +} else { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] +} } else { + if {([info sharedlibextension] eq ".dll") + && ![catch {package require registry}]} { + # Windows and Cygwin have other ways to determine the + # locale when the environment variables are missing + # and the registry package is present + continue + } set result c } } + test msgcat-0.$count [list \ locale initialization from environment variables $setVars \ ] -setup { variable var foreach var $envVars { catch {variable $var $::env($var)} - catch {unset ::env($var)} + unset -nocomplain ::env($var) } foreach var $setVars { set ::env($var) $var @@ -77,14 +91,14 @@ namespace eval ::msgcat::test { } -cleanup { interp delete [namespace current]::i foreach var $envVars { - catch {unset ::env($var)} + unset -nocomplain ::env($var) catch {set ::env($var) [set [namespace current]::$var]} } } -body {i eval msgcat::mclocale} -result $result incr count } - catch {unset result} - + unset -nocomplain result + # Could add tests of initialization from Windows registry here. # Use a fake registry package. @@ -184,6 +198,28 @@ namespace eval ::msgcat::test { mclocale looks/ok/../../../../but/is/path/to/evil/code } -returnCodes error -match glob -result {invalid newLocale value *} + test msgcat-1.14 {mcpreferences, custom locale preferences} -setup { + variable locale [mclocale] + mclocale en + mcpreferences fr en {} + } -cleanup { + mclocale $locale + } -body { + mcpreferences + } -result {fr en {}} + + test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\ + -setup { + variable locale [mclocale] + mcpreferences fr en {} + mclocale en + } -cleanup { + mclocale $locale + } -body { + mcpreferences + } -result {en {}} + + # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning test msgcat-2.1 {mcset, global scope} { @@ -284,11 +320,11 @@ namespace eval ::msgcat::test { variable count 2 variable result array set result { - foo,ov0 ov0_ROOT foo,ov1 ov1_foo foo,ov2 ov2_foo + foo,ov0 ov0_ROOT foo,ov1 ov1_foo foo,ov2 ov2_foo foo,ov3 ov3_foo foo,ov4 ov4 - foo_BAR,ov0 ov0_ROOT foo_BAR,ov1 ov1_foo foo_BAR,ov2 ov2_foo_BAR - foo_BAR,ov3 ov3_foo_BAR foo_BAR,ov4 ov4 - foo_BAR_baz,ov0 ov0_ROOT foo_BAR_baz,ov1 ov1_foo + foo_BAR,ov0 ov0_ROOT foo_BAR,ov1 ov1_foo foo_BAR,ov2 ov2_foo_BAR + foo_BAR,ov3 ov3_foo_BAR foo_BAR,ov4 ov4 + foo_BAR_baz,ov0 ov0_ROOT foo_BAR_baz,ov1 ov1_foo foo_BAR_baz,ov2 ov2_foo_BAR foo_BAR_baz,ov3 ov3_foo_BAR_baz foo_BAR_baz,ov4 ov4 } @@ -317,7 +353,7 @@ namespace eval ::msgcat::test { incr count } } - catch {unset result} + unset -nocomplain result # Tests msgcat-4.*: [mcunknown] @@ -405,9 +441,14 @@ namespace eval ::msgcat::test { foreach loc {foo foo_BAR foo_BAR_baz} { test msgcat-5.$count {mcload} -setup { variable locale [mclocale] + ::msgcat::mclocale "" + ::msgcat::mcloadedlocales clear + ::msgcat::mcpackageconfig unset mcfolder mclocale $loc } -cleanup { mclocale $locale + ::msgcat::mcloadedlocales clear + ::msgcat::mcpackageconfig unset mcfolder } -body { mcload $msgdir } -result [expr { $count+1 }] @@ -421,6 +462,8 @@ namespace eval ::msgcat::test { mclocale foo_BAR_notexist } -cleanup { mclocale $locale + mcloadedlocales clear + mcpackageconfig unset mcfolder } -body { mcload $msgdir } -result 3 @@ -430,6 +473,8 @@ namespace eval ::msgcat::test { mclocale no_FI_notexist } -cleanup { mclocale $locale + mcloadedlocales clear + mcpackageconfig unset mcfolder } -body { mcload $msgdir } -result 1 @@ -490,6 +535,20 @@ namespace eval ::msgcat::test { mc def } -result unknown:no_fi_notexist:def + test msgcat-5.11 {mcpackageconfig mcfolder} -setup { + variable locale [mclocale] + mclocale "" + mcloadedlocales clear + mcpackageconfig unset mcfolder + } -cleanup { + mclocale $locale + mcloadedlocales clear + mcpackageconfig unset mcfolder + } -body { + mclocale foo + mcpackageconfig set mcfolder $msgdir + } -result 2 + foreach loc $locales { if { $loc eq {} } { set msg ROOT @@ -503,7 +562,7 @@ namespace eval ::msgcat::test { # Tests msgcat-6.*: [mcset], [mc] namespace inheritance # # Test mcset and mc, ensuring that resolution for messages -# proceeds from the current ns to its parent and so on to the +# proceeds from the current ns to its parent and so on to the # global ns. # # Do this for the 12 permutations of @@ -547,7 +606,7 @@ namespace eval ::msgcat::test { ::msgcat::mcset foo ov3 "ov3_foo_bar_baz" } } - + } variable locale [mclocale] mclocale foo @@ -611,8 +670,697 @@ namespace eval ::msgcat::test { mc "this is a %s" "good test" } -result "this is a good test" + # Tests msgcat-8.*: [mcflset] + + set msgdir1 [makeDirectory msgdir1] + makeFile {::msgcat::mcflset k1 v1} l1.msg $msgdir1 + + test msgcat-8.1 {mcflset} -setup { + variable locale [mclocale] + mclocale l1 + mcload $msgdir1 + } -cleanup { + mclocale $locale + } -body { + mc k1 + } -result v1 + + removeFile l1.msg $msgdir1 + removeDirectory msgdir1 + + set msgdir2 [makeDirectory msgdir2] + set msgdir3 [makeDirectory msgdir3] + makeFile "::msgcat::mcflset k2 v2 ; ::msgcat::mcload [list $msgdir3]"\ + l2.msg $msgdir2 + makeFile {::msgcat::mcflset k3 v3 ; ::msgcat::mcflmset {k4 v4 k5 v5}} l2.msg $msgdir3 + + # chained mcload + test msgcat-8.2 {mcflset/mcflmset} -setup { + variable locale [mclocale] + mclocale l2 + mcload $msgdir2 + } -cleanup { + mclocale $locale + } -body { + return [mc k2][mc k3]--[mc k4][mc k5] + } -result v2v3--v4v5 + + removeFile l2.msg $msgdir2 + removeDirectory msgdir2 + removeDirectory msgdir3 + + # Tests msgcat-9.*: [mcexists] + + test msgcat-9.1 {mcexists no parameter} -body { + mcexists + } -returnCodes 1\ + -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"} + + test msgcat-9.2 {mcexists unknown option} -body { + mcexists -unknown src + } -returnCodes 1\ + -result {unknown option "-unknown"} + + test msgcat-9.3 {mcexists} -setup { + mcforgetpackage + variable locale [mclocale] + mclocale foo + mcset foo k1 v1 + } -cleanup { + mclocale $locale + } -body { + list [mcexists k1] [mcexists k2] + } -result {1 0} + + test msgcat-9.4 {mcexists descendent preference} -setup { + mcforgetpackage + variable locale [mclocale] + mclocale foo_bar + mcset foo k1 v1 + } -cleanup { + mclocale $locale + } -body { + list [mcexists k1] [mcexists -exactlocale k1] + } -result {1 0} + + test msgcat-9.5 {mcexists parent namespace} -setup { + mcforgetpackage + variable locale [mclocale] + mclocale foo_bar + mcset foo k1 v1 + } -cleanup { + mclocale $locale + namespace delete ::foo + } -body { + namespace eval ::foo { + list [::msgcat::mcexists k1]\ + [::msgcat::mcexists -namespace ::msgcat::test k1] + } + } -result {0 1} + + test msgcat-9.6 {mcexists -namespace ns parameter} -setup { + mcforgetpackage + variable locale [mclocale] + mclocale foo_bar + mcset foo k1 v1 + } -cleanup { + mclocale $locale + namespace delete ::foo + } -body { + namespace eval ::foo { + list [::msgcat::mcexists k1]\ + [::msgcat::mcexists -namespace ::msgcat::test k1] + } + } -result {0 1} + + test msgcat-9.7 {mcexists -namespace - ns argument missing} -body { + mcexists -namespace src + } -returnCodes 1\ + -result {Argument missing for switch "-namespace"} + + + # Tests msgcat-10.*: [mcloadedlocales] + + test msgcat-10.1 {mcloadedlocales no arg} -body { + mcloadedlocales + } -returnCodes 1\ + -result {wrong # args: should be "mcloadedlocales subcommand"} + + test msgcat-10.2 {mcloadedlocales wrong subcommand} -body { + mcloadedlocales junk + } -returnCodes 1\ + -result {unknown subcommand "junk": must be clear, or loaded} + + test msgcat-10.3 {mcloadedlocales loaded} -setup { + mcforgetpackage + variable locale [mclocale] + mclocale {} + mcloadedlocales clear + } -cleanup { + mclocale $locale + } -body { + mclocale foo_bar + # The result is position independent so sort + set resultlist [lsort [mcloadedlocales loaded]] + } -result {{} foo foo_bar} + + test msgcat-10.4 {mcloadedlocales clear} -setup { + mcforgetpackage + variable locale [mclocale] + mclocale {} + mcloadedlocales clear + } -cleanup { + mclocale $locale + } -body { + mclocale foo + mcset foo k1 v1 + set res [mcexists k1] + mclocale "" + mcloadedlocales clear + mclocale foo + lappend res [mcexists k1] + } -result {1 0} + + # Tests msgcat-11.*: [mcforgetpackage] + + test msgcat-11.1 {mcforgetpackage translation} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + } -body { + mclocale foo + mcset foo k1 v1 + set res [mcexists k1] + mcforgetpackage + lappend res [mcexists k1] + } -result {1 0} + + test msgcat-11.2 {mcforgetpackage locale} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + } -body { + mclocale foo + mcpackagelocale set bar + set res [mcpackagelocale get] + mcforgetpackage + lappend res [mcpackagelocale get] + } -result {bar foo} + + test msgcat-11.3 {mcforgetpackage options} -body { + mcpackageconfig set loadcmd "" + set res [mcpackageconfig isset loadcmd] + mcforgetpackage + lappend res [mcpackageconfig isset loadcmd] + } -result {1 0} + + # Tests msgcat-12.*: [mcpackagelocale] + + test msgcat-12.1 {mcpackagelocale no subcommand} -body { + mcpackagelocale + } -returnCodes 1\ + -result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"} + + test msgcat-12.2 {mclpackagelocale wrong subcommand} -body { + mcpackagelocale junk + } -returnCodes 1\ + -result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset} + + test msgcat-12.2.1 {mclpackagelocale set multiple args} -body { + mcpackagelocale set a b + } -returnCodes 1\ + -result {wrong # args: should be "mcpackagelocale set ?locale?"} + + test msgcat-12.3 {mcpackagelocale set} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + mcpackagelocale set bar + list [mcpackagelocale get] [mclocale] + } -result {bar foo} + + test msgcat-12.4 {mcpackagelocale get} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + set res [mcpackagelocale get] + mcpackagelocale set bar + lappend res [mcpackagelocale get] + } -result {foo bar} + + test msgcat-12.5 {mcpackagelocale preferences} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + set res [list [mcpackagelocale preferences]] + mcpackagelocale set bar + lappend res [mcpackagelocale preferences] + } -result {{foo {}} {bar {}}} + + test msgcat-12.6 {mcpackagelocale loaded} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale "" + mcloadedlocales clear + mclocale foo + # The result is position independent so sort + set res [list [lsort [mcpackagelocale loaded]]] + mcpackagelocale set bar + lappend res [lsort [mcpackagelocale loaded]] + } -result {{{} foo} {{} bar foo}} + + test msgcat-12.7 {mcpackagelocale isset} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + set res [mcpackagelocale isset] + mcpackagelocale set bar + lappend res [mcpackagelocale isset] + } -result {0 1} + + test msgcat-12.8 {mcpackagelocale unset} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mcpackagelocale set bar + set res [mcpackagelocale isset] + mcpackagelocale unset + lappend res [mcpackagelocale isset] + } -result {1 0} + + test msgcat-12.9 {mcpackagelocale present} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale "" + mcloadedlocales clear + mclocale foo + set res [mcpackagelocale present foo] + lappend res [mcpackagelocale present bar] + mcpackagelocale set bar + lappend res [mcpackagelocale present foo]\ + [mcpackagelocale present bar] + } -result {1 0 1 1} + + test msgcat-12.10 {mcpackagelocale clear} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale "" + mcloadedlocales clear + mclocale foo + mcpackagelocale set bar + mcpackagelocale clear + list [mcpackagelocale present foo] [mcpackagelocale present bar] + } -result {0 1} + + test msgcat-12.11 {mcpackagelocale custom preferences} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + set res [list [mcpackagelocale preferences]] + mcpackagelocale preferences bar {} + lappend res [mcpackagelocale preferences] + } -result {{foo {}} {bar {}}} + + test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + mcpackagelocale preferences + mcpackagelocale isset + } -result {0} + + + # Tests msgcat-13.*: [mcpackageconfig subcmds] + + test msgcat-13.1 {mcpackageconfig no subcommand} -body { + mcpackageconfig + } -returnCodes 1\ + -result {wrong # args: should be "mcpackageconfig subcommand option ?value?"} + + test msgcat-13.2 {mclpackageconfig wrong subcommand} -body { + mcpackageconfig junk mcfolder + } -returnCodes 1\ + -result {unknown subcommand "junk": must be get, isset, set, or unset} + + test msgcat-13.3 {mclpackageconfig wrong option} -body { + mcpackageconfig get junk + } -returnCodes 1\ + -result {bad option "junk": must be mcfolder, loadcmd, changecmd, or unknowncmd} + + test msgcat-13.4 {mcpackageconfig get} -setup { + mcforgetpackage + } -cleanup { + mcforgetpackage + } -body { + mcpackageconfig set loadcmd "" + mcpackageconfig get loadcmd + } -result {} + + test msgcat-13.5 {mcpackageconfig (is/un)set} -setup { + mcforgetpackage + } -cleanup { + mcforgetpackage + } -body { + set res [mcpackageconfig isset loadcmd] + lappend res [mcpackageconfig set loadcmd ""] + lappend res [mcpackageconfig isset loadcmd] + mcpackageconfig unset loadcmd + lappend res [mcpackageconfig isset loadcmd] + } -result {0 0 1 0} + + # option mcfolder is already tested with 5.11 + + # Tests msgcat-14.*: callbacks: loadcmd, changecmd, unknowncmd + + # This routine is used as bgerror and by direct callback invocation + proc callbackproc args { + variable resultvariable + set resultvariable $args + } + proc callbackfailproc args { + return -code error fail + } + set bgerrorsaved [interp bgerror {}] + interp bgerror {} [namespace code callbackproc] + + variable locale + if {![info exist locale]} { set locale [mclocale] } + + test msgcat-14.1 {invokation loadcmd} -setup { + mcforgetpackage + mclocale $locale + mclocale "" + mcloadedlocales clear + set resultvariable "" + } -cleanup { + mcforgetpackage + } -body { + mcpackageconfig set loadcmd [namespace code callbackproc] + mclocale foo_bar + lsort $resultvariable + } -result {foo foo_bar} + + test msgcat-14.2 {invokation failed in loadcmd} -setup { + mcforgetpackage + mclocale $locale + mclocale "" + mcloadedlocales clear + } -cleanup { + mcforgetpackage + after cancel set [namespace current]::resultvariable timeout + } -body { + mcpackageconfig set loadcmd [namespace code callbackfailproc] + mclocale foo_bar + # let the bgerror run + after 100 set [namespace current]::resultvariable timeout + vwait [namespace current]::resultvariable + lassign $resultvariable err errdict + list $err [dict get $errdict -code] + } -result {fail 1} + + test msgcat-14.3 {invokation changecmd} -setup { + mcforgetpackage + mclocale $locale + mclocale "" + set resultvariable "" + } -cleanup { + mcforgetpackage + } -body { + mcpackageconfig set changecmd [namespace code callbackproc] + mclocale foo_bar + set resultvariable + } -result {foo_bar foo {}} + + test msgcat-14.4 {invokation unknowncmd} -setup { + mcforgetpackage + mclocale $locale + mclocale "" + mcloadedlocales clear + set resultvariable "" + } -cleanup { + mcforgetpackage + } -body { + mcpackageconfig set unknowncmd [namespace code callbackproc] + mclocale foo_bar + mc k1 p1 + set resultvariable + } -result {foo_bar k1 p1} + + test msgcat-14.5 {disable global unknowncmd} -setup { + mcforgetpackage + mclocale $locale + mclocale "" + mcloadedlocales clear + set resultvariable "" + rename ::msgcat::mcunknown SavedMcunknown + proc ::msgcat::mcunknown {dom s} { + return unknown:$dom:$s + } + } -cleanup { + mcforgetpackage + rename ::msgcat::mcunknown {} + rename SavedMcunknown ::msgcat::mcunknown + } -body { + mcpackageconfig set unknowncmd "" + mclocale foo_bar + mc k1%s p1 + } -result {k1p1} + + test msgcat-14.6 {unknowncmd failing} -setup { + mcforgetpackage + mclocale $locale + mclocale "" + mcloadedlocales clear + set resultvariable "" + } -cleanup { + mcforgetpackage + } -body { + mcpackageconfig set unknowncmd [namespace code callbackfailproc] + mclocale foo_bar + mc k1 + } -returnCodes 1\ + -result {fail} + + + # Tests msgcat-15.*: tcloo coverage + + # There are 4 use-cases, where 3 must be tested now: + # - namespace defined, in class definition, class defined oo, classless + + test msgcat-15.1 {mc in class setup} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::class create ClassCur + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar + } -body { + oo::define bar::ClassCur msgcat::mc con2 + } -result con2bar + + test msgcat-15.2 {mc in class} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::class create ClassCur + oo::define ClassCur method method1 {} {::msgcat::mc con2} + } + # full namespace is ::msgcat::test:baz + namespace eval baz { + set ObjCur [::msgcat::test::bar::ClassCur new] + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar baz + } -body { + $baz::ObjCur method1 + } -result con2bar + + test msgcat-15.3 {mc in classless object} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} {::msgcat::mc con2} + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar + } -body { + bar::ObjCur method1 + } -result con2bar + + test msgcat-15.4 {mc in classless object with explicite namespace eval}\ + -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} { + namespace eval ::msgcat::test::baz { + ::msgcat::mc con2 + } + } + } + namespace eval baz { + ::msgcat::mcset foo_BAR con2 con2baz + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace eval baz {::msgcat::mcforgetpackage} + namespace delete bar baz + } -body { + bar::ObjCur method1 + } -result con2baz + + # Test msgcat-16.*: command mcpackagenamespaceget + + test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body { + namespace eval baz {msgcat::mcpackagenamespaceget} + } -result ::msgcat::test::baz + + test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup { + namespace eval bar { + oo::class create ClassCur + oo::define ClassCur variable a + } + } -cleanup { + namespace delete bar + } -body { + oo::define bar::ClassCur msgcat::mcpackagenamespaceget + } -result ::msgcat::test::bar + + test msgcat-16.3 {mcpackagenamespaceget in class} -setup { + namespace eval bar { + oo::class create ClassCur + oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget} + } + namespace eval baz { + set ObjCur [::msgcat::test::bar::ClassCur new] + } + } -cleanup { + namespace delete bar baz + } -body { + $baz::ObjCur method1 + } -result ::msgcat::test::bar + + test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup { + namespace eval bar { + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget} + } + } -cleanup { + namespace delete bar + } -body { + bar::ObjCur method1 + } -result ::msgcat::test::bar + + test msgcat-16.5\ + {mcpackagenamespaceget in classless object with explicite namespace eval}\ + -setup { + namespace eval bar { + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} { + namespace eval ::msgcat::test::baz { + msgcat::mcpackagenamespaceget + } + } + } + } -cleanup { + namespace delete bar baz + } -body { + bar::ObjCur method1 + } -result ::msgcat::test::baz + + + # Test msgcat-17.*: mcn command + + test msgcat-17.1 {mcn no parameters} -body { + mcn + } -returnCodes 1\ + -result {wrong # args: should be "mcn ns src ?arg ...?"} + + test msgcat-17.2 {mcn} -setup { + namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar} + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + } -body { + ::msgcat::mcn [namespace current]::bar con1 + } -result con1bar + + + interp bgerror {} $bgerrorsaved + + # Tests msgcat-18.*: [mcutil] + + test msgcat-18.1 {mcutil - no argument} -body { + mcutil + } -returnCodes 1\ + -result {wrong # args: should be "mcutil subcommand ?arg ...?"} + + test msgcat-18.2 {mcutil - wrong argument} -body { + mcutil junk + } -returnCodes 1\ + -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale} + + test msgcat-18.3 {mcutil - partial argument} -body { + mcutil getsystem + } -returnCodes 1\ + -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale} + + test msgcat-18.4 {mcutil getpreferences - no argument} -body { + mcutil getpreferences + } -returnCodes 1\ + -result {wrong # args: should be "mcutil getpreferences locale"} + + test msgcat-18.5 {mcutil getpreferences - DE_de} -body { + mcutil getpreferences DE_de + } -result {de_de de {}} + + test msgcat-18.6 {mcutil getsystemlocale - wrong argument} -body { + mcutil getsystemlocale DE_de + } -returnCodes 1\ + -result {wrong # args: should be "mcutil getsystemlocale"} + + # The result is system dependent + # So just test if it runs + # The environment variable version was test with test 0.x + test msgcat-18.7 {mcutil getsystemlocale} -body { + mcutil getsystemlocale + set ok ok + } -result {ok} + + cleanupTests } namespace delete ::msgcat::test return +# Local Variables: +# mode: tcl +# End: diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 1d8ba31..06eedfd 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -7,15 +7,15 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1997 Lucent Technologies -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1997 Lucent Technologies +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -57,6 +57,12 @@ test namespace-old-1.9 {add elements to a namespace} { } } } {} +namespace eval test_ns_simple { + variable test_ns_x 0 + proc test {test_ns_x} { + return "test: $test_ns_x" + } +} test namespace-old-1.10 {commands in a namespace} { namespace eval test_ns_simple { info commands [namespace current]::*} } {::test_ns_simple::test} @@ -74,6 +80,12 @@ test namespace-old-1.13 {add to an existing namespace} { } } } "" +namespace eval test_ns_simple { + variable test_ns_y 123 + proc _backdoor {cmd} { + eval $cmd + } +} test namespace-old-1.14 {commands in a namespace} { lsort [namespace eval test_ns_simple {info commands [namespace current]::*}] } {::test_ns_simple::_backdoor ::test_ns_simple::test} @@ -128,6 +140,8 @@ test namespace-old-1.26 {namespace qualifiers are okay after $'s} { test namespace-old-1.27 {can create commands with null names} { proc test_ns_simple:: {args} {return $args} } {} +# Redeclare; later tests depend on it +proc test_ns_simple:: {args} {return $args} # ----------------------------------------------------------------------- # TEST: using "info" in namespace contexts @@ -212,6 +226,11 @@ test namespace-old-4.3 {command "namespace delete" doesn't support patterns} { } list [catch $cmd msg] $msg } {1 {unknown namespace "ns*" in namespace delete command}} +namespace eval test_ns_delete { + namespace eval ns1 {} + namespace eval ns2 {} + namespace eval another {} +} test namespace-old-4.4 {command "namespace delete" handles multiple args} { set cmd { namespace eval test_ns_delete { @@ -256,6 +275,24 @@ test namespace-old-5.3 {namespace qualifiers work in namespace command} { [namespace eval test_ns_hier1::test_ns_hier2 {namespace current}] \ [namespace eval ::test_ns_hier1::test_ns_hier2 {namespace current}] } {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2} +set ::test_ns_var_global "var in ::" +proc test_ns_cmd_global {} {return "cmd in ::"} +namespace eval test_ns_hier1 { + variable test_ns_var_hier1 "particular to hier1" + proc test_ns_cmd_hier1 {} {return "particular to hier1"} + variable test_ns_level 1 + proc test_ns_show {} {return "[namespace current]: 1"} + namespace eval test_ns_hier2 { + variable test_ns_var_hier2 "particular to hier2" + proc test_ns_cmd_hier2 {} {return "particular to hier2"} + variable test_ns_level 2 + proc test_ns_show {} {return "[namespace current]: 2"} + namespace eval test_ns_hier3a {} + namespace eval test_ns_hier3b {} + } + namespace eval test_ns_hier2a {} + namespace eval test_ns_hier2b {} +} test namespace-old-5.4 {nested namespaces can access global namespace} { list [namespace eval test_ns_hier1 {set test_ns_var_global}] \ [namespace eval test_ns_hier1 {test_ns_cmd_global}] \ @@ -331,16 +368,12 @@ test namespace-old-5.21 {querying namespace parent for explicit namespace} { # ----------------------------------------------------------------------- # TEST: name resolution and caching # ----------------------------------------------------------------------- +set trigger {namespace eval test_ns_cache2 {namespace current}} +set trigger2 {namespace eval test_ns_cache2::test_ns_cache3 {namespace current}} test namespace-old-6.1 {relative ns names only looked up in current ns} { namespace eval test_ns_cache1 {} namespace eval test_ns_cache2 {} namespace eval test_ns_cache2::test_ns_cache3 {} - set trigger { - namespace eval test_ns_cache2 {namespace current} - } - set trigger2 { - namespace eval test_ns_cache2::test_ns_cache3 {namespace current} - } list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 $trigger2] } {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} @@ -354,20 +387,19 @@ test namespace-old-6.3 {relative ns names only looked up in current ns} { list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 $trigger2] } {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} +namespace eval test_ns_cache1::test_ns_cache2 {} test namespace-old-6.4 {relative ns names only looked up in current ns} { namespace delete test_ns_cache1::test_ns_cache2 list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 $trigger2] } {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} +namespace eval test_ns_cache1 { + proc trigger {} {test_ns_cache_cmd} +} test namespace-old-6.5 {define test commands} { proc test_ns_cache_cmd {} { return "global version" } - namespace eval test_ns_cache1 { - proc trigger {} { - test_ns_cache_cmd - } - } test_ns_cache1::trigger } {global version} test namespace-old-6.6 {one-level check for command shadowing} { @@ -376,24 +408,36 @@ test namespace-old-6.6 {one-level check for command shadowing} { } test_ns_cache1::trigger } {cache1 version} -test namespace-old-6.7 {renaming commands changes command epoch} { - namespace eval test_ns_cache1 { - rename test_ns_cache_cmd test_ns_new +proc test_ns_cache_cmd {} { + return "global version" +} +test namespace-old-6.7 {renaming commands changes command epoch} -setup { + proc test_ns_cache1::test_ns_cache_cmd {} { + return "cache1 version" } - test_ns_cache1::trigger -} {global version} -test namespace-old-6.8 {renaming back handles shadowing} { - namespace eval test_ns_cache1 { - rename test_ns_new test_ns_cache_cmd +} -body { + list [test_ns_cache1::trigger] \ + [namespace eval test_ns_cache1 {rename test_ns_cache_cmd test_ns_new}]\ + [test_ns_cache1::trigger] +} -result {{cache1 version} {} {global version}} +test namespace-old-6.8 {renaming back handles shadowing} -setup { + proc test_ns_cache1::test_ns_new {} { + return "cache1 version" } - test_ns_cache1::trigger -} {cache1 version} -test namespace-old-6.9 {deleting commands changes command epoch} { - namespace eval test_ns_cache1 { - rename test_ns_cache_cmd "" +} -body { + list [test_ns_cache1::trigger] \ + [namespace eval test_ns_cache1 {rename test_ns_new test_ns_cache_cmd}]\ + [test_ns_cache1::trigger] +} -result {{global version} {} {cache1 version}} +test namespace-old-6.9 {deleting commands changes command epoch} -setup { + proc test_ns_cache1::test_ns_cache_cmd {} { + return "cache1 version" } - test_ns_cache1::trigger -} {global version} +} -body { + list [test_ns_cache1::trigger] \ + [namespace eval test_ns_cache1 {rename test_ns_cache_cmd ""}] \ + [test_ns_cache1::trigger] +} -result {{cache1 version} {} {global version}} test namespace-old-6.10 {define test namespaces} { namespace eval test_ns_cache2 { proc test_ns_cache_cmd {} { @@ -412,6 +456,12 @@ test namespace-old-6.10 {define test namespaces} { } list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] } {{global cache2 version} {global version}} +namespace eval test_ns_cache1 { + proc trigger {} { test_ns_cache2::test_ns_cache_cmd } + namespace eval test_ns_cache2 { + proc trigger {} { test_ns_cache_cmd } + } +} test namespace-old-6.11 {commands affect all parent namespaces} { proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} { return "cache2 version" @@ -423,18 +473,22 @@ test namespace-old-6.12 {define test variables} { set trigger {set test_ns_cache_var} namespace eval test_ns_cache1 $trigger } {global version} + set trigger {set test_ns_cache_var} test namespace-old-6.13 {one-level check for variable shadowing} { namespace eval test_ns_cache1 { variable test_ns_cache_var "cache1 version" } namespace eval test_ns_cache1 $trigger } {cache1 version} +variable ::test_ns_cache_var "global version" test namespace-old-6.14 {deleting variables changes variable epoch} { namespace eval test_ns_cache1 { - unset test_ns_cache_var + variable test_ns_cache_var "cache1 version" } - namespace eval test_ns_cache1 $trigger -} {global version} + list [namespace eval test_ns_cache1 $trigger] \ + [namespace eval test_ns_cache1 {unset test_ns_cache_var}] \ + [namespace eval test_ns_cache1 $trigger] +} {{cache1 version} {} {global version}} test namespace-old-6.15 {define test namespaces} { namespace eval test_ns_cache2 { variable test_ns_cache_var "global cache2 version" @@ -443,6 +497,7 @@ test namespace-old-6.15 {define test namespaces} { list [namespace eval test_ns_cache1 $trigger2] \ [namespace eval test_ns_cache1::test_ns_cache2 $trigger] } {{global cache2 version} {global version}} +set trigger2 {set test_ns_cache2::test_ns_cache_var} test namespace-old-6.16 {public variables affect all parent namespaces} { variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" list [namespace eval test_ns_cache1 $trigger2] \ @@ -467,6 +522,7 @@ test namespace-old-6.19 {querying: namespace which -command} { test namespace-old-6.20 {command "namespace which" may not find commands} { namespace eval test_ns_cache1 {namespace which -command xyzzy} } {} +variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" test namespace-old-6.21 {querying: namespace which -variable} { namespace eval test_ns_cache1::test_ns_cache2 { namespace which -variable test_ns_cache_var @@ -493,6 +549,18 @@ test namespace-old-7.1 {define test namespace} { } } } {} +namespace eval test_ns_uplevel { + variable x 0 + variable y 1 + proc show_vars {num} { + return [uplevel $num {info vars}] + } + proc test_uplevel {num} { + set a 0 + set b 1 + namespace eval ::test_ns_uplevel " return \[show_vars $num\] " + } +} test namespace-old-7.2 {uplevel can access namespace call frame} { list [expr {"x" in [test_ns_uplevel::test_uplevel 1]}] \ [expr {"y" in [test_ns_uplevel::test_uplevel 1]}] @@ -526,6 +594,17 @@ test namespace-old-7.8 {namespaces are included in the call stack} { } } } {} +namespace eval test_ns_upvar { + variable scope "test_ns_upvar" + proc show_val {var num} { + upvar $num $var x + return $x + } + proc test_upvar {num} { + set scope "test_ns_upvar::test_upvar" + namespace eval ::test_ns_upvar " return \[show_val scope $num\] " + } +} test namespace-old-7.9 {upvar can access namespace call frame} { test_ns_upvar::test_upvar 1 } {test_ns_upvar} @@ -581,6 +660,15 @@ test namespace-old-9.3 {define test namespaces for import} { } lsort [info commands test_ns_export::*] } {::test_ns_export::cmd1 ::test_ns_export::cmd2 ::test_ns_export::cmd3 ::test_ns_export::cmd4 ::test_ns_export::cmd5 ::test_ns_export::cmd6} +namespace eval test_ns_export { + namespace export cmd1 cmd2 cmd3 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + proc cmd5 {args} {return "cmd5: $args"} + proc cmd6 {args} {return "cmd6: $args"} +} test namespace-old-9.4 {check export status} { set x "" namespace eval test_ns_import { @@ -592,6 +680,10 @@ test namespace-old-9.4 {check export status} { } set x } {::test_ns_import::cmd1 ::test_ns_import::cmd2 ::test_ns_import::cmd3} +namespace eval test_ns_import { + namespace export cmd1 cmd2 + namespace import ::test_ns_export::* +} test namespace-old-9.5 {empty import list in "namespace import" command} { namespace eval test_ns_import_empty { namespace import ::test_ns_export::* @@ -615,6 +707,7 @@ test namespace-old-9.8 {only exported commands are imported} { namespace import test_ns_import::cmd* set x [lsort [info commands cmd*]] } {cmd1 cmd2} +namespace import test_ns_import::cmd* test namespace-old-9.9 {imported commands work just the same as original} { list [cmd1 test 1 2 3] [test_ns_import::cmd1 test 4 5 6] } {{cmd1: test 1 2 3} {cmd1: test 4 5 6}} @@ -629,10 +722,19 @@ test namespace-old-9.10 {commands can be imported from many namespaces} { namespace import test_ns_import2::* lsort [concat [info commands cmd*] [info commands ncmd*]] } {cmd1 cmd2 ncmd ncmd1 ncmd2} +namespace eval test_ns_import2 { + namespace export ncmd ncmd1 ncmd2 + proc ncmd {args} {return "ncmd: $args"} + proc ncmd1 {args} {return "ncmd1: $args"} + proc ncmd2 {args} {return "ncmd2: $args"} + proc ncmd3 {args} {return "ncmd3: $args"} +} +namespace import test_ns_import2::* test namespace-old-9.11 {imported commands can be removed by deleting them} { rename cmd1 "" lsort [concat [info commands cmd*] [info commands ncmd*]] } {cmd2 ncmd ncmd1 ncmd2} +catch { rename cmd1 "" } test namespace-old-9.12 {command "namespace forget" checks for valid namespaces} { list [catch {namespace forget xyzzy::*} msg] $msg } {1 {unknown namespace in namespace forget pattern "xyzzy::*"}} @@ -647,12 +749,13 @@ test namespace-old-9.14 {imported commands can be removed} { } {{} 1 {invalid command name "cmd1"}} test namespace-old-9.15 {existing commands can't be overwritten} { proc cmd1 {x y} { - return [expr $x+$y] + return [expr {$x+$y}] } list [catch {namespace import test_ns_import::cmd?} msg] $msg \ [cmd1 3 5] } {1 {can't import command "cmd1": already exists} 8} test namespace-old-9.16 {use "-force" option to override existing commands} { + proc cmd1 {x y} { return [expr {$x+$y}] } list [cmd1 3 5] \ [namespace import -force test_ns_import::cmd?] \ [cmd1 3 5] @@ -711,10 +814,18 @@ test namespace-old-10.6 {with many args, each "scope" adds new args} { set sval [namespace eval test_ns_inscope {namespace code {one two}}] namespace code "$sval three" } {::namespace inscope ::test_ns_inscope {one two} three} +namespace eval test_ns_inscope { + proc show {args} { + return "show: $args" + } +} test namespace-old-10.7 {scoped commands work with eval} { set cref [namespace eval test_ns_inscope {namespace code show}] list [eval $cref "a" "b c" "d e f"] } {{show: a b c d e f}} +namespace eval test_ns_inscope { + variable x "x-value" +} test namespace-old-10.8 {scoped commands execute in namespace context} { set cref [namespace eval test_ns_inscope { namespace code {set x "some new value"} diff --git a/tests/namespace.test b/tests/namespace.test index 1d46bf0..efd00a8 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -6,18 +6,20 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-2000 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} testConstraint memory [llength [info commands memory]] ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # # REMARK: the tests for 'namespace upvar' are not done here. They are to be @@ -56,7 +58,7 @@ test namespace-2.2 {Tcl_GetCurrentNamespace} { test namespace-3.1 {Tcl_GetGlobalNamespace} { namespace eval test_ns_1 {namespace eval foo {namespace eval bar {} } } - # namespace children uses Tcl_GetGlobalNamespace + # namespace children uses Tcl_GetGlobalNamespace namespace eval test_ns_1 {namespace children foo b*} } {::test_ns_1::foo::bar} @@ -82,12 +84,14 @@ test namespace-4.2 {Tcl_PushCallFrame with isProcCallFrame=0} { test namespace-5.1 {Tcl_PopCallFrame, no vars} { namespace eval test_ns_1::blodge {} ;# pushes then pops frame } {} -test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} { +test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} -setup { + namespace eval test_ns_1 {} +} -body { proc test_ns_1::r {} { set a 123 } test_ns_1::r ;# pushes then pop's r's frame -} {123} +} -result {123} test namespace-6.1 {Tcl_CreateNamespace} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -106,7 +110,7 @@ test namespace-6.2 {Tcl_CreateNamespace, odd number of :'s in name is okay} { [namespace eval test_ns_2:::::foo {namespace current}] } {::test_ns_1::foo ::test_ns_2::foo} test namespace-6.3 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} { - list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg + list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg } {0 ::test_ns_7} test namespace-6.4 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -177,23 +181,35 @@ test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} namespace delete test_ns_2 } {} test namespace-7.7 {Bug 1655305} -setup { - interp create slave + interp create child # Can't invoke through the ensemble, since deleting the global namespace # (indirectly, via deleting ::tcl) deletes the ensemble. - slave eval {rename ::tcl::info::commands ::infocommands} - slave hide infocommands - slave eval { + child eval {rename ::tcl::info::commands ::infocommands} + child hide infocommands + child eval { proc foo {} { namespace delete :: } } } -body { - slave eval foo - slave invokehidden infocommands + child eval foo + child invokehidden infocommands } -cleanup { - interp delete slave + interp delete child } -result {} +test namespace-7.8 {Bug ba1419303b4c} -setup { + namespace eval ns1 { + namespace ensemble create + } + + trace add command ns1 delete { + namespace delete ns1 + } +} -body { + # No segmentation fault given --enable-symbols=mem. + namespace delete ns1 +} -result {} test namespace-8.1 {TclTeardownNamespace, delete global namespace} { catch {interp delete test_interp} @@ -255,28 +271,28 @@ test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} [info commands test_ns_import::*] } [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p] test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add execution error leave {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add execution error leave {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorInfo } {bar invoked from within -"slave eval error foo bar baz"} +"child eval error foo bar baz"} test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add variable errorCode write {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add variable errorCode write {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorInfo } {bar invoked from within -"slave eval error foo bar baz"} +"child eval error foo bar baz"} test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add execution error leave {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add execution error leave {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorCode } baz @@ -303,15 +319,24 @@ 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} -setup { + namespace eval test_ns_import {} + namespace eval test_ns_export {} +} -body { 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} { +} -result {0 {}} +test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} -setup { + namespace eval test_ns_import {} + namespace eval ::test_ns_export { + proc cmd1 {args} {return "cmd1: $args"} + namespace export cmd1 + } +} -body { namespace eval test_ns_import { namespace import -force ::test_ns_export::* cmd1 555 } -} {cmd1: 555} +} -result {cmd1: 555} test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} { catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_export { @@ -329,7 +354,6 @@ test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} { [test_ns_import::cmd1 g h i] \ [test_ns_export::cmd1 j k l] } {{cmd1: a b c} {cmd1: d e f} {} ::test_ns_export::cmd1 ::test_ns_export::cmd1 {new1: g h i} {new1: j k l}} - test namespace-9.8 {Tcl_Import: Bug 1017299} -setup { namespace eval one { namespace export cmd @@ -354,7 +378,6 @@ test namespace-9.8 {Tcl_Import: Bug 1017299} -setup { } -cleanup { namespace delete one two three } -match glob -result *::one::cmd - test namespace-9.9 {Tcl_Import: Bug 1017299} -setup { namespace eval one { namespace export cmd @@ -388,7 +411,13 @@ test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} { namespace forget ::test_ns_export::wombat } } {} -test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} { +test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} -setup { + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } +} -body { namespace eval test_ns_import { namespace import ::test_ns_export::* proc p {} {return [cmd1 123]} @@ -398,8 +427,7 @@ test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} { lappend l [info commands ::test_ns_import::*] lappend l [catch {cmd1 777} msg] $msg } -} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}] - +} -result [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}] test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -417,7 +445,6 @@ test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin unrelated my } - test namespace-10.5 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -433,7 +460,6 @@ test namespace-10.5 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin my } -returnCodes error -match glob -result * - test namespace-10.6 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -450,7 +476,6 @@ test namespace-10.6 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin my your } -returnCodes error -match glob -result * - test namespace-10.7 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -471,7 +496,6 @@ test namespace-10.7 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin link link2 my } -returnCodes error -match glob -result * - test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -492,7 +516,6 @@ test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin link link2 my } - test namespace-10.9 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -514,29 +537,47 @@ test namespace-10.9 {Tcl_ForgetImport: Bug 560297} -setup { namespace delete origin link link2 my } -returnCodes error -match glob -result * -test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} { +test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_export { namespace export cmd1 proc cmd1 {args} {return "cmd1: $args"} } list [namespace origin set] [namespace origin test_ns_export::cmd1] -} {::set ::test_ns_export::cmd1} -test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} { +} -result {::set ::test_ns_export::cmd1} +test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + } +} -body { namespace eval test_ns_import1 { namespace import ::test_ns_export::* namespace export * proc p {} {namespace origin cmd1} } list [test_ns_import1::p] [namespace origin test_ns_import1::cmd1] -} {::test_ns_export::cmd1 ::test_ns_export::cmd1} -test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} { +} -result {::test_ns_export::cmd1 ::test_ns_export::cmd1} +test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + } + namespace eval test_ns_import1 { + namespace import ::test_ns_export::* + namespace export * + proc p {} {namespace origin cmd1} + } +} -body { namespace eval test_ns_import2 { namespace import ::test_ns_import1::* proc q {} {return [cmd1 123]} } list [test_ns_import2::q] [namespace origin test_ns_import2::cmd1] -} {{cmd1: 123} ::test_ns_export::cmd1} +} -result {{cmd1: 123} ::test_ns_export::cmd1} test namespace-12.1 {InvokeImportedCmd} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -550,16 +591,34 @@ test namespace-12.1 {InvokeImportedCmd} { list [test_ns_import::cmd1] } {::test_ns_export} -test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} { +test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {namespace current} + } + namespace eval test_ns_import { + namespace import ::test_ns_export::* + } +} -body { namespace eval test_ns_import { set l {} lappend l [info commands ::test_ns_import::*] namespace forget ::test_ns_export::cmd1 lappend l [info commands ::test_ns_import::*] } -} {::test_ns_import::cmd1 {}} +} -result {::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} { +test namespace-14.1 {TclGetNamespaceForQualName, absolute names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} variable v 10 namespace eval test_ns_1::test_ns_2 { @@ -568,22 +627,41 @@ test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { namespace eval test_ns_2 { variable v 30 } +} -body { namespace eval test_ns_1 { list $::v $::test_ns_2::v $::test_ns_1::test_ns_2::v \ [lsort [namespace children :: test_ns_*]] } -} [list 10 30 20 [lsort {::test_ns_1 ::test_ns_2}]] -test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} { +} -result [list 10 30 20 [lsort {::test_ns_1 ::test_ns_2}]] +test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + variable v 10 + namespace eval test_ns_1::test_ns_2 { + variable v 20 + } + namespace eval test_ns_2 { + variable v 30 + } +} -body { namespace eval test_ns_1 { list [catch {set ::test_ns_777::v} msg] $msg \ [catch {namespace children test_ns_777} msg] $msg } -} {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} -test namespace-14.3 {TclGetNamespaceForQualName, relative names} { +} -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} +test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + variable v 10 + namespace eval test_ns_1::test_ns_2 { + variable v 20 + } + namespace eval test_ns_2 { + variable v 30 + } +} -body { namespace eval test_ns_1 { list $v $test_ns_2::v } -} {10 20} +} -result {10 20} test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { namespace eval foo {} @@ -610,57 +688,72 @@ test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up onl [catch {namespace children test_ns_1} msg] $msg } } {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}} -test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} { +test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} -setup { + namespace eval test_ns_1::test_ns_2::foo {} +} -body { namespace children test_ns_1::: -} {::test_ns_1::test_ns_2} -test namespace-14.8 {TclGetNamespaceForQualName, ignore extra :s if ns} { +} -result {::test_ns_1::test_ns_2} +test namespace-14.8 {TclGetNamespaceForQualName, ignore extra :s if ns} -setup { + namespace eval test_ns_1::test_ns_2::foo {} +} -body { namespace children :::test_ns_1:::::test_ns_2::: -} {::test_ns_1::test_ns_2::foo} +} -result {::test_ns_1::test_ns_2::foo} test namespace-14.9 {TclGetNamespaceForQualName, extra ::s are significant for vars} { set l {} lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg namespace eval test_ns_1::test_ns_2 {variable {} 2525} lappend l [set test_ns_1::test_ns_2::] } {1 {can't read "test_ns_1::test_ns_2::": no such variable} 2525} -test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} { - catch {unset test_ns_1::test_ns_2::} +test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { + namespace eval test_ns_1::test_ns_2::foo {} + unset -nocomplain test_ns_1::test_ns_2:: set l {} +} -body { lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg set test_ns_1::test_ns_2:: 314159 lappend l [set test_ns_1::test_ns_2::] -} {1 {can't read "test_ns_1::test_ns_2::": no such variable} 314159} -test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for commands} { +} -result {1 {can't read "test_ns_1::test_ns_2::": no such variable} 314159} +test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for commands} -setup { + namespace eval test_ns_1::test_ns_2::foo {} catch {rename test_ns_1::test_ns_2:: {}} set l {} +} -body { lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"} lappend l [test_ns_1::test_ns_2:: hello] -} {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} -test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} { +} -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} +test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { variable {} set test_ns_1::(x) y } set test_ns_1::(x) -} y -test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} { +} -result y +test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} - list [catch {namespace eval test_ns_1 {proc {} {} {}; namespace eval {} {}; {}}} msg] $msg -} {1 {can't create namespace "": only global namespace can have empty name}} +} -returnCodes error -body { + namespace eval test_ns_1 { + proc {} {} {} + namespace eval {} {} + {} + } +} -result {can't create namespace "": only global namespace can have empty name} -test namespace-15.1 {Tcl_FindNamespace, absolute name found} { +test namespace-15.1 {Tcl_FindNamespace, absolute name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_delete { namespace eval test_ns_delete2 {} proc cmd {args} {namespace current} } list [namespace delete ::test_ns_delete::test_ns_delete2] \ [namespace children ::test_ns_delete] -} {{} {}} -test namespace-15.2 {Tcl_FindNamespace, absolute name not found} { - list [catch {namespace delete ::test_ns_delete::test_ns_delete2} msg] $msg -} {1 {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command}} +} -result {{} {}} +test namespace-15.2 {Tcl_FindNamespace, absolute name not found} -body { + namespace delete ::test_ns_delete::test_ns_delete2 +} -returnCodes error -result {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command} test namespace-15.3 {Tcl_FindNamespace, relative name found} { namespace eval test_ns_delete { namespace eval test_ns_delete2 {} @@ -676,17 +769,24 @@ test namespace-15.4 {Tcl_FindNamespace, relative name not found} { } } {1 {unknown namespace "test_ns_delete2" in namespace delete command}} -test namespace-16.1 {Tcl_FindCommand, absolute name found} { +test namespace-16.1 {Tcl_FindCommand, absolute name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { proc cmd {args} {return "[namespace current]::cmd: $args"} variable v "::test_ns_1::cmd" eval $v one } -} {::test_ns_1::cmd: one} -test namespace-16.2 {Tcl_FindCommand, absolute name found} { +} -result {::test_ns_1::cmd: one} +test namespace-16.2 {Tcl_FindCommand, absolute name found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc cmd {args} {return "[namespace current]::cmd: $args"} + variable v "::test_ns_1::cmd" + } +} -body { eval $test_ns_1::v two -} {::test_ns_1::cmd: two} +} -result {::test_ns_1::cmd: two} test namespace-16.3 {Tcl_FindCommand, absolute name not found} { namespace eval test_ns_1 { variable v2 "::test_ns_1::ladidah" @@ -715,11 +815,16 @@ test namespace-16.7 {Tcl_FindCommand, relative name and TCL_GLOBAL_ONLY} { catch {rename unknown {}} catch {rename unknown.old unknown} -test namespace-16.8 {Tcl_FindCommand, relative name found} { +test namespace-16.8 {Tcl_FindCommand, relative name found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc cmd {args} {return "[namespace current]::cmd: $args"} + } +} -body { namespace eval test_ns_1 { cmd a b c } -} {::test_ns_1::cmd: a b c} +} -result {::test_ns_1::cmd: a b c} test namespace-16.9 {Tcl_FindCommand, relative name found} -body { proc cmd2 {args} {return "[namespace current]::cmd2: $args"} namespace eval test_ns_1 { @@ -741,20 +846,22 @@ test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current } -cleanup { catch {rename cmd2 {}} } -result {::::cmd2: a b c} -test namespace-16.11 {Tcl_FindCommand, relative name not found} { +test namespace-16.11 {Tcl_FindCommand, relative name not found} -body { namespace eval test_ns_1 { - list [catch {cmd3 a b c} msg] $msg + cmd3 a b c } -} {1 {invalid command name "cmd3"}} +} -returnCodes error -result {invalid command name "cmd3"} -catch {unset x} -test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} { +unset -nocomplain x +test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { set x 314159 namespace eval test_ns_1 { set ::x } -} {314159} +} -result {314159} +variable ::x 314159 test namespace-17.2 {Tcl_FindNamespaceVar, absolute name found} { namespace eval test_ns_1 { variable x 777 @@ -769,46 +876,54 @@ test namespace-17.3 {Tcl_FindNamespaceVar, absolute name found} { set ::test_ns_1::test_ns_2::x } } {1111} -test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} { +test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} -body { namespace eval test_ns_1 { namespace eval test_ns_2 { variable x 1111 } - list [catch {set ::test_ns_1::test_ns_2::y} msg] $msg + set ::test_ns_1::test_ns_2::y } -} {1 {can't read "::test_ns_1::test_ns_2::y": no such variable}} -test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} { +} -returnCodes error -result {can't read "::test_ns_1::test_ns_2::y": no such variable} +test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} -setup { + namespace eval ::test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace eval test_ns_3 { variable ::test_ns_1::test_ns_2::x 2222 } } set ::test_ns_1::test_ns_2::x -} {2222} -test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} { +} -result {2222} +test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} -setup { + namespace eval test_ns_1 { + variable x 777 + } +} -body { namespace eval test_ns_1 { set x } -} {777} +} -result {777} test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} { namespace eval test_ns_1 { + variable x 777 unset x set x ;# must be global x now } } {314159} -test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} { +test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} -body { namespace eval test_ns_1 { - list [catch {set wuzzat} msg] $msg + set wuzzat } -} {1 {can't read "wuzzat": no such variable}} +} -returnCodes error -result {can't read "wuzzat": no such variable} test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} { namespace eval test_ns_1 { variable a hello } set test_ns_1::a } {hello} -test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} { +test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} -setup { namespace eval test_ns_1 {} +} -body { proc test_ns {} { set ::test_ns_1::a 0 } @@ -819,14 +934,15 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} { namespace eval test_ns_1 set a 1 namespace delete test_ns_1 return $a -} 1 +} -result 1 catch {unset a} catch {unset x} catch {unset l} catch {rename foo {}} -test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} { +test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { proc foo {} {return "global foo"} namespace eval test_ns_1 { proc trigger {} { @@ -840,7 +956,7 @@ test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadow proc foo {} {return "foo in test_ns_1"} } lappend l [test_ns_1::trigger] -} {{global foo} {foo in test_ns_1}} +} -result {{global foo} {foo in test_ns_1}} test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} { namespace eval test_ns_2 { proc foo {} {return "foo in ::test_ns_2"} @@ -864,22 +980,31 @@ test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shado catch {unset l} catch {rename foo {}} -test namespace-19.1 {GetNamespaceFromObj, global name found} { +test namespace-19.1 {GetNamespaceFromObj, global name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::test_ns_2 {} namespace children ::test_ns_1 -} {::test_ns_1::test_ns_2} -test namespace-19.2 {GetNamespaceFromObj, relative name found} { +} -result {::test_ns_1::test_ns_2} +test namespace-19.2 {GetNamespaceFromObj, relative name found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace children test_ns_2 } -} {} -test namespace-19.3 {GetNamespaceFromObj, name not found} -body { +} -result {} +test namespace-19.3 {GetNamespaceFromObj, name not found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace children test_ns_99 } } -returnCodes error -result {namespace "test_ns_99" not found in "::test_ns_1"} -test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { +test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { proc foo {} { return [namespace children test_ns_2] @@ -891,7 +1016,7 @@ test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { namespace delete test_ns_1::test_ns_2 namespace eval test_ns_1::test_ns_2::test_ns_3 {} lappend l [test_ns_1::foo] -} {{} ::test_ns_1::test_ns_2::test_ns_3} +} -result {{} ::test_ns_1::test_ns_2::test_ns_3} test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -904,24 +1029,34 @@ test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} { namespace ch :: test_ns_* } {} -test namespace-21.1 {NamespaceChildrenCmd, no args} { +test namespace-21.1 {NamespaceChildrenCmd, no args} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::test_ns_2 {} - expr {[string first ::test_ns_1 [namespace children]] != -1} -} {1} -test namespace-21.2 {NamespaceChildrenCmd, no args} { + expr {"::test_ns_1" in [namespace children]} +} -result {1} +test namespace-21.2 {NamespaceChildrenCmd, no args} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace children } -} {::test_ns_1::test_ns_2} -test namespace-21.3 {NamespaceChildrenCmd, ns name given} { +} -result {::test_ns_1::test_ns_2} +test namespace-21.3 {NamespaceChildrenCmd, ns name given} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace children ::test_ns_1 -} {::test_ns_1::test_ns_2} -test namespace-21.4 {NamespaceChildrenCmd, ns name given} { +} -result {::test_ns_1::test_ns_2} +test namespace-21.4 {NamespaceChildrenCmd, ns name given} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace children test_ns_2 } -} {} +} -result {} test namespace-21.5 {NamespaceChildrenCmd, too many args} { namespace eval test_ns_1 { list [catch {namespace children test_ns_2 xxx yyy} msg] $msg @@ -931,10 +1066,13 @@ test namespace-21.6 {NamespaceChildrenCmd, glob-style pattern given} { namespace eval test_ns_1::test_ns_foo {} namespace children test_ns_1 *f* } {::test_ns_1::test_ns_foo} -test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} { +test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1::test_ns_foo {} lsort [namespace children test_ns_1 test*] -} [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}] +} -result {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo} test namespace-21.8 {NamespaceChildrenCmd, trivial pattern starting with ::} { namespace eval test_ns_1 {} namespace children [namespace current] [fq test_ns_1] @@ -962,17 +1100,17 @@ test namespace-22.5 {NamespaceCodeCmd, in other namespace} { namespace code cmd } } {::namespace inscope ::test_ns_1 cmd} -test namespace-22.6 {NamespaceCodeCmd, in other namespace} { - namespace eval test_ns_1 { - variable v 42 - } - namespace eval test_ns_2 { - proc namespace args {} - } - namespace eval test_ns_2 [namespace eval test_ns_1 { - namespace code {set v} - }] -} {42} +test namespace-22.6 {NamespaceCodeCmd, in other namespace} { + namespace eval test_ns_1 { + variable v 42 + } + namespace eval test_ns_2 { + proc namespace args {} + } + namespace eval test_ns_2 [namespace eval test_ns_1 { + namespace code {set v} + }] +} {42} test namespace-22.7 {NamespaceCodeCmd, Bug 3202171} { namespace eval demo { proc namespace args {puts $args} @@ -1029,15 +1167,25 @@ test namespace-25.3 {NamespaceEvalCmd, new namespace} { } test_ns_1::p } {314159} -test namespace-25.4 {NamespaceEvalCmd, existing namespace} { +test namespace-25.4 {NamespaceEvalCmd, existing namespace} -setup { + namespace eval test_ns_1 { + variable v 314159 + proc p {} { + variable v + return $v + } + } +} -body { namespace eval test_ns_1 { proc q {} {return [expr {[p]+1}]} } test_ns_1::q -} {314160} -test namespace-25.5 {NamespaceEvalCmd, multiple args} { +} -result {314160} +test namespace-25.5 {NamespaceEvalCmd, multiple args} -setup { + namespace eval test_ns_1 {variable v 314159} +} -body { namespace eval test_ns_1 "set" "v" -} {314159} +} -result {314159} test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} { list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $::errorInfo } {1 {invalid command name "xxxx"} {invalid command name "xxxx" @@ -1088,21 +1236,50 @@ test namespace-26.4 {NamespaceExportCmd, one pattern} { } list [info commands test_ns_2::*] [test_ns_2::cmd1 hello] } {::test_ns_2::cmd1 {cmd1: hello}} -test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} { +test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} namespace export cmd1 cmd3 } +} -body { namespace eval test_ns_2 { namespace import -force ::test_ns_1::* } list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd3 hello] -} [list [lsort {::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd3: hello}] -test namespace-26.6 {NamespaceExportCmd, no patterns means return uniq'ed export list} { +} -result {{::test_ns_2::cmd1 ::test_ns_2::cmd3} {cmd3: hello}} +test namespace-26.6 {NamespaceExportCmd, no patterns means return uniq'ed export list} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + namespace export cmd1 cmd3 + } +} -body { namespace eval test_ns_1 { namespace export } -} {cmd1 cmd3} -test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { +} -result {cmd1 cmd3} +test namespace-26.7 {NamespaceExportCmd, -clear resets export list} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + } +} -body { + namespace eval test_ns_1 { + namespace export cmd1 cmd3 + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::* + } namespace eval test_ns_1 { namespace export -clear cmd4 } @@ -1110,7 +1287,15 @@ test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { namespace import ::test_ns_1::* } list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello] -} [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}] +} -result [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}] +test namespace-26.8 {NamespaceExportCmd, -clear resets export list} { + catch {namespace delete foo} + namespace eval foo { + namespace export x + namespace export -clear + } + list [namespace eval foo namespace export] [namespace delete foo] +} {{} {}} test namespace-27.1 {NamespaceForgetCmd, no args} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -1185,14 +1370,23 @@ test namespace-29.4 {NamespaceInscopeCmd, simple case} { } namespace inscope test_ns_1 cmd } {::test_ns_1::cmd: v=747, args=} -test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} { +test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} -setup { + namespace eval test_ns_1 { + variable v 747 + proc cmd {args} { + variable v + return "[namespace current]::cmd: v=$v, args=$args" + } + } +} -body { list [namespace inscope test_ns_1 cmd x y z] \ [namespace eval test_ns_1 [concat cmd [list x y z]]] -} {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}} -test namespace-29.6 {NamespaceInscopeCmd, 1400572} { +} -result {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}} +test namespace-29.6 {NamespaceInscopeCmd, 1400572} -setup { + namespace eval test_ns_1 {} +} -body { namespace inscope test_ns_1 {info level 0} -} {namespace inscope test_ns_1 {info level 0}} - +} -result {namespace inscope test_ns_1 {info level 0}} test namespace-30.1 {NamespaceOriginCmd, bad args} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -1313,7 +1507,8 @@ test namespace-34.3 {NamespaceWhichCmd, single arg is always command name} { test namespace-34.4 {NamespaceWhichCmd, bad args} { list [catch {namespace which a b} msg] $msg } {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} -test namespace-34.5 {NamespaceWhichCmd, command lookup} { +test namespace-34.5 {NamespaceWhichCmd, command lookup} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { namespace export cmd* variable v1 111 @@ -1326,6 +1521,7 @@ test namespace-34.5 {NamespaceWhichCmd, command lookup} { variable v2 222 proc p {} {} } +} -body { namespace eval test_ns_3 { namespace import ::test_ns_2::* variable v3 333 @@ -1335,26 +1531,59 @@ test namespace-34.5 {NamespaceWhichCmd, command lookup} { [namespace which -command ::test_ns_2::cmd2] \ [catch {namespace which -command ::test_ns_2::noSuchCmd} msg] $msg } -} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}} -test namespace-34.6 {NamespaceWhichCmd, -command is default} { +} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}} +test namespace-34.6 {NamespaceWhichCmd, -command is default} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + namespace export cmd* + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace export * + namespace import ::test_ns_1::* + proc p {} {} + } + namespace eval test_ns_3 { + namespace import ::test_ns_2::* + } +} -body { namespace eval test_ns_3 { list [namespace which foreach] \ [namespace which p] \ [namespace which cmd1] \ [namespace which ::test_ns_2::cmd2] } -} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} -test namespace-34.7 {NamespaceWhichCmd, variable lookup} { +} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} +test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + namespace export cmd* + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace export * + namespace import ::test_ns_1::* + variable v2 222 + proc p {} {} + } + namespace eval test_ns_3 { + variable v3 333 + namespace import ::test_ns_2::* + } +} -body { namespace eval test_ns_3 { list [namespace which -variable env] \ [namespace which -variable v3] \ [namespace which -variable ::test_ns_2::v2] \ [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg } -} {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} +} -result {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} -test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} { +test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { proc p {} { namespace delete [namespace current] @@ -1362,7 +1591,7 @@ test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} { } } test_ns_1::p -} {::test_ns_1} +} -result {::test_ns_1} test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} { namespace eval test_ns_1 { proc q {} { @@ -1432,7 +1661,7 @@ test namespace-40.1 {Ignoring namespace proc "unknown"} -setup { namespace eval ns {proc unknown args {return local}} list [namespace eval ns aaa bbb] [namespace eval ns aaa] } -cleanup { - rename unknown {} + rename unknown {} rename _unknown unknown namespace delete ns } -result {global global} @@ -1443,7 +1672,7 @@ test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} { set res {} proc test {} { set ::g 0 - } + } lappend ::res [test] proc set {a b} { ::set a [incr b] @@ -1571,7 +1800,10 @@ test namespace-42.7 {ensembles: nested} -body { } -cleanup { namespace delete ns } -result {{1 ::ns::x0::z} 1 2 3} -test namespace-42.8 {ensembles: [Bug 1670091]} -setup { +test namespace-42.8 { + ensembles: [Bug 1670091], panic due to pointer to a deallocated List + struct. +} -setup { proc demo args {} variable target [list [namespace which demo] x] proc trial args {variable target; string length $target} @@ -1586,6 +1818,34 @@ test namespace-42.8 {ensembles: [Bug 1670091]} -setup { rename foo {} } -result {} +test namespace-42.9 { + ensembles: [Bug 4f6a1ebd64], segmentation fault due to pointer to a + deallocated List struct. +} -setup { + namespace eval n {namespace ensemble create} + set lst [dict create one ::two] + namespace ensemble configure n -subcommands $lst -map $lst +} -body { + n one +} -cleanup { + namespace delete n + unset -nocomplain lst +} -returnCodes error -match glob -result {invalid command name*} + +test namespace-42.10 { + ensembles: [Bug 4f6a1ebd64] segmentation fault due to pointer to a + deallocated List struct (this time with duplicate of one in "dict"). +} -setup { + namespace eval n {namespace ensemble create} + set lst [list one ::two one ::three] + namespace ensemble configure n -subcommands $lst -map $lst +} -body { + n one +} -cleanup { + namespace delete n + unset -nocomplain lst +} -returnCodes error -match glob -result {invalid command name *three*} + test namespace-43.1 {ensembles: dict-driven} { namespace eval ns { namespace export x* @@ -1706,7 +1966,7 @@ test namespace-44.5 {ensemble: errors} -setup { foobar foobarcon } -cleanup { rename foobar {} -} -returnCodes error -result {invalid command name "::foobarconfigure"} +} -returnCodes error -result {invalid command name "foobarconfigure"} test namespace-44.6 {ensemble: errors} -returnCodes error -body { namespace ensemble create gorp } -result {wrong # args: should be "namespace ensemble create ?option value ...?"} @@ -2090,6 +2350,68 @@ test namespace-50.4 {chained ensembles affect error messages} -body { rename a {} rename c {} } +test namespace-50.5 {[4402cfa58c]} -setup { + proc bar {ev} {} + proc bingo {xx} {} + namespace ensemble create -command launch -map {foo bar event bingo} + set result {} +} -body { + catch {launch foo} m; lappend result $m + catch {launch ev} m; lappend result $m + catch {launch foo} m; lappend result $m +} -cleanup { + rename launch {} + rename bingo {} + rename bar {} +} -result {{wrong # args: should be "launch foo ev"} {wrong # args: should be "launch event xx"} {wrong # args: should be "launch foo ev"}} +test namespace-50.6 {[4402cfa58c]} -setup { + proc target {x y} {} + namespace ensemble create -command e2 -map {s2 target} + namespace ensemble create -command e1 -map {s1 e2} + set result {} +} -body { + set s s + catch {e1 s1 s2 a} m; lappend result $m + catch {e1 $s s2 a} m; lappend result $m + catch {e1 s1 $s a} m; lappend result $m + catch {e1 $s $s a} m; lappend result $m +} -cleanup { + rename e1 {} + rename e2 {} + rename target {} +} -result {{wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"}} +test namespace-50.7 {[4402cfa58c]} -setup { + proc target {x y} {} + namespace ensemble create -command e2 -map {s2 target} + namespace ensemble create -command e1 -map {s1 e2} -parameters foo + set result {} +} -body { + set s s + catch {e1 s2 s1 a} m; lappend result $m + catch {e1 $s s1 a} m; lappend result $m + catch {e1 s2 $s a} m; lappend result $m + catch {e1 $s $s a} m; lappend result $m +} -cleanup { + rename e1 {} + rename e2 {} + rename target {} +} -result {{wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"}} +test namespace-50.8 {[f961d7d1dd]} -setup { + proc target {} {} + namespace ensemble create -command e -map {s target} -parameters {{a b}} +} -body { + e +} -returnCodes error -result {wrong # args: should be "e {a b} subcommand ?arg ...?"} -cleanup { + rename e {} + rename target {} +} +test namespace-50.9 {[cea0344a51]} -body { + namespace eval foo { + namespace eval bar { + namespace delete foo + } + } +} -returnCodes error -result {unknown namespace "foo" in namespace delete command} test namespace-51.1 {name resolution path control} -body { namespace eval ::test_ns_1 { @@ -2304,6 +2626,7 @@ test namespace-51.6 {name resolution path control} -body { namespace delete ::test_ns_1 catch {rename ::pathtestB {}} catch {rename ::pathtestD {}} + catch {rename ::pathtestC {}} } test namespace-51.7 {name resolution path control} -body { namespace eval ::test_ns_1 { @@ -2476,9 +2799,9 @@ test namespace-51.15 {namespace resolution path control} -body { namespace delete ::test_ns_2 } test namespace-51.16 {Bug 1566526} { - interp create slave - slave eval namespace eval demo namespace path :: - interp delete slave + interp create child + child eval namespace eval demo namespace path :: + interp delete child } {} test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup { set result {} @@ -2679,19 +3002,19 @@ test namespace-52.11 {unknown: with TCL_EVAL_INVOKE} -setup { } } catch {rename ::noSuchCommand {}} - set ::slave [interp create] + set ::child [interp create] } -body { - $::slave alias bar noSuchCommand + $::child alias bar noSuchCommand namespace eval test_ns_1 { namespace unknown unknown proc unknown args { return FAIL } - $::slave eval bar + $::child eval bar } } -cleanup { - interp delete $::slave - unset ::slave + interp delete $::child + unset ::child namespace delete test_ns_1 rename ::unknown {} rename unknown.save ::unknown @@ -2911,6 +3234,22 @@ test namespace-53.10 {ensembles: nested rewrite} -setup { 0 {1 v}\ 1 {wrong # args: should be "ns v x z2 a2"}\ 0 {2 v v2}} +test namespace-53.11 {ensembles: nested rewrite} -setup { + namespace eval ns { + namespace export x + namespace eval x { + proc z2 {a1 a2} {list 2 $a1 $a2} + namespace export z* + namespace ensemble create -parameter p + } + namespace ensemble create + } +} -body { + list [catch {ns x 1 z2} msg] $msg +} -cleanup { + namespace delete ns + unset -nocomplain msg +} -result {1 {wrong # args: should be "ns x 1 z2 a2"}} test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ -setup { @@ -2932,6 +3271,117 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ rename getbytes {} unset i ns start end } -result 0 + +test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} { + info class [format %s constructor] oo::object +} "" + +test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} { + namespace eval ::testing { + proc abc {} {} + proc def {} {} + trace add command abc delete "rename ::testing::def {}; #" + trace add command def delete "rename ::testing::abc {}; #" + } + namespace delete ::testing +} {} +test namespace-56.2 {bug f97d4ee020: mutually-entangled deletion} { + namespace eval ::testing { + namespace eval abc {proc xyz {} {}} + namespace eval def {proc xyz {} {}} + trace add command abc::xyz delete "namespace delete ::testing::def {}; #" + trace add command def::xyz delete "namespace delete ::testing::abc {}; #" + } + namespace delete ::testing +} {} +test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} { + namespace eval ::testing { + variable gone {} + oo::class create CB { + variable cmd + constructor other {set cmd $other} + destructor {rename $cmd {}; lappend ::testing::gone $cmd} + } + namespace eval abc { + ::testing::CB create def ::testing::abc::ghi + ::testing::CB create ghi ::testing::abc::def + } + namespace delete abc + try { + return [lsort $gone] + } finally { + namespace delete ::testing + } + } +} {::testing::abc::def ::testing::abc::ghi} + +test namespace-56.4 {bug 16fe1b5807: names starting with ":"} knownBug { +namespace eval : { + namespace ensemble create + namespace export * + proc p1 {} { + return 16fe1b5807 + } +} + +: p1 +} 16fe1b5807 + +test namespace-56.5 {Bug 8b9854c3d8} -setup { + namespace eval namespace-56.5 { + proc cmd {} {string match ::* [lindex [[string cat info] level 0] 0]} + namespace export * + namespace ensemble create + } +} -body { + namespace-56.5 cmd +} -cleanup { + namespace delete namespace-56.5 +} -result 1 + + + +test namespace-57.0 { + an imported alias should be usable in the deletion trace for the alias + + see 29e8848eb976 +} -body { + variable res {} + namespace eval ns2 { + namespace export * + proc p1 {oldname newname op} { + return success + } + + interp alias {} [namespace current]::p2 {} [namespace which p1] + } + + + namespace eval ns3 { + namespace import ::ns2::p2 + } + + + set ondelete [list apply [list {oldname newname op} { + variable res + catch { + ns3::p2 $oldname $newname $op + } cres + lappend res $cres + } [namespace current]]] + + + trace add command ::ns2::p2 delete $ondelete + rename ns2::p2 {} + return $res +} -cleanup { + unset res + namespace delete ns2 + namespace delete ns3 +} -result success + + + # cleanup catch {rename cmd1 {}} diff --git a/tests/notify.test b/tests/notify.test index d2b9123..840ad31 100755 --- a/tests/notify.test +++ b/tests/notify.test @@ -8,18 +8,18 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. +# Copyright © 2003 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testevent [llength [info commands testevent]] diff --git a/tests/nre.test b/tests/nre.test index b8ef2e0..8296569 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -4,18 +4,18 @@ # avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the # actual command functionality is tested in the specific test file. # -# Copyright (c) 2008 by Miguel Sofer. +# Copyright © 2008 Miguel Sofer. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testnrelevels [llength [info commands testnrelevels]] @@ -29,9 +29,9 @@ if {[testConstraint testnrelevels]} { namespace path ::tcl::mathop # # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, - # cmdFrame level, callFrame level, tosPtr and callback depth + # cmdFrame level, callFrame level, tosPtr and callback depth # - variable last [testnrelevels] + variable last [testnrelevels] proc depthDiff {} { variable last set depth [testnrelevels] @@ -64,6 +64,12 @@ if {[testConstraint testnrelevels]} { namespace import testnre::* } +test nre-0.1 {levels while unwinding} -body { + testnreunwind +} -constraints { + testnrelevels +} -result {0 0 0} + test nre-1.1 {self-recursive procs} -setup { proc a i [makebody {a $i}] } -body { @@ -74,7 +80,6 @@ test nre-1.1 {self-recursive procs} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-1.2 {self-recursive lambdas} -setup { set a [list i [makebody {apply $::a $i}]] } -body { @@ -85,7 +90,6 @@ test nre-1.2 {self-recursive lambdas} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-1.3 {mutually recursive procs and lambdas} -setup { proc a i { apply $::b [incr i] @@ -153,6 +157,27 @@ test nre-4.1 {ensembles are not recursive} -setup { testnrelevels } -result {{0 2 1 1} 0} +test nre-4.2 {(compiled) ensembles do not break tailcall} -setup { + # Fix Bug d87cb18205 + proc b {} { + tailcall append result first + } + set map [namespace ensemble configure ::dict -map] + dict set map a b + namespace ensemble configure ::dict -map $map + proc demo {} { + dict a + append result second + } +} -body { + demo +} -cleanup { + rename demo {} + namespace ensemble configure ::dict -map [dict remove $map a] + unset map + rename b {} +} -result firstsecond + test nre-5.1 {[namespace eval] is not recursive} -setup { namespace eval ::foo { setabs @@ -164,8 +189,7 @@ test nre-5.1 {[namespace eval] is not recursive} -setup { namespace delete ::foo } -constraints { testnrelevels -} -result {{0 3 2 2} 0} - +} -result {{0 2 2 2} 0} test nre-5.2 {[namespace eval] is not recursive} -setup { namespace eval ::foo { setabs @@ -177,7 +201,7 @@ test nre-5.2 {[namespace eval] is not recursive} -setup { namespace delete ::foo } -constraints { testnrelevels -} -result {{0 3 2 2} 0} +} -result {{0 2 2 2} 0} test nre-6.1 {[uplevel] is not recursive} -setup { proc a i [makebody {uplevel 1 [list a $i]}] @@ -189,7 +213,6 @@ test nre-6.1 {[uplevel] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-6.2 {[uplevel] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "set x $i; a $i"}] @@ -211,7 +234,6 @@ test nre-7.1 {[catch] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 3 3 0} 0} - test nre-7.2 {[if] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "if 1 {a $i}"}] @@ -222,7 +244,6 @@ test nre-7.2 {[if] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-7.3 {[while] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "while 1 {set res \[a $i\]; break}; set res"}] @@ -233,7 +254,6 @@ test nre-7.3 {[while] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-7.4 {[for] is not recursive} -setup { setabs proc a i [makebody {uplevel 1 "for {set j 0} {\$j < 10} {incr j} {set res \[a $i\]; break}; set res"}] @@ -244,7 +264,6 @@ test nre-7.4 {[for] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 0} 0} - test nre-7.5 {[foreach] is not recursive} -setup { # # Enable once [foreach] is NR-enabled @@ -258,7 +277,6 @@ test nre-7.5 {[foreach] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 3 3 0} 0} - test nre-7.6 {[eval] is not recursive} -setup { proc a i [makebody {eval [list a $i]}] } -body { @@ -269,7 +287,6 @@ test nre-7.6 {[eval] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 1} 0} - test nre-7.7 {[eval] is not recursive} -setup { proc a i [makebody {eval "a $i"}] } -body { @@ -280,7 +297,6 @@ test nre-7.7 {[eval] is not recursive} -setup { } -constraints { testnrelevels } -result {{0 2 2 1} 0} - test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { proc foo args {} foo @@ -295,18 +311,15 @@ test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { } -body { # if switching to plain eval is not nre aware, this will cause a "cannot # yield" error - list [bar] [bar] [bar] } -cleanup { rename bar {} rename foo {} } -result {1 2 3} - test nre-8.1 {nre and {*}} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the TEBCdataPtr. This crashes on failure. - proc inner {} { set long [lrepeat 1000000 1] list {*}$long @@ -316,26 +329,23 @@ test nre-8.1 {nre and {*}} -body { } -cleanup { rename inner {} rename outer {} -} -result {1 1 1} +} -result {1 1 1} test nre-8.2 {nre and {*}, [Bug 2415422]} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the bcFramePtr. This causes an NRE assertion to fail if it is not # done properly. - proc nop {} {} proc crash {} { foreach val [list {*}[lrepeat 100000 x]] { nop } } - crash } -cleanup { rename nop {} rename crash {} } - # # Basic TclOO tests # @@ -351,7 +361,6 @@ test nre-oo.1 {really deep calls in oo - direct} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.2 {really deep calls in oo - call via [self]} -setup { oo::object create foo oo::objdefine foo method bar i [makebody {[self] bar $i}] @@ -363,7 +372,6 @@ test nre-oo.2 {really deep calls in oo - call via [self]} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.3 {really deep calls in oo - private calls} -setup { oo::object create foo oo::objdefine foo method bar i [makebody {my bar $i}] @@ -375,7 +383,6 @@ test nre-oo.3 {really deep calls in oo - private calls} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.4 {really deep calls in oo - overriding} -setup { oo::class create foo { method bar i [makebody {my bar $i}] @@ -392,7 +399,6 @@ test nre-oo.4 {really deep calls in oo - overriding} -setup { } -constraints { testnrelevels } -result {{0 1 1 1} 0} - test nre-oo.5 {really deep calls in oo - forwards} -setup { oo::object create foo set body [makebody {my boo $i}] @@ -409,7 +415,6 @@ test nre-oo.5 {really deep calls in oo - forwards} -setup { testnrelevels } -result {{0 2 1 1} 0} - # # NASTY BUG found by tcllib's interp package # diff --git a/tests/obj.test b/tests/obj.test index 71a39b4..a2976de 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -5,38 +5,36 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 foreach {t} { - {array search} bytearray bytecode cmdName dict - end-offset regexp string } { set first [string first $t [testobj types]] - set r [expr {$r && ($first != -1)}] + set r [expr {$r && ($first >= 0)}] } set result $r } {1} @@ -53,15 +51,6 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj { lappend result [testobj refcount 1] } {{} 12 12 bytearray 3} -test obj-3.1 {Tcl_ConvertToType error} testobj { - list [testdoubleobj set 1 12.34] \ - [catch {testobj convert 1 end-offset} msg] \ - $msg -} {12.34 1 {bad index "12.34": must be end?[+-]integer?}} -test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj { - list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg -} {{} 1 {bad index "": must be end?[+-]integer?}} - test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" lappend result [testobj freeallvars] @@ -82,7 +71,7 @@ test obj-6.1 {Tcl_DuplicateObj, object has internal rep} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 47] - lappend result [testobj duplicate 1 2] + lappend result [testobj duplicate 1 2] lappend result [testintobj get 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] @@ -91,7 +80,7 @@ test obj-6.2 {Tcl_DuplicateObj, "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] - lappend result [testobj duplicate 1 2] + lappend result [testobj duplicate 1 2] lappend result [testintobj get 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] @@ -487,11 +476,11 @@ test obj-26.1 {UpdateStringOfInt} testobj { lappend result [testintobj get 1] ;# must update string rep } {512 5120 5120} -test obj-27.1 {Tcl_NewLongObj} testobj { +test obj-27.1 {Tcl_NewWideObj} testobj { set result "" lappend result [testobj freeallvars] - testintobj setmaxlong 1 - lappend result [testintobj ismaxlong 1] + testintobj setmax 1 + lappend result [testintobj ismax 1] lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 1 int 1} @@ -500,7 +489,7 @@ test obj-28.1 {Tcl_SetLongObj, existing "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] - lappend result [testintobj setlong 1 77] ;# makes existing obj long int + lappend result [testintobj setint 1 77] ;# makes existing obj int lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} 77 int 2} @@ -508,32 +497,32 @@ test obj-28.2 {Tcl_SetLongObj, existing non-"empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testdoubleobj set 1 12.34] - lappend result [testintobj setlong 1 77] ;# makes existing obj long int + lappend result [testintobj setint 1 77] ;# makes existing obj int lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 12.34 77 int 2} -test obj-29.1 {Tcl_GetLongFromObj, existing long integer object} testobj { +test obj-29.1 {Tcl_GetWideIntFromObj, existing int object} testobj { set result "" - lappend result [testintobj setlong 1 22] - lappend result [testintobj mult10 1] ;# gets existing long int rep + lappend result [testintobj setint 1 22] + lappend result [testintobj mult10 1] ;# gets existingint rep } {22 220} -test obj-29.2 {Tcl_GetLongFromObj, convert to long} testobj { +test obj-29.2 {Tcl_GetWideIntFromObj, convert to int} testobj { set result "" - lappend result [testintobj setlong 1 477] + lappend result [testintobj setint 1 477] lappend result [testintobj div10 1] ;# must convert to bool lappend result [testobj type 1] } {477 47 int} -test obj-29.3 {Tcl_GetLongFromObj, error converting to long integer} testobj { +test obj-29.3 {Tcl_GetWideIntFromObj, error converting to int} testobj { set result "" lappend result [teststringobj set 1 abc] - lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int + lappend result [catch {testintobj ismax 1} msg] ;# cvts to long int lappend result $msg } {abc 1 {expected integer but got "abc"}} -test obj-29.4 {Tcl_GetLongFromObj, error converting from "empty string"} testobj { +test obj-29.4 {Tcl_GetWideIntFromObj, error converting from "empty string"} testobj { set result "" lappend result [testobj newobj 1] - lappend result [catch {testintobj ismaxlong 1} msg] ;# cvts to long int + lappend result [catch {testintobj ismax 1} msg] ;# cvts to long int lappend result $msg } {{} 1 {expected integer but got ""}} @@ -551,44 +540,6 @@ test obj-30.1 {Ref counting and object deletion, simple types} testobj { lappend result [testobj refcount 2] } {{} 1024 1024 int 4 4 0 int 3 2} - -test obj-31.1 {regenerate string rep of "end"} testobj { - testobj freeallvars - teststringobj set 1 end - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end -test obj-31.2 {regenerate string rep of "end-1"} testobj { - testobj freeallvars - teststringobj set 1 end-0x1 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end-1 -test obj-31.3 {regenerate string rep of "end--1"} testobj { - testobj freeallvars - teststringobj set 1 end--0x1 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--1 -test obj-31.4 {regenerate string rep of "end-bigInteger"} testobj { - testobj freeallvars - teststringobj set 1 end-0x7fffffff - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end-2147483647 -test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj { - testobj freeallvars - teststringobj set 1 end--0x7fffffff - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--2147483647 -test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} { - testobj freeallvars - teststringobj set 1 end--0x80000000 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--2147483648 - test obj-32.1 {freeing very large object trees} { set x {} for {set i 0} {$i<100000} {incr i} { @@ -597,34 +548,47 @@ test obj-32.1 {freeing very large object trees} { unset x } {} -test obj-33.1 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.1 {integer overflow on input} {longIs32bit wideIs64bit} { set x 0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 2147483648} -test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.2 {integer overflow on input} {longIs32bit wideIs64bit} { set x 0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 4294967295} -test obj-33.3 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.3 {integer overflow on input} { set x 0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] -} {0 4294967296} -test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +} {1 4294967296} +test obj-33.4 {integer overflow on input} {longIs32bit wideIs64bit} { set x -0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 -2147483648} -test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.5 {integer overflow on input} {longIs32bit wideIs64bit} { set x -0x8000; append x 0001 list [string is integer $x] [expr { wide($x) }] } {1 -2147483649} -test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.6 {integer overflow on input} {longIs32bit wideIs64bit} { set x -0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 -4294967295} -test obj-33.7 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.7 {integer overflow on input} { set x -0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] -} {0 -4294967296} +} {1 -4294967296} + +test obj-34.1 {mp_iseven} testobj { + set result "" + lappend result [testbignumobj set 1 0] + lappend result [testbignumobj iseven 1] ; + lappend result [testobj type 1] +} {0 1 int} +test obj-34.2 {mp_radix_size} testobj { + set result "" + lappend result [testbignumobj set 1 9] + lappend result [testbignumobj radixsize 1] ; + lappend result [testobj type 1] +} {9 2 int} if {[testConstraint testobj]} { testobj freeallvars diff --git a/tests/oo.test b/tests/oo.test index 00663e9..168baee 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2,17 +2,22 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-2011 Donal K. Fellows +# Copyright © 2006-2013 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require -exact TclOO 0.6.3 ;# Must match value in generic/tclOO.h -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +package require tcl::oo 1.0.3 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } +# The foundational objects oo::object and oo::class are sensitive to reference +# counting errors and are deallocated only when an interp is deleted, so in +# this test suite, interp creation and interp deletion are often used in +# leaktests in order to leverage this sensitivity. + testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { proc getbytes {} { @@ -33,21 +38,21 @@ if {[testConstraint memory]} { test oo-0.1 {basic test of OO's ability to clean up its initial state} { interp create t t eval { - package require TclOO + package require tcl::oo } interp delete t } {} test oo-0.2 {basic test of OO's ability to clean up its initial state} { set i [interp create] interp eval $i { - package require TclOO + package require tcl::oo namespace delete :: } interp delete $i } {} test oo-0.3 {basic test of OO's ability to clean up its initial state} -body { leaktest { - [oo::object new] destroy + [oo::object new] destroy } } -constraints memory -result 0 test oo-0.4 {basic test of OO's ability to clean up its initial state} -body { @@ -57,7 +62,13 @@ test oo-0.4 {basic test of OO's ability to clean up its initial state} -body { foo destroy } } -constraints memory -result 0 -test oo-0.5 {testing literal leak on interp delete} memory { +test oo-0.5.1 {testing object foundation cleanup} memory { + leaktest { + interp create foo + interp delete foo + } +} 0 +test oo-0.5.2 {testing literal leak on interp delete} memory { leaktest { interp create foo foo eval {oo::object new} @@ -68,7 +79,7 @@ test oo-0.6 {cleaning the core class pair; way #1} -setup { interp create t } -body { t eval { - package require TclOO + package require tcl::oo namespace path oo list [catch {class destroy} m] $m [catch {object destroy} m] $m } @@ -79,7 +90,7 @@ test oo-0.7 {cleaning the core class pair; way #2} -setup { interp create t } -body { t eval { - package require TclOO + package require tcl::oo namespace path oo list [catch {object destroy} m] $m [catch {class destroy} m] $m } @@ -98,10 +109,10 @@ test oo-0.8 {leak in variable management} -setup { } -cleanup { foo destroy } -result 0 -test oo-0.9 {various types of presence of the TclOO package} { - list [lsearch -nocase -all -inline [package names] tcloo] \ - [package present TclOO] [package versions TclOO] -} [list TclOO $::oo::version $::oo::version] +test oo-0.9 {various types of presence of the tcl::oo package} { + list [lsearch -nocase -all -inline [package names] tcl::oo] \ + [package present tcl::oo] [expr {$::oo::patchlevel in [package versions tcl::oo]}] +} [list tcl::oo $::oo::patchlevel 1] test oo-1.1 {basic test of OO functionality: no classes} { set result {} @@ -118,16 +129,23 @@ test oo-1.1 {basic test of OO functionality: no classes} { } {::foo {} a b c 3 {} {}} test oo-1.2 {basic test of OO functionality: no classes} -body { oo::define oo::object method missingArgs -} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name args body\"" +} -returnCodes 1 -result "wrong # args: should be \"oo::define oo::object method name ?option? args body\"" test oo-1.3 {basic test of OO functionality: no classes} { catch {oo::define oo::object method missingArgs} set errorInfo -} "wrong # args: should be \"oo::define oo::object method name args body\" +} "wrong # args: should be \"oo::define oo::object method name ?option? args body\" while executing \"oo::define oo::object method missingArgs\"" test oo-1.4 {basic test of OO functionality} -body { oo::object create {} } -returnCodes 1 -result {object name must not be empty} +test oo-1.4.1 {fully-qualified nested name} -body { + oo::object create ::one::two::three +} -result {::one::two::three} +test oo-1.4.2 {automatic command name has same name as namespace} -body { + set obj [oo::object new] + expr {[info object namespace $obj] == $obj} +} -result 1 test oo-1.5 {basic test of OO functionality} -body { oo::object doesnotexist } -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new} @@ -258,6 +276,77 @@ test oo-1.18 {OO: create object in NS with same name as global cmd} -setup { rename test-oo-1.18 {} A destroy } -result ::C +test oo-1.18.1 {no memory leak: superclass} -setup { +} -constraints memory -body { + + leaktest { + interp create t + t eval { + oo::class create A { + superclass oo::class + } + } + interp delete t + } +} -cleanup { +} -result 0 +test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup { + proc test-oo-1.18 {} return +} -constraints memory -body { + leaktest { + oo::class create A + oo::class create B {superclass A} + oo::define B constructor {} {A create test-oo-1.18} + B create C + A destroy + } +} -cleanup { + rename test-oo-1.18 {} +} -result 0 +test oo-1.18.3 {Bug 21c144f0f5} -setup { + interp create child +} -body { + child eval { + oo::define [oo::class create foo] superclass oo::class + oo::class destroy + } +} -cleanup { + interp delete child +} +test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup { + interp create child +} -body { + child eval { + oo::class create A + oo::class create B { + superclass oo::class + constructor {} { + next {superclass A} + next {superclass -append A} + } + } + [B create C] create d + } +} -returnCodes error -cleanup { + interp delete child +} -result {class should only be a direct superclass once} +test oo-1.18.5 {correct handling of cleanup in superclass set error} -setup { + interp create child +} -body { + child eval { + oo::class create A + oo::class create B { + superclass oo::class + constructor {c} { + next {superclass A} + next [list superclass -append {*}$c] + } + } + [B create C {B C}] create d + } +} -returnCodes error -cleanup { + interp delete child +} -result {attempt to form circular dependency graph} test oo-1.19 {basic test of OO functionality: teardown order} -body { oo::object create o namespace delete [info object namespace o] @@ -270,13 +359,31 @@ test oo-1.20 {basic test of OO functionality: my teardown post rename} -body { obj destroy info commands ::AGlobalName } -result {} +test oo-1.21 {basic test of OO functionality: default relations} -setup { + set fresh [interp create] +} -body { + lmap x [$fresh eval { + set initials {::oo::object ::oo::class ::oo::Slot} + foreach cmd {instances subclasses mixins superclass} { + foreach initial $initials { + lappend x [info class $cmd $initial] + } + } + foreach initial $initials { + lappend x [info object class $initial] + } + return $x + }] {lsort [lsearch -all -not -inline $x *::delegate]} +} -cleanup { + interp delete $fresh +} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as # we're modifying the root object class's constructor interp create subinterp subinterp eval { - package require TclOO + package require tcl::oo } } -body { subinterp eval { @@ -376,13 +483,38 @@ test oo-2.8 {construction, method calls and ensembles - Bug 3514761} -setup { } -returnCodes error -cleanup { namespace delete k } -result {wrong # args: should be "k next j"} +test oo-2.9 {construction failures and self creation} -setup { + set ::result {} + oo::class create Root +} -body { + oo::class create A { + superclass Root + constructor {} { + lappend ::result "in A" + error "failure in A" + } + destructor {lappend ::result [self]} + } + oo::class create B { + superclass Root + constructor {} { + lappend ::result "in B [self]" + error "failure in B" + } + destructor {lappend ::result [self]} + } + lappend ::result [catch {A create a} msg] $msg + lappend ::result [catch {B create b} msg] $msg +} -cleanup { + Root destroy +} -result {{in A} ::a 1 {failure in A} {in B ::b} ::b 1 {failure in B}} test oo-3.1 {basic test of OO functionality: destructor} -setup { # This is a bit complex because it needs to run in a sub-interp as we're # modifying the root object class's constructor interp create subinterp subinterp eval { - package require TclOO + package require tcl::oo } } -body { subinterp eval { @@ -402,7 +534,7 @@ test oo-3.2 {basic test of OO functionality: destructor} -setup { # we're modifying the root object class's constructor interp create subinterp subinterp eval { - package require TclOO + package require tcl::oo } } -body { subinterp eval { @@ -573,6 +705,57 @@ test oo-3.9 {Bug 2944404: deleting the object in the destructor} -setup { } -cleanup { cls destroy } -result {in destructor} +test oo-3.10 {Bug 3d96b7076e: killing the object's class in a method call} -setup { + oo::class create Super +} -body { + # Only reliably failed in a memdebug build + oo::class create Cls { + superclass Super + method mthd {} { + [self class] destroy + return ok + } + } + [Cls new] mthd +} -cleanup { + Super destroy +} -result ok +test oo-3.11 {Bug 3d96b7076e: killing the object's class in a method call} -setup { + oo::class create Super + oo::class create Sub { + superclass Super + } +} -body { + # Only reliably failed in a memdebug build + oo::class create Cls { + superclass Super + method mthd {} { + oo::objdefine [self] class Sub + Cls destroy + return ok + } + } + [Cls new] mthd +} -cleanup { + Super destroy +} -result ok +test oo-3.12 {Bug 3d96b7076e: killing the object's class in a method call} -setup { + oo::class create Super +} -body { + # Only reliably failed in a memdebug build + oo::class create Cls { + superclass Super + method mthd {} { + [self class] destroy + return ok + } + } + set o [Super new] + oo::objdefine $o mixin Cls + $o mthd +} -cleanup { + Super destroy +} -result ok test oo-4.1 {basic test of OO functionality: export} { set o [oo::object new] @@ -630,6 +813,76 @@ test oo-4.6 {export creates proper method entries} -setup { } -cleanup { testClass destroy } -result ok +test oo-4.7 {basic test of OO functionality: method -export flag} -setup { + set o [oo::object new] + unset -nocomplain result +} -body { + oo::objdefine $o { + method Foo {} { + lappend ::result Foo + return foo + } + method Bar -export {} { + lappend ::result Bar + return bar + } + } + lappend result [catch {$o Foo} msg] $msg + lappend result [$o Bar] +} -cleanup { + $o destroy +} -result {1 {unknown method "Foo": must be Bar or destroy} Bar bar} +test oo-4.8 {basic test of OO functionality: method -unexport flag} -setup { + set o [oo::object new] + unset -nocomplain result +} -body { + oo::objdefine $o { + method foo {} { + lappend ::result foo + return Foo + } + method bar -unexport {} { + lappend ::result bar + return Bar + } + } + lappend result [$o foo] + lappend result [catch {$o bar} msg] $msg +} -cleanup { + $o destroy +} -result {foo Foo 1 {unknown method "bar": must be destroy or foo}} +test oo-4.9 {basic test of OO functionality: method -private flag} -setup { + set o [oo::object new] + unset -nocomplain result +} -body { + oo::objdefine $o { + method foo {} { + lappend ::result foo + return Foo + } + method bar -private {} { + lappend ::result bar + return Bar + } + export eval + method gorp {} { + my bar + } + } + lappend result [$o foo] + lappend result [catch {$o bar} msg] $msg + lappend result [catch {$o eval my bar} msg] $msg + lappend result [$o gorp] +} -cleanup { + $o destroy +} -result {foo Foo 1 {unknown method "bar": must be destroy, eval, foo or gorp} 1 {unknown method "bar": must be <cloned>, destroy, eval, foo, gorp, unknown, variable or varname} bar Bar} +test oo-4.10 {basic test of OO functionality: method flag parsing} -setup { + set o [oo::object new] +} -body { + oo::objdefine $o method foo -gorp xyz {return Foo} +} -returnCodes error -cleanup { + $o destroy +} -result {bad export flag "-gorp": must be -export, -private, or -unexport} test oo-5.1 {OO: manipulation of classes as objects} -setup { set obj [oo::object new] @@ -936,6 +1189,69 @@ test oo-6.18 {Bug 3408830: more forwarding cases} -setup { } -returnCodes error -cleanup { fooClass destroy } -result {wrong # args: should be "::foo len string"} +test oo-6.19 {Bug 3610404: forwarding resolution + traces} -setup { + oo::object create foo + unset -nocomplain ::result + set ::result {} +} -body { + proc ::my {method} {lappend ::result global} + oo::objdefine foo { + method target {} {lappend ::result instance} + forward bar my target + method bump {} { + set ns [info object namespace ::foo] + rename ${ns}::my ${ns}:: + rename ${ns}:: ${ns}::my + } + } + proc harness {} { + foo target + foo bar + foo target + } + trace add execution harness enterstep {apply {{cmd args} {foo bump}}} + foo target + foo bar + foo bump + foo bar + harness +} -cleanup { + catch {rename harness {}} + catch {rename ::my {}} + foo destroy +} -result {instance instance instance instance instance instance} +test oo-6.20 {Bug 3610404: forwarding resolution + traces} -setup { + oo::class create fooClass + fooClass create foo + unset -nocomplain ::result + set ::result {} +} -body { + proc ::my {method} {lappend ::result global} + oo::define fooClass { + method target {} {lappend ::result class} + forward bar my target + method bump {} { + set ns [info object namespace [self]] + rename ${ns}::my ${ns}:: + rename ${ns}:: ${ns}::my + } + } + proc harness {} { + foo target + foo bar + foo target + } + trace add execution harness enterstep {apply {{cmd args} {foo bump}}} + foo target + foo bar + foo bump + foo bar + harness +} -cleanup { + catch {rename harness {}} + catch {rename ::my {}} + fooClass destroy +} -result {class class class class class class} test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass @@ -1123,16 +1439,16 @@ test oo-7.8 {OO: next at the end of the method chain} -setup { } -result {foo2 foo 1 {no next method implementation}} test oo-7.9 {OO: defining inheritance in namespaces} -setup { set ::result {} - oo::class create ::master + oo::class create ::parent namespace eval ::foo { - oo::class create mixin {superclass ::master} + oo::class create mixin {superclass ::parent} } } -cleanup { - ::master destroy + ::parent destroy namespace delete ::foo } -body { namespace eval ::foo { - oo::class create bar {superclass master} + oo::class create bar {superclass parent} oo::class create boo oo::define boo {superclass bar} oo::define boo {mixin mixin} @@ -1140,6 +1456,35 @@ test oo-7.9 {OO: defining inheritance in namespaces} -setup { return } } -result {} +test oo-7.10 {OO: next after object deletion, bug [135804138e]} -setup { + set ::result "" + oo::class create c1 { + method m1 {} { + lappend ::result c1::m1 + } + } + oo::class create c2 { + superclass c1 + destructor { + lappend ::result c2::destructor + my m1 + lappend ::result /c2::destructor + } + method m1 {} { + lappend ::result c2::m1 + rename [self] {} + lappend ::result no-self + next + lappend ::result /c2::m1 + } + } +} -body { + c2 create o + lappend ::result [catch {o m1} msg] $msg +} -cleanup { + c1 destroy + unset ::result +} -result {c2::m1 c2::destructor c2::m1 no-self c1::m1 /c2::m1 /c2::destructor no-self 1 {no next method implementation}} test oo-8.1 {OO: global must work in methods} { oo::object create foo @@ -1267,6 +1612,30 @@ test oo-10.3 {OO: invoke and modify} -setup { oo::define B deletemethod b c lappend result [C a] [C b] [C c] } -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c} +test oo-10.4 {OO: invoke and modify} -setup { + oo::class create A { + method a {} {return A.a} + method b {} {return A.b} + method c {} {return A.c} + } + A create B + oo::objdefine B { + method a {} {return [next],B.a} + method b {} {return [next],B.b} + method c {} {return [next],B.c} + } + set result {} +} -cleanup { + A destroy +} -body { + lappend result [B a] [B b] [B c] - + oo::objdefine B deletemethod b + lappend result [B a] [B b] [B c] - + oo::objdefine B renamemethod a b + lappend result [B a] [B b] [B c] - + oo::objdefine B deletemethod b c + lappend result [B a] [B b] [B c] +} -result {A.a,B.a A.b,B.b A.c,B.c - A.a,B.a A.b A.c,B.c - A.a A.b,B.a A.c,B.c - A.a A.b A.c} test oo-11.1 {OO: cleanup} { oo::object create foo @@ -1303,6 +1672,87 @@ test oo-11.4 {OO: cleanup} { lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \ [oo::object create bar2] [bar2 destroy] } {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}} +test oo-11.5 {OO: cleanup} { + oo::class create obj1 + + trace add command obj1 delete {apply {{name1 name2 action} { + set namespace [info object namespace $name1] + namespace delete $namespace + }}} + + rename obj1 {} + # No segmentation fault + return done +} done + +test oo-11.6.1 { + OO: cleanup of when an class is mixed into itself +} -constraints memory -body { + leaktest { + interp create interp1 + oo::class create obj1 + ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} + rename obj1 {} + interp delete interp1 + } +} -result 0 -cleanup { +} + +test oo-11.6.2 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} -constraints memory -body { + leaktest { + interp create interp1 + interp1 eval { + oo::class create obj1 + ::oo::copy obj1 obj2 + rename obj2 {} + rename obj1 {} + } + interp delete interp1 + } +} -result 0 -cleanup { +} + +test oo-11.6.3 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} -constraints memory -body { + leaktest { + interp create interp1 + interp1 eval { + oo::class create obj1 + ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} + + ::oo::copy obj1 obj2 + rename obj2 {} + rename obj1 {} + } + interp delete interp1 + } +} -result 0 -cleanup { +} + +test oo-11.6.4 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} -body { + oo::class create obj1 + ::oo::define obj1 {self mixin [self]} + + ::oo::copy obj1 obj2 + ::oo::objdefine obj2 {mixin [self]} + + ::oo::copy obj2 obj3 + rename obj3 {} + rename obj2 {} + + # No segmentation fault + return done +} -result done -cleanup { + rename obj1 {} +} test oo-12.1 {OO: filters} { oo::class create Aclass @@ -1441,6 +1891,34 @@ test oo-12.7 {OO: filters} -setup { } -cleanup { Aclass destroy } -result {foo {{::Aclass outerfoo} {::Aclass InnerFoo}}} +test oo-12.8 {OO: filters and destructors} -setup { + oo::class create Aclass + Aclass create Aobject + set ::log {} +} -body { + oo::define Aclass { + constructor {} { + lappend ::log "in constructor" + } + destructor { + lappend ::log "in destructor" + } + method bar {} { + lappend ::log "in method" + } + method Boo args { + lappend ::log [self target] + next {*}$args + } + filter Boo + } + set obj [Aclass new] + $obj bar + $obj destroy + return $::log +} -cleanup { + Aclass destroy +} -result {{in constructor} {::Aclass bar} {in method} {::oo::object destroy} {in destructor}} test oo-13.1 {OO: changing an object's class} { oo::class create Aclass @@ -1461,13 +1939,13 @@ test oo-13.2 {OO: changing an object's class} -body { oo::objdefine foo class oo::class } -cleanup { foo destroy -} -returnCodes 1 -result {may not change a non-class object into a class object} +} -result {} test oo-13.3 {OO: changing an object's class} -body { oo::class create foo oo::objdefine foo class oo::object } -cleanup { foo destroy -} -returnCodes 1 -result {may not change a class object into a non-class object} +} -result {} test oo-13.4 {OO: changing an object's class} -body { oo::class create foo { method m {} { @@ -1482,6 +1960,106 @@ test oo-13.4 {OO: changing an object's class} -body { foo destroy bar destroy } -result {::foo ::foo ::foo ::bar} +test oo-13.5 {OO: changing an object's class: non-class to class} -setup { + oo::object create fooObj +} -body { + oo::objdefine fooObj { + class oo::class + } + oo::define fooObj { + method x {} {expr {1+2+3}} + } + [fooObj new] x +} -cleanup { + fooObj destroy +} -result 6 +test oo-13.6 {OO: changing an object's class: class to non-class} -setup { + oo::class create foo + unset -nocomplain ::result +} -body { + set result dangling + oo::define foo { + method x {} {expr {1+2+3}} + } + oo::class create boo { + superclass foo + destructor {set ::result "ok"} + } + boo new + foo create bar + oo::objdefine foo { + class oo::object + } + list $result [catch {bar x} msg] $msg +} -cleanup { + catch {bar destroy} + foo destroy +} -result {ok 1 {invalid command name "bar"}} +test oo-13.7 {OO: changing an object's class} -setup { + oo::class create foo + oo::class create bar + unset -nocomplain result +} -body { + oo::define bar method x {} {return ok} + oo::define foo { + method x {} {expr {1+2+3}} + self mixin foo + } + lappend result [foo x] + oo::objdefine foo class bar + lappend result [foo x] +} -cleanup { + foo destroy + bar destroy +} -result {6 ok} +test oo-13.8 {OO: changing an object's class to itself} -setup { + oo::class create foo +} -body { + oo::define foo { + method x {} {expr {1+2+3}} + } + oo::objdefine foo class foo +} -cleanup { + foo destroy +} -returnCodes error -result {may not change classes into an instance of themselves} +test oo-13.9 {OO: changing an object's class: roots are special} -setup { + set i [interp create] +} -body { + $i eval { + oo::objdefine oo::object { + class oo::class + } + } +} -cleanup { + interp delete $i +} -returnCodes error -result {may not modify the class of the root object class} +test oo-13.10 {OO: changing an object's class: roots are special} -setup { + set i [interp create] +} -body { + $i eval { + oo::objdefine oo::class { + class oo::object + } + } +} -cleanup { + interp delete $i +} -returnCodes error -result {may not modify the class of the class of classes} +test oo-13.11 {OO: changing an object's class in a tricky place} -setup { + oo::class create cls + unset -nocomplain result +} -body { + set result gorp + list [catch { + oo::define cls { + method x {} {return} + self class oo::object + ::set ::result ok + method y {} {return}; # I'm sorry, Dave. I'm afraid I can't do that. + } + } msg] $msg $result +} -cleanup { + cls destroy +} -result {1 {attempt to misuse API} ok} # todo: changing a class subtype (metaclass) to another class subtype test oo-14.1 {OO: mixins} { @@ -1557,18 +2135,18 @@ test oo-14.5 {OO and mixins and filters - advanced case} -setup { mix destroy } -result >>foobar<< test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create A { - superclass master + superclass parent method egg {} { return chicken } } oo::class create B { - superclass master + superclass parent mixin A method bar {} { # mixin from A @@ -1576,7 +2154,7 @@ test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { } } oo::class create C { - superclass master + superclass parent mixin B method foo {} { # mixin from B @@ -1586,12 +2164,12 @@ test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { [C new] foo } -result chicken test oo-14.7 {OO and filters from mixins of mixins} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create A { - superclass master + superclass parent method egg {} { return chicken } @@ -1602,7 +2180,7 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup { } } oo::class create B { - superclass master + superclass parent mixin A filter f method bar {} { @@ -1611,7 +2189,7 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup { } } oo::class create C { - superclass master + superclass parent mixin B filter f method foo {} { @@ -1623,18 +2201,18 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup { } -result {(foo) (bar) (egg) chicken (egg) (bar) (foo)} test oo-14.8 {OO: class mixin order - Bug 1998221} -setup { set ::result {} - oo::class create master { + oo::class create parent { method test {} {} } } -cleanup { - master destroy + parent destroy } -body { oo::class create mix { - superclass master + superclass parent method test {} {lappend ::result mix; next; return $::result} } oo::class create cls { - superclass master + superclass parent mixin mix method test {} {lappend ::result cls; next; return $::result} } @@ -1776,16 +2354,111 @@ test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup { } -returnCodes error -cleanup { Foo destroy } -result {wrong # args: should be "::bar <cloned> a b"} +test oo-15.10 {variable binding must not bleed through oo::copy} -setup { + oo::class create FooClass + set result {} +} -body { + set obj1 [FooClass new] + oo::objdefine $obj1 { + variable var + method m {} { + set var foo + } + method get {} { + return $var + } + export eval + } + + $obj1 m + lappend result [$obj1 get] + set obj2 [oo::copy $obj1] + $obj2 eval { + set var bar + } + lappend result [$obj2 get] + $obj1 eval { + set var grill + } + lappend result [$obj1 get] [$obj2 get] +} -cleanup { + FooClass destroy +} -result {foo bar grill bar} +test oo-15.11 {OO: object cloning} -returnCodes error -body { + oo::copy +} -result {wrong # args: should be "oo::copy sourceName ?targetName? ?targetNamespace?"} +test oo-15.12 {OO: object cloning with target NS} -setup { + oo::class create Super + oo::class create Cls {superclass Super} +} -body { + namespace eval ::existing {} + oo::copy Cls {} ::existing +} -returnCodes error -cleanup { + Super destroy + catch {namespace delete ::existing} +} -result {::existing refers to an existing namespace} +test oo-15.13.1 { + OO: object cloning with target NS + Valgrind will report a leak if the reference count of the namespace isn't + properly incremented. +} -setup { + oo::class create Cls {} +} -body { + oo::copy Cls Cls2 ::dupens + return done +} -cleanup { + Cls destroy + Cls2 destroy +} -result done +test oo-15.13.2 {OO: object cloning with target NS} -setup { + oo::class create Super + oo::class create Cls {superclass Super} +} -body { + list [namespace exist ::dupens] [oo::copy Cls Cls2 ::dupens] [namespace exist ::dupens] +} -cleanup { + Super destroy +} -result {0 ::Cls2 1} +test oo-15.14 {OO: object cloning with target NS} -setup { + oo::class create Cls {export eval} + set result {} +} -body { + Cls create obj + obj eval { + proc test-15.14 {} {} + } + lappend result [info commands ::dupens::t*] + oo::copy obj obj2 ::dupens + lappend result [info commands ::dupens::t*] +} -cleanup { + Cls destroy +} -result {{} ::dupens::test-15.14} +test oo-15.15 {method cloning must ensure that there is a string representation of bodies} -setup { + oo::class create cls +} -body { + cls create foo + oo::objdefine foo { + method m1 {} [string map {a b} {return hello}] + } + [oo::copy foo] m1 +} -cleanup { + cls destroy +} -result hello test oo-16.1 {OO: object introspection} -body { info object } -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\"" +test oo-16.1.1 {OO: object introspection} -body { + catch {info object} m o + dict get $o -errorinfo +} -result "wrong \# args: should be \"info object subcommand ?arg ...?\" + while executing +\"info object\"" test oo-16.2 {OO: object introspection} -body { info object class NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } [meta create instance1] create instance2 @@ -1891,10 +2564,107 @@ test oo-16.13 {OO: object introspection} -setup { oo::objdefine foo method Bar {} {return "ok in foo"} [info object namespace foo]::my Bar } -result "ok in foo" +test oo-16.14 {OO: object introspection: TIP #436} -setup { + oo::class create meta { superclass oo::class } + [meta create instance1] create instance2 +} -body { + list class [list [info object isa class NOTANOBJECT] \ + [info object isa class list]] \ + meta [list [info object isa metaclass NOTANOBJECT] \ + [info object isa metaclass list] \ + [info object isa metaclass oo::object]] \ + type [list [info object isa typeof oo::object NOTANOBJECT] \ + [info object isa typeof NOTANOBJECT oo::object] \ + [info object isa typeof list NOTANOBJECT] \ + [info object isa typeof NOTANOBJECT list] \ + [info object isa typeof oo::object list] \ + [info object isa typeof list oo::object]] \ + mix [list [info object isa mixin oo::object NOTANOBJECT] \ + [info object isa mixin NOTANOBJECT oo::object] \ + [info object isa mixin list NOTANOBJECT] \ + [info object isa mixin NOTANOBJECT list] \ + [info object isa mixin oo::object list] \ + [info object isa mixin list oo::object]] +} -cleanup { + meta destroy +} -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}} +test oo-16.15 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + info object creationid [cls new] +} -cleanup { + cls destroy +} -result {^\d+$} -match regexp +test oo-16.16 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set obj [cls new] + set id [info object creationid $obj] + rename $obj gorp + set id2 [info object creationid gorp] + list $id $id2 +} -cleanup { + cls destroy +} -result {^(\d+) \1$} -match regexp +test oo-16.17 {OO: object introspection: creationid #500} -body { + info object creationid nosuchobject +} -returnCodes error -result {nosuchobject does not refer to an object} +test oo-16.18 {OO: object introspection: creationid #500} -body { + info object creationid +} -returnCodes error -result {wrong # args: should be "info object creationid objName"} +test oo-16.18.1 {OO: object introspection: creationid #500} -body { + info object creationid oo::object gorp +} -returnCodes error -result {wrong # args: should be "info object creationid objName"} +test oo-16.19 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set id1 [info object creationid [set o1 [cls new]]] + set id2 [info object creationid [set o2 [cls new]]] + if {$id1 == $id2} { + format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 + } else { + string cat not-equal + } +} -cleanup { + cls destroy +} -result not-equal +test oo-16.20 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set id1 [info object creationid [set o1 [cls new]]] + $o1 destroy + set id2 [info object creationid [set o2 [cls new]]] + if {$id1 == $id2} { + format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 + } else { + string cat not-equal + } +} -cleanup { + cls destroy +} -result not-equal +test oo-16.21 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set id1 [info object creationid [set o1 [cls new]]] + set id2 [info object creationid [set o2 [oo::copy $o1]]] + if {$id1 == $id2} { + format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 + } else { + string cat not-equal + } +} -cleanup { + cls destroy +} -result not-equal test oo-17.1 {OO: class introspection} -body { info class } -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\"" +test oo-17.1.1 {OO: class introspection} -body { + catch {info class} m o + dict get $o -errorinfo +} -result "wrong \# args: should be \"info class subcommand ?arg ...?\" + while executing +\"info class\"" test oo-17.2 {OO: class introspection} -body { info class superclass NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} @@ -1907,7 +2677,7 @@ test oo-17.3 {OO: class introspection} -setup { } -result {"foo" is not a class} test oo-17.4 {OO: class introspection} -body { info class gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { @@ -1968,6 +2738,44 @@ test oo-17.10 {OO: class introspection} -setup { oo::define foo unexport {*}[info class methods foo -all] info class methods foo -all } -result {} +set stdmethods {<cloned> destroy eval unknown variable varname} +test oo-17.11 {OO: object method unexport (bug 900cb0284bc)} -setup { + oo::object create o + oo::objdefine o unexport m +} -body { + lsort [info object methods o -all -private] +} -cleanup { + o destroy +} -result $stdmethods +test oo-17.12 {OO: instance method unexport (bug 900cb0284bc)} -setup { + oo::class create c + c create o + oo::objdefine o unexport m +} -body { + lsort [info object methods o -all -private] +} -cleanup { + o destroy + c destroy +} -result $stdmethods +test oo-17.13 {OO: class method unexport (bug 900cb0284bc)} -setup { + oo::class create c + oo::define c unexport m +} -body { + lsort [info class methods c -all -private] +} -cleanup { + c destroy +} -result $stdmethods +test oo-17.14 {OO: instance method unexport (bug 900cb0284bc)} -setup { + oo::class create c + oo::define c unexport m + c create o +} -body { + lsort [info object methods o -all -private] +} -cleanup { + o destroy + c destroy +} -result $stdmethods + test oo-18.1 {OO: define command support} { list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo @@ -2107,13 +2915,13 @@ test oo-18.7 {OO: objdefine command support} -setup { invoked from within "oo::objdefine inst {rename ::inst ::INST;error foo}"}} test oo-18.8 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {foobar while executing "error foobar" @@ -2124,15 +2932,15 @@ test oo-18.8 {OO: define/self command support} -setup { invoked from within "oo::define foo {rename ::foo ::bar; self {error foobar}}"} test oo-18.9 {OO: define/self command support} -setup { - oo::class create master + oo::class create parent set c [oo::class create now_this_is_a_very_very_long_class_name_indeed { - superclass master + superclass parent }] } -body { catch {oo::define $c {error err}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {err while executing "error err" @@ -2140,13 +2948,13 @@ test oo-18.9 {OO: define/self command support} -setup { invoked from within "oo::define $c {error err}"} test oo-18.10 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {foobar while executing "error foobar" @@ -2157,13 +2965,13 @@ test oo-18.10 {OO: define/self command support} -setup { invoked from within "oo::define foo {self {rename ::foo {}; error foobar}}"} test oo-18.11 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {this command cannot be called when the object has been deleted while executing "self {error foobar}" @@ -2204,6 +3012,25 @@ test oo-19.2 {OO: varname method: Bug 2883857} -setup { } -cleanup { SpecialClass destroy } -result ::oo_test::x(y) +test oo-19.3 {OO: varname method and variable decl: Bug 3603695} -setup { + oo::class create testClass { + variable foo + export varname + constructor {} { + variable foo x + } + method bar {obj} { + my varname foo + $obj varname foo + } + } +} -body { + testClass create A + testClass create B + lsearch [list [A varname foo] [B varname foo]] [B bar A] +} -cleanup { + testClass destroy +} -result 0 test oo-20.1 {OO: variable method} -body { oo::class create testClass { @@ -2339,7 +3166,7 @@ test oo-20.10 {OO: variable and varname methods refer to same things} -setup { test oo-20.11 {OO: variable mustn't crash when recursing} -body { oo::class create A { constructor {name} { - my variable np_name + my variable np_name set np_name $name } method copy {nm} { @@ -2354,7 +3181,7 @@ test oo-20.11 {OO: variable mustn't crash when recursing} -body { lappend objs [$ref copy {}] } $cpy prop $var $objs - } else { + } else { $cpy prop $var $val } } @@ -2767,12 +3594,12 @@ test oo-27.2 {variables declaration - object introspection} -setup { info object variables foo } -result {a b c} test oo-27.3 {variables declaration - basic behaviour} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -2782,13 +3609,13 @@ test oo-27.3 {variables declaration - basic behaviour} -setup { bar y } -result 3 test oo-27.4 {variables declaration - destructors too} -setup { - oo::class create master + oo::class create parent set result bad! } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -2813,12 +3640,12 @@ test oo-27.5 {variables declaration - object-bound variables} -setup { foo y } -result 2 test oo-27.6 {variables declaration - non-interference of levels} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -2833,12 +3660,12 @@ test oo-27.6 {variables declaration - non-interference of levels} -setup { list [bar y] [lsort [info object vars bar]] [bar eval {info vars *!}] } -result {{3 2 y! {}} {x! y!} {x! y!}} test oo-27.7 {variables declaration - one underlying variable space} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -2865,12 +3692,12 @@ test oo-27.9 {variables declaration - error cases - arrays} -body { oo::define oo::object variable bad(var) } -returnCodes error -result {invalid declared variable name "bad(var)": must not refer to an array element} test oo-27.10 {variables declaration - no instance var leaks with class resolvers} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable clsvar constructor {} { set clsvar 0 @@ -2893,12 +3720,12 @@ test oo-27.10 {variables declaration - no instance var leaks with class resolver list [inst1 value] [inst2 value] } -result {3 2} test oo-27.11 {variables declaration - no instance var leaks with class resolvers} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable clsvar constructor {} { set clsvar 0 @@ -2966,12 +3793,12 @@ test oo-27.13 {variables declaration: Bug 3185009: require refcount management} foo destroy } -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}} test oo-27.14 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable y method boo {} { @@ -2982,12 +3809,12 @@ test oo-27.14 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 2,2} test oo-27.15 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable variable x y method boo {} { @@ -2998,12 +3825,12 @@ test oo-27.15 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 2,2} test oo-27.16 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -clear variable y @@ -3015,12 +3842,12 @@ test oo-27.16 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 1,2} test oo-27.17 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -set y method boo {} { @@ -3031,12 +3858,12 @@ test oo-27.17 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 1,2} test oo-27.18 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -? y method boo {} { @@ -3132,6 +3959,38 @@ test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup { } -cleanup { foo destroy } -result {v t} +test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { + oo::class create Super + oo::class create Parent { + superclass Super + variable member1 member2 + constructor {} { + set member1 parent1 + set member2 parent2 + } + method getChild {} { + Child new [self] + } + } + oo::class create Child { + superclass Super + variable member1 result + constructor {m} { + set [namespace current]::member1 child1 + set ns [info object namespace $m] + namespace upvar $ns member1 l1 member2 l2 + upvar 1 member1 l3 member2 l4 + [format namespace] upvar $ns member1 l5 member2 l6 + [format upvar] 1 member1 l7 member2 l8 + set result [list $l1 $l2 $l3 $l4 $l5 $l6 $l7 $l8] + } + method result {} {return $result} + } +} -body { + [[Parent new] getChild] result +} -cleanup { + Super destroy +} -result {parent1 parent2 parent1 parent2 parent1 parent2 parent1 parent2} # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... @@ -3214,99 +4073,131 @@ test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup { cls destroy } -result {0 {}} -oo::class create SampleSlot { - superclass oo::Slot - constructor {} { - variable contents {a b c} ops {} - } - method contents {} {variable contents; return $contents} - method ops {} {variable ops; return $ops} - method Get {} { - variable contents - variable ops - lappend ops [info level] Get - return $contents - } - method Set {lst} { - variable contents $lst - variable ops - lappend ops [info level] Set $lst - return +proc SampleSlotSetup script { + set script0 { + oo::class create SampleSlot { + superclass oo::Slot + constructor {} { + variable contents {a b c} ops {} + } + method contents {} {variable contents; return $contents} + method ops {} {variable ops; return $ops} + method Get {} { + variable contents + variable ops + lappend ops [info level] Get + return $contents + } + method Set {lst} { + variable contents $lst + variable ops + lappend ops [info level] Set $lst + return + } + method Resolve {lst} { + variable ops + lappend ops [info level] Resolve $lst + return $lst + } + } } + append script0 \n$script } -test oo-32.1 {TIP 380: slots - class test} -setup { +proc SampleSlotCleanup script { + set script0 { + SampleSlot destroy + } + append script \n$script0 +} + +test oo-32.1 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {a b c} {}} -test oo-32.2 {TIP 380: slots - class test} -setup { +}] -result {0 {a b c} {}} +test oo-32.2 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot -clear] \ [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {} {} {1 Set {}}} -test oo-32.3 {TIP 380: slots - class test} -setup { +}] -result {0 {} {} {1 Set {}}} +test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}} -test oo-32.4 {TIP 380: slots - class test} -setup { +}] -result {0 {} {a b c g h i} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {a b c g h i}}} +test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot -set d e f] \ [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {} {d e f} {1 Set {d e f}}} -test oo-32.5 {TIP 380: slots - class test} -setup { +}] -result {0 {} {d e f} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f}}} +test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { + rename sampleSlot {} +}] -result {0 {} {} {d e f g h i} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f} 1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {d e f g h i}}} +test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { + SampleSlot create sampleSlot +}] -body { + list [info level] [sampleSlot -prepend g h i] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}} +}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}} +test oo-32.7 {TIP 516: slots - class test} -setup [SampleSlotSetup { + SampleSlot create sampleSlot +}] -body { + list [info level] [sampleSlot -remove c a] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup [SampleSlotCleanup { + rename sampleSlot {} +}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}} -test oo-33.1 {TIP 380: slots - defaulting} -setup { +test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] -} -body { +}] -body { list [$s x y] [$s contents] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename $s {} -} -result {{} {a b c x y}} -test oo-33.2 {TIP 380: slots - defaulting} -setup { +}] -result {{} {a b c x y}} +test oo-33.2 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] -} -body { +}] -body { list [$s destroy; $s unknown] [$s contents] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename $s {} -} -result {{} {a b c destroy unknown}} -test oo-33.3 {TIP 380: slots - defaulting} -setup { +}] -result {{} {a b c destroy unknown}} +test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] -} -body { +}] -body { oo::objdefine $s forward --default-operation my -set list [$s destroy; $s unknown] [$s contents] [$s ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename $s {} -} -result {{} unknown {1 Set destroy 1 Set unknown}} -test oo-33.4 {TIP 380: slots - errors} -setup { +}] -result {{} unknown {1 Resolve destroy 1 Set destroy 1 Resolve unknown 1 Set unknown}} +test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { set s [SampleSlot new] -} -body { +}] -body { # Method names beginning with "-" are special to slots $s -grill q -} -returnCodes error -cleanup { +} -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} -} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops} - -SampleSlot destroy +}] -result \ + {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops} test oo-34.1 {TIP 380: slots - presence} -setup { set obj [oo::object new] @@ -3336,25 +4227,1261 @@ proc getMethods obj { } test oo-34.3 {TIP 380: slots - presence} { getMethods oo::define::filter -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.4 {TIP 380: slots - presence} { getMethods oo::define::mixin -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.5 {TIP 380: slots - presence} { getMethods oo::define::superclass -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.6 {TIP 380: slots - presence} { getMethods oo::define::variable -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.7 {TIP 380: slots - presence} { getMethods oo::objdefine::filter -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.8 {TIP 380: slots - presence} { getMethods oo::objdefine::mixin -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} +test oo-34.10 {TIP 516: slots - resolution} -setup { + oo::class create parent + set result {} + oo::class create 516a { superclass parent } + oo::class create 516b { superclass parent } + oo::class create 516c { superclass parent } + namespace eval 516test { + oo::class create 516a { superclass parent } + oo::class create 516b { superclass parent } + oo::class create 516c { superclass parent } + } +} -body { + # Must find the right classes when making the mixin + namespace eval 516test { + oo::define 516a { + mixin 516b 516c + } + } + lappend result [info class mixin 516test::516a] + # Must not remove class with just simple name match + oo::define 516test::516a { + mixin -remove 516b + } + lappend result [info class mixin 516test::516a] + # Must remove class with resolved name match + oo::define 516test::516a { + mixin -remove 516test::516c + } + lappend result [info class mixin 516test::516a] + # Must remove class with resolved name match even after renaming, but only + # with the renamed name; it is a slot of classes, not strings! + rename 516test::516b 516test::516d + oo::define 516test::516a { + mixin -remove 516test::516b + } + lappend result [info class mixin 516test::516a] + oo::define 516test::516a { + mixin -remove 516test::516d + } + lappend result [info class mixin 516test::516a] +} -cleanup { + parent destroy +} -result {{::516test::516b ::516test::516c} {::516test::516b ::516test::516c} ::516test::516b ::516test::516d {}} + +test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { + oo::class create fruit { + method eat {} {} + } + set result {} +} -body { + lappend result [fruit create ::apple] [info class superclasses fruit] + oo::define fruit superclass + lappend result [info class superclasses fruit] \ + [info object class apple oo::object] \ + [info class call fruit destroy] \ + [catch { apple }] +} -cleanup { + unset -nocomplain result + fruit destroy +} -result {::apple ::oo::object ::oo::object 1 {{method destroy ::oo::object {core method: "destroy"}}} 1} +test oo-35.2 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { + oo::class create fruitMetaclass { + superclass oo::class + method eat {} {} + } + set result {} +} -body { + lappend result [fruitMetaclass create ::appleClass] \ + [appleClass create orange] \ + [info class superclasses fruitMetaclass] + oo::define fruitMetaclass superclass + lappend result [info class superclasses fruitMetaclass] \ + [info object class appleClass oo::class] \ + [catch { orange }] [info object class orange] \ + [appleClass create pear] +} -cleanup { + unset -nocomplain result + fruitMetaclass destroy +} -result {::appleClass ::orange ::oo::class ::oo::class 1 1 ::appleClass ::pear} +test oo-35.3 {Bug 593baa032c: superclass list teardown} { + # Bug makes this crash, especially with mem-debugging on + oo::class create B {} + oo::class create D {superclass B} + namespace eval [info object namespace D] [list [namespace which B] destroy] +} {} +test oo-35.4 {Bug 593baa032c: mixins list teardown} { + # Bug makes this crash, especially with mem-debugging on + oo::class create B {} + oo::class create D {mixin B} + namespace eval [info object namespace D] [list [namespace which B] destroy] +} {} +test oo-35.5 {Bug 1a56550e96: introspectors must traverse mixin links correctly} -setup { + oo::class create base { + unexport destroy + } +} -body { + oo::class create C { + superclass base + method c {} {} + } + oo::class create D { + superclass base + mixin C + method d {} {} + } + oo::class create E { + superclass D + method e {} {} + } + E create e1 + list [lsort [info class methods E -all]] [lsort [info object methods e1 -all]] +} -cleanup { + base destroy +} -result {{c d e} {c d e}} +test oo-35.6 { + Bug : teardown of an object that is a class that is an instance of itself +} -setup { + oo::class create obj + + oo::copy obj obj1 obj1 + oo::objdefine obj1 { + mixin obj1 obj + } + oo::copy obj1 obj2 + oo::objdefine obj2 { + mixin obj2 obj1 + } +} -body { + rename obj2 {} + rename obj1 {} + # doesn't crash + return done +} -cleanup { + rename obj {} +} -result done + +test oo-36.1 {TIP #470: introspection within oo::define} { + oo::define oo::object self +} ::oo::object +test oo-36.2 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls +} -body { + oo::define Cls self +} -cleanup { + Cls destroy +} -result ::Cls +test oo-36.3 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self] + } + return $result +} -cleanup { + Super destroy +} -result ::Sub +test oo-36.4 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self {}] + } + return $result +} -cleanup { + Super destroy +} -result {} +test oo-36.5 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self self] + } +} -cleanup { + Super destroy +} -result ::Sub +test oo-36.6 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls + set result uncalled +} -body { + Cls create obj + oo::objdefine obj { + ::set ::result [self] + } +} -cleanup { + Cls destroy +} -result ::obj +test oo-36.7 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls +} -body { + Cls create obj + oo::objdefine obj { + self + } +} -cleanup { + Cls destroy +} -result ::obj +test oo-36.8 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls +} -body { + Cls create obj + oo::objdefine obj { + self anything + } +} -returnCodes error -cleanup { + Cls destroy +} -result {wrong # args: should be "self"} +test oo-36.9 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls + set result uncalled +} -body { + proc oo::define::testself {} { + global result + set result [list [catch {self} msg] $msg \ + [catch {uplevel 1 self} msg] $msg] + return + } + list [oo::define Cls testself] $result +} -cleanup { + Cls destroy + catch {rename oo::define::testself {}} +} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::Cls}} +test oo-36.10 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls + set result uncalled +} -body { + proc oo::objdefine::testself {} { + global result + set result [list [catch {self} msg] $msg \ + [catch {uplevel 1 self} msg] $msg] + return + } + Cls create obj + list [oo::objdefine obj testself] $result +} -cleanup { + Cls destroy + catch {rename oo::objdefine::testself {}} +} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}} + +test oo-37.1 {TIP 500: private command propagates errors} -setup { + oo::class create cls +} -body { + oo::define cls { + private ::error "this is an error" + } +} -cleanup { + cls destroy +} -returnCodes error -result {this is an error} +test oo-37.2 {TIP 500: private command propagates errors} -setup { + oo::class create cls +} -body { + oo::define cls { + private { + ::error "this is an error" + } + } +} -cleanup { + cls destroy +} -returnCodes error -result {this is an error} +test oo-37.3 {TIP 500: private command propagates errors} -setup { + oo::object create obj +} -body { + oo::objdefine obj { + private ::error "this is an error" + } +} -cleanup { + obj destroy +} -returnCodes error -result {this is an error} +test oo-37.4 {TIP 500: private command propagates errors} -setup { + oo::object create obj +} -body { + oo::objdefine obj { + private { + ::error "this is an error" + } + } +} -cleanup { + obj destroy +} -returnCodes error -result {this is an error} +test oo-37.5 {TIP 500: private command can't be used outside definitions} -body { + oo::define::private error "xyz" +} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} +test oo-37.6 {TIP 500: private command can't be used outside definitions} -body { + oo::objdefine::private error "xyz" +} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} + +test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + private variable x + constructor {} { + set x 1 + } + method getA {} { + return $x + } + } + oo::class create clsB { + superclass clsA + private { + variable x + } + constructor {} { + set x 2 + next + } + method getB {} { + return $x + } + } + oo::class create clsC { + superclass clsB + variable x + constructor {} { + set x 3 + next + } + method getC {} { + return $x + } + } + clsC create obj + oo::objdefine obj { + private { + variable x + } + method setup {} { + set x 4 + } + method getO {} { + return $x + } + } + obj setup + list [obj getA] [obj getB] [obj getC] [obj getO] \ + [lsort [string map [list [info object creationid clsA] CLASS-A \ + [info object creationid clsB] CLASS-B \ + [info object creationid obj] OBJ] \ + [info object vars obj]]] +} -cleanup { + parent destroy +} -result {1 2 3 4 {{CLASS-A : x} {CLASS-B : x} {OBJ : x} x}} +test oo-38.2 {TIP 500: private variables introspection} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + private { + variable x1 + variable x2 + } + variable y1 y2 + } + cls create obj + oo::objdefine obj { + private variable a1 a2 + variable b1 b2 + } + list [lsort [info class variables cls]] \ + [lsort [info class variables cls -private]] \ + [lsort [info object variables obj]] \ + [lsort [info object variables obj -private]] +} -cleanup { + parent destroy +} -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}} +test oo-38.3 {TIP 500: private variables and oo::object·varname} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + private { + variable x + } + method getx {} { + set x 1 + my varname x + } + method readx {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method gety {} { + set x 1 + my varname x + } + method ready {} { + return $x + } + } + clsB create obj + set [obj getx] 2 + set [obj gety] 3 + list [obj readx] [obj ready] +} -cleanup { + parent destroy +} -result {2 3} +test oo-38.4 {TIP 500: private variables introspection} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + private { + variable x1 x2 + } + variable y1 y2 + constructor {} { + variable z boo + set x1 a + set y1 c + } + method list {} { + variable z + set ok 1 + list [info locals] [lsort [info vars]] [info exist x2] + } + } + cls create obj + oo::objdefine obj { + private variable a1 a2 + variable b1 b2 + method init {} { + # Because we don't have a constructor to do this setup for us + set a1 p + set b1 r + } + method list {} { + variable z + set yes 1 + list {*}[next] [info locals] [lsort [info vars]] [info exist a2] + } + } + obj init + obj list +} -cleanup { + parent destroy +} -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0} +test oo-38.5 {TIP 500: private variables and oo::object·variable} -setup { + oo::class create parent +} -body { + oo::class create cls1 { + superclass parent + private variable x + method abc val { + my variable x + set x $val + } + method def val { + my variable y + set y $val + } + method get1 {} { + my variable x y + return [list $x $y] + } + } + oo::class create cls2 { + superclass cls1 + private variable x + method x-exists {} { + return [info exists x],[uplevel 1 {info exists x}] + } + method ghi x { + # Additional instrumentation to show that we're not using the + # resolved variable until we ask for it; the argument nixed that + # happening by default. + set val $x + set before [my x-exists] + unset x + set x $val + set mid [my x-exists] + unset x + set mid2 [my x-exists] + my variable x + set x $val + set after [my x-exists] + return "$before;$mid;$mid2;$after" + } + method jkl val { + my variable y + set y $val + } + method get2 {} { + my variable x y + return [list $x $y] + } + } + cls2 create a + a abc 123 + a def 234 + set tmp [a ghi 345] + a jkl 456 + list $tmp [a get1] [a get2] +} -cleanup { + parent destroy +} -result {{0,1;0,1;0,0;1,1} {123 456} {345 456}} + +test oo-39.1 {TIP 500: private methods internal call; class private} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + my step + my step + return + } + private { + method step {} { + incr x 2 + } + } + method x {} { + return $x + } + } + clsA create obj + obj act + list [obj x] [catch {obj step} msg] $msg +} -cleanup { + parent destroy +} -result {7 1 {unknown method "step": must be act, destroy or x}} +test oo-39.2 {TIP 500: private methods internal call; class private} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + my step + my step + return + } + private { + method step {} { + incr x 2 + } + } + method x {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method step {} { + incr x 5 + } + } + clsB create obj + obj act + list [obj x] [obj step] +} -cleanup { + parent destroy +} -result {7 12} +test oo-39.3 {TIP 500: private methods internal call; class private} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my Step + my Step + my Step + return + } + method x {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method Step {} { + incr x 5 + } + } + clsB create obj + obj act + set result [obj x] + oo::define clsA { + private { + method Step {} { + incr x 2 + } + } + } + obj act + lappend result [obj x] +} -cleanup { + parent destroy +} -result {16 22} +test oo-39.4 {TIP 500: private methods internal call; instance private} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + return + } + method step {} { + incr x + } + method x {} { + return $x + } + } + clsA create obj + obj act + set result [obj x] + oo::objdefine obj { + variable x + private { + method step {} { + incr x 2 + } + } + } + obj act + lappend result [obj x] + oo::objdefine obj { + method act {} { + my step + next + } + } + obj act + lappend result [obj x] +} -cleanup { + parent destroy +} -result {2 3 6} +test oo-39.5 {TIP 500: private methods internal call; cross object} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + method equal {other} { + expr {$x == [$other x]} + } + } + cls create a 1 + cls create b 2 + cls create c 1 + list [a equal b] [b equal c] [c equal a] [catch {a x} msg] $msg +} -cleanup { + parent destroy +} -result {0 0 1 1 {unknown method "x": must be destroy or equal}} +test oo-39.6 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + method equal {other} { + expr {$x == [$other y]} + } + } + cls create a 1 + cls create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be destroy, equal or x} +test oo-39.7 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + method equal {other} { + expr {[[self] y] == [$other x]} + } + } + cls create a 1 + cls create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be destroy, equal or x} +test oo-39.8 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + method equal {other} { + expr {[my y] == [$other x]} + } + } + cls create a 1 + cls create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable, varname or x} +test oo-39.9 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + } + oo::class create cls2 { + superclass cls + method equal {other} { + expr {[my y] == [$other x]} + } + } + cls2 create a 1 + cls2 create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable or varname} +test oo-39.10 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + } + oo::class create cls2 { + superclass cls + method equal {other} { + expr {[my x] == [$other x]} + } + } + cls2 create a 1 + cls2 create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "x": must be <cloned>, destroy, equal, eval, unknown, variable or varname} +test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method chain {} { + return [self call] + } + } + oo::class create cls2 { + superclass cls + private method chain {} { + next + } + method chain2 {} { + my chain + } + method chain3 {} { + [self] chain + } + } + cls create a + cls2 create b + list [a chain] [b chain] [b chain2] [b chain3] +} -cleanup { + parent destroy +} -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}} +test oo-39.12 {TIP 500: private methods; introspection} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method chain {} { + return [self call] + } + private method abc {} {} + } + oo::class create cls2 { + superclass cls + method chain2 {} { + my chain + } + method chain3 {} { + [self] chain + } + private method def {} {} + unexport chain3 + } + cls create a + cls2 create b + oo::objdefine b { + private method ghi {} {} + method ABC {} {} + method foo {} {} + } + set scopes {public unexported private} + list a: [lmap s $scopes {info object methods a -scope $s}] \ + b: [lmap s $scopes {info object methods b -scope $s}] \ + cls: [lmap s $scopes {info class methods cls -scope $s}] \ + cls2: [lmap s $scopes {info class methods cls2 -scope $s}] \ +} -cleanup { + parent destroy +} -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}} + +test oo-40.1 {TIP 500: private and self} -setup { + oo::class create cls +} -body { + oo::define cls { + self { + private { + variable a + } + variable b + } + private { + self { + variable c + } + variable d + } + variable e + } + list \ + [lsort [info class variables cls]] \ + [lsort [info class variables cls -private]] \ + [lsort [info object variables cls]] \ + [lsort [info object variables cls -private]] +} -cleanup { + cls destroy +} -result {e d b {a c}} +test oo-40.2 {TIP 500: private and export} -setup { + oo::class create cls +} -body { + oo::define cls { + private method foo {} {} + } + set result [lmap s {public unexported private} { + info class methods cls -scope $s}] + oo::define cls { + export foo + } + lappend result {*}[lmap s {public unexported private} { + info class methods cls -scope $s}] +} -cleanup { + cls destroy +} -result {{} {} foo foo {} {}} +test oo-40.3 {TIP 500: private and unexport} -setup { + oo::class create cls +} -body { + oo::define cls { + private method foo {} {} + } + set result [lmap s {public unexported private} { + info class methods cls -scope $s}] + oo::define cls { + unexport foo + } + lappend result {*}[lmap s {public unexported private} { + info class methods cls -scope $s}] +} -cleanup { + cls destroy +} -result {{} {} foo {} foo {}} + +test oo-41.1 {TIP 478: myclass command, including class morphing} -setup { + oo::class create parent + set result {} +} -body { + oo::class create cls1 { + superclass parent + self method count {} { + my variable c + incr c + } + method act {} { + myclass count + } + } + cls1 create x + lappend result [x act] [x act] + cls1 create y + lappend result [y act] [y act] [x act] + oo::class create cls2 { + superclass cls1 + self method count {} { + my variable d + expr {1.0 * [incr d]} + } + } + oo::objdefine x {class cls2} + lappend result [x act] [y act] [x act] [y act] +} -cleanup { + parent destroy +} -result {1 2 3 4 5 1.0 6 2.0 7} +test oo-41.2 {TIP 478: myclass command cleanup} -setup { + oo::class create parent + set result {} +} -body { + oo::class create cls1 { + superclass parent + self method hi {} { + return "this is [self]" + } + method hi {} { + return "this is [self]" + } + } + cls1 create x + rename [info object namespace x]::my foo + rename [info object namespace x]::myclass bar + lappend result [cls1 hi] [x hi] [foo hi] [bar hi] + x destroy + lappend result [catch {foo hi}] [catch {bar hi}] +} -cleanup { + parent destroy +} -result {{this is ::cls1} {this is ::x} {this is ::x} {this is ::cls1} 1 1} +test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -setup { + oo::class create parent + set result {} +} -body { + oo::class create cls1 { + superclass parent + self method Hi {} { + return "this is [self]" + } + forward poke myclass Hi + } + cls1 create x + lappend result [catch {cls1 Hi}] [x poke] +} -cleanup { + parent destroy +} -result {1 {this is ::cls1}} + +test oo-42.1 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::object +} {} +test oo-42.2 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::object -class +} {} +test oo-42.3 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::object -instance +} ::oo::objdefine +test oo-42.4 {TIP 524: definition namespace control: introspection} -body { + info class definitionnamespace oo::object -gorp +} -returnCodes error -result {bad kind "-gorp": must be -class or -instance} +test oo-42.5 {TIP 524: definition namespace control: introspection} -body { + info class definitionnamespace oo::object -class x +} -returnCodes error -result {wrong # args: should be "info class definitionnamespace className ?kind?"} +test oo-42.6 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::class +} ::oo::define +test oo-42.7 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::class -class +} ::oo::define +test oo-42.8 {TIP 524: definition namespace control: introspection} { + info class definitionnamespace oo::class -instance +} {} + +test oo-43.1 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + oo::class create foo { + superclass parent + self class foocls + } + oo::define foo { + sparkle + } +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.2 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} + unset -nocomplain ::result +} -body { + namespace eval foodef { + namespace path ::oo::define + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + foocls create foo { + superclass parent + lappend ::result [sparkle] + } + return $result +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.3 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} + unset -nocomplain ::result +} -body { + namespace eval foodef { + namespace path ::oo::define + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace -class foodef + } + foocls create foo { + superclass parent + lappend ::result [sparkle] + } + return $result +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.4 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace -instance foodef + } + foocls create foo { + sparkle + } +} -returnCodes error -cleanup { + parent destroy + namespace delete foodef +} -result {invalid command name "sparkle"} +test oo-43.5 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + namespace delete foodef + foocls create foo { + sparkle + } +} -returnCodes error -cleanup { + parent destroy + catch {namespace delete foodef} +} -result {invalid command name "sparkle"} +test oo-43.6 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} + unset -nocomplain result +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + foocls create foo + lappend result [catch {oo::define foo sparkle} msg] $msg + namespace delete foodef + lappend result [catch {oo::define foo sparkle} msg] $msg + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + lappend result [catch {oo::define foo sparkle} msg] $msg +} -cleanup { + parent destroy + catch {namespace delete foodef} +} -result {0 ok 1 {invalid command name "sparkle"} 0 ok} +test oo-43.7 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::define + proc sparkle {x} {return ok} + } + oo::class create foocls { + superclass oo::class parent + definitionnamespace foodef + } + foocls create foo { + superclass parent + } + oo::define foo spar gorp +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.8 {TIP 524: definition namespace control: semantics} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef { + namespace path ::oo::objdefine + proc sparkle {} {return ok} + } + oo::class create foo { + superclass parent + definitionnamespace -instance foodef + } + oo::objdefine [foo new] { + method x y z + sparkle + } +} -cleanup { + parent destroy + namespace delete foodef +} -result ok +test oo-43.9 {TIP 524: definition namespace control: syntax} -body { + oo::class create foo { + definitionnamespace -gorp foodef + } +} -returnCodes error -result {bad kind "-gorp": must be -class or -instance} +test oo-43.10 {TIP 524: definition namespace control: syntax} -body { + oo::class create foo { + definitionnamespace -class foodef x + } +} -returnCodes error -result {wrong # args: should be "definitionnamespace ?kind? namespace"} +test oo-43.11 {TIP 524: definition namespace control: syntax} -setup { + catch {namespace delete ::no_such_ns} +} -body { + oo::class create foo { + definitionnamespace -class ::no_such_ns + } +} -returnCodes error -result {namespace "::no_such_ns" not found} +test oo-43.12 {TIP 524: definition namespace control: user-level introspection} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef {} + oo::class create foo { + superclass oo::class parent + } + list [info class definitionnamespace foo] \ + [oo::define foo definitionnamespace foodef] \ + [info class definitionnamespace foo] \ + [oo::define foo definitionnamespace {}] \ + [info class definitionnamespace foo] +} -cleanup { + parent destroy + namespace delete foodef +} -result {{} {} ::foodef {} {}} +test oo-43.13 {TIP 524: definition namespace control: user-level introspection} -setup { + oo::class create parent + namespace eval foodef {} +} -body { + namespace eval foodef {} + oo::class create foo { + superclass parent + } + list [info class definitionnamespace foo -instance] \ + [oo::define foo definitionnamespace -instance foodef] \ + [info class definitionnamespace foo -instance] \ + [oo::define foo definitionnamespace -instance {}] \ + [info class definitionnamespace foo -instance] +} -cleanup { + parent destroy + namespace delete foodef +} -result {{} {} ::foodef {} {}} cleanupTests return diff --git a/tests/ooNext2.test b/tests/ooNext2.test index eeade11..3d28f3f 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -2,16 +2,14 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-2008 Donal K. Fellows +# Copyright © 2006-2011 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: oo.test,v 1.59 2011/01/18 16:10:48 dkf Exp $ -package require -exact TclOO 0.6.3 ;# Must match value in configure.in -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +package require tcl::oo 1.0.3 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -528,6 +526,93 @@ test oo-call-1.19 {object call introspection - memory leaks} -setup { } -cleanup { leaktester destroy } -constraints memory -result 0 +test oo-call-1.20 {object call introspection - complex case} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + oo::class create ::C { + superclass root + method x {} {} + mixin B + } + oo::class create ::D { + superclass C + method x {} {} + } + oo::class create ::E { + superclass root + method x {} {} + } + oo::class create ::F { + superclass E + method x {} {} + } + oo::class create ::G { + superclass root + method x {} {} + } + oo::class create ::H { + superclass G + method x {} {} + } + oo::define F mixin H + F create y + oo::objdefine y { + method x {} {} + mixin D + } + info object call y x +} -cleanup { + root destroy +} -result {{method x ::D method} {method x ::B method} {method x ::A method} {method x ::C method} {method x ::H method} {method x ::G method} {method x object method} {method x ::F method} {method x ::E method}} +test oo-call-1.21 {object call introspection - complex case} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method y {} {} + } + oo::class create ::C { + superclass root + method x {} {} + mixin B + } + oo::class create ::D { + superclass C + filter x + } + oo::class create ::E { + superclass root + method y {} {} + method x {} {} + } + oo::class create ::F { + superclass E + method z {} {} + method q {} {} + } + F create y + oo::objdefine y { + method unknown {} {} + mixin D + filter q + } + info object call y z +} -cleanup { + root destroy +} -result {{filter x ::C method} {filter x ::E method} {filter y ::B method} {filter y ::A method} {filter y ::E method} {filter q ::F method} {method z ::F method}} test oo-call-2.1 {class call introspection} -setup { oo::class create root @@ -781,6 +866,196 @@ test oo-call-3.4 {current call introspection: in destructors} -setup { } -cleanup { root destroy } -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}} + +# Contributed tests from aspect, related to [0f42ff7871] +# +# dkf's "Principles Leading to a Fix" +# +# A method ought to work "the same" whether or not it has been overridden by +# a subclass. A tailcalled command ought to have as parent stack the same +# thing you'd get with uplevel 1. A subclass will often expect the +# superclass's result to be the result that would be returned if the +# subclass was not there. + +# Common setup: +# any invocation of bar should emit "abc\nhi\n" then return to its +# caller +set testopts { + -setup { + oo::class create Parent + oo::class create Foo { + superclass Parent + method bar {} { + puts abc + tailcall puts hi + puts xyz + } + } + oo::class create Foo2 { + superclass Parent + } + } + -cleanup { + Parent destroy + } +} + +# these succeed, showing that without [next] the bug doesn't fire +test next-tailcall-simple-1 "trivial case with one method" {*}$testopts -body { + [Foo create foo] bar +} -output [join {abc hi} \n]\n +test next-tailcall-simple-2 "my bar" {*}$testopts -body { + oo::define Foo method baz {} { + puts a + my bar + puts b + } + [Foo create foo] baz +} -output [join {a abc hi b} \n]\n +test next-tailcall-simple-3 "\[self\] bar" {*}$testopts -body { + oo::define Foo method baz {} { + puts a + [self] bar + puts b + } + [Foo create foo] baz +} -output [join {a abc hi b} \n]\n +test next-tailcall-simple-4 "foo bar" {*}$testopts -body { + oo::define Foo method baz {} { + puts a + foo bar + puts b + } + [Foo create foo] baz +} -output [join {a abc hi b} \n]\n + +# everything from here on uses [next], and fails on 8.6.4 with compilation +test next-tailcall-superclass-1 "next superclass" {*}$testopts -body { + oo::define Foo2 { + superclass Foo + method bar {} { + puts a + next + puts b + } + } + [Foo2 create foo] bar +} -output [join {a abc hi b} \n]\n +test next-tailcall-superclass-2 "nextto superclass" {*}$testopts -body { + oo::define Foo2 { + superclass Foo + method bar {} { + puts a + nextto Foo + puts b + } + } + [Foo2 create foo] bar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-mixin-1 "class mixin" {*}$testopts -body { + oo::define Foo2 { + method Bar {} { + puts a + next + puts b + } + filter Bar + } + oo::define Foo mixin Foo2 + Foo create foo + foo bar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-objmixin-1 "object mixin" {*}$testopts -body { + oo::define Foo2 { + method Bar {} { + puts a + next + puts b + } + filter Bar + } + Foo create foo + oo::objdefine foo mixin Foo2 + foo bar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-filter-1 "filter method" {*}$testopts -body { + oo::define Foo method Filter {} { + puts a + next + puts b + } + oo::define Foo filter Filter + [Foo new] bar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-forward-1 "forward method" {*}$testopts -body { + proc foobar {} { + puts "abc" + tailcall puts "hi" + puts "xyz" + } + oo::define Foo forward foobar foobar + oo::define Foo2 { + superclass Foo + method foobar {} { + puts a + next + puts b + } + } + [Foo2 new] foobar +} -output [join {a abc hi b} \n]\n + +test next-tailcall-constructor-1 "next in constructor" -body { + oo::class create Foo { + constructor {} { + puts abc + tailcall puts hi + puts xyz + } + } + oo::class create Foo2 { + superclass Foo + constructor {} { + puts a + next + puts b + } + } + list [Foo new] [Foo2 new] + return "" +} -cleanup { + Foo destroy +} -output [join {abc hi a abc hi b} \n]\n + +test next-tailcall-destructor-1 "next in destructor" -body { + oo::class create Foo { + destructor { + puts abc + tailcall puts hi + puts xyz + } + } + oo::class create Foo2 { + superclass Foo + destructor { + puts a + next + puts b + } + } + Foo create foo + Foo2 create foo2 + foo destroy + foo2 destroy +} -output [join {abc hi a abc hi b} \n]\n -cleanup { + Foo destroy +} + +unset testopts cleanupTests return diff --git a/tests/ooUtil.test b/tests/ooUtil.test new file mode 100644 index 0000000..9a28c46 --- /dev/null +++ b/tests/ooUtil.test @@ -0,0 +1,563 @@ +# This file contains a collection of tests for functionality originally +# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs +# the tests and generates output for errors. No output means no errors were +# found. +# +# Copyright © 2014-2016 Andreas Kupries +# Copyright © 2018 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcl::oo 1.0.3 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +test ooUtil-1.1 {TIP 478: classmethod} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + Table find foo bar +} -cleanup { + parent destroy +} -result {::Table called with arguments: foo bar} +test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup { + namespace eval ::testns {} +} -body { + namespace eval ::testns { + oo::class create ActiveRecord { + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + } + testns::Table find foo bar +} -cleanup { + namespace delete ::testns +} -result {::testns::Table called with arguments: foo bar} +test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup { + oo::class create parent +} -body { + oo::class create TestClass { + superclass oo::class parent + self method create {name ignore body} { + next $name $body + } + } + TestClass create okay {} {} +} -cleanup { + parent destroy +} -result {::okay} +test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + oo::class create SubTable { + superclass Table + } + SubTable find foo bar +} -cleanup { + parent destroy +} -result {::SubTable called with arguments: foo bar} +test ooUtil-1.5 {TIP 478: classmethod and instances} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + set t [Table new] + $t find 1 2 3 +} -cleanup { + parent destroy +} -result {::Table called with arguments: 1 2 3} +test ooUtil-1.6 {TIP 478: classmethod and instances} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + unexport find + } + set t [Table new] + $t find 1 2 3 +} -returnCodes error -cleanup { + parent destroy +} -match glob -result {unknown method "find": must be *} +test ooUtil-1.7 {} -setup { + oo::class create parent +} -body { + oo::class create Foo { + superclass parent + classmethod bar {} { + puts "This is in the class; self is [self]" + my meee + } + classmethod meee {} { + puts "This is meee" + } + } + oo::class create Grill { + superclass Foo + classmethod meee {} { + puts "This is meee 2" + } + } + list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar] +} -cleanup { + parent destroy +} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n" +# Two tests to confirm that we correctly initialise the scripted part of TclOO +# in child interpreters. This is slightly tricky at the implementation level +# because we cannot count on either [source] or [open] being available. +test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup { + set childinterp [interp create] +} -body { + $childinterp eval { + oo::class create ActiveRecord { + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + # This is confirming that this is not the parent interpreter + list [Table find foo bar] [info globals childinterp] + } +} -cleanup { + interp delete $childinterp +} -result {{::Table called with arguments: foo bar} {}} +test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup { + set safeinterp [interp create -safe] +} -body { + $safeinterp eval { + oo::class create ActiveRecord { + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + # This is confirming that this is a (basic) safe interpreter + list [Table find foo bar] [info commands source] + } +} -cleanup { + interp delete $safeinterp +} -result {{::Table called with arguments: foo bar} {}} + +test ooUtil-2.1 {TIP 478: callback generation} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {} { return ok,[self] } + method makeCall {} { + return [callback CallMe] + } + } + c create ::context + set cb [context makeCall] + {*}$cb +} -cleanup { + parent destroy +} -result {ok,::context} +test ooUtil-2.2 {TIP 478: callback generation} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {a b c} { return ok,[self],$a,$b,$c } + method makeCall {b} { + return [callback CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + {*}$cb PQR +} -cleanup { + parent destroy +} -result {ok,::context,123,a b c,PQR} +test ooUtil-2.3 {TIP 478: callback generation, alternate name} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {} { return ok,[self] } + method makeCall {} { + return [mymethod CallMe] + } + } + c create ::context + set cb [context makeCall] + {*}$cb +} -cleanup { + parent destroy +} -result {ok,::context} +test ooUtil-2.4 {TIP 478: callback generation, alternate name} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {a b c} { return ok,[self],$a,$b,$c } + method makeCall {b} { + return [mymethod CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + {*}$cb PQR +} -cleanup { + parent destroy +} -result {ok,::context,123,a b c,PQR} +test ooUtil-2.5 {TIP 478: callbacks and method lifetime} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method makeCall {b} { + return [callback CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + set result [list [catch {{*}$cb PQR} msg] $msg] + oo::objdefine context { + method CallMe {a b c} { return ok,[self],$a,$b,$c } + } + lappend result [{*}$cb PQR] +} -cleanup { + parent destroy +} -result {1 {unknown method "CallMe": must be <cloned>, destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}} +test ooUtil-2.6 {TIP 478: callback use case} -setup { + oo::class create parent + unset -nocomplain x +} -body { + oo::class create c { + superclass parent + variable count + constructor {var} { + set count 0 + upvar 1 $var v + trace add variable v write [callback TraceCallback] + } + method count {} {return $count} + method TraceCallback {name1 name2 op} { + incr count + } + } + set o [c new x] + for {set x 0} {$x < 5} {incr x} {} + $o count +} -cleanup { + unset -nocomplain x + parent destroy +} -result 6 + +test ooUtil-3.1 {TIP 478: class initialisation} -setup { + oo::class create parent + catch {rename ::foobar-3.1 {}} +} -body { + oo::class create ::cls { + superclass parent + initialise { + proc foobar-3.1 {} {return ok} + } + method calls {} { + list [catch foobar-3.1 msg] $msg \ + [namespace eval [info object namespace [self class]] foobar-3.1] + } + } + [cls new] calls +} -cleanup { + parent destroy +} -result {1 {invalid command name "foobar-3.1"} ok} +test ooUtil-3.2 {TIP 478: class variables} -setup { + oo::class create parent + catch {rename ::foobar-3.1 {}} +} -body { + oo::class create ::cls { + superclass parent + initialise { + variable x 123 + } + method call {} { + classvariable x + incr x + } + } + cls create a + cls create b + cls create c + list [a call] [b call] [c call] [a call] [b call] [c call] +} -cleanup { + parent destroy +} -result {124 125 126 127 128 129} +test ooUtil-3.3 {TIP 478: class initialisation} -setup { + oo::class create parent + catch {rename ::foobar-3.3 {}} +} -body { + oo::class create ::cls { + superclass parent + initialize { + proc foobar-3.3 {} {return ok} + } + method calls {} { + list [catch foobar-3.3 msg] $msg \ + [namespace eval [info object namespace [self class]] foobar-3.3] + } + } + [cls new] calls +} -cleanup { + parent destroy +} -result {1 {invalid command name "foobar-3.3"} ok} +test ooUtil-3.4 {TIP 478: class initialisation} -setup { + oo::class create parent + catch {rename ::appendToResultVar {}} + proc ::appendToResultVar args { + lappend ::result {*}$args + } + set result {} +} -body { + trace add execution oo::define::initialise enter appendToResultVar + oo::class create ::cls { + superclass parent + initialize {proc xyzzy {} {}} + } + return $result +} -cleanup { + catch { + trace remove execution oo::define::initialise enter appendToResultVar + } + rename ::appendToResultVar {} + parent destroy +} -result {{initialize {proc xyzzy {} {}}} enter} +test ooUtil-3.5 {TIP 478: class initialisation} -body { + oo::define oo::object { + ::list [::namespace which initialise] [::namespace which initialize] \ + [::namespace origin initialise] [::namespace origin initialize] + } +} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise} + +test ooUtil-4.1 {TIP 478: singleton} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + set x [xyz new] + set y [xyz new] + set z [xyz new] + set code [catch {$x destroy} msg] + set p [xyz new] + lappend code [catch {rename $x ""}] + set q [xyz new] + string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]] +} -cleanup { + parent destroy +} -result {1 0 ONE ONE ONE ONE TWO TWO} +test ooUtil-4.2 {TIP 478: singleton errors} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + [xyz new] destroy +} -returnCodes error -cleanup { + parent destroy +} -result {may not destroy a singleton object} +test ooUtil-4.3 {TIP 478: singleton errors} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + oo::copy [xyz new] +} -returnCodes error -cleanup { + parent destroy +} -result {may not clone a singleton object} + + +test ooUtil-5.1 {TIP 478: abstract} -setup { + oo::class create parent +} -body { + oo::abstract create xyz { + superclass parent + method foo {} {return 123} + } + oo::class create pqr { + superclass xyz + method bar {} {return 456} + } + set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]] + set x [pqr new] + set y [pqr create ::y] + lappend codes [$x foo] [$x bar] $y +} -cleanup { + parent destroy +} -result {1 1 1 123 456 ::y} + +test ooUtil-6.1 {TIP 478: classvarable} -setup { + oo::class create parent +} -body { + oo::class create xyz { + superclass parent + initialise { + variable x 1 y 2 + } + method a {} { + classvariable x + incr x + } + method b {} { + classvariable y + incr y + } + method c {} { + classvariable x y + list $x $y + } + } + set p [xyz new] + set q [xyz new] + set result [list [$p c] [$q c]] + $p a + $q b + lappend result [[xyz new] c] +} -cleanup { + parent destroy +} -result {{1 2} {1 2} {2 3}} +test ooUtil-6.2 {TIP 478: classvarable error case} -setup { + oo::class create parent +} -body { + oo::class create xyz { + superclass parent + method a {} { + classvariable x(1) + incr x(1) + } + } + set p [xyz new] + set q [xyz new] + list [$p a] [$q a] +} -returnCodes error -cleanup { + parent destroy +} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element} +test ooUtil-6.3 {TIP 478: classvarable error case} -setup { + oo::class create parent +} -body { + oo::class create xyz { + superclass parent + method a {} { + classvariable ::x + incr x + } + } + set p [xyz new] + set q [xyz new] + list [$p a] [$q a] +} -returnCodes error -cleanup { + parent destroy +} -result {bad variable name "::x": can't create a local variable with a namespace separator in it} + +test ooUtil-7.1 {TIP 478: link calling pattern} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method foo {} {return "in foo of [self]"} + method Bar {} {return "in bar of [self]"} + method Grill {} {return "in grill of [self]"} + export eval + constructor {} { + link foo + link {bar Bar} {grill Grill} + } + } + cls create o + o eval {list [foo] [bar] [grill]} +} -cleanup { + parent destroy +} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}} +test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method foo {} {return "in foo of [self]"} + constructor {cmd} { + link [list ::$cmd foo] + } + } + cls create o pqr + list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg +} -cleanup { + parent destroy +} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}} + +# Tests that verify issues detected with the tcllib version of the code +test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup { + oo::class create animal {} + namespace eval ::ooutiltest { + oo::class create pet { superclass animal } + } +} -body { + namespace eval ::ooutiltest { + oo::class create dog { superclass pet } + } +} -cleanup { + namespace delete ooutiltest + rename animal {} +} -result {::ooutiltest::dog} +test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup { + oo::class create TestClass { + superclass oo::class + self method create {name ignore body} { + next $name $body + } + } +} -body { + TestClass create okay {} {} +} -cleanup { + rename TestClass {} +} -result {::okay} + +cleanupTests +return + +# Local Variables: +# fill-column: 78 +# mode: tcl +# End: diff --git a/tests/opt.test b/tests/opt.test index 2732d40..2d304c6 100644 --- a/tests/opt.test +++ b/tests/opt.test @@ -4,20 +4,20 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # the package we are going to test -package require opt 0.4.6 +package require opt 0.4.8 # we are using implementation specifics to test the package @@ -27,8 +27,8 @@ package require opt 0.4.6 set n $::tcl::OptDescN test opt-1.1 {OptKeyRegister / check that auto allocation is skipping existing keys} { - list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr $n+1]] [::tcl::OptKeyRegister {}] -} "$n [expr $n+1] [expr $n+2]" + list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr {$n+1}]] [::tcl::OptKeyRegister {}] +} "$n [expr {$n+1}] [expr {$n+2}]" test opt-2.1 {OptKeyDelete} { list [::tcl::OptKeyRegister {} testkey] \ diff --git a/tests/package.test b/tests/package.test index da778f1..134b4f7 100644 --- a/tests/package.test +++ b/tests/package.test @@ -5,28 +5,34 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2011 Donal K. Fellows +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2011 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.3.3 + package require tcltest 2.5 namespace import -force ::tcltest::* } -# Do all this in a slave interp to avoid garbaging the package list +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] + +# Do all this in a child interp to avoid garbaging the package list set i [interp create] -tcltest::loadIntoSlaveInterpreter $i {*}$argv +tcltest::loadIntoChildInterpreter $i {*}$argv +catch [list load {} Tcltest $i] interp eval $i { namespace import -force ::tcltest::* -package forget {*}[package names] +#package forget {*}[package names] set oldPkgUnknown [package unknown] package unknown {} set oldPath $auto_path set auto_path "" + +testConstraint testpreferstable [llength [info commands testpreferstable]] test package-1.1 {pkg::create gives error on insufficient args} -body { ::pkg::create @@ -134,7 +140,7 @@ test package-3.1 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.4} test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -144,7 +150,7 @@ test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.5} test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -154,7 +160,7 @@ test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.2 - return $x + set x } -result {2.3} test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -164,7 +170,7 @@ test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require -exact t 2.3 - return $x + set x } -result {2.3} test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -174,7 +180,7 @@ test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.1 - return $x + set x } -result {2.4} test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup { package forget t @@ -233,7 +239,7 @@ test package-3.12 {Tcl_PkgRequire procedure, self-deleting script} -setup { } -body { package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" package require t 1.2 - return $x + set x } -result {1.2} test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t @@ -251,7 +257,7 @@ test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { } package unknown pkgUnknown package require -exact t 1.5 - return $x + set x } -cleanup { package unknown {} } -result {t 1.5-1.5} @@ -278,7 +284,7 @@ test package-3.15 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package provide [lindex $args 0] 2.0 } package require {a b} - return $x + set x } -cleanup { package unknown {} } -result {{a b} 0-} @@ -569,15 +575,24 @@ test package-3.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { } -returnCodes error -cleanup { package forget demo } -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} -test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -setup { +test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + interp create child + load {} Tcltest child + child eval { + testpreferstable package forget t set x xxx + } } -body { + child eval { foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x + } +} -cleanup { + interp delete child } -result {3.4} test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t @@ -587,7 +602,7 @@ test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t @@ -597,34 +612,81 @@ test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} +test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + testpreferstable + package forget t + set x xxx +} -body { + foreach i {1.2b1 1.1} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + set x +} -result {1.1} +test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup { + package forget t +} -body { + coroutine coro1 apply {{} { + package ifneeded t 2.1 { + yield + package provide t 2.1 + } + package require t 2.1 + }} + list [catch {coro1} msg] $msg +} -match glob -result {0 2.1} + test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { package } -result {wrong # args: should be "package option ?arg ...?"} -test package-4.2 {Tcl_PackageCmd procedure, "forget" option} { +test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} -test package-4.3 {Tcl_PackageCmd procedure, "forget" option} { + } +} -cleanup { + interp delete child +} -result {} +test package-4.3 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package forget foo -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] set result {} + } } -body { + child eval { package ifneeded t 1.1 {first script} package ifneeded t 2.3 {second script} package ifneeded x 1.4 {x's script} lappend result [lsort [package names]] [package versions t] package forget t lappend result [lsort [package names]] [package versions t] + } +} -cleanup { + interp delete child } -result {{t x} {1.1 2.3} x {}} test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded a 1.1 {first script} package ifneeded b 2.3 {second script} package ifneeded c 1.4 {third script} @@ -632,6 +694,9 @@ test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { set result [list [lsort [package names]]] package forget a c lappend result [lsort [package names]] + } +} -cleanup { + interp delete child } -result {{a b c} b} test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body { # Test for Bug 415273 @@ -650,28 +715,55 @@ test package-4.7 {Tcl_PackageCmd procedure, "ifneeded" option} -body { test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body { package ifneeded t xyz } -returnCodes error -result {expected version number but got "xyz"} -test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} { +test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] list [package ifneeded foo 1.1] [package names] -} {{} {}} + } +} -cleanup { + interp delete child +} -result {{} {}} test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package names] [package ifneeded t 1.4] [package versions t] + } +} -cleanup { + interp delete child } -result {t {script for t 1.4} 1.4} test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package ifneeded t 1.5] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{} t 1.4} test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" package ifneeded t 1.4 "second script for t 1.4" list [package ifneeded t 1.4] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{second script for t 1.4} t 1.4} test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { package forget t @@ -684,18 +776,31 @@ test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body { package names a } -returnCodes error -result {wrong # args: should be "package names"} -test package-4.15 {Tcl_PackageCmd procedure, "names" option} { +test package-4.15 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded x 1.2 {dummy} package provide x 1.3 package provide y 2.4 catch {package require z 47.16} lsort [package names] + } +} -cleanup { + interp delete child } -result {x y} test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body { package provide @@ -826,7 +931,7 @@ test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { } {0} test package-4.53 {Tcl_PackageCmd procedure, "versions" option} -body { package foo -} -returnCodes error -result {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} +} -returnCodes error -result {bad option "foo": must be files, forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} test package-4.54 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { package vsatisfies 2.1 2.1-3.2-4.5 } -returnCodes error -result {expected versionMin-versionMax but got "2.1-3.2-4.5"} @@ -840,15 +945,15 @@ test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { # No tests for FindPackage; can't think up anything detectable errors. test package-5.1 {TclFreePackageInfo procedure} { - interp create slave - slave eval { + interp create child + child eval { package ifneeded t 2.3 x package ifneeded t 2.4 y package ifneeded x 3.1 z package provide q 4.3 package unknown "will this get freed?" } - interp delete slave + interp delete child } {} test package-5.2 {TclFreePackageInfo procedure} -body { interp create foo @@ -1233,9 +1338,9 @@ proc prefer {args} { } } -test package-13.0 {package prefer defaults} { +test package-13.0 {package prefer defaults} -body { prefer -} stable +} -result [expr {[string match {*[ab]*} [package provide tcl]] ? "latest" : "stable"}] test package-13.1 {package prefer defaults} -body { set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! prefer @@ -1250,15 +1355,27 @@ test package-14.1 {bogus argument} -returnCodes error -body { package prefer foo } -result {bad preference "foo": must be latest or stable} -test package-15.0 {set, keep} {package prefer stable} stable -test package-15.1 {set stable, keep} {prefer stable} {stable stable} -test package-15.2 {set latest, change} {prefer latest} {stable latest} -test package-15.3 {set latest, keep} { - prefer latest latest -} {stable latest latest} -test package-15.4 {set stable, rejected} { - prefer latest stable -} {stable latest latest} +test package-15.0 {set, keep} -constraints testpreferstable -setup { + testpreferstable +} -body {package prefer} -result stable +test package-15.1 {set stable, keep} -constraints testpreferstable -setup { + testpreferstable +} -body {package prefer stable} -result stable +test package-15.2 {set latest, change} -constraints testpreferstable -setup { + testpreferstable +} -body {package prefer latest} -result latest +test package-15.3 {set latest, keep} -constraints testpreferstable -setup { + testpreferstable +} -body { + package prefer latest + package prefer latest +} -result latest +test package-15.4 {set stable, rejected} -constraints testpreferstable -setup { + testpreferstable +} -body { + package prefer latest + package prefer stable +} -result latest rename prefer {} diff --git a/tests/parse.test b/tests/parse.test index 0f76d64..ff8a6ee 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -2,33 +2,36 @@ # file tclParse.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcl::test::parse { namespace import ::tcltest::* ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testparser [llength [info commands testparser]] +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testevalobjv [llength [info commands testevalobjv]] testConstraint testevalex [llength [info commands testevalex]] testConstraint testparsevarname [llength [info commands testparsevarname]] testConstraint testparsevar [llength [info commands testparsevar]] testConstraint testasync [llength [info commands testasync]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] +testConstraint testevent [llength [info commands testevent]] +testConstraint memory [llength [info commands memory]] -test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser { - testparser [bytestring "foo\0 bar"] -1 +test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {testparser testbytestring} { + testparser [testbytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser { testparser "foo bar" -1 @@ -299,9 +302,11 @@ test parse-6.15 {ParseTokens procedure, backslash-newline} testparser { test parse-6.16 {ParseTokens procedure, backslash substitution} testparser { testparser {\n\a\x7f} 0 } {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}} -test parse-6.17 {ParseTokens procedure, null characters} testparser { - testparser [bytestring "foo\0zz"] 0 -} "- [bytestring foo\0zz] 1 word [bytestring foo\0zz] 3 text foo 0 text [bytestring \0] 0 text zz 0 {}" +test parse-6.17 {ParseTokens procedure, null characters} {testparser testbytestring} { + expr {[testparser [testbytestring "foo\0zz"] 0] eq +"- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \0] 0 text zz 0 {}" + } +} 1 test parse-6.18 {ParseTokens procedure, seek past numBytes for close-bracket} testparser { # Test for Bug 681841 list [catch {testparser {[a]} 2} msg] $msg @@ -364,7 +369,7 @@ test parse-8.8 {Tcl_EvalObjv procedure, async handlers} -constraints { variable ::aresult variable ::acode proc async1 {result code} { - variable ::aresult + variable ::aresult variable ::acode set aresult $result set acode $code @@ -400,14 +405,14 @@ test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv { proc ::unknown args {lappend ::info [info level]; uplevel 1 foo} proc ::foo args {lappend ::info global} catch {rename ::noSuchCommand {}} - set ::slave [interp create] - $::slave alias bar noSuchCommand + set ::child [interp create] + $::child alias bar noSuchCommand set ::info {} namespace eval test_ns_1 { proc foo args {lappend ::info namespace} - $::slave eval bar - testevalobjv 1 [list $::slave eval bar] - uplevel #0 [list $::slave eval bar] + $::child eval bar + testevalobjv 1 [list $::child eval bar] + uplevel #0 [list $::child eval bar] } namespace delete test_ns_1 rename ::foo {} @@ -424,21 +429,21 @@ test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} { lappend ::info ns }] catch {rename ::noSuchCommand {}} - set ::slave [interp create] - $::slave alias bar noSuchCommand + set ::child [interp create] + $::child alias bar noSuchCommand set ::info {} namespace eval test_ns_1 { - $::slave eval bar + $::child eval bar } namespace delete test_ns_1 - interp delete $::slave + interp delete $::child catch {rename ::noSuchCommand {}} set ::info } global test parse-9.1 {Tcl_LogCommandInfo, line numbers} testevalex { - catch {unset x} + unset -nocomplain x list [catch {testevalex {for {} 1 {} { @@ -476,10 +481,10 @@ test parse-10.2 {Tcl_EvalTokens, backslash sequences} testevalex { testevalex {concat test\063\062test} } {test32test} test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex { - testevalex {concat [expr 2 + 6]} + testevalex {concat [expr {2 + 6}]} } {8} test parse-10.4 {Tcl_EvalTokens, nested commands} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat xxx[expr $a]}} msg] $msg } {1 {can't read "a": no such variable}} test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex { @@ -487,21 +492,21 @@ test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex { testevalex {concat $a} } {hello} test parse-10.6 {Tcl_EvalTokens, array variables} testevalex { - catch {unset a} + unset -nocomplain a set a(12) 46 testevalex {concat $a(12)} } {46} test parse-10.7 {Tcl_EvalTokens, array variables} testevalex { - catch {unset a} + unset -nocomplain a set a(12) 46 - testevalex {concat $a(1[expr 3 - 1])} + testevalex {concat $a(1[expr {3 - 1}])} } {46} test parse-10.8 {Tcl_EvalTokens, array variables} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat $x($a)}} msg] $msg } {1 {can't read "a": no such variable}} test parse-10.9 {Tcl_EvalTokens, array variables} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat xyz$a(1)}} msg] $msg } {1 {can't read "a(1)": no such variable}} test parse-10.10 {Tcl_EvalTokens, object values} testevalex { @@ -541,11 +546,11 @@ test parse-11.2 {Tcl_EvalEx, error while parsing} testevalex { list [catch {testevalex {concat "abc}} msg] $msg } {1 {missing "}} test parse-11.3 {Tcl_EvalEx, error while collecting words} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat xyz $a}} msg] $msg } {1 {can't read "a": no such variable}} test parse-11.4 {Tcl_EvalEx, error in Tcl_EvalObjv call} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {_bogus_ a b c d}} msg] $msg } {1 {invalid command name "_bogus_"}} test parse-11.5 {Tcl_EvalEx, exceptional return} testevalex { @@ -564,7 +569,7 @@ test parse-11.8 {Tcl_EvalEx, multiple commands in script} testevalex { }] $a $c } {d b d} test parse-11.9 {Tcl_EvalEx, freeing memory after error} testevalex { - catch {unset a} + unset -nocomplain a list [catch {testevalex {concat a b c d e f g h i j k l m n o p q r s t u v w x y z $a}} msg] $msg } {1 {can't read "a": no such variable}} test parse-11.10 {Tcl_EvalTokens, empty commands} testevalex { @@ -658,6 +663,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 @@ -670,16 +678,36 @@ test parse-13.3 {Tcl_ParseVar procedure, no variable name} testparsevar { testparsevar {$.123} } {{$} .123} test parse-13.4 {Tcl_ParseVar procedure, error looking up variable} testparsevar { - catch {unset abc} + unset -nocomplain abc list [catch {testparsevar {$abc}} msg] $msg } {1 {can't read "abc": no such variable}} test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar { - catch {unset abc} + unset -nocomplain abc list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg } {1 {invalid command name "bogus"}} +test parse-13.6 {Tcl_ParseVar memory leak} -constraints {testparsevar memory} -setup { + proc getbytes {} { + return [lindex [split [memory info] \n] 3 3] + } +} -body { + set a() foo + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set vn {} + set res [testparsevar [append vn $ a([string repeat {[]} 19]) bar]] + if {$res ne {foo bar}} {error "Unexpected result: $res"} -test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser { - testparser [bytestring "foo\0 bar"] -1 + set tmp $end + set end [getbytes] + } + expr {$end - $tmp} +} -cleanup { + unset -nocomplain a end i vn res tmp + rename getbytes {} +} -result 0 + +test parse-14.1 {Tcl_ParseBraces procedure, computing string length} {testparser testbytestring} { + testparser [testbytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-14.2 {Tcl_ParseBraces procedure, computing string length} testparser { testparser "foo bar" -1 @@ -715,8 +743,8 @@ test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} testparser { list [catch {testparser "foo \{xy\\\nz" 0} msg] $msg $::errorInfo } {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"} -test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} testparser { - testparser [bytestring "foo\0 bar"] -1 +test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} {testparser testbytestring} { + testparser [testbytestring "foo\0 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} testparser { testparser "foo bar" -1 @@ -881,11 +909,11 @@ test parse-15.53 {CommandComplete procedure} " test parse-15.54 {CommandComplete procedure} " info complete \"foo bar;# \{\" " 1 -test parse-15.55 {CommandComplete procedure} { - info complete "set x [bytestring \0]; puts hi" +test parse-15.55 {CommandComplete procedure} testbytestring { + info complete "set x [testbytestring \0]; puts hi" } 1 -test parse-15.56 {CommandComplete procedure} { - info complete "set x [bytestring \0]; \{" +test parse-15.56 {CommandComplete procedure} testbytestring { + info complete "set x [testbytestring \0]; \{" } 0 test parse-15.57 {CommandComplete procedure} { info complete "# Comment should be complete command" @@ -893,9 +921,9 @@ test parse-15.57 {CommandComplete procedure} { test parse-15.58 {CommandComplete procedure, memory leaks} { info complete "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22" } 1 -test parse-15.59 {CommandComplete procedure} { +test parse-15.59 {CommandComplete procedure} testbytestring { # Test for Tcl Bug 684744 - info complete [encoding convertfrom identity "\x00;if 1 \{"] + info complete [testbytestring "\x00;if 1 \{"] } 0 test parse-15.60 {CommandComplete procedure} { # Test for Tcl Bug 1968882 @@ -1090,6 +1118,19 @@ test parse-20.12 {TclParseBackslash: truncated escape} testparser { testparser {\x12X} 5 } {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}} +test parse-21.0 {Bug 1884496} testevent { + set ::script {testevent delete a; set a [p]; set ::done $a} + proc ::p {} {string first s $::script} + testevent queue a head $::script + vwait done +} {} +test parse-21.1 {TCL_EVAL_DIRECT coverage} testevent { + testevent queue a head {testevent delete a; \ + set ::done [dict get [info frame 0] line]} + vwait done + set ::done +} 2 + cleanupTests } diff --git a/tests/parseExpr.test b/tests/parseExpr.test index 7910974..99ada39 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -2,19 +2,19 @@ # file tclCompExpr.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Note that the Tcl expression parser (tclCompExpr.c) does not check # the semantic validity of the expressions it parses. It does not check, @@ -22,6 +22,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # of "<<" are integers. testConstraint testexprparser [llength [info commands testexprparser]] +testConstraint testbytestring [llength [info commands testbytestring]] # Big test for correct ordering of data in [expr] @@ -83,8 +84,8 @@ testConstraint ieeeFloatingPoint [testIEEE] ###################################################################### -test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} testexprparser { - testexprparser [bytestring "1+2\0 +3"] -1 +test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {testexprparser testbytestring} { + testexprparser [testbytestring "1+2\0 +3"] -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser { testexprparser "1 + 2" -1 @@ -769,11 +770,11 @@ test parseExpr-21.8 {error messages} -body { expr {0o8x} } -returnCodes error -match glob -result {*invalid octal number*} test parseExpr-21.9 {error messages} -body { - expr {"} + expr {"} } -returnCodes error -result {missing " in expression """} test parseExpr-21.10 {error messages} -body { - expr \{ + expr \{ } -returnCodes error -result "missing close-brace in expression \"\{\"" test parseExpr-21.11 {error messages} -body { @@ -1045,9 +1046,8 @@ test parseExpr-22.13 {Bug 3401704} -constraints testexprparser -body { } -result {- {} 0 subexpr naner() 1 operator naner 0 {}} test parseExpr-22.14 {Bug 3401704} -constraints testexprparser -body { - catch {testexprparser 08 -1} m o - dict get $o -errorcode -} -result {TCL PARSE EXPR BADNUMBER OCTAL} + testexprparser 07 -1 +} -result {- {} 0 subexpr 07 1 text 07 0 {}} test parseExpr-22.15 {Bug 3401704} -constraints testexprparser -body { catch {testexprparser 0o8 -1} m o dict get $o -errorcode @@ -1065,7 +1065,24 @@ test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body { dict get $o -errorcode } -result {TCL PARSE EXPR BADNUMBER BINARY} +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*} + +test parseExpr-23.1 {TIP 582: comments} -constraints testexprparser -body { + testexprparser "7 # * 8 " -1 +} -result {- {} 0 subexpr 7 1 text 7 0 {}} +test parseExpr-23.2 {TIP 582: comments} -constraints testexprparser -body { + testexprparser "7 #\n* 8 " -1 +} -result {- {} 0 subexpr {7 # +*} 5 operator # 0 subexpr 7 1 text 7 0 subexpr * 1 text * 0 {}} # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/parseOld.test b/tests/parseOld.test index 0edcbf0..8a58fbb 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -6,22 +6,23 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testwordend [llength [info commands testwordend]] +testConstraint testbytestring [llength [info commands testbytestring]] # Save the argv value for restoration later set savedArgv $argv @@ -38,7 +39,7 @@ proc getArgs args { global argv set argv $args } - + # Basic argument parsing. test parseOld-1.1 {basic argument parsing} { @@ -134,7 +135,7 @@ format %s $b } a22b test parseOld-4.4 {command substitution} { set a 7.7 - if [catch {expr int($a)}] {set a foo} + if {[catch {expr {int($a)}}]} {set a foo} set a } 7.7 @@ -166,25 +167,25 @@ test parseOld-5.6 {variable substitution} { set msg } {can't read "_non_existent_": no such variable} test parseOld-5.7 {array variable substitution} { - catch {unset a} + unset -nocomplain a set a(xyz) 123 set b $a(xyz)foo set b } 123foo test parseOld-5.8 {array variable substitution} { - catch {unset a} + unset -nocomplain a set "a(x y z)" 123 set b $a(x y z)foo set b } 123foo test parseOld-5.9 {array variable substitution} { - catch {unset a}; catch {unset qqq} + unset -nocomplain a qqq set "a(x y z)" qqq set $a([format x]\ y [format z]) foo set qqq } foo test parseOld-5.10 {array variable substitution} { - catch {unset a} + unset -nocomplain a list [catch {set b $a(22)} msg] $msg } {1 {can't read "a(22)": no such variable}} test parseOld-5.11 {array variable substitution} { @@ -194,9 +195,9 @@ test parseOld-5.11 {array variable substitution} { test parseOld-5.12 {empty array name support} { list [catch {set b a$()} msg] $msg } {1 {can't read "()": no such variable}} -catch {unset a} +unset -nocomplain a test parseOld-5.13 {array variable substitution} { - catch {unset a} + unset -nocomplain a set long {This is a very long variable, long enough to cause storage \ allocation to occur in Tcl_ParseVar. If that storage isn't getting \ freed up correctly, then a core leak will occur when this test is \ @@ -211,13 +212,13 @@ test parseOld-5.13 {array variable substitution} { run. This text is probably beginning to sound like drivel, but I've \ run out of things to say and I need more characters still.}}} test parseOld-5.14 {array variable substitution} { - catch {unset a}; catch {unset b}; catch {unset a1} + unset -nocomplain a b a1 set a1(22) foo set a(foo) bar set b $a($a1(22)) set b } bar -catch {unset a}; catch {unset a1} +unset -nocomplain a a1 test parseOld-7.1 {backslash substitution} { set a "\a\c\n\]\}" @@ -263,15 +264,15 @@ test parseOld-7.10 {backslash substitution} { test parseOld-7.11 {backslash substitution} { eval "list a \"b c\"\\\nd e" } {a {b c} d e} -test parseOld-7.12 {backslash substitution} { - list \ua2 -} [bytestring "\xc2\xa2"] -test parseOld-7.13 {backslash substitution} { - list \u4e21 -} [bytestring "\xe4\xb8\xa1"] -test parseOld-7.14 {backslash substitution} { - list \u4e2k -} [bytestring "\xd3\xa2k"] +test parseOld-7.12 {backslash substitution} testbytestring { + expr {[list \ua2] eq [testbytestring "\xc2\xa2"]} +} 1 +test parseOld-7.13 {backslash substitution} testbytestring { + expr {[list \u4e21] eq [testbytestring "\xe4\xb8\xa1"]} +} 1 +test parseOld-7.14 {backslash substitution} testbytestring { + expr {[list \u4e2k] eq [testbytestring "\xd3\xa2k"]} +} 1 # Semi-colon. @@ -297,6 +298,7 @@ test parseOld-8.4 {semi-colons} { # The following checks are to ensure that the interpreter's result # gets re-initialized by Tcl_Eval in all the right places. +set a 22 test parseOld-9.1 {result initialization} {concat abc} abc test parseOld-9.2 {result initialization} {concat abc; proc foo {} {}} {} test parseOld-9.3 {result initialization} {concat abc; proc foo {} $a} {} @@ -409,6 +411,8 @@ test parseOld-11.7 {long values} { set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] llength $b } 43 +# Duplicate action of previous test +llength [set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH]] test parseOld-11.8 {long values} { set b } $a @@ -456,72 +460,6 @@ expr 1+1 ]" } {2} -test parseOld-14.1 {TclWordEnd procedure} {testwordend} { - testwordend " \n abc" -} {c} -test parseOld-14.2 {TclWordEnd procedure} {testwordend} { - testwordend " \\\n" -} {} -test parseOld-14.3 {TclWordEnd procedure} {testwordend} { - testwordend " \\\n " -} { } -test parseOld-14.4 {TclWordEnd procedure} {testwordend} { - testwordend {"abc"} -} {"} -#" Emacs formatting :^( -test parseOld-14.5 {TclWordEnd procedure} {testwordend} { - testwordend {{xyz}} -} \} -test parseOld-14.6 {TclWordEnd procedure} {testwordend} { - testwordend {{a{}b{}\}} xyz} -} "\} xyz" -test parseOld-14.7 {TclWordEnd procedure} {testwordend} { - testwordend {abc[this is a]def ghi} -} {f ghi} -test parseOld-14.8 {TclWordEnd procedure} {testwordend} { - testwordend "puts\\\n\n " -} "s\\\n\n " -test parseOld-14.9 {TclWordEnd procedure} {testwordend} { - testwordend "puts\\\n " -} "s\\\n " -test parseOld-14.10 {TclWordEnd procedure} {testwordend} { - testwordend "puts\\\n xyz" -} "s\\\n xyz" -test parseOld-14.11 {TclWordEnd procedure} {testwordend} { - testwordend {a$x.$y(a long index) foo} -} ") foo" -test parseOld-14.12 {TclWordEnd procedure} {testwordend} { - testwordend {abc; def} -} {; def} -test parseOld-14.13 {TclWordEnd procedure} {testwordend} { - testwordend {abc def} -} {c def} -test parseOld-14.14 {TclWordEnd procedure} {testwordend} { - testwordend {abc def} -} {c def} -test parseOld-14.15 {TclWordEnd procedure} {testwordend} { - testwordend "abc\ndef" -} "c\ndef" -test parseOld-14.16 {TclWordEnd procedure} {testwordend} { - testwordend "abc" -} {c} -test parseOld-14.17 {TclWordEnd procedure} {testwordend} { - testwordend "a\000bc" -} {c} -test parseOld-14.18 {TclWordEnd procedure} {testwordend} { - testwordend \[a\000\] -} {]} -test parseOld-14.19 {TclWordEnd procedure} {testwordend} { - testwordend \"a\000\" -} {"} -#" Emacs formatting :^( -test parseOld-14.20 {TclWordEnd procedure} {testwordend} { - testwordend a{\000}b -} {b} -test parseOld-14.21 {TclWordEnd procedure} {testwordend} { - testwordend " \000b" -} {b} - test parseOld-15.1 {TclScriptEnd procedure} { info complete {puts [ expr 1+1 @@ -539,8 +477,12 @@ test parseOld-15.4 {TclScriptEnd procedure} { test parseOld-15.5 {TclScriptEnd procedure} { info complete "xyz \[abc" } {0} - + # cleanup set argv $savedArgv ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/pid.test b/tests/pid.test index d21dbaa..3f62457 100644 --- a/tests/pid.test +++ b/tests/pid.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -21,7 +21,7 @@ testConstraint pidDefined [llength [info commands pid]] test pid-1.1 {pid command} pidDefined { regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid] } 1 -test pid-1.2 {pid command} -constraints {unixOrPc unixExecs pidDefined} -setup { +test pid-1.2 {pid command} -constraints {unixOrWin unixExecs pidDefined} -setup { set path(test1) [makeFile {} test1] file delete $path(test1) } -body { diff --git a/tests/pkgIndex.tcl b/tests/pkgIndex.tcl new file mode 100644 index 0000000..96542f9 --- /dev/null +++ b/tests/pkgIndex.tcl @@ -0,0 +1,3 @@ +#! /usr/bin/env tclsh + +package ifneeded tcltests 0.1 [list source $dir/tcltests.tcl]
\ No newline at end of file diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 0fe394e..df49c32 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -5,11 +5,11 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -45,7 +45,7 @@ proc pkgtest::parseArgs { args } { set a [lindex $args $iarg] if {[regexp {^-} $a]} { lappend options $a - if {[string compare -load $a] == 0} { + if {$a eq "-load"} { incr iarg lappend options [lindex $args $iarg] } @@ -74,14 +74,14 @@ proc pkgtest::parseArgs { args } { # of the command line. proc pkgtest::parseIndex { filePath } { - # create a slave interpreter, where we override "package ifneeded" + # create a child interpreter, where we override "package ifneeded" - set slave [interp create] + set child [interp create] if {[catch { - $slave eval { + $child eval { rename package package_original proc package { args } { - if {[string compare [lindex $args 0] ifneeded] == 0} { + if {[lindex $args 0] eq "ifneeded"} { set pkg [lindex $args 1] set ver [lindex $args 2] set ::PKGS($pkg:$ver) [lindex $args 3] @@ -93,17 +93,17 @@ proc pkgtest::parseIndex { filePath } { } set dir [file dirname $filePath] - $slave eval {set curdir [pwd]} - $slave eval [list cd $dir] - $slave eval [list set dir $dir] - $slave eval [list source [file tail $filePath]] - $slave eval {cd $curdir} + $child eval {set curdir [pwd]} + $child eval [list cd $dir] + $child eval [list set dir $dir] + $child eval [list source [file tail $filePath]] + $child eval {cd $curdir} # Create the list in sorted order, so that we don't get spurious # errors because the order has changed. array set P {} - foreach {k v} [$slave eval {array get ::PKGS}] { + foreach {k v} [$child eval {array get ::PKGS}] { set P($k) $v } @@ -111,16 +111,16 @@ proc pkgtest::parseIndex { filePath } { foreach k [lsort [array names P]] { lappend PKGS $k $P($k) } - } err]} { - set ei $::errorInfo - set ec $::errorCode + } err opts]} { + set ei [dict get $opts -errorinfo] + set ec [dict get $opts -errorcode] - catch {interp delete $slave} + catch {interp delete $child} error $ei $ec } - interp delete $slave + interp delete $child return $PKGS } @@ -233,7 +233,7 @@ proc pkgtest::runCreatedIndex {rv args} { set result [list 0 [makePkgList [parseIndex $idxFile]]] } err]} { set result [list 1 $err] - } + } file delete $idxFile } else { set result $rv @@ -315,7 +315,7 @@ namespace eval pkg2 { namespace export p2-1 } proc pkg2::p2-1 { num } { - return [expr $num * 2] + return [expr {$num * 2}] } } [file join pkg pkg2_a.tcl] @@ -328,7 +328,7 @@ namespace eval pkg2 { namespace export p2-2 } proc pkg2::p2-2 { num } { - return [expr $num * 3] + return [expr {$num * 3}] } } [file join pkg pkg2_b.tcl] @@ -409,10 +409,10 @@ namespace eval pkg3 { namespace export p3-1 p3-2 } proc pkg3::p3-1 { num } { - return {[expr $num * 2]} + return {[expr {$num * 2}]} } proc pkg3::p3-2 { num } { - return {[expr $num * 3]} + return {[expr {$num * 3}]} } } [file join pkg pkg3.tcl] @@ -520,10 +520,10 @@ namespace eval circ2 { namespace export c2-1 c2-2 } proc circ2::c2-1 { num } { - return [expr $num * [circ3::c3-1]] + return [expr {$num * [circ3::c3-1]}] } proc circ2::c2-2 { num } { - return [expr $num * [circ3::c3-2]] + return [expr {$num * [circ3::c3-2]}] } } [file join pkg circ2.tcl] @@ -559,8 +559,8 @@ testConstraint $dll [file exists $x] if {[testConstraint $dll]} { makeFile { -# This package provides Pkga, which is also provided by a DLL. -package provide Pkga 1.0 +# This package provides pkga, which is also provided by a DLL. +package provide pkga 1.0 proc pkga_neq { x } { return [expr {! [pkgq_eq $x]}] } @@ -576,7 +576,7 @@ test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] { set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl] exec [interpreter] << $cmd pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl -} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" +} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] { # Do all [load]ing of shared libraries in another process, so we can # delete the file and not get stuck because we're holding a reference to diff --git a/tests/platform.test b/tests/platform.test index aab7c78..b5fd405 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -1,23 +1,35 @@ -# 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 # generates output for errors. No output means no errors were found. # -# Copyright (c) 1999 by Scriptics Corporation +# Copyright © 1999 Scriptics Corporation # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} +package require tcltest 2.5 + +namespace eval ::tcl::test::platform { + namespace import ::tcltest::testConstraint + namespace import ::tcltest::test + namespace import ::tcltest::cleanupTests + + # This is not how [variable] works. See TIP 276. + #variable ::tcl_platform + namespace upvar :: tcl_platform tcl_platform ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] +package require tcltests testConstraint testCPUID [llength [info commands testcpuid]] +testConstraint testlongsize [llength [info commands testlongsize]] + +test platform-1.0 {tcl_platform(engine)} { + set tcl_platform(engine) +} {Tcl} test platform-1.1 {TclpSetVariables: tcl_platform} { interp create i @@ -26,35 +38,45 @@ 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 pathSeparator 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 -# this is intentional since that could make Tcl's numbers wider than -# the machine-integer on some platforms... -test platform-2.1 {tcl_platform(wordSize) indicates size of native word} { - set result [expr {int(1 << (8 * $tcl_platform(wordSize) - 1))}] - # Result must be the largest bit in a machine word, which this checks - # without assuming how wide the word really is - list [expr {$result < 0}] [expr {$result ^ int($result - 1)}] -} {1 -1} +} {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize} + +test platform-2.1 {tcl_platform(wordSize) indicates size of native word} testlongsize { + expr {$tcl_platform(wordSize) == [testlongsize]} +} {1} # On Windows/UNIX, test that the CPU ID works test platform-3.1 {CPU ID on Windows/UNIX} \ -constraints testCPUID \ - -body { + -body { set cpudata [testcpuid 0] binary format iii \ [lindex $cpudata 1] \ [lindex $cpudata 3] \ - [lindex $cpudata 2] + [lindex $cpudata 2] } \ -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} -constraints notValgrind -match regexp -body { + # [identify] may attempt to [exec] dpkg-architecture, which may not exist, + # in which case fork will not be followed by exec, and valgrind will issue + # "still reachable" reports. + platform::identify +} -result {^([^-]+-)+[^-]+$} +test platform-4.2 {format of platform::generic result} -match regexp -body { + platform::generic +} -result {^([^-]+-)+[^-]+$} + # cleanup -::tcltest::cleanupTests +cleanupTests + +} +namespace delete ::tcl::test::platform return # Local Variables: diff --git a/tests/proc-old.test b/tests/proc-old.test index e45cf5c..ab93fca 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -7,15 +7,15 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -25,7 +25,7 @@ catch {rename foo ""} proc tproc {} {return a; return b} test proc-old-1.1 {simple procedure call and return} {tproc} a proc tproc x { - set x [expr $x+1] + set x [expr {$x + 1}] return $x } test proc-old-1.2 {simple procedure call and return} {tproc 2} 3 @@ -49,7 +49,7 @@ test proc-old-1.6 {simple procedure call and return (shared proc body string)} { test proc-old-2.1 {local and global variables} { proc tproc x { - set x [expr $x+1] + set x [expr {$x + 1}] return $x } set x 42 @@ -57,7 +57,7 @@ test proc-old-2.1 {local and global variables} { } {7 42} test proc-old-2.2 {local and global variables} { proc tproc x { - set y [expr $x+1] + set y [expr {$x + 1}] return $y } set y 18 @@ -66,7 +66,7 @@ test proc-old-2.2 {local and global variables} { test proc-old-2.3 {local and global variables} { proc tproc x { global y - set y [expr $x+1] + set y [expr {$x + 1}] return $y } set y 189 @@ -75,7 +75,7 @@ test proc-old-2.3 {local and global variables} { test proc-old-2.4 {local and global variables} { proc tproc x { global y - return [expr $x+$y] + return [expr {$x + $y}] } set y 189 list [tproc 6] $y @@ -504,7 +504,7 @@ test proc-old-10.1 {ByteCode epoch change during recursive proc execution} { set y 20 rename expr expr.old rename expr.old expr - if $x then {t1 0} ;# recursive call after foo's code is invalidated + if {$x} then {t1 0} ;# recursive call after foo's code is invalidated return 20 } t1 1 diff --git a/tests/proc.test b/tests/proc.test index e06720e..23aea28 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -7,18 +7,18 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } -testConstraint procbodytest [expr {![catch {package require procbodytest}]}] +testConstraint tcl::test [expr {![catch {package require tcl::test}]}] testConstraint memory [llength [info commands memory]] catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -99,17 +99,25 @@ test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or e test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} -setup { catch {rename p ""} } -returnCodes error -body { - proc p {a(1) a(2)} { - set z [expr $a(1)+$a(2)] + proc p {a(1) a(2)} { + set z [expr {$a(1)+$a(2)}] puts "$z=z, $a(1)=$a(1)" } } -result {formal parameter "a(1)" is an array element} test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} -setup { catch {rename p ""} } -body { - proc p {b:a b::a} { + proc p {b:a b::a} { } } -returnCodes error -result {formal parameter "b::a" is not a simple name} +test proc-1.9 {Tcl_ProcObjCmd, arguments via canonical list (string-representation bug [631b4c45df])} -body { + set v 2 + binary scan AB cc a b + proc p [list [list a $a] [list b $b] [list v [expr {$v + 2}]]] {expr {$a + $b + $v}} + p +} -result [expr {65+66+4}] -cleanup { + rename p {} +} test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -202,14 +210,14 @@ catch {rename p ""} catch {rename t ""} # Note that the test require that procedures whose body is used to create -# procbody objects must be executed before the procbodytest::proc command is +# procbody objects must be executed before the tcl::procbodytest::proc command is # executed, so that the Proc struct is populated correctly (CompiledLocals are # added at compile time). -test proc-4.1 {TclCreateProc, procbody obj} -constraints procbodytest -body { +test proc-4.1 {TclCreateProc, procbody obj} -constraints tcl::test -body { proc p x {return "$x:$x"} set rv [p P] - procbodytest::proc t x p + tcl::procbodytest::proc t x p lappend rv [t T] } -cleanup { catch {rename p ""} @@ -221,9 +229,9 @@ test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} -body { return "$x:$y" } set rv [p P] - procbodytest::proc t x p + tcl::procbodytest::proc t x p lappend rv [t T] -} -constraints procbodytest -cleanup { +} -constraints tcl::test -cleanup { catch {rename p ""} catch {rename t ""} } -result {P:p T:t} @@ -233,9 +241,9 @@ test proc-4.3 {TclCreateProc, procbody obj, too many args} -body { return "$x:$y" } set rv [p P] - procbodytest::proc t {x x1 x2} p + tcl::procbodytest::proc t {x x1 x2} p lappend rv [t T] -} -constraints procbodytest -returnCodes error -cleanup { +} -constraints tcl::test -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": arg list contains 3 entries, precompiled header expects 1} @@ -246,9 +254,9 @@ test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} -body { return "$v:$w" } set rv [p P Q R] - procbodytest::proc t {x x1 z} p + tcl::procbodytest::proc t {x x1 z} p lappend rv [t S T U] -} -constraints procbodytest -returnCodes error -cleanup { +} -constraints tcl::test -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter 1 is inconsistent with precompiled body} @@ -259,9 +267,9 @@ test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} -body return "$v:$w" } set rv [p P Q R] - procbodytest::proc t {x y z} p + tcl::procbodytest::proc t {x y z} p lappend rv [t S T U] -} -constraints procbodytest -returnCodes error -cleanup { +} -constraints tcl::test -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} @@ -272,9 +280,9 @@ test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} -body return "$v:$w" } set rv [p P Q R] - procbodytest::proc t {x y {z Z}} p + tcl::procbodytest::proc t {x y {z Z}} p lappend rv [t S T U] -} -returnCodes error -constraints procbodytest -cleanup { +} -returnCodes error -constraints tcl::test -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} @@ -285,9 +293,9 @@ test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} -bod return "$v:$w" } set rv [p P Q R] - procbodytest::proc t {x y {z ZZ}} p + tcl::procbodytest::proc t {x y {z ZZ}} p lappend rv [t S T U] -} -constraints procbodytest -returnCodes error -cleanup { +} -constraints tcl::test -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} @@ -301,10 +309,10 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set return "$x:$y" } px x -} -constraints {procbodytest memory} -body { +} -constraints {tcl::test memory} -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { - procbodytest::proc tx x px + tcl::procbodytest::proc tx x px set tmp $end set end [getbytes] } @@ -313,6 +321,9 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set rename getbytes {} unset -nocomplain end i tmp leakedBytes } -result 0 +test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} tcl::test { + tcl::procbodytest::check +} 1 test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body { proc p args {} ; # this will be bytecompiled into t @@ -329,7 +340,7 @@ test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body } -cleanup { catch {rename p ""} catch {rename t ""} -} -result {aba} +} -result {aba} test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} -body { proc a {} {return -code -5} @@ -378,11 +389,19 @@ test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} -body { test proc-7.4 {Proc struct outlives its interp: Bug 3532959} { set lambda x lappend lambda {set a 1} - interp create slave - slave eval [list apply $lambda foo] - interp delete slave + interp create child + child eval [list apply $lambda foo] + interp delete child unset lambda } {} + +test proc-7.5 {[631b4c45df] Crash in argument processing} { + binary scan A c val + proc foo [list [list from $val]] {} + rename foo {} + unset -nocomplain val +} {} + # cleanup catch {rename p ""} diff --git a/tests/process.test b/tests/process.test new file mode 100644 index 0000000..4533108 --- /dev/null +++ b/tests/process.test @@ -0,0 +1,341 @@ +# process.test -- +# +# This file contains a collection of tests for the tcl::process ensemble. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright © 2017 Frederic Bonnet +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +# Utilities +file delete [set path(test-signalfile) [makeFile {} test-signalfile]] +set path(test-signalfile2) [makeFile {} test-signalfile2] +# $path(sleep) time ?filename? -- sleep for time (in ms) and stop if it gets signaled (file gets deleted) +set path(sleep) [makeFile { + after [expr {[lindex $argv 0]*1000}] {set stop 1} + if {[set fn [lindex $::argv 1]] ne ""} { + close [open $fn w] + proc check {} { + if {![file exists $::fn]} { # exit signaled + after 10 {set ::stop 2} + } + after 10 check + } + after 10 check + } + vwait stop + exit +} sleep] + +proc wait_for_file {fn {timeout 10000}} { + if {![file exists $fn]} { + set toev [after $timeout {set found 0}] + proc check {fn} { + if {[file exists $fn]} { + set ::found 1 + return + } + after 10 [list check $fn] + } + after 10 [list check $fn] + vwait ::found + after cancel $toev + unset ::found + } + file exists $fn +} +proc signal_exit {fn {wait 1}} { + # wait for until file created if expected: + if {!$wait || [wait_for_file $fn]} { + # delete file to signal exit for child-process: + while {1} { + if {![catch { file delete $fn } msg opt] + || [lrange [dict get $opt -errorcode] 0 1] ne {POSIX EACCES} + } break + } + } +} + +set path(exit) [makeFile { + exit [lindex $argv 0] +} exit] + +# Basic syntax checking +test process-1.1 {tcl::process command basic syntax} -returnCodes error -body { + tcl::process +} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"} +test process-1.2 {tcl::process subcommands} -returnCodes error -body { + tcl::process ? +} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status} + +# Autopurge flag +# - Default state +test process-2.1 {autopurge default} -body { + tcl::process autopurge +} -result {1} +# - Enabling autopurge +test process-2.2 {enable autopurge} -body { + tcl::process autopurge true + tcl::process autopurge +} -result {1} +# - Disabling autopurge +test process-2.3 {disable autopurge} -body { + tcl::process autopurge false + tcl::process autopurge +} -result {0} -cleanup {tcl::process autopurge true} + +# Subprocess list & status +test process-3.1 {empty subprocess list} -body { + llength [tcl::process list] +} -result {0} +test process-3.2 {empty subprocess status} -body { + dict size [tcl::process status] +} -result {0} + +# Spawn subprocesses using [exec] +# - One child +test process-4.1 {exec one child} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(exit) 0 &] + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status [lindex [tcl::process status $pid] 1] + expr { + [llength $list] eq 1 + && [lindex $list 0] eq $pid + && [dict size $statuses] eq 1 + && [dict get $statuses $pid] eq $status + && $status eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +# - Two children +test process-4.2 {exec two children in parallel} -body { + tcl::process autopurge 0 + set pid1 [exec [interpreter] $path(exit) 0 &] + set pid2 [exec [interpreter] $path(exit) 0 &] + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status1 [lindex [tcl::process status $pid1] 1] + set status2 [lindex [tcl::process status $pid2] 1] + expr { + [llength $list] eq 2 + && [lsearch $list $pid1] >= 0 + && [lsearch $list $pid2] >= 0 + && [dict size $statuses] eq 2 + && [dict get $statuses $pid1] eq $status1 + && [dict get $statuses $pid2] eq $status2 + && $status1 eq 0 + && $status2 eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +# - 3-stage pipe +test process-4.3 {exec 3-stage pipe} -body { + tcl::process autopurge 0 + set pids [exec \ + [interpreter] $path(exit) 0 \ + | [interpreter] $path(exit) 0 \ + | [interpreter] $path(exit) 0 \ + &] + lassign $pids pid1 pid2 pid3 + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status1 [lindex [tcl::process status $pid1] 1] + set status2 [lindex [tcl::process status $pid2] 1] + set status3 [lindex [tcl::process status $pid3] 1] + expr { + [llength $pids] eq 3 + && [llength $list] eq 3 + && [lsearch $list $pid1] >= 0 + && [lsearch $list $pid2] >= 0 + && [lsearch $list $pid3] >= 0 + && [dict size $statuses] eq 3 + && [dict get $statuses $pid1] eq $status1 + && [dict get $statuses $pid2] eq $status2 + && [dict get $statuses $pid3] eq $status3 + && $status1 eq 0 + && $status2 eq 0 + && $status3 eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} + +# Spawn subprocesses using [open "|"] +# - One child +test process-5.1 {exec one child} -body { + tcl::process autopurge 0 + set f [open "|\"[interpreter]\" \"$path(exit)\" 0"] + set pid [pid $f] + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status [lindex [tcl::process status $pid] 1] + expr { + [llength $list] eq 1 + && [lindex $list 0] eq $pid + && [dict size $statuses] eq 1 + && [dict get $statuses $pid] eq $status + && $status eq 0 + } +} -result {1} -cleanup { + close $f + tcl::process purge + tcl::process autopurge 1 +} +# - Two children +test process-5.2 {exec two children in parallel} -body { + tcl::process autopurge 0 + set f1 [open "|\"[interpreter]\" \"$path(exit)\" 0"] + set f2 [open "|\"[interpreter]\" \"$path(exit)\" 0"] + set pid1 [pid $f1] + set pid2 [pid $f2] + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status1 [lindex [tcl::process status $pid1] 1] + set status2 [lindex [tcl::process status $pid2] 1] + expr { + [llength $list] eq 2 + && [lsearch $list $pid1] >= 0 + && [lsearch $list $pid2] >= 0 + && [dict size $statuses] eq 2 + && [dict get $statuses $pid1] eq $status1 + && [dict get $statuses $pid2] eq $status2 + && $status1 eq 0 + && $status2 eq 0 + } +} -result {1} -cleanup { + close $f1 + close $f2 + tcl::process purge + tcl::process autopurge 1 +} +# - 3-stage pipe +test process-5.3 {exec 3-stage pipe} -body { + tcl::process autopurge 0 + set f [open "| + \"[interpreter]\" \"$path(exit)\" 0 + | \"[interpreter]\" \"$path(exit)\" 0 + | \"[interpreter]\" \"$path(exit)\" 0 + "] + set pids [pid $f] + lassign $pids pid1 pid2 pid3 + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status1 [lindex [tcl::process status $pid1] 1] + set status2 [lindex [tcl::process status $pid2] 1] + set status3 [lindex [tcl::process status $pid3] 1] + expr { + [llength $pids] eq 3 + && [llength $list] eq 3 + && [lsearch $list $pid1] >= 0 + && [lsearch $list $pid2] >= 0 + && [lsearch $list $pid3] >= 0 + && [dict size $statuses] eq 3 + && [dict get $statuses $pid1] eq $status1 + && [dict get $statuses $pid2] eq $status2 + && [dict get $statuses $pid3] eq $status3 + && $status1 eq 0 + && $status2 eq 0 + && $status3 eq 0 + } +} -result {1} -cleanup { + close $f + tcl::process purge + tcl::process autopurge 1 +} + +# Async child status +test process-6.1 {async status} -setup { + signal_exit $path(test-signalfile) 0; # clean signal-file +} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &] + set status1 [lindex [tcl::process status $pid] 1] + signal_exit $path(test-signalfile); # signal exit (stop sleep) + set status2 [lindex [tcl::process status -wait $pid] 1] + expr { + $status1 eq {} + && $status2 eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +test process-6.2 {selective wait} -setup { + signal_exit $path(test-signalfile) 0; # clean signal-files + signal_exit $path(test-signalfile2) 0; +} -body { + tcl::process autopurge 0 + # Child 1 sleeps 1s + set pid1 [exec [interpreter] $path(sleep) 1 $path(test-signalfile) &] + # Child 2 sleeps 1s + set pid2 [exec [interpreter] $path(sleep) 2 $path(test-signalfile2) &] + # Initial status + set status1_1 [lindex [tcl::process status $pid1] 1] + set status1_2 [lindex [tcl::process status $pid2] 1] + # Wait until child 1 termination + signal_exit $path(test-signalfile); # signal exit for pid1 (stop sleep) + set status2_1 [lindex [tcl::process status -wait $pid1] 1] + set status2_2 [lindex [tcl::process status $pid2] 1] + # Wait until child 2 termination + signal_exit $path(test-signalfile2); # signal exit for pid2 (stop sleep) + set status3_2 [lindex [tcl::process status -wait $pid2] 1] + set status3_1 [lindex [tcl::process status $pid1] 1] + expr { + $status1_1 eq {} + && $status1_2 eq {} + && $status2_1 eq 0 + && $status2_2 eq {} + && $status3_1 eq 0 + && $status3_2 eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} + +# Error codes +test process-7.1 {normal exit} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(exit) 0 &] + lindex [tcl::process status -wait $pid] 1 +} -result {0} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +test process-7.2 {abnormal exit} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(exit) 1 &] + lindex [tcl::process status -wait $pid] 1 +} -match glob -result {1 {child process exited abnormally} {CHILDSTATUS * 1}} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +test process-7.3 {child killed} -constraints {win} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(exit) -1 &] + lindex [tcl::process status -wait $pid] 1 +} -match glob -result {1 {child killed: unknown signal} {CHILDKILLED * {unknown signal} {unknown signal}}} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} + +removeFile $path(exit) +removeFile $path(sleep) + +rename wait_for_file {} +rename signal_exit {} +::tcltest::cleanupTests +return diff --git a/tests/pwd.test b/tests/pwd.test index 175c852..c069eef 100644 --- a/tests/pwd.test +++ b/tests/pwd.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -20,9 +20,10 @@ test pwd-1.1 {simple pwd} { catch pwd } 0 test pwd-1.2 {simple pwd} { - expr [string length pwd]>0 + expr {[string length [pwd]]>0} } 1 -test pwd-1.3 {pwd takes no args} -body { + +test pwd-2.1 {pwd takes no args} -body { pwd foobar } -returnCodes error -result "wrong \# args: should be \"pwd\"" diff --git a/tests/reg.test b/tests/reg.test index a0ea850..3c9020d 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -7,14 +7,15 @@ # and aren't using Tcl -- reg's own regression tester also knows how # to read this file, ignoring the Tcl-isms.) # -# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. +# Copyright © 1998, 1999 Henry Spencer. All rights reserved. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # All tests require the testregexp command, return if this # command doesn't exist @@ -49,9 +50,9 @@ catch [list package require -exact Tcltest [info patchlevel]] # subexpressions, checking where empty substrings are located, # etc. should be done using expectIndices and expectPartial. -# The flag characters are complex and a bit eclectic. Generally speaking, +# The flag characters are complex and a bit eclectic. Generally speaking, # lowercase letters are compile options, uppercase are expected re_info -# bits, and nonalphabetics are match options, controls for how the test is +# bits, and nonalphabetics are match options, controls for how the test is # run, or testing options. The one small surprise is that AREs are the # default, and you must explicitly request lesser flavors of RE. The flags # are as follows. It is admitted that some are not very mnemonic. @@ -287,7 +288,7 @@ namespace eval RETest { set infoflags [TestInfoFlags $flags] set ccmd [list testregexp -about {*}$f $re] set nsub [expr {[llength $args] - 1}] - if {$nsub == -1} { + if {$nsub < 0} { # didn't tell us number of subexps set ccmd "lreplace \[$ccmd\] 0 0" set info [list $infoflags] @@ -311,7 +312,7 @@ namespace eval RETest { # match expected (full fanciness) # expectIndices testno flags re target mat submat ... proc expectIndices {args} { - MatchExpected -indices {*}$args + MatchExpected -indices {*}$args } # partial match expected @@ -626,6 +627,7 @@ expectMatch 13.14 P "a\\rb" "a\rb" "a\rb" expectMatch 13.15 P "a\\tb" "a\tb" "a\tb" expectMatch 13.16 P "a\\u0008x" "a\bx" "a\bx" expectMatch 13.17 P {a\u008x} "a\bx" "a\bx" +expectError 13.17.1 - {a\ux} EESCAPE expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x" expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx" expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx" @@ -669,7 +671,13 @@ expectError 14.19 - {a(b)c\2} ESUBREG expectMatch 14.20 bR {a\(b*\)c\1} abbcbb abbcbb bb expectMatch 14.21 RP {^([bc])\1*$} bbb bbb b expectMatch 14.22 RP {^([bc])\1*$} ccc ccc c -knownBug expectNomatch 14.23 R {^([bc])\1*$} bcb +expectNomatch 14.23 RP {^([bc])\1*$} bcb +expectMatch 14.24 LRP {^(\w+)( \1)+$} {abc abc abc} {abc abc abc} abc { abc} +expectNomatch 14.25 LRP {^(\w+)( \1)+$} {abc abd abc} +expectNomatch 14.26 LRP {^(\w+)( \1)+$} {abc abc abd} +expectMatch 14.27 RP {^(.+)( \1)+$} {abc abc abc} {abc abc abc} abc { abc} +expectNomatch 14.28 RP {^(.+)( \1)+$} {abc abd abc} +expectNomatch 14.29 RP {^(.+)( \1)+$} {abc abc abd} doing 15 "octal escapes vs back references" @@ -796,6 +804,7 @@ expectMatch 21.31 LP "\\y(\\w+)\\y" "-- abc-" "abc" "abc" expectMatch 21.32 - a((b|c)d+)+ abacdbd acdbd bd b expectMatch 21.33 N (.*).* abc abc abc expectMatch 21.34 N (a*)* bc "" "" +expectMatch 21.35 M { TO (([a-z0-9._]+|"([^"]+|"")+")+)} {asd TO foo} { TO foo} foo o {} doing 22 "multicharacter collating elements" @@ -848,6 +857,7 @@ expectMatch 24.9 - 3z* 123zzzz456 3zzzz expectMatch 24.10 PT 3z*? 123zzzz456 3 expectMatch 24.11 - z*4 123zzzz456 zzzz4 expectMatch 24.12 PT z*?4 123zzzz456 zzzz4 +expectMatch 24.13 PT {^([^/]+?)(?:/([^/]+?))(?:/([^/]+?))?$} {foo/bar/baz} {foo/bar/baz} {foo} {bar} {baz} doing 25 "mixed quantifiers" @@ -1080,7 +1090,138 @@ 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.1 {Bug 3603557 - an "in the wild" RE} { + lindex [regexp -expanded -about { + ^TETRA_MODE_CMD # Message Type + ([[:blank:]]+) # Pad + (ETS_1_1|ETS_1_2|ETS_2_2) # SystemCode + ([[:blank:]]+) # Pad + (CONTINUOUS|CARRIER|MCCH|TRAFFIC) # SharingMode + ([[:blank:]]+) # Pad + ([[:digit:]]{1,2}) # ColourCode + ([[:blank:]]+) # Pad + (1|2|3|4|6|9|12|18) # TSReservedFrames + ([[:blank:]]+) # Pad + (PASS|TRUE|FAIL|FALSE) # UPlaneDTX + ([[:blank:]]+) # Pad + (PASS|TRUE|FAIL|FALSE) # Frame18Extension + ([[:blank:]]+) # Pad + ([[:digit:]]{1,4}) # MCC + ([[:blank:]]+) # Pad + ([[:digit:]]{1,5}) # MNC + ([[:blank:]]+) # Pad + (BOTH|BCAST|ENQRY|NONE) # NbrCellBcast + ([[:blank:]]+) # Pad + (UNKNOWN|LOW|MEDIUM|HIGH) # CellServiceLevel + ([[:blank:]]+) # Pad + (PASS|TRUE|FAIL|FALSE) # LateEntryInfo + ([[:blank:]]+) # Pad + (300|400) # FrequencyBand + ([[:blank:]]+) # Pad + (NORMAL|REVERSE) # ReverseOperation + ([[:blank:]]+) # Pad + (NONE|\+6\.25|\-6\.25|\+12\.5) # Offset + ([[:blank:]]+) # Pad + (10) # DuplexSpacing + ([[:blank:]]+) # Pad + ([[:digit:]]{1,4}) # MainCarrierNr + ([[:blank:]]+) # Pad + (0|1|2|3) # NrCSCCH + ([[:blank:]]+) # Pad + (15|20|25|30|35|40|45) # MSTxPwrMax + ([[:blank:]]+) # Pad + (\-125|\-120|\-115|\-110|\-105|\-100|\-95|\-90|\-85|\-80|\-75|\-70|\-65|\-60|\-55|\-50) + # RxLevAccessMin + ([[:blank:]]+) # Pad + (\-53|\-51|\-49|\-47|\-45|\-43|\-41|\-39|\-37|\-35|\-33|\-31|\-29|\-27|\-25|\-23) + # AccessParameter + ([[:blank:]]+) # Pad + (DISABLE|[[:digit:]]{3,4}) # RadioDLTimeout + ([[:blank:]]+) # Pad + (\-[[:digit:]]{2,3}) # RSSIThreshold + ([[:blank:]]+) # Pad + ([[:digit:]]{1,5}) # CCKIdSCKVerNr + ([[:blank:]]+) # Pad + ([[:digit:]]{1,5}) # LocationArea + ([[:blank:]]+) # Pad + ([(1|0)]{16}) # SubscriberClass + ([[:blank:]]+) # Pad + ([(1|0)]{12}) # BSServiceDetails + ([[:blank:]]+) # Pad + (RANDOMIZE|IMMEDIATE|[[:digit:]]{1,2}) # IMM + ([[:blank:]]+) # Pad + ([[:digit:]]{1,2}) # WT + ([[:blank:]]+) # Pad + ([[:digit:]]{1,2}) # Nu + ([[:blank:]]+) # Pad + ([0-1]) # FrameLngFctr + ([[:blank:]]+) # Pad + ([[:digit:]]{1,2}) # TSPtr + ([[:blank:]]+) # Pad + ([0-7]) # MinPriority + ([[:blank:]]+) # Pad + (PASS|TRUE|FAIL|FALSE) # ExtdSrvcsEnabled + ([[:blank:]]+) # Pad + (.*) # ConditionalFields + }] 0 +} 68 +test reg-33.16.1 {Bug [8d2c0da36d]- another "in the wild" RE} { + lindex [regexp -about "^MRK:client1: =1339 14HKelly Talisman 10011000 (\[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]*) \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 8 0 8 0 0 0 77 77 1 1 2 0 11 { 1 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 13HC6 My Creator 2 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 31HC7 Slightly offensive name, huh 3 8 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 23HE-mail:kelly@hotbox.com 4 9 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 17Hcompface must die 5 10 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 3HAir 6 12 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 14HPGP public key 7 13 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 16Hkelly@hotbox.com 8 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 12H2 text/plain 9 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 13H2 x-kom/basic 10 33 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H0 11 14 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H3 }\r?"] 0 +} 1 + +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 return diff --git a/tests/regexp.test b/tests/regexp.test index 7cafd1b..842789e 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -4,21 +4,35 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } unset -nocomplain foo testConstraint exec [llength [info commands exec]] + +# Used for constraining memory leak tests +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc memtest script { + set end [lindex [split [memory info] \n] 3 3] + for {set i 0} {$i < 5} {incr i} { + uplevel 1 $script + set tmp $end + set end [lindex [split [memory info] \n] 3 3] + } + expr {$end - $tmp} + } +} test regexp-1.1 {basic regexp operation} { regexp ab*c abbbc @@ -178,6 +192,17 @@ test regexp-3.7 {getting substrings back from regexp} { set foo 1; set f2 1; set f3 1; set f4 1 list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 } {1 {1 2} {1 1} {-1 -1} {2 2}} +test regexp-3.8a {-indices by multi-byte utf-8} { + regexp -inline -indices {(\w+)-(\w+)} \ + "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442" +} {{0 10} {0 3} {5 10}} +test regexp-3.8b {-indices by multi-byte utf-8, from -start position} { + list\ + [regexp -inline -indices -start 3 {(\w+)-(\w+)} \ + "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] \ + [regexp -inline -indices -start 4 {(\w+)-(\w+)} \ + "gr\u00FC\u00DF-\u043F\u0440\u0438\u0432\u0435\u0442"] +} {{{3 10} {3 3} {5 10}} {}} test regexp-4.1 {-nocase option to regexp} { regexp -nocase foo abcFOo @@ -241,13 +266,13 @@ test regexp-5.5 {exercise cache of compiled expressions} { test regexp-6.1 {regexp errors} { list [catch {regexp a} msg] $msg -} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} +} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexp-6.2 {regexp errors} { list [catch {regexp -nocase a} msg] $msg -} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} +} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexp-6.3 {regexp errors} { list [catch {regexp -gorp a} msg] $msg -} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} +} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexp-6.4 {regexp errors} { list [catch {regexp a( b} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} @@ -441,19 +466,19 @@ test regexp-10.5 {inverse partial newline sensitivity in regsub} { test regexp-11.1 {regsub errors} { list [catch {regsub a b} msg] $msg -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.2 {regsub errors} { list [catch {regsub -nocase a b} msg] $msg -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.3 {regsub errors} { list [catch {regsub -nocase -all a b} msg] $msg -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.4 {regsub errors} { list [catch {regsub a b c d e f} msg] $msg -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.5 {regsub errors} { list [catch {regsub -gorp a b c} msg] $msg -} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} +} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexp-11.6 {regsub errors} { list [catch {regsub -nocase a( b c d} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} @@ -480,7 +505,7 @@ test regexp-11.12 {regsub without final variable name returns value} { } {a,bcd,c,ea,bcfd,cf,e} # This test crashes on the Mac unless you increase the Stack Space to about 1 -# Meg. This is probably bigger than most users want... +# Meg. This is probably bigger than most users want... # 8.2.3 regexp reduced stack space requirements, but this should be # tested again test regexp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} { @@ -528,133 +553,133 @@ test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -co removeFile junk.tcl } -result 1 -test regexp-15.1 {regexp -start} { +test regexp-15.1 {regexp -start} -body { unset -nocomplain x list [regexp -start -10 {\d} 1abc2de3 x] $x -} {1 1} -test regexp-15.2 {regexp -start} { +} -result {1 1} +test regexp-15.2 {regexp -start} -body { unset -nocomplain x list [regexp -start 2 {\d} 1abc2de3 x] $x -} {1 2} -test regexp-15.3 {regexp -start} { +} -result {1 2} +test regexp-15.3 {regexp -start} -body { unset -nocomplain x list [regexp -start 4 {\d} 1abc2de3 x] $x -} {1 2} -test regexp-15.4 {regexp -start} { +} -result {1 2} +test regexp-15.4 {regexp -start} -body { unset -nocomplain x list [regexp -start 5 {\d} 1abc2de3 x] $x -} {1 3} -test regexp-15.5 {regexp -start, over end of string} { +} -result {1 3} +test regexp-15.5 {regexp -start, over end of string} -body { unset -nocomplain x list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x] -} {0 0} -test regexp-15.6 {regexp -start, loss of ^$ behavior} { +} -result {0 0} +test regexp-15.6 {regexp -start, loss of ^$ behavior} -body { list [regexp -start 2 {^$} {}] -} {0} -test regexp-15.7 {regexp -start, double option} { +} -result {0} +test regexp-15.7 {regexp -start, double option} -body { regexp -start 2 -start 0 a abc -} 1 -test regexp-15.8 {regexp -start, double option} { +} -result 1 +test regexp-15.8 {regexp -start, double option} -body { regexp -start 0 -start 2 a abc -} 0 -test regexp-15.9 {regexp -start, end relative index} { +} -result 0 +test regexp-15.9 {regexp -start, end relative index} -body { unset -nocomplain x list [regexp -start end {\d} 1abc2de3 x] [info exists x] -} {0 0} -test regexp-15.10 {regexp -start, end relative index} { +} -result {0 0} +test regexp-15.10 {regexp -start, end relative index} -body { unset -nocomplain x list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x -} {1 1 3} -test regexp-15.11 {regexp -start, over end of string} { +} -result {1 1 3} +test regexp-15.11 {regexp -start, over end of string} -body { set x NA list [regexp -start 2 {.*} ab x] $x -} {1 {}} +} -result {1 {}} -test regexp-16.1 {regsub -start} { +test regexp-16.1 {regsub -start} -body { unset -nocomplain x list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x -} {4 a1b/2c/3d/4e/5} -test regexp-16.2 {regsub -start} { +} -result {4 a1b/2c/3d/4e/5} +test regexp-16.2 {regsub -start} -body { unset -nocomplain x list [regsub -all -start -25 {z} hello {/&} x] $x -} {0 hello} -test regexp-16.3 {regsub -start} { +} -result {0 hello} +test regexp-16.3 {regsub -start} -body { unset -nocomplain x list [regsub -all -start 3 {z} hello {/&} x] $x -} {0 hello} -test regexp-16.4 {regsub -start, \A behavior} { +} -result {0 hello} +test regexp-16.4 {regsub -start, \A behavior} -body { set out {} lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x -} {5 /a/b/c/d/e 3 ab/c/d/e} -test regexp-16.5 {regsub -start, double option} { +} -result {5 /a/b/c/d/e 3 ab/c/d/e} +test regexp-16.5 {regsub -start, double option} -body { list [regsub -start 2 -start 0 a abc c x] $x -} {1 cbc} -test regexp-16.6 {regsub -start, double option} { +} -result {1 cbc} +test regexp-16.6 {regsub -start, double option} -body { list [regsub -start 0 -start 2 a abc c x] $x -} {0 abc} -test regexp-16.7 {regexp -start, end relative index} { +} -result {0 abc} +test regexp-16.7 {regexp -start, end relative index} -body { list [regsub -start end a aaa b x] $x -} {0 aaa} -test regexp-16.8 {regexp -start, end relative index} { +} -result {0 aaa} +test regexp-16.8 {regexp -start, end relative index} -body { list [regsub -start end-1 a aaa b x] $x -} {1 aab} -test regexp-16.9 {regsub -start and -all} { +} -result {1 aab} +test regexp-16.9 {regsub -start and -all} -body { set foo {} list [regsub -start 0 -all x+ axxxbxx |&| foo] $foo -} {2 a|xxx|b|xx|} -test regexp-16.10 {regsub -start and -all} { +} -result {2 a|xxx|b|xx|} +test regexp-16.10 {regsub -start and -all} -body { set foo {} list [regsub -start 1 -all x+ axxxbxx |&| foo] $foo -} {2 a|xxx|b|xx|} -test regexp-16.11 {regsub -start and -all} { +} -result {2 a|xxx|b|xx|} +test regexp-16.11 {regsub -start and -all} -body { set foo {} list [regsub -start 4 -all x+ axxxbxx |&| foo] $foo -} {1 axxxb|xx|} -test regexp-16.12 {regsub -start} { +} -result {1 axxxb|xx|} +test regexp-16.12 {regsub -start} -body { set foo {} list [regsub -start 4 x+ axxxbxx |&| foo] $foo -} {1 axxxb|xx|} -test regexp-16.13 {regsub -start and -all} { +} -result {1 axxxb|xx|} +test regexp-16.13 {regsub -start and -all} -body { set foo {} list [regsub -start 1 -all a+ "" & foo] $foo -} {0 {}} -test regexp-16.14 {regsub -start} { +} -result {0 {}} +test regexp-16.14 {regsub -start} -body { set foo {} list [regsub -start 1 a+ "" & foo] $foo -} {0 {}} -test regexp-16.15 {regsub -start and -all} { +} -result {0 {}} +test regexp-16.15 {regsub -start and -all} -body { set foo {} list [regsub -start 2 -all a+ "xy" & foo] $foo -} {0 xy} -test regexp-16.16 {regsub -start} { +} -result {0 xy} +test regexp-16.16 {regsub -start} -body { set foo {} list [regsub -start 2 a+ "xy" & foo] $foo -} {0 xy} -test regexp-16.17 {regsub -start and -all} { +} -result {0 xy} +test regexp-16.17 {regsub -start and -all} -body { set foo {} list [regsub -start 1 -all y+ "xy" & foo] $foo -} {1 xy} -test regexp-16.18 {regsub -start} { +} -result {1 xy} +test regexp-16.18 {regsub -start} -body { set foo {} list [regsub -start 1 y+ "xy" & foo] $foo -} {1 xy} -test regexp-16.19 {regsub -start} { +} -result {1 xy} +test regexp-16.19 {regsub -start} -body { set foo {} list [regsub -start -1 a+ "" & foo] $foo -} {0 {}} -test regexp-16.20 {regsub -start, loss of ^$ behavior} { +} -result {0 {}} +test regexp-16.20 {regsub -start, loss of ^$ behavior} -body { set foo NA list [regsub -start 1 {^$} {} & foo] $foo -} {0 {}} -test regexp-16.21 {regsub -start, loss of ^$ behavior} { +} -result {0 {}} +test regexp-16.21 {regsub -start, loss of ^$ behavior} -body { set foo NA list [regsub -start 1 {^.*$} abc & foo] $foo -} {0 abc} -test regexp-16.22 {regsub -start, loss of ^$ behavior} { +} -result {0 abc} +test regexp-16.22 {regsub -start, loss of ^$ behavior} -body { set foo NA list [regsub -all -start 1 {^.*$} abc & foo] $foo -} {0 abc} +} -result {0 abc} test regexp-17.1 {regexp -inline} { regexp -inline b ababa @@ -740,45 +765,45 @@ test regexp-19.2 {regsub null replacement} { string equal $result $expected } 1 -test regexp-20.1 {regsub shared object shimmering} { +test regexp-20.1 {regsub shared object shimmering} -body { # Bug #461322 - set a abcdefghijklmnopqurstuvwxyz - set b $a - set c abcdefghijklmnopqurstuvwxyz0123456789 - regsub $a $c $b d + set a abcdefghijklmnopqurstuvwxyz + set b $a + set c abcdefghijklmnopqurstuvwxyz0123456789 + regsub $a $c $b d list $d [string length $d] [string bytelength $d] -} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] -test regexp-20.2 {regsub shared object shimmering with -about} { +} -result [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] +test regexp-20.2 {regsub shared object shimmering with -about} -body { eval regexp -about abc -} {0 {}} +} -result {0 {}} -test regexp-21.1 {regsub works with empty string} { +test regexp-21.1 {regsub works with empty string} -body { regsub -- ^ {} foo -} {foo} -test regexp-21.2 {regsub works with empty string} { +} -result {foo} +test regexp-21.2 {regsub works with empty string} -body { regsub -- \$ {} foo -} {foo} -test regexp-21.3 {regsub works with empty string offset} { +} -result {foo} +test regexp-21.3 {regsub works with empty string offset} -body { regsub -start 0 -- ^ {} foo -} {foo} -test regexp-21.4 {regsub works with empty string offset} { +} -result {foo} +test regexp-21.4 {regsub works with empty string offset} -body { regsub -start 0 -- \$ {} foo -} {foo} -test regexp-21.5 {regsub works with empty string offset} { +} -result {foo} +test regexp-21.5 {regsub works with empty string offset} -body { regsub -start 3 -- \$ {123} foo -} {123foo} -test regexp-21.6 {regexp works with empty string} { +} -result {123foo} +test regexp-21.6 {regexp works with empty string} -body { regexp -- ^ {} -} {1} -test regexp-21.7 {regexp works with empty string} { +} -result {1} +test regexp-21.7 {regexp works with empty string} -body { regexp -start 0 -- ^ {} -} {1} -test regexp-21.8 {regexp works with empty string offset} { +} -result {1} +test regexp-21.8 {regexp works with empty string offset} -body { regexp -start 3 -- ^ {123} -} {0} -test regexp-21.9 {regexp works with empty string offset} { +} -result {0} +test regexp-21.9 {regexp works with empty string offset} -body { regexp -start 3 -- \$ {123} -} {1} +} -result {1} test regexp-21.10 {multiple matches handle newlines} { regsub -all -lineanchor -- {^#[^\n]*\n} "#one\n#two\n#three\n" foo\n } "foo\nfoo\nfoo\n" @@ -819,6 +844,67 @@ test regexp-22.1 {Bug 1810038} { test regexp-22.2 {regexp compile and backrefs, Bug 1857126} { regexp -- {([bc])\1} bb } 1 +test regexp-22.3 {Bug 3604074} { + # This will hang in interps where the bug is not fixed + regexp ((((((((a)*)*)*)*)*)*)*)* a +} 1 +test regexp-22.4 {Bug 3606139} -setup { + interp alias {} a {} string repeat a +} -body { + # This crashes in interps where the bug is not fixed + regexp [join [list [a 160]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 649]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 672]([a 55])[a 669]([a 55])[a 671]([a 55])[a 671]([a 55]) \ + [a 672]([a 55])[a 652]([a 55])[a 672]([a 55])[a 671]([a 55]) \ + [a 671]([a 55])[a 671]([a 55])[a 653]([a 55])[a 672]([a 55]) \ + [a 653]([a 55])[a 672]([a 55])[a 672]([a 55])[a 652]([a 55]) \ + [a 671]([a 55])[a 652]([a 55])[a 652]([a 55])[a 672]([a 55]) \ + [a 672]([a 55])[a 672]([a 55])[a 653]([a 55])[a 671]([a 55]) \ + [a 669]([a 55])[a 649]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 650]([a 55])[a 650]([a 55])[a 672]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 672]([a 55])[a 669]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 672]([a 55]) \ + [a 670]([a 55])[a 671]([a 55])[a 672]([a 55])[a 672]([a 55]) \ + [a 671]([a 55])[a 671]([a 55])[a 672]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 669]([a 55])[a 668]([a 55])[a 669]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 672]([a 55])[a 669]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 672]([a 55])[a 669]([a 55])[a 669]([a 55])[a 710]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 672]([a 55])[a 669]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 667]([a 55])[a 668]([a 55])[a 669]([a 55])[a 668]([a 55]) \ + [a 671]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 669]([a 55])[a 669]([a 55])[a 668]([a 55])[a 669]([a 55]) \ + [a 668]([a 55])[a 710]([a 55])[a 668]([a 55])[a 668]([a 55]) \ + [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 511]] {}] a +} -cleanup { + rename a {} +} -returnCodes 1 -match glob -result {couldn't compile regular expression pattern: *} +test regexp-22.5 {Bug 3610026} -setup { + set e {} + set cp 99 + while {$cp < 32864} { + append e [format %c [incr cp]] + } +} -body { + regexp -about $e +} -cleanup { + unset -nocomplain e cp +} -returnCodes error -match glob -result {*too many colors*} +test regexp-22.6 {Bug 6585b21ca8} { + expr {[regexp {(\w).*?\1} Programmer m] ? $m : "<NONE>"} +} rogr + test regexp-23.1 {regexp -all and -line} { set string "" @@ -1021,13 +1107,13 @@ test regexp-26.1 {matches start of line 1 time} { test regexp-26.2 {matches start of line(s) 2 times} { regexp -all -inline -line -- {^a+} "aab\naaa" } {aa aaa} -test regexp-26.3 {effect of -line -all and -start} { +test regexp-26.3 {effect of -line -all and -start} -body { list \ [regexp -all -inline -line -start 0 -- {^a+} "aab\naaa"] \ [regexp -all -inline -line -start 1 -- {^a+} "aab\naaa"] \ [regexp -all -inline -line -start 3 -- {^a+} "aab\naaa"] \ [regexp -all -inline -line -start 4 -- {^a+} "aab\naaa"] \ -} {{aa aaa} aaa aaa aaa} +} -result {{aa aaa} aaa aaa aaa} # No regexp-26.4 test regexp-26.5 {match length 0, match length 1} { regexp -all -inline -line -- {^b*} "a\nb" @@ -1062,6 +1148,57 @@ test regexp-26.12 {regexp with -line option} { test regexp-26.13 {regexp without -line option} { regexp -all -inline -- {a*} "b\n" } {{} {}} + +test regexp-27.1 {regsub -command} { + regsub -command {.x.} {abcxdef} {string length} +} ab3ef +test regexp-27.2 {regsub -command} { + regsub -command {.x.} {abcxdefxghi} {string length} +} ab3efxghi +test regexp-27.3 {regsub -command} { + set x 0 + regsub -all -command {(?=.)} abcde {apply {args {incr ::x}}} +} 1a2b3c4d5e +test regexp-27.4 {regsub -command} -body { + regsub -command {.x.} {abcxdef} error +} -returnCodes error -result cxd +test regexp-27.5 {regsub -command} { + regsub -command {(.)(.)} {abcdef} {list ,} +} {, ab a bcdef} +test regexp-27.6 {regsub -command} { + regsub -command -all {(.)(.)} {abcdef} {list ,} +} {, ab a b, cd c d, ef e f} +test regexp-27.7 {regsub -command representation smash} { + set ::s {123=456 789} + regsub -command -all {\d+} $::s {apply {n { + expr {[llength $::s] + $n} + }}} +} {125=458 791} +test regexp-27.8 {regsub -command representation smash} { + set ::t {apply {n { + expr {[llength [lindex $::t 1 1 1]] + $n} + }}} + regsub -command -all {\d+} "123=456 789" $::t +} {131=464 797} +test regexp-27.9 {regsub -command memory leak testing} memory { + set ::s "123=456 789" + set ::t {apply {n { + expr {[llength [lindex $::t 1 1 1]] + [llength $::s] + $n} + }}} + memtest { + regsub -command -all {\d+} $::s $::t + } +} 0 +test regexp-27.10 {regsub -command error cases} -returnCodes error -body { + regsub -command . abc "def \{ghi" +} -result {unmatched open brace in list} +test regexp-27.11 {regsub -command error cases} -returnCodes error -body { + regsub -command . abc {} +} -result {command prefix must be a list of at least one element} +test regexp-27.12 {regsub -command representation smash} { + set s {list (.+)} + regsub -command $s {list list} $s +} {(.+) {list list} list} # cleanup ::tcltest::cleanupTests diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 94fb90e..4dfc2e6 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -22,7 +22,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { proc evalInProc { script } { proc testProc {} $script set status [catch { - testProc + testProc } result] rename testProc {} return $result @@ -316,17 +316,17 @@ test regexpComp-6.1 {regexp errors} { evalInProc { list [catch {regexp a} msg] $msg } -} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} +} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexpComp-6.2 {regexp errors} { evalInProc { list [catch {regexp -nocase a} msg] $msg } -} {1 {wrong # args: should be "regexp ?-switch ...? exp string ?matchVar? ?subMatchVar ...?"}} +} {1 {wrong # args: should be "regexp ?-option ...? exp string ?matchVar? ?subMatchVar ...?"}} test regexpComp-6.3 {regexp errors} { evalInProc { list [catch {regexp -gorp a} msg] $msg } -} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} +} {1 {bad option "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexpComp-6.4 {regexp errors} { evalInProc { list [catch {regexp a( b} msg] $msg @@ -526,6 +526,11 @@ test regexpComp-9.6 {-all option to regsub} { list [regsub -all ^ xxx 123 foo] $foo } } {1 123xxx} +test regexpComp-9.7 {Bug 84af1192f5: -all option to regsub} { + evalInProc { + regsub -all {\(.*} 123(qwe) "" + } +} 123 test regexpComp-10.1 {expanded syntax in regsub} { evalInProc { @@ -562,27 +567,27 @@ test regexpComp-11.1 {regsub errors} { evalInProc { list [catch {regsub a b} msg] $msg } -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.2 {regsub errors} { evalInProc { list [catch {regsub -nocase a b} msg] $msg } -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.3 {regsub errors} { evalInProc { list [catch {regsub -nocase -all a b} msg] $msg } -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.4 {regsub errors} { evalInProc { list [catch {regsub a b c d e f} msg] $msg } -} {1 {wrong # args: should be "regsub ?-switch ...? exp string subSpec ?varName?"}} +} {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexpComp-11.5 {regsub errors} { evalInProc { list [catch {regsub -gorp a b c} msg] $msg } -} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} +} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexpComp-11.6 {regsub errors} { evalInProc { list [catch {regsub -nocase a( b c d} msg] $msg @@ -602,7 +607,7 @@ test regexpComp-11.8 {regsub errors, -start bad int check} { } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} # This test crashes on the Mac unless you increase the Stack Space to about 1 -# Meg. This is probably bigger than most users want... +# Meg. This is probably bigger than most users want... # 8.2.3 regexp reduced stack space requirements, but this should be # tested again test regexpComp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} { @@ -660,54 +665,54 @@ test regexpComp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} removeFile junk.tcl } -result 1 -test regexpComp-15.1 {regexp -start} { +test regexpComp-15.1 {regexp -start} -body { unset -nocomplain x list [regexp -start -10 {\d} 1abc2de3 x] $x -} {1 1} -test regexpComp-15.2 {regexp -start} { +} -result {1 1} +test regexpComp-15.2 {regexp -start} -body { unset -nocomplain x list [regexp -start 2 {\d} 1abc2de3 x] $x -} {1 2} -test regexpComp-15.3 {regexp -start} { +} -result {1 2} +test regexpComp-15.3 {regexp -start} -body { unset -nocomplain x list [regexp -start 4 {\d} 1abc2de3 x] $x -} {1 2} -test regexpComp-15.4 {regexp -start} { +} -result {1 2} +test regexpComp-15.4 {regexp -start} -body { unset -nocomplain x list [regexp -start 5 {\d} 1abc2de3 x] $x -} {1 3} -test regexpComp-15.5 {regexp -start, over end of string} { +} -result {1 3} +test regexpComp-15.5 {regexp -start, over end of string} -body { unset -nocomplain x list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x] -} {0 0} -test regexpComp-15.6 {regexp -start, loss of ^$ behavior} { +} -result {0 0} +test regexpComp-15.6 {regexp -start, loss of ^$ behavior} -body { list [regexp -start 2 {^$} {}] -} {0} +} -result {0} -test regexpComp-16.1 {regsub -start} { +test regexpComp-16.1 {regsub -start} -body { unset -nocomplain x list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x -} {4 a1b/2c/3d/4e/5} -test regexpComp-16.2 {regsub -start} { +} -result {4 a1b/2c/3d/4e/5} +test regexpComp-16.2 {regsub -start} -body { unset -nocomplain x list [regsub -all -start -25 {z} hello {/&} x] $x -} {0 hello} -test regexpComp-16.3 {regsub -start} { +} -result {0 hello} +test regexpComp-16.3 {regsub -start} -body { unset -nocomplain x list [regsub -all -start 3 {z} hello {/&} x] $x -} {0 hello} -test regexpComp-16.4 {regsub -start, \A behavior} { +} -result {0 hello} +test regexpComp-16.4 {regsub -start, \A behavior} -body { set out {} lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x -} {5 /a/b/c/d/e 3 ab/c/d/e} +} -result {5 /a/b/c/d/e 3 ab/c/d/e} -test regexpComp-17.1 {regexp -inline} { +test regexpComp-17.1 {regexp -inline} -body { regexp -inline b ababa -} {b} -test regexpComp-17.2 {regexp -inline} { +} -result {b} +test regexpComp-17.2 {regexp -inline} -body { regexp -inline (b) ababa -} {b b} +} -result {b b} test regexpComp-17.3 {regexp -inline -indices} { regexp -inline -indices (b) ababa } {{1 1} {1 1}} @@ -789,10 +794,10 @@ test regexpComp-19.1 {regsub null replacement} { test regexpComp-20.1 {regsub shared object shimmering} { evalInProc { # Bug #461322 - set a abcdefghijklmnopqurstuvwxyz - set b $a - set c abcdefghijklmnopqurstuvwxyz0123456789 - regsub $a $c $b d + set a abcdefghijklmnopqurstuvwxyz + set b $a + set c abcdefghijklmnopqurstuvwxyz0123456789 + regsub $a $c $b d list $d [string length $d] [string bytelength $d] } } [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] diff --git a/tests/registry.test b/tests/registry.test index 77588e3..4fc96bf 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -7,11 +7,11 @@ # In order for these tests to run, the registry package must be on the # auto_path or the registry package must have been loaded already. # -# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. All rights reserved. +# Copyright © 1998-1999 Scriptics Corporation. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -19,11 +19,12 @@ testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::regver [package require registry 1.3.0] + set ::regver [package require registry 1.3.6] }]} { testConstraint reg 1 } } +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] # determine the current locale testConstraint english [expr { @@ -33,7 +34,7 @@ testConstraint english [expr { test registry-1.0 {check if we are testing the right dll} {win reg} { set ::regver -} {1.3.0} +} {1.3.6} test registry-1.1 {argument parsing for registry command} {win reg} { list [catch {registry} msg] $msg } {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} @@ -283,7 +284,7 @@ test registry-4.7 {GetKeyNames: Unicode} {win reg english} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "baz\u00c7bar blat" -test registry-4.8 {GetKeyNames: Unicode} {win reg nt} { +test registry-4.8 {GetKeyNames: Unicode} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u30b7bar registry set HKEY_CURRENT_USER\\TclFoobar\\blat @@ -487,7 +488,7 @@ test registry-6.17 {GetValue: Unicode value names} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } foobar -test registry-6.18 {GetValue: values with Unicode strings} {win reg nt} { +test registry-6.18 {GetValue: values with Unicode strings} {win reg} { registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz set result [registry get HKEY_CURRENT_USER\\TclFoobar val1] registry delete HKEY_CURRENT_USER\\TclFoobar @@ -505,7 +506,7 @@ test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "foo ba r baz" -test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} { +test registry-6.21 {GetValue: very long value names and values} {win reg} { registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]] registry delete HKEY_CURRENT_USER\\TclFoobar @@ -604,7 +605,7 @@ test registry-9.3 {ParseKeyName: bad keys} -constraints {win reg} -body { test registry-9.4 {ParseKeyName: bad keys} -constraints {win reg} -body { registry values \\\\\\ } -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA} -test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english nt} -body { +test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english} -body { registry values \\\\\\HKEY_CLASSES_ROOT } -returnCodes error -result {unable to open key: The network address is invalid.} test registry-9.6 {ParseKeyName: bad keys} -constraints {win reg} -body { @@ -673,10 +674,10 @@ test registry-12.2 {BroadcastValue} -constraints {win reg} -body { test registry-12.3 {BroadcastValue} -constraints {win reg} -body { registry broadcast "" - 500 } -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\"" -test registry-12.4 {BroadcastValue} -constraints {win reg} -body { +test registry-12.4 {BroadcastValue} -constraints {win reg notWine} -body { registry broadcast {Environment} } -result {1 0} -test registry-12.5 {BroadcastValue} -constraints {win reg} -body { +test registry-12.5 {BroadcastValue} -constraints {win reg notWine} -body { registry b {} } -result {1 0} diff --git a/tests/remote.tcl b/tests/remote.tcl index 097e41f..6bc4b17 100644 --- a/tests/remote.tcl +++ b/tests/remote.tcl @@ -4,7 +4,7 @@ # # Source this file in the remote server you are using to test Tcl against. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright © 1995-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -91,8 +91,8 @@ if {![info exists serverPort]} { if {![info exists serverPort]} { for {set i 0} {$i < $argc} {incr i} { if {[string compare -port [lindex $argv $i]] == 0} { - if {$i < [expr $argc - 1]} { - set serverPort [lindex $argv [expr $i + 1]] + if {$i < $argc - 1} { + set serverPort [lindex $argv [expr {$i + 1}]] } break } @@ -110,8 +110,8 @@ if {![info exists serverAddress]} { if {![info exists serverAddress]} { for {set i 0} {$i < $argc} {incr i} { if {[string compare -address [lindex $argv $i]] == 0} { - if {$i < [expr $argc - 1]} { - set serverAddress [lindex $argv [expr $i + 1]] + if {$i < $argc - 1} { + set serverAddress [lindex $argv [expr {$i + 1}]] } break } diff --git a/tests/rename.test b/tests/rename.test index 1fa0441..9b8f9a0 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -4,20 +4,20 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testdel [llength [info commands testdel]] @@ -140,6 +140,13 @@ test rename-4.7 {reentrancy issues with command deletion and renaming} testdel { if {[info exists env(value)]} { unset env(value) } +test rename-4.8 {Bug a16752c252} testdel { + set x broken + testdel {} foo {set x ok} + proc foo args {} + rename foo {} + return -level 0 $x[unset x] +} ok # Save the unknown procedure which is modified by the following test. diff --git a/tests/resolver.test b/tests/resolver.test index e73ea50..51df07c 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -4,19 +4,19 @@ # in the reusing context. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at> -# Copyright (c) 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at> +# Copyright © 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at> +# Copyright © 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at> # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testinterpresolver [llength [info commands testinterpresolver]] @@ -135,14 +135,14 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s z } } + namespace eval :: { + variable r2 "" + } } -constraints testinterpresolver -body { - set r0 [namespace eval ::ns2 {x}] - set r1 [namespace eval ::ns2 {z}] - namespace eval ::ns2 { + list [namespace eval ::ns2 {x}] [namespace eval ::ns2 {z}] [namespace eval ::ns2 { namespace import ::ns1::z - set r2 [z] - } - list $r0 $r1 $r2 + z + }] } -cleanup { testinterpresolver down namespace delete ::ns2 @@ -184,7 +184,7 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup { # During the compilation the compiled var resolver, the resolve-specific # var info is allocated, during the execution of the body, the variable is # fetched and cached. - x; + x # During later calls, the cached variable is reused. x # When the proc is freed, the resolver-specific resolver var info is @@ -193,6 +193,121 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup { } -cleanup { testinterpresolver down } -result {} + + +# +# The test resolver-3.1* test bad interactions of resolvers on the "global" +# (per interp) literal pools. A resolver might resolve a cmd literal depending +# on a context differently, whereas the cmd literal sharing assumed that the +# namespace containing the literal solely determines the resolved cmd (and is +# resolver-agnostic). +# +# In order to make the test cases for the per-interpreter cmd literal pool +# reproducable and to minimize interactions between test cases, we use a child +# interpreter per test-case. +# +# +# Testing resolver in namespace-based context "ctx1" +# +test resolver-3.1a { + interp command resolver, + resolve literal "z" in proc "x1" in context "ctx1" +} -setup { + + interp create i0 + testinterpresolver up i0 + i0 eval { + proc y {} { return yy } + namespace eval ::ns { + proc x1 {} { z } + } + } +} -constraints testinterpresolver -body { + + set r [i0 eval {namespace eval ::ctx1 { + ::ns::x1 + }}] + + return $r +} -cleanup { + testinterpresolver down i0 + interp delete i0 +} -result {yy} + +# +# Testing resolver in namespace-based context "ctx2" +# +test resolver-3.1b { + interp command resolver, + resolve literal "z" in proc "x2" in context "ctx2" +} -setup { + + interp create i0 + testinterpresolver up i0 + i0 eval { + proc Y {} { return YY } + namespace eval ::ns { + proc x2 {} { z } + } + } +} -constraints testinterpresolver -body { + + set r [i0 eval {namespace eval ::ctx2 { + ::ns::x2 + }}] + + return $r +} -cleanup { + testinterpresolver down i0 + interp delete i0 +} -result {YY} + +# +# Testing resolver in namespace-based context "ctx1" and "ctx2" in the same +# interpreter. +# + +test resolver-3.1c { + interp command resolver, + resolve literal "z" in proc "x1" in context "ctx1", + resolve literal "z" in proc "x2" in context "ctx2" + + Test, whether the shared cmd literal created by the first byte-code + compilation interacts with the second one. +} -setup { + + interp create i0 + testinterpresolver up i0 + + i0 eval { + proc y {} { return yy } + proc Y {} { return YY } + namespace eval ::ns { + proc x1 {} { z } + proc x2 {} { z } + } + } + +} -constraints testinterpresolver -body { + + set r1 [i0 eval {namespace eval ::ctx1 { + ::ns::x1 + }}] + + set r2 [i0 eval {namespace eval ::ctx2 { + ::ns::x2 + }}] + + set r3 [i0 eval {namespace eval ::ctx1 { + ::ns::x1 + }}] + + return [list $r1 $r2 $r3] +} -cleanup { + testinterpresolver down i0 + interp delete i0 +} -result {yy YY yy} + cleanupTests return diff --git a/tests/result.test b/tests/result.test index 3391ce1..845c26e 100644 --- a/tests/result.test +++ b/tests/result.test @@ -4,19 +4,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Some tests require the testsaveresult command @@ -33,7 +33,7 @@ test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} { } {append result} test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 0 -} {dynamic result notCalled present} +} {dynamic result presentOrFreed} test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 0 } {object result same} @@ -45,7 +45,7 @@ test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} { } {42} test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 1 -} {42 called missing} +} {42 presentOrFreed} test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 1 } {42 different} diff --git a/tests/safe-stock.test b/tests/safe-stock.test new file mode 100644 index 0000000..bfea85c --- /dev/null +++ b/tests/safe-stock.test @@ -0,0 +1,248 @@ +# safe-stock.test -- +# +# This file contains tests for safe Tcl that were previously in the file +# safe.test, and use files and packages of stock Tcl 8.7 to perform the tests. +# These files may be changed or disappear in future revisions of Tcl, for +# example package opt will eventually be removed. +# +# The tests are replaced in safe.tcl with tests that use files provided in the +# tests directory. Test numbering is for comparison with similar tests in +# safe.test. +# +# Sourcing this file into tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# The defunct package http 1.0 was convenient for testing package loading. +# - This file, safe-stock.test, uses packages opt and (from cookiejar) +# tcl::idna to provide alternative tests based on stock Tcl packages. +# - These are tests 7.1 7.2 7.4 9.11 9.13 +# - Tests 7.[124], 9.1[13] use "package require opt". +# - Tests 9.1[13] also use "package require tcl::idna". +# - The corresponding tests in safe.test use example packages provided in +# subdirectory auto0 of the tests directory, which are independent of any +# changes made to the packages provided with Tcl. +# +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +foreach i [interp children] { + interp delete $i +} + +# When using package opt for testing positive/negative package search: +# - The directory location and the error message depend on whether +# and how the package is installed. + +# Error message for test 7.2 for "package require opt". +if {[string match *zipfs:/* [info library]]} { + # pkgIndex.tcl is in [info library] + # file to be sourced is in [info library]/opt* + set pkgOptErrMsg {permission denied} +} else { + # pkgIndex.tcl and file to be sourced are + # both in [info library]/opt* + set pkgOptErrMsg {can't find package opt} +} + +# Directory of opt for tests 7.4, 9.10, 9.12 for "package require opt". +if {[file exists [file join [info library] opt0.4]]} { + # Installed files in lib8.7/opt0.4 + set pkgOptDir opt0.4 +} elseif {[file exists [file join [info library] opt]]} { + # Installed files in zipfs, or source files used by "make test" + set pkgOptDir opt +} else { + error {cannot find opt library} +} + +# Directory of cookiejar for tests 9.10, 9.12 for "package require tcl::idna". +if {[file exists [file join [info library] cookiejar0.2]]} { + # Installed files in lib8.7/cookiejar0.2 + set pkgJarDir cookiejar0.2 +} elseif {[file exists [file join [info library] cookiejar]]} { + # Installed files in zipfs, or source files used by "make test" + set pkgJarDir cookiejar +} else { + error {cannot find cookiejar library} +} + +set SaveAutoPath $::auto_path +set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] +set PathMapp {} +lappend PathMapp [file join [info library] $pkgOptDir] TCLLIB/OPTDIR +lappend PathMapp [file join [info library] $pkgJarDir] TCLLIB/JARDIR +lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR + +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} +proc mapAndSortList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + lsort $listOut +} + +# Force actual loading of the safe package because we use un-exported (and +# thus un-autoindexed) APIs in this test result arguments: +catch {safe::interpConfigure} + +# high level general test +test safe-stock-7.1 {tests that everything works at high level, uses pkg opt} -setup { + set i [safe::interpCreate] +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a child works like in the parent) + set v [interp eval $i {package require opt}] + # no error shall occur: + interp eval $i {::tcl::Lempty {a list}} + set v +} -cleanup { + safe::interpDelete $i +} -match glob -result 0.4.* +test safe-stock-7.2 {tests specific path and interpFind/AddToAccessPath, uses pkg opt} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # an error shall occur (opt is not anymore in the secure 0-level + # provided deep path) + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + list $token1 $token2 -- \ + [catch {interp eval $i {package require opt}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -cleanup { +} -match glob -result "{\$p(:0:)} {\$p(:*:)} -- 1 {$pkgOptErrMsg} --\ + {TCLLIB */dummy/unixlike/test/path} -- {}" +test safe-stock-7.4 {tests specific path and positive search, uses pkg opt} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-stock-7.2, opt should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require opt}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 0.4.* --\ + {TCLLIB * TCLLIB/OPTDIR} -- {}} + +# The following test checks whether the definition of tcl_endOfWord can be +# obtained from auto_loading. It was previously test "safe-5.1". +test safe-stock-9.8 {test auto-loading in safe interpreters, was safe-5.1} -setup { + catch {safe::interpDelete a} + safe::interpCreate a +} -body { + interp eval a {tcl_endOfWord "" 0} +} -cleanup { + safe::interpDelete a +} -result -1 +test safe-stock-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, uses pkg opt and tcl::idna} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $tcl_library $pkgOptDir] \ + [file join $tcl_library $pkgJarDir]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + # This has no effect because the records in Pkg of these directories were from access as children of {$p(:0:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $tcl_library $pkgJarDir] \ + [file join $tcl_library $pkgOptDir]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path4 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require tcl::idna}} msg3] + set code4 [catch {interp eval $i {package require opt}} msg4] + set code5 [catch {interp eval $i {::tcl::Lempty {a list}}} msg5] + set code6 [catch {interp eval $i {::tcl::idna::IDNAencode example.com}} msg6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 1.* 0 0.4.* --\ + {TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} --\ + {TCLLIB TCLLIB/JARDIR TCLLIB/OPTDIR*} --\ + 0 0 0 example.com} +test safe-stock-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, uses pkg opt and tcl::idna} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $tcl_library $pkgOptDir] \ + [file join $tcl_library $pkgJarDir]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require opt}} msg3] + set code6 [catch {interp eval $i {package require tcl::idna}} msg6] + + list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ + $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} -- {TCLLIB*}} + +set ::auto_path $SaveAutoPath +unset pkgOptErrMsg pkgOptDir pkgJarDir SaveAutoPath TestsDir PathMapp +rename mapList {} +rename mapAndSortList {} +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/tests/safe-stock86.test diff --git a/tests/safe-zipfs.test b/tests/safe-zipfs.test new file mode 100644 index 0000000..f67bc43 --- /dev/null +++ b/tests/safe-zipfs.test @@ -0,0 +1,727 @@ +# safe-zipfs.test -- +# +# This file contains tests for safe Tcl that test its compatibility with the +# zipfs facilities introduced in Tcl 8.7. Test numbering is for comparison +# with similar tests in safe.test that do not use the zipfs file system. +# +# Sourcing this file into tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +foreach i [interp children] { + interp delete $i +} + +set SaveAutoPath $::auto_path +set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] + +set ZipMountPoint [zipfs root]auto-files +zipfs mount $ZipMountPoint [file join $TestsDir auto-files.zip] + +set PathMapp {} +lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR $ZipMountPoint ZIPDIR + +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} +proc mapAndSortList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + lsort $listOut +} + +# Force actual loading of the safe package because we use un-exported (and +# thus un-autoindexed) APIs in this test result arguments: +catch {safe::interpConfigure} + +# testing that nested and statics do what is advertised (we use a +# package - tcl::test - but it might be absent if we're in standard tclsh) + +testConstraint tcl::test [expr {![catch {package require tcl::test}]}] + +# Tests 5.* test the example files before using them to test safe interpreters. + +test safe-zipfs-5.1 {example tclIndex commands, test in parent interpreter; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {0 ok1 0 ok2} +test safe-zipfs-5.2 {example tclIndex commands, negative test in parent interpreter; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} +test safe-zipfs-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-zipfs-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-zipfs-5.5 {example modules packages, test in parent interpreter, replace path; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} +test safe-zipfs-5.6 {example modules packages, test in parent interpreter, append to path; zipfs} -setup { + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + +# high level general test +# Use zipped example packages not http1.0 etc +test safe-zipfs-7.1 {tests that everything works at high level; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] + set i [safe::interpCreate] + set ::auto_path $tmpAutoPath +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a child works like in the parent) + set v [interp eval $i {package require SafeTestPackage1}] + # no error shall occur: + interp eval $i {HeresPackage1} + set v +} -cleanup { + safe::interpDelete $i +} -match glob -result 1.2.3 +test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath; zipfs} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # should add as p* (not p2 if parent has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 $token3 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ + 1 {can't find package SafeTestPackage1} --\ + {TCLLIB */dummy/unixlike/test/path ZIPDIR/auto0} -- {}} +test safe-zipfs-7.4 {tests specific path and positive search; zipfs} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-zipfs-7.2, SafeTestPackage1 should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ + {TCLLIB * ZIPDIR/auto0/auto1} -- {}} + +test safe-zipfs-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset); zipfs} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}} +test safe-zipfs-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset); zipfs} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 ok1 0 ok2 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}} +test safe-zipfs-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement; zipfs} -setup { +} -body { + # For complete correspondence to safe-stock87-9.11, include auto0 in access path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0] \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0] \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-zipfs-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0; zipfs} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 1.2.3 0 2.3.4 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-zipfs-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed; zipfs} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ + $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB*}} +test safe-zipfs-9.20 {check module loading; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} -- res0 res1 res2} +# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in +# tokenized form to the child's access path, and then adds all the +# descendants, discovered recursively by using glob. +# - The order of the directories in the list returned by glob is system-dependent, +# and therefore this is true also for (a) the order of token assignment to +# descendants of the [tcl::tm::list] roots; and (b) the order of those same +# directories in the access path. Both those things must be sorted before +# comparing with expected results. The test is therefore not totally strict, +# but will notice missing or surplus directories. +test safe-zipfs-9.21 {interpConfigure change the access path; check module loading; stale data case 1; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-zipfs-9.20. +test safe-zipfs-9.22 {interpConfigure change the access path; check module loading; stale data case 0; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-zipfs-9.20. +test safe-zipfs-9.23 {interpConfigure change the access path; check module loading; stale data case 3; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-zipfs-9.20. +test safe-zipfs-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case); zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-zipfs-9.20. + +# cleanup +set ::auto_path $SaveAutoPath +zipfs unmount ${ZipMountPoint} +unset SaveAutoPath TestsDir ZipMountPoint PathMapp +rename mapList {} +rename mapAndSortList {} +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/safe.test b/tests/safe.test index 4a2792e..db881c2 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -4,47 +4,72 @@ # using safe interpreters. Sourcing this file into tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# The defunct package http 1.0 was convenient for testing package loading. +# - Tests that used http are replaced here with tests that use example packages +# provided in subdirectory auto0 of the tests directory, which are independent +# of any changes made to the packages provided with Tcl itself. +# - These are tests 7.1 7.2 7.4 9.11 9.13 +# - Tests 5.* test the example packages themselves before they +# are used to test Safe Base interpreters. +# - Alternative tests using stock packages of Tcl 8.7 are in file +# safe-stock.test. +# +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5 - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } -set saveAutoPath $::auto_path +set SaveAutoPath $::auto_path set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] +set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR] + +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} +proc mapAndSortList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + lsort $listOut +} -# Force actual loading of the safe package because we use un exported (and +# Force actual loading of the safe package because we use un-exported (and # thus un-autoindexed) APIs in this test result arguments: catch {safe::interpConfigure} # testing that nested and statics do what is advertised (we use a static -# package - Tcltest - but it might be absent if we're in standard tclsh) +# package - tcl::test - but it might be absent if we're in standard tclsh) -testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] +testConstraint tcl::test [expr {![catch {package require tcl::test}]}] test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body { safe::interpConfigure -} -result {no value given for parameter "slave" (use -help for full usage) : - slave name () name of the slave} +} -result {no value given for parameter "child" (use -help for full usage) : + child name () name of the child} test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body { safe::interpCreate -help } -result {Usage information: Var/FlagName Type Value Help ------------ ---- ----- ---- (-help gives this help) - ?slave? name () name of the slave (optional) - -accessPath list () access path for the slave + ?child? name () name of the child (optional) + -accessPath list () access path for the child -noStatics boolflag (false) prevent loading of statically linked pkgs -statics boolean (true) loading of statically linked pkgs -nestedLoadOk boolflag (false) allow nested loading @@ -53,7 +78,7 @@ test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body { test safe-1.3 {safe::interpInit syntax} -returnCodes error -body { safe::interpInit -noStatics } -result {bad value "-noStatics" for parameter - slave name () name of the slave} + child name () name of the child} test safe-2.1 {creating interpreters, should have no aliases} emptyTest { # Disabled this test. It tests nothing sensible. [Bug 999612] @@ -66,6 +91,8 @@ test safe-2.2 {creating interpreters, should have no aliases} -setup { a aliases } -cleanup { safe::interpDelete a + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -setup { catch {safe::interpDelete a} @@ -74,7 +101,7 @@ test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -s lsort [a aliases] } -cleanup { interp delete a -} -result {::tcl::mathfunc::max ::tcl::mathfunc::min clock} +} -result {clock} test safe-3.1 {calling safe::interpInit is safe} -setup { catch {safe::interpDelete a} @@ -92,7 +119,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} -setup { lsort [a aliases] } -cleanup { safe::interpDelete a -} -result {::tcl::file::atime ::tcl::file::attributes ::tcl::file::copy ::tcl::file::delete ::tcl::file::dirname ::tcl::file::executable ::tcl::file::exists ::tcl::file::extension ::tcl::file::isdirectory ::tcl::file::isfile ::tcl::file::link ::tcl::file::lstat ::tcl::file::mkdir ::tcl::file::mtime ::tcl::file::nativename ::tcl::file::normalize ::tcl::file::owned ::tcl::file::readable ::tcl::file::readlink ::tcl::file::rename ::tcl::file::rootname ::tcl::file::size ::tcl::file::stat ::tcl::file::tail ::tcl::file::tempfile ::tcl::file::type ::tcl::file::volumes ::tcl::file::writable ::tcl::info::nameofexecutable clock encoding exit glob load source} +} -result {::tcl::encoding::system ::tcl::file::dirname ::tcl::file::extension ::tcl::file::rootname ::tcl::file::tail ::tcl::info::nameofexecutable clock encoding exit file glob load source} test safe-3.3 {calling safe::interpCreate on trusted interp} -setup { catch {safe::interpDelete a} } -body { @@ -115,6 +142,8 @@ test safe-4.1 {safe::interpDelete} -setup { } -body { interp create a safe::interpDelete a + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-4.2 {safe::interpDelete, indirectly} -setup { catch {safe::interpDelete a} @@ -122,6 +151,8 @@ test safe-4.2 {safe::interpDelete, indirectly} -setup { interp create a a alias exit safe::interpDelete a a eval exit + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-4.5 {safe::interpDelete} -setup { catch {safe::interpDelete a} @@ -138,17 +169,120 @@ test safe-4.6 {safe::interpDelete, indirectly} -setup { a eval exit } -result "" -# The following test checks whether the definition of tcl_endOfWord can be -# obtained from auto_loading. +# The old test "safe-5.1" has been moved to "safe-stock-9.8". +# A replacement test using example files is "safe-9.8". +# Tests 5.* test the example files before using them to test safe interpreters. -test safe-5.1 {test auto-loading in safe interpreters} -setup { - catch {safe::interpDelete a} - safe::interpCreate a +unset -nocomplain path + +test safe-5.1 {example tclIndex commands, test in parent interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] [file join $TestsDir auto0 auto2] } -body { - interp eval a {tcl_endOfWord "" 0} + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 } -cleanup { - safe::interpDelete a -} -result -1 + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {0 ok1 0 ok2} +test safe-5.2 {example tclIndex commands, negative test in parent interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} +test safe-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-5.5 {example modules packages, test in parent interpreter, replace path} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} +test safe-5.6 {example modules packages, test in parent interpreter, append to path} -setup { + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} # test safe interps 'information leak' proc SafeEval {script} { @@ -174,41 +308,99 @@ test safe-6.3 {test safe interpreters knowledge of the world} { } set r [lsearch -all -inline -not -exact $r "threaded"] lsort $r -} {byteOrder pathSeparator platform pointerSize wordSize} +} {byteOrder engine pathSeparator platform pointerSize wordSize} +rename SafeEval {} # More test should be added to check that hostname, nameofexecutable, aren't # leaking infos, but they still do... # high level general test -test safe-7.1 {tests that everything works at high level} { +# Use example packages not http1.0 etc +test safe-7.1 {tests that everything works at high level} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] set i [safe::interpCreate] + set ::auto_path $tmpAutoPath +} -body { # no error shall occur: # (because the default access_path shall include 1st level sub dirs so - # package require in a slave works like in the master) - set v [interp eval $i {package require http 1}] + # package require in a child works like in the parent) + set v [interp eval $i {package require SafeTestPackage1}] # no error shall occur: - interp eval $i {http_config} - safe::interpDelete $i + interp eval $i {HeresPackage1} set v -} 1.0 -test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { +} -cleanup { + safe::interpDelete $i +} -match glob -result 1.2.3 +test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup { +} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p1 + # should add as p* (not p1 if parent has a module path) set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # an error shall occur (http is not anymore in the secure 0-level + # should add as p* (not p2 if parent has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level # provided deep path) - list $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ - [safe::interpConfigure $i]\ - [safe::interpDelete $i] -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" + list $token1 $token2 $token3 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ + 1 {can't find package SafeTestPackage1} --\ + {TCLLIB */dummy/unixlike/test/path TESTSDIR/auto0} -- {}} test safe-7.3 {check that safe subinterpreters work} { + set g [interp children] + if {$g ne {}} { + append g { -- residue of an earlier test} + } + set h [info vars ::safe::S*] + if {$h ne {}} { + append h { -- residue of an earlier test} + } set i [safe::interpCreate] set j [safe::interpCreate [list $i x]] - list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] -} {ok {} 0} + list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] \ + [interp exists $j] [info vars ::safe::S*] +} {{} {} ok {} 0 {}} +test safe-7.3.1 {check that safe subinterpreters work with namespace names} -setup { +} -body { + set g [interp children] + if {$g ne {}} { + append g { -- residue of an earlier test} + } + set h [info vars ::safe::S*] + if {$h ne {}} { + append h { -- residue of an earlier test} + } + set i [safe::interpCreate foo::bar] + set j [safe::interpCreate [list $i hello::world]] + list $g $h [interp eval $j {join {o k} ""}] \ + [foo::bar eval {hello::world eval {join {o k} ""}}] \ + [safe::interpDelete $i] \ + [interp exists $j] [info vars ::safe::S*] +} -match glob -result {{} {} ok ok {} 0 {}} +test safe-7.4 {tests specific path and positive search} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-7.2, SafeTestPackage1 should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ + {TCLLIB * TESTSDIR/auto0/auto1} -- {}} # test source control on file name test safe-8.1 {safe source control on file} -setup { @@ -219,6 +411,7 @@ test safe-8.1 {safe source control on file} -setup { $i eval {source} } -returnCodes error -cleanup { safe::interpDelete $i + unset i } -result {wrong # args: should be "source ?-encoding E? fileName"} test safe-8.2 {safe source control on file} -setup { set i "a" @@ -228,6 +421,7 @@ test safe-8.2 {safe source control on file} -setup { $i eval {source a b c d e} } -returnCodes error -cleanup { safe::interpDelete $i + unset i } -result {wrong # args: should be "source ?-encoding E? fileName"} test safe-8.3 {safe source control on file} -setup { set i "a" @@ -241,9 +435,10 @@ test safe-8.3 {safe source control on file} -setup { list [catch {$i eval {source .}} msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i -} -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}} + rename safe-test-log {} + unset i log +} -result {1 {permission denied} {{ERROR for child a : ".": is a directory}}} test safe-8.4 {safe source control on file} -setup { set i "a" catch {safe::interpDelete $i} @@ -256,9 +451,10 @@ test safe-8.4 {safe source control on file} -setup { list [catch {$i eval {source /abc/def}} msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i -} -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}} + rename safe-test-log {} + unset i log +} -result {1 {permission denied} {{ERROR for child a : "/abc/def": not in access_path}}} test safe-8.5 {safe source control on file} -setup { set i "a" catch {safe::interpDelete $i} @@ -275,9 +471,10 @@ test safe-8.5 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i -} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]] + rename safe-test-log {} + unset i log +} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] blah]:no such file or directory"]] test safe-8.6 {safe source control on file} -setup { set i "a" catch {safe::interpDelete $i} @@ -292,9 +489,10 @@ test safe-8.6 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i -} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]] + rename safe-test-log {} + unset i log +} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] blah.tcl]:no such file or directory"]] test safe-8.7 {safe source control on file} -setup { set i "a" catch {safe::interpDelete $i} @@ -311,19 +509,16 @@ test safe-8.7 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log - safe::interpDelete $i -} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]] -test safe-8.8 {safe source forbids -rsrc} -setup { - set i "a" - catch {safe::interpDelete $i} - safe::interpCreate $i -} -body { - $i eval {source -rsrc Init} -} -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "source ?-encoding E? fileName"} + rename safe-test-log {} + unset i log +} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]] +test safe-8.8 {safe source forbids -rsrc} emptyTest { + # Disabled this test. It was only useful for long unsupported + # Mac OS 9 systems. [Bug 860a9f1945] +} {} test safe-8.9 {safe source and return} -setup { + set i "a" set returnScript [makeFile {return "ok"} return.tcl] catch {safe::interpDelete $i} } -body { @@ -333,8 +528,10 @@ test safe-8.9 {safe source and return} -setup { } -cleanup { catch {safe::interpDelete $i} removeFile $returnScript + unset i } -result ok test safe-8.10 {safe source and return} -setup { + set i "a" set returnScript [makeFile {return -level 2 "ok"} return.tcl] catch {safe::interpDelete $i} } -body { @@ -347,6 +544,7 @@ test safe-8.10 {safe source and return} -setup { } -cleanup { catch {safe::interpDelete $i} removeFile $returnScript + unset i } -result ok test safe-9.1 {safe interps' deleteHook} -setup { @@ -363,6 +561,9 @@ test safe-9.1 {safe interps' deleteHook} -setup { } safe::interpCreate $i -deleteHook "testDelHook arg1 arg2" list [interp eval $i exit] $res +} -cleanup { + catch {rename testDelHook {}} + unset i res } -result {{} {arg1 arg2 a}} test safe-9.2 {safe interps' error in deleteHook} -setup { set i "a" @@ -386,8 +587,10 @@ test safe-9.2 {safe interps' error in deleteHook} -setup { list [safe::interpDelete $i] $res $log } -cleanup { safe::setLogCmd $prevlog - unset log -} -result {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}}} + catch {rename testDelHook {}} + rename safe-test-log {} + unset i log res +} -result {{} {arg1 arg2 a} {{NOTICE for child a : About to delete} {ERROR for child a : Delete hook error (being catched)} {NOTICE for child a : Deleted}}} test safe-9.3 {dual specification of statics} -returnCodes error -body { safe::interpCreate -stat true -nostat } -result {conflicting values given for -statics and -noStatics} @@ -415,17 +618,569 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i]\ [safe::interpConfigure $i -deleteHook toto -nosta -nested 0 safe::interpConfigure $i] -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +} -cleanup { + safe::interpDelete $i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { + # this test shall work, believed equivalent to 9.6 + set i [safe::interpCreate \ + -noStatics \ + -nestedLoadOk \ + -deleteHook {foo bar}] + safe::interpConfigure $i -accessPath /foo/bar + set a [safe::interpConfigure $i] + set b [safe::interpConfigure $i -aCCess] + set c [safe::interpConfigure $i -nested] + set d [safe::interpConfigure $i -statics] + set e [safe::interpConfigure $i -DEL] + safe::interpConfigure $i -accessPath /blah -statics 1 + set f [safe::interpConfigure $i] + safe::interpConfigure $i -deleteHook toto -nosta -nested 0 + set g [safe::interpConfigure $i] + + list $a $b $c $d $e $f $g +} -cleanup { + safe::interpDelete $i + unset -nocomplain a b c d e f g i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +test safe-9.8 {test autoloading commands indexed in tclIndex files} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}} +test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} +test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} +test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { +} -body { + # For complete correspondence to safe-9.10opt, include auto0 in access path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- \ + $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ + $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}} +test safe-9.20 {check module loading} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} -- res0 res1 res2} +# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in +# tokenized form to the child's access path, and then adds all the +# descendants, discovered recursively by using glob. +# - The order of the directories in the list returned by glob is system-dependent, +# and therefore this is true also for (a) the order of token assignment to +# descendants of the [tcl::tm::list] roots; and (b) the order of those same +# directories in the access path. Both those things must be sorted before +# comparing with expected results. The test is therefore not totally strict, +# but will notice missing or surplus directories. +test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. catch {teststaticpkg Safepkg1 0 0} -test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { +test safe-10.1 {testing statics loading} -constraints tcl::test -setup { set i [safe::interpCreate] } -body { interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} -test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body { +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.1.1 {testing statics loading} -constraints tcl::test -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i {load {} Safepkg1}} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure + invoked from within +"load {} Safepkg1" + invoked from within +"interp eval $i {load {} Safepkg1}"} +test safe-10.2 {testing statics loading / -nostatics} -constraints tcl::test -body { set i [safe::interpCreate -nostatics] interp eval $i {load {} Safepkg1} } -returnCodes error -cleanup { @@ -433,17 +1188,29 @@ test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackag } -result {permission denied (static package)} test safe-10.3 {testing nested statics loading / no nested by default} -setup { set i [safe::interpCreate] -} -constraints TcltestPackage -body { +} -constraints tcl::test -body { interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i } -result {permission denied (nested load)} -test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { +test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body { set i [safe::interpCreate -nestedloadok] interp eval $i {interp create x; load {} Safepkg1 x} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body { + set i [safe::interpCreate -nestedloadok] + catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {load of binary library for package Safepkg1 failed: can't use package in a safe interpreter: no Safepkg1_SafeInit procedure + invoked from within +"load {} Safepkg1 x" + invoked from within +"interp eval $i {interp create x; load {} Safepkg1 x}"} test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] @@ -451,14 +1218,14 @@ test safe-11.1 {testing safe encoding} -setup { interp eval $i encoding } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding option ?arg ...?"} +} -result {wrong # args: should be "encoding subcommand ?arg ...?"} test safe-11.1a {testing safe encoding} -setup { set i [safe::interpCreate] } -body { interp eval $i encoding foobar } -returnCodes error -cleanup { safe::interpDelete $i -} -match glob -result {bad option "foobar": must be *} +} -match glob -result {unknown or ambiguous subcommand "foobar": must be *} test safe-11.2 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -501,6 +1268,21 @@ test safe-11.7 {testing safe encoding} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +test safe-11.7.1 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i encoding convertfrom} m o + dict get $o -errorinfo +} -returnCodes ok -match glob -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {wrong # args: should be "encoding convertfrom ?encoding? data" + while executing +"encoding convertfrom" + invoked from within +"encoding convertfrom" + invoked from within +"interp eval $i encoding convertfrom"} test safe-11.8 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -508,6 +1290,21 @@ test safe-11.8 {testing safe encoding} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertto ?encoding? data"} +test safe-11.8.1 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i encoding convertto} m o + dict get $o -errorinfo +} -returnCodes ok -match glob -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {wrong # args: should be "encoding convertto ?encoding? data" + while executing +"encoding convertto" + invoked from within +"encoding convertto" + invoked from within +"interp eval $i encoding convertto"} test safe-12.1 {glob is restricted [Bug 2906841]} -setup { set i [safe::interpCreate] @@ -565,6 +1362,15 @@ proc buildEnvironment {filename} { set testdir2 [makeDirectory deletemetoo $testdir] set testfile [makeFile {} $filename $testdir2] } +proc buildEnvironment2 {filename} { + upvar 1 testdir testdir testdir2 testdir2 testfile testfile + upvar 1 testdir3 testdir3 testfile2 testfile2 + set testdir [makeDirectory deletethisdir] + set testdir2 [makeDirectory deletemetoo $testdir] + set testfile [makeFile {} $filename $testdir2] + set testdir3 [makeDirectory deleteme $testdir] + set testfile2 [makeFile {} $filename $testdir3] +} #### New tests for Safe base glob, with patches @ Bug 2964715 test safe-13.1 {glob is restricted [Bug 2964715]} -setup { set i [safe::interpCreate] @@ -636,21 +1442,33 @@ test safe-13.6 {as 13.4 but test silent failure when result is outside access_pa safe::interpDelete $i removeDirectory $testdir } -result {} -test safe-13.7 {mimic the glob call by tclPkgUnknown which gives a deliberate error in a safe interpreter [Bug 2964715]} -setup { +test safe-13.7 {mimic the glob call by tclPkgUnknown in a safe interpreter [Bug 2964715]} -setup { set i [safe::interpCreate] buildEnvironment pkgIndex.tcl } -body { set safeTD [::safe::interpAddToAccessPath $i $testdir] ::safe::interpAddToAccessPath $i $testdir2 - string map [list $safeTD EXPECTED] [$i eval [list \ + mapList [list $safeTD EXPECTED] [$i eval [list \ + glob -directory $safeTD -join * pkgIndex.tcl]] +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {EXPECTED/deletemetoo/pkgIndex.tcl} +test safe-13.7.1 {mimic the glob call by tclPkgUnknown in a safe interpreter with multiple subdirectories} -setup { + set i [safe::interpCreate] + buildEnvironment2 pkgIndex.tcl +} -body { + set safeTD [::safe::interpAddToAccessPath $i $testdir] + ::safe::interpAddToAccessPath $i $testdir2 + ::safe::interpAddToAccessPath $i $testdir3 + mapAndSortList [list $safeTD EXPECTED] [$i eval [list \ glob -directory $safeTD -join * pkgIndex.tcl]] } -cleanup { safe::interpDelete $i removeDirectory $testdir -} -result {{EXPECTED/deletemetoo/pkgIndex.tcl}} -# Note the extra {} around the result above; that's *expected* because of the -# format of virtual path roots. -test safe-13.8 {mimic the glob call by tclPkgUnknown without the deliberate error that is specific to pkgIndex.tcl [Bug 2964715]} -setup { +} -result {EXPECTED/deleteme/pkgIndex.tcl EXPECTED/deletemetoo/pkgIndex.tcl} +# See comments on lsort after test safe-9.20. +test safe-13.8 {mimic the glob call by tclPkgUnknown without the special treatment that is specific to pkgIndex.tcl [Bug 2964715]} -setup { set i [safe::interpCreate] buildEnvironment notIndex.tcl } -body { @@ -688,9 +1506,10 @@ test safe-13.10 {as 13.8 but test silent failure when result is outside access_p removeDirectory $testdir } -result {} rename buildEnvironment {} +rename buildEnvironment2 {} #### Test for the module path -test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup { +test safe-14.1 {Check that module path is the same as in the parent interpreter [Bug 2964715]} -setup { set i [safe::interpCreate] } -body { set tm {} @@ -715,8 +1534,29 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup { lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg } -cleanup { + unset -nocomplain msg interp delete $i } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}} +test safe-15.2 {safe file ensemble does not surprise code} -setup { + set i [interp create -safe] +} -body { + set result [expr {"file" in [interp hidden $i]}] + lappend result [interp eval $i {tcl::file::split a/b/c}] + lappend result [catch {interp eval $i {tcl::file::isdirectory .}}] + lappend result [interp invokehidden $i file split a/b/c] + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp invokehidden $i file isdirectory .}] + interp expose $i file + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp eval $i {file isdirectory .}} msg o] [dict get $o -errorinfo] +} -cleanup { + unset -nocomplain msg o + interp delete $i +} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file + while executing +"file isdirectory ." + invoked from within +"interp eval $i {file isdirectory .}"}} ### ~ should have no special meaning in paths in safe interpreters test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { @@ -731,6 +1571,7 @@ test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { } -cleanup { safe::interpDelete $i set env(HOME) $savedHOME + unset savedHOME } -result {./~} test safe-16.2 {Bug 3529949: defang ~user in paths} -setup { set i [safe::interpCreate] @@ -740,6 +1581,7 @@ test safe-16.2 {Bug 3529949: defang ~user in paths} -setup { "file join \[file dirname ~$user\] \[file tail ~$user\]"] } -cleanup { safe::interpDelete $i + unset user } -result {./~USER} test safe-16.3 {Bug 3529949: defang ~ in globs} -setup { set syntheticHOME [makeDirectory foo] @@ -754,6 +1596,7 @@ test safe-16.3 {Bug 3529949: defang ~ in globs} -setup { safe::interpDelete $i set env(HOME) $savedHOME removeDirectory $syntheticHOME + unset savedHOME syntheticHOME } -result {} test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { set i [safe::interpCreate] @@ -763,9 +1606,59 @@ test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { } -cleanup { safe::interpDelete $i } -result {} +test safe-16.5 {Bug 3529949: defang ~ in paths used by AliasGlob (1)} -setup { + set savedHOME $env(HOME) + set env(HOME) /foo/bar + set i [safe::interpCreate] +} -body { + $i eval { + set d [format %c 126] + file join {$p(:0:)} $d + } +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME + unset savedHOME +} -result {~} +test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup { + set savedHOME $env(HOME) + set env(HOME) /foo/bar + set i [safe::interpCreate] +} -body { + $i eval { + set d [format %c 126] + file join {$p(:0:)/foo/bar} $d + } +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME + unset savedHOME +} -result {~} +test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -body { + string map [list $user USER] [$i eval [list file join {$p(:0:)} ~$user]] +} -cleanup { + safe::interpDelete $i + unset user +} -result {~USER} +test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -body { + string map [list $user USER] [$i eval [list file join {$p(:0:)/foo/bar} ~$user]] +} -cleanup { + safe::interpDelete $i + unset user +} -result {~USER} -set ::auto_path $saveAutoPath # cleanup +set ::auto_path $SaveAutoPath +unset SaveAutoPath TestsDir PathMapp +unset -nocomplain path +rename mapList {} +rename mapAndSortList {} ::tcltest::cleanupTests return diff --git a/tests/scan.test b/tests/scan.test index 97ad5eb..c125080 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -1,24 +1,89 @@ # Commands covered: scan # -# 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 -# generates output for errors. No output means no errors were found. +# 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 generates output +# for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } -testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] +# procedure that returns the range of integers + +proc int_range {} { + set MAX_INT [expr {[format %u -2]/2}] + set MIN_INT [expr { ~ $MAX_INT }] + return [list $MIN_INT $MAX_INT] +} +# Big test for correct ordering of data in [expr] + +proc testIEEE {} { + variable ieeeValues + binary scan [binary format dd -1.0 1.0] c* c + switch -exact -- $c { + {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { + # little endian + binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + ieeeValues(-Infinity) + binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + ieeeValues(-Normal) + binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ + ieeeValues(-Subnormal) + binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ + ieeeValues(-0) + binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+0) + binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ + ieeeValues(+Subnormal) + binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + ieeeValues(+Normal) + binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + ieeeValues(+Infinity) + binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + ieeeValues(NaN) + set ieeeValues(littleEndian) 1 + return 1 + } + {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { + binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-Infinity) + binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-Normal) + binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-Subnormal) + binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-0) + binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+0) + binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+Subnormal) + binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+Normal) + binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+Infinity) + binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(NaN) + set ieeeValues(littleEndian) 0 + return 1 + } + default { + return 0 + } + } +} + +testConstraint ieeeFloatingPoint [testIEEE] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] + test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x } {1 f} @@ -43,10 +108,11 @@ test scan-1.7 {BuildCharSet, CharInSet} { test scan-1.8 {BuildCharSet, CharInSet} { list [scan def-abc {%[^c-a]} x] $x } {1 def-} -test scan-1.9 {BuildCharSet, CharInSet no match} { - catch {unset x} +test scan-1.9 {BuildCharSet, CharInSet no match} -setup { + unset -nocomplain x +} -body { list [scan {= f} {= %[TF]} x] [info exists x] -} {0 0} +} -result {0 0} test scan-2.1 {ReleaseCharSet} { list [scan abcde {%[abc]} x] $x @@ -55,53 +121,53 @@ test scan-2.2 {ReleaseCharSet} { list [scan abcde {%[a-c]} x] $x } {1 abc} -test scan-3.1 {ValidateFormat} { - list [catch {scan {} {%d%1$d} x} msg] $msg -} {1 {cannot mix "%" and "%n$" conversion specifiers}} -test scan-3.2 {ValidateFormat} { - list [catch {scan {} {%d%1$d} x} msg] $msg -} {1 {cannot mix "%" and "%n$" conversion specifiers}} -test scan-3.3 {ValidateFormat} { - list [catch {scan {} {%2$d%d} x} msg] $msg -} {1 {"%n$" argument index out of range}} +test scan-3.1 {ValidateFormat} -returnCodes error -body { + scan {} {%d%1$d} x +} -result {cannot mix "%" and "%n$" conversion specifiers} +test scan-3.2 {ValidateFormat} -returnCodes error -body { + scan {} {%d%1$d} x +} -result {cannot mix "%" and "%n$" conversion specifiers} +test scan-3.3 {ValidateFormat} -returnCodes error -body { + scan {} {%2$d%d} x +} -result {"%n$" argument index out of range} test scan-3.4 {ValidateFormat} { # degenerate case, before changed from 8.2 to 8.3 list [catch {scan {} %d} msg] $msg } {0 {}} -test scan-3.5 {ValidateFormat} { - list [catch {scan {} {%10c} a} msg] $msg -} {1 {field width may not be specified in %c conversion}} -test scan-3.6 {ValidateFormat} { - list [catch {scan {} {%*1$d} a} msg] $msg -} {1 {bad scan conversion character "$"}} -test scan-3.7 {ValidateFormat} { - list [catch {scan {} {%1$d%1$d} a} msg] $msg -} {1 {variable is assigned by multiple "%n$" conversion specifiers}} -test scan-3.8 {ValidateFormat} { - list [catch {scan {} a x} msg] $msg -} {1 {variable is not assigned by any conversion specifiers}} -test scan-3.9 {ValidateFormat} { - list [catch {scan {} {%2$s} x y} msg] $msg -} {1 {variable is not assigned by any conversion specifiers}} -test scan-3.10 {ValidateFormat} { - list [catch {scan {} {%[a} x} msg] $msg -} {1 {unmatched [ in format string}} -test scan-3.11 {ValidateFormat} { - list [catch {scan {} {%[^a} x} msg] $msg -} {1 {unmatched [ in format string}} -test scan-3.12 {ValidateFormat} { - list [catch {scan {} {%[]a} x} msg] $msg -} {1 {unmatched [ in format string}} -test scan-3.13 {ValidateFormat} { - list [catch {scan {} {%[^]a} x} msg] $msg -} {1 {unmatched [ in format string}} +test scan-3.5 {ValidateFormat} -returnCodes error -body { + scan {} {%10c} a +} -result {field width may not be specified in %c conversion} +test scan-3.6 {ValidateFormat} -returnCodes error -body { + scan {} {%*1$d} a +} -result {bad scan conversion character "$"} +test scan-3.7 {ValidateFormat} -returnCodes error -body { + scan {} {%1$d%1$d} a +} -result {variable is assigned by multiple "%n$" conversion specifiers} +test scan-3.8 {ValidateFormat} -returnCodes error -body { + scan {} a x +} -result {variable is not assigned by any conversion specifiers} +test scan-3.9 {ValidateFormat} -returnCodes error -body { + scan {} {%2$s} x y +} -result {variable is not assigned by any conversion specifiers} +test scan-3.10 {ValidateFormat} -returnCodes error -body { + scan {} {%[a} x +} -result {unmatched [ in format string} +test scan-3.11 {ValidateFormat} -returnCodes error -body { + scan {} {%[^a} x +} -result {unmatched [ in format string} +test scan-3.12 {ValidateFormat} -returnCodes error -body { + scan {} {%[]a} x +} -result {unmatched [ in format string} +test scan-3.13 {ValidateFormat} -returnCodes error -body { + scan {} {%[^]a} x +} -result {unmatched [ in format string} -test scan-4.1 {Tcl_ScanObjCmd, argument checks} { - list [catch {scan} msg] $msg -} {1 {wrong # args: should be "scan string format ?varName ...?"}} -test scan-4.2 {Tcl_ScanObjCmd, argument checks} { - list [catch {scan string} msg] $msg -} {1 {wrong # args: should be "scan string format ?varName ...?"}} +test scan-4.1 {Tcl_ScanObjCmd, argument checks} -returnCodes error -body { + scan +} -result {wrong # args: should be "scan string format ?varName ...?"} +test scan-4.2 {Tcl_ScanObjCmd, argument checks} -returnCodes error -body { + scan string +} -result {wrong # args: should be "scan string format ?varName ...?"} test scan-4.3 {Tcl_ScanObjCmd, argument checks} { # degenerate case, before changed from 8.2 to 8.3 list [catch {scan string format} msg] $msg @@ -191,99 +257,126 @@ test scan-4.29 {Tcl_ScanObjCmd, character scanning} { list [scan {abcdef} {%*c%n} x] $x } {1 1} -test scan-4.30 {Tcl_ScanObjCmd, base-10 integer scanning} { +test scan-4.30 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {1234567890a} {%3d} x] $x -} {1 123} -test scan-4.31 {Tcl_ScanObjCmd, base-10 integer scanning} { +} -result {1 123} +test scan-4.31 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {1234567890a} {%d} x] $x -} {1 1234567890} -test scan-4.32 {Tcl_ScanObjCmd, base-10 integer scanning} { +} -result {1 1234567890} +test scan-4.32 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {01234567890a} {%d} x] $x -} {1 1234567890} -test scan-4.33 {Tcl_ScanObjCmd, base-10 integer scanning} { +} -result {1 1234567890} +test scan-4.33 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {+01234} {%d} x] $x -} {1 1234} -test scan-4.34 {Tcl_ScanObjCmd, base-10 integer scanning} { +} -result {1 1234} +test scan-4.34 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {-01234} {%d} x] $x -} {1 -1234} -test scan-4.35 {Tcl_ScanObjCmd, base-10 integer scanning} { +} -result {1 -1234} +test scan-4.35 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {a01234} {%d} x] $x -} {0 {}} -test scan-4.36 {Tcl_ScanObjCmd, base-10 integer scanning} { +} -result {0 {}} +test scan-4.36 {Tcl_ScanObjCmd, base-10 integer scanning} -setup { set x {} +} -body { list [scan {0x10} {%d} x] $x -} {1 0} -test scan-4.37 {Tcl_ScanObjCmd, base-8 integer scanning} { +} -result {1 0} +test scan-4.37 {Tcl_ScanObjCmd, base-8 integer scanning} -setup { set x {} +} -body { list [scan {012345678} {%o} x] $x -} {1 342391} -test scan-4.38 {Tcl_ScanObjCmd, base-8 integer scanning} { +} -result {1 342391} +test scan-4.38 {Tcl_ScanObjCmd, base-8 integer scanning} -setup { set x {} +} -body { list [scan {+1238 -1239 123a} {%o%*s%o%*s%o} x y z] $x $y $z -} {3 83 -83 83} -test scan-4.39 {Tcl_ScanObjCmd, base-16 integer scanning} { +} -result {3 83 -83 83} +test scan-4.39 {Tcl_ScanObjCmd, base-16 integer scanning} -setup { set x {} +} -body { list [scan {+1238 -123a 0123} {%x%x%x} x y z] $x $y $z -} {3 4664 -4666 291} -test scan-4.40 {Tcl_ScanObjCmd, base-16 integer scanning} { +} -result {3 4664 -4666 291} +test scan-4.40 {Tcl_ScanObjCmd, base-16 integer scanning} -setup { + set x {} +} -body { # The behavior changed in 8.4a4/8.3.4cvs (6 Feb) to correctly # return '1' for 0x1 scanned via %x, to comply with 8.0 and C scanf. # Bug #495213 - set x {} list [scan {aBcDeF AbCdEf 0x1} {%x%x%x} x y z] $x $y $z -} {3 11259375 11259375 1} -test scan-4.40.1 {Tcl_ScanObjCmd, base-16 integer scanning} { +} -result {3 11259375 11259375 1} +test scan-4.40.1 {Tcl_ScanObjCmd, base-16 integer scanning} -setup { set x {} +} -body { list [scan {0xF 0x00A0B 0X0XF} {%x %x %x} x y z] $x $y $z -} {3 15 2571 0} -test scan-4.40.2 {Tcl_ScanObjCmd, base-16 integer scanning} { - catch {unset x} +} -result {3 15 2571 0} +test scan-4.40.2 {Tcl_ScanObjCmd, base-16 integer scanning} -setup { + unset -nocomplain x +} -body { list [scan {xF} {%x} x] [info exists x] -} {0 0} -test scan-4.40.3 {Tcl_ScanObjCmd, base-2 integer scanning} { +} -result {0 0} +test scan-4.40.3 {Tcl_ScanObjCmd, base-2 integer scanning} -setup { set x {} +} -body { list [scan {1001 0b101 100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} {%b %b %llb} x y z] $x $y $z -} {3 9 5 340282366920938463463374607431768211456} -test scan-4.41 {Tcl_ScanObjCmd, base-unknown integer scanning} { +} -result {3 9 5 340282366920938463463374607431768211456} +test scan-4.41 {Tcl_ScanObjCmd, base-unknown integer scanning} -setup { set x {} +} -body { list [scan {10 010 0x10 0b10} {%i%i%i%i} x y z t] $x $y $z $t -} {4 10 8 16 0} -test scan-4.42 {Tcl_ScanObjCmd, base-unknown integer scanning} { +} -result {4 10 8 16 0} +test scan-4.42 {Tcl_ScanObjCmd, base-unknown integer scanning} -setup { set x {} +} -body { list [scan {10 010 0X10} {%i%i%i} x y z] $x $y $z -} {3 10 8 16} -test scan-4.43 {Tcl_ScanObjCmd, integer scanning, odd cases} { +} -result {3 10 8 16} +test scan-4.43 {Tcl_ScanObjCmd, integer scanning, odd cases} -setup { set x {} +} -body { list [scan {+ } {%i} x] $x -} {0 {}} -test scan-4.44 {Tcl_ScanObjCmd, integer scanning, odd cases} { +} -result {0 {}} +test scan-4.44 {Tcl_ScanObjCmd, integer scanning, odd cases} -setup { set x {} +} -body { list [scan {+} {%i} x] $x -} {-1 {}} -test scan-4.45 {Tcl_ScanObjCmd, integer scanning, odd cases} { +} -result {-1 {}} +test scan-4.45 {Tcl_ScanObjCmd, integer scanning, odd cases} -setup { set x {} +} -body { list [scan {0x} {%i%s} x y] $x $y -} {2 0 x} -test scan-4.46 {Tcl_ScanObjCmd, integer scanning, odd cases} { +} -result {2 0 x} +test scan-4.46 {Tcl_ScanObjCmd, integer scanning, odd cases} -setup { set x {} +} -body { list [scan {0X} {%i%s} x y] $x $y -} {2 0 X} -test scan-4.47 {Tcl_ScanObjCmd, integer scanning, suppressed} { +} -result {2 0 X} +test scan-4.47 {Tcl_ScanObjCmd, integer scanning, suppressed} -setup { set x {} +} -body { list [scan {123def} {%*i%s} x] $x -} {1 def} +} -result {1 def} test scan-4.48 {Tcl_ScanObjCmd, float scanning} { list [scan {1 2 3} {%e %f %g} x y z] $x $y $z } {3 1.0 2.0 3.0} 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} @@ -299,133 +392,137 @@ test scan-4.53 {Tcl_ScanObjCmd, float scanning} { test scan-4.54 {Tcl_ScanObjCmd, float scanning} { list [scan {1.0e-1} %f x] $x } {1 0.1} -test scan-4.55 {Tcl_ScanObjCmd, odd cases} { +test scan-4.55 {Tcl_ScanObjCmd, odd cases} -setup { set x {} +} -body { list [scan {+} %f x] $x -} {-1 {}} -test scan-4.56 {Tcl_ScanObjCmd, odd cases} { +} -result {-1 {}} +test scan-4.56 {Tcl_ScanObjCmd, odd cases} -setup { set x {} +} -body { list [scan {1.0e} %f%s x y] $x $y -} {2 1.0 e} -test scan-4.57 {Tcl_ScanObjCmd, odd cases} { +} -result {2 1.0 e} +test scan-4.57 {Tcl_ScanObjCmd, odd cases} -setup { set x {} +} -body { list [scan {1.0e+} %f%s x y] $x $y -} {2 1.0 e+} -test scan-4.58 {Tcl_ScanObjCmd, odd cases} { +} -result {2 1.0 e+} +test scan-4.58 {Tcl_ScanObjCmd, odd cases} -setup { set x {} set y {} +} -body { list [scan {e1} %f%s x y] $x $y -} {0 {} {}} +} -result {0 {} {}} test scan-4.59 {Tcl_ScanObjCmd, float scanning} { list [scan {1.0e-1x} %*f%n x] $x } {1 6} -test scan-4.60 {Tcl_ScanObjCmd, set errors} { +test scan-4.60 {Tcl_ScanObjCmd, set errors} -setup { set x {} set y {} - catch {unset z}; array set z {} - set result [list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] \ - $msg $x $y] - unset z - set result -} {1 {can't set "z": variable is array} abc ghi} -test scan-4.61 {Tcl_ScanObjCmd, set errors} { + unset -nocomplain z +} -body { + array set z {} + list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] $msg $x $y +} -cleanup { + unset -nocomplain z +} -result {1 {can't set "z": variable is array} abc ghi} +test scan-4.61 {Tcl_ScanObjCmd, set errors} -setup { set x {} - catch {unset y}; array set y {} - catch {unset z}; array set z {} - set result [list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] \ - $msg $x] - unset y - unset z - set result -} {1 {can't set "z": variable is array} abc} - -# procedure that returns the range of integers - -proc int_range {} { - for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} { - set MIN_INT [expr { $MIN_INT << 1 }] - } - set MIN_INT [expr {int($MIN_INT)}] - set MAX_INT [expr { ~ $MIN_INT }] - return [list $MIN_INT $MAX_INT] -} + unset -nocomplain y + unset -nocomplain z +} -body { + array set y {} + array set z {} + list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] $msg $x +} -cleanup { + unset -nocomplain y + unset -nocomplain z +} -result {1 {can't set "z": variable is array} abc} test scan-4.62 {scanning of large and negative octal integers} { - foreach { MIN_INT MAX_INT } [int_range] {} + lassign [int_range] MIN_INT MAX_INT set scanstring [format {%o %o %o} -1 $MIN_INT $MAX_INT] list [scan $scanstring {%o %o %o} a b c] \ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }] } {3 1 1 1} test scan-4.63 {scanning of large and negative hex integers} { - foreach { MIN_INT MAX_INT } [int_range] {} + lassign [int_range] MIN_INT MAX_INT set scanstring [format {%x %x %x} -1 $MIN_INT $MAX_INT] 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 - -catch { - rename int_range {} -} - -test scan-5.1 {integer scanning} { +test scan-5.1 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "-20 1476 \n33 0" "%d %d %d %d" a b c d] $a $b $c $d -} {4 -20 1476 33 0} -test scan-5.2 {integer scanning} { +} -result {4 -20 1476 33 0} +test scan-5.2 {integer scanning} -setup { set a {}; set b {}; set c {} +} -body { list [scan "-45 16 7890 +10" "%2d %*d %10d %d" a b c] $a $b $c -} {3 -4 16 7890} -test scan-5.3 {integer scanning} { +} -result {3 -4 16 7890} +test scan-5.3 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "-45 16 +10 987" "%ld %d %ld %d" a b c d] $a $b $c $d -} {4 -45 16 10 987} -test scan-5.4 {integer scanning} { +} -result {4 -45 16 10 987} +test scan-5.4 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "14 1ab 62 10" "%d %x %lo %x" a b c d] $a $b $c $d -} {4 14 427 50 16} -test scan-5.5 {integer scanning} { +} -result {4 14 427 50 16} +test scan-5.5 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "12345670 1234567890ab cdefg" "%o %o %x %lx" a b c d] \ $a $b $c $d -} {4 2739128 342391 561323 52719} -test scan-5.6 {integer scanning} { +} -result {4 2739128 342391 561323 52719} +test scan-5.6 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "ab123-24642" "%2x %3x %3o %2o" a b c d] $a $b $c $d -} {4 171 291 -20 52} -test scan-5.7 {integer scanning} { +} -result {4 171 291 -20 52} +test scan-5.7 {integer scanning} -setup { set a {}; set b {} +} -body { list [scan "1234567 234 567 " "%*3x %x %*o %4o" a b] $a $b -} {2 17767 375} -test scan-5.8 {integer scanning} { +} -result {2 17767 375} +test scan-5.8 {integer scanning} -setup { set a {}; set b {} +} -body { list [scan "a 1234" "%d %d" a b] $a $b -} {0 {} {}} -test scan-5.9 {integer scanning} { - set a {}; set b {}; set c {}; set d {}; +} -result {0 {} {}} +test scan-5.9 {integer scanning} -setup { + set a {}; set b {}; set c {}; set d {} +} -body { list [scan "12345678" "%2d %2d %2ld %2d" a b c d] $a $b $c $d -} {4 12 34 56 78} -test scan-5.10 {integer scanning} { +} -result {4 12 34 56 78} +test scan-5.10 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "1 2 " "%hd %d %d %d" a b c d] $a $b $c $d -} {2 1 2 {} {}} +} -result {2 1 2 {} {}} # -# The behavior for scaning intergers larger than MAX_INT is -# not defined by the ANSI spec. Some implementations wrap the -# input (-16) some return MAX_INT. +# The behavior for scaning intergers larger than MAX_INT is not defined by the +# ANSI spec. Some implementations wrap the input (-16) some return MAX_INT. # -test scan-5.11 {integer scanning} {nonPortable} { - set a {}; set b {}; +test scan-5.11 {integer scanning} -constraints {nonPortable} -setup { + set a {}; set b {} +} -body { list [scan "4294967280 4294967280" "%u %d" a b] $a \ [expr {$b == -16 || $b == 0x7fffffff}] -} {2 4294967280 1} -test scan-5.12 {integer scanning} {wideIs64bit} { +} -result {2 4294967280 1} +test scan-5.12 {integer scanning} -constraints {wideIs64bit} -setup { set a {}; set b {}; set c {} +} -body { list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \ %ld,%lx,%lo a b c] $a $b $c -} {3 7810179016327718216 7810179016327718216 7810179016327718216} +} -result {3 7810179016327718216 7810179016327718216 7810179016327718216} test scan-5.13 {integer scanning and overflow} { # This test used to fail on some 64-bit systems. [Bug 1011860] scan {300000000 3000000000 30000000000} {%ld %ld %ld} @@ -434,154 +531,219 @@ test scan-5.13 {integer scanning and overflow} { test scan-5.14 {integer scanning} { scan 0xff %u } 0 +test scan-5.15 {Bug be003d570f} { + scan 0x40 %o +} 0 +test scan-5.16 {Bug be003d570f} { + scan 0x40 %b +} 0 +test scan-5.17 {bigint scanning} -setup { + set a {}; set b {}; set c {} +} -body { + list [scan "207698809136909011942886895,abcdef0123456789abcdef,125715736004432126361152746757" \ + %lld,%llx,%llo a b c] $a $b $c +} -result {3 207698809136909011942886895 207698809136909011942886895 207698809136909011942886895} +test scan-5.18 {bigint scanning underflow} -setup { + set a {}; +} -body { + list [scan "-207698809136909011942886895" \ + %llu a] $a +} -returnCodes 1 -result {unsigned bignum scans are invalid} +test scan-5.19 {bigint scanning invalid} -setup { + set a {}; +} -body { + list [scan "207698809136909011942886895" \ + %llu a] $a +} -result {1 207698809136909011942886895} +test scan-5.20 {ignore digit separators} -setup { + set a {}; set b {}; set c {}; +} -body { + list [scan "10_23_45" %d_%d_%d a b c] $a $b $c +} -result {3 10 23 45} -test scan-6.1 {floating-point scanning} { +test scan-6.1 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d -} {3 2.1 -300000000.0 0.99962 {}} -test scan-6.2 {floating-point scanning} { +} -result {3 2.1 -300000000.0 0.99962 {}} +test scan-6.2 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "-1.2345 +8.2 9" "%3e %3lf %f %f" a b c d] $a $b $c $d -} {4 -1.0 234.0 5.0 8.2} -test scan-6.3 {floating-point scanning} { +} -result {4 -1.0 234.0 5.0 8.2} +test scan-6.3 {floating-point scanning} -setup { set a {}; set b {}; set c {} +} -body { list [scan "1e00004 332E-4 3e+4" "%Lf %*2e %f %f" a b c] $a $c -} {3 10000.0 30000.0} +} -result {3 10000.0 30000.0} # -# Some libc implementations consider 3.e- bad input. The ANSI -# spec states that digits must follow the - sign. +# Some libc implementations consider 3.e- bad input. The ANSI spec states +# that digits must follow the - sign. # -test scan-6.4 {floating-point scanning} { +test scan-6.4 {floating-point scanning} -setup { set a {}; set b {}; set c {} +} -body { list [scan "1. 47.6 2.e2 3.e-" "%f %*f %f %f" a b c] $a $b $c -} {3 1.0 200.0 3.0} -test scan-6.5 {floating-point scanning} { +} -result {3 1.0 200.0 3.0} +test scan-6.5 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "4.6 99999.7 876.43e-1 118" "%f %f %f %e" a b c d] $a $b $c $d -} {4 4.6 99999.7 87.643 118.0} -test scan-6.6 {floating-point scanning} { +} -result {4 4.6 99999.7 87.643 118.0} +test scan-6.6 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "1.2345 697.0e-3 124 .00005" "%f %e %f %e" a b c d] $a $b $c $d -} {4 1.2345 0.697 124.0 5e-5} -test scan-6.7 {floating-point scanning} { +} -result {4 1.2345 0.697 124.0 5e-5} +test scan-6.7 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d -} {1 4.6 {} {} {}} -test scan-6.8 {floating-point scanning} { +} -result {1 4.6 {} {} {}} +test scan-6.8 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d -} {2 4.6 5.2 {} {}} +} -result {2 4.6 5.2 {} {}} +test scan-6.8 {disallow diget separator in floating-point} -setup { + set a {}; set b {}; set c {}; +} -body { + list [scan "3.14_2.35_98.6" %f_%f_%f a b c ] $a $b $c +} -result {3 3.14 2.35 98.6} -test scan-7.1 {string and character scanning} { +test scan-7.1 {string and character scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d -} {4 abc def ghijk dum} -test scan-7.2 {string and character scanning} { +} -result {4 abc def ghijk dum} +test scan-7.2 {string and character scanning} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "a bcdef" "%c%c%1s %s" a b c d] $a $b $c $d -} {4 97 32 b cdef} -test scan-7.3 {string and character scanning} { +} -result {4 97 32 b cdef} +test scan-7.3 {string and character scanning} -setup { set a {}; set b {}; set c {} +} -body { list [scan "123456 test " "%*c%*s %s %s %s" a b c] $a $b $c -} {1 test {} {}} -test scan-7.4 {string and character scanning} { - set a {}; set b {}; set c {}; set d +} -result {1 test {} {}} +test scan-7.4 {string and character scanning} -setup { + set a {}; set b {}; set c {}; set d {} +} -body { list [scan "ababcd01234 f 123450" {%4[abcd] %4[abcd] %[^abcdef] %[^0]} a b c d] $a $b $c $d -} {4 abab cd {01234 } {f 12345}} -test scan-7.5 {string and character scanning} { +} -result {4 abab cd {01234 } {f 12345}} +test scan-7.5 {string and character scanning} -setup { set a {}; set b {}; set c {} +} -body { list [scan "aaaaaabc aaabcdefg + + XYZQR" {%*4[a] %s %*4[a]%s%*4[ +]%c} a b c] $a $b $c -} {3 aabc bcdefg 43} -test scan-7.6 {string and character scanning, unicode} { +} -result {3 aabc bcdefg 43} +test scan-7.6 {string and character scanning, unicode} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "abc d\u00c7fghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d -} "4 abc d\u00c7f ghijk dum" -test scan-7.7 {string and character scanning, unicode} { +} -result "4 abc d\u00c7f ghijk dum" +test scan-7.7 {string and character scanning, unicode} -setup { set a {}; set b {} +} -body { list [scan "ab\u00c7cdef" "ab%c%c" a b] $a $b -} "2 199 99" -test scan-7.8 {string and character scanning, unicode} { +} -result "2 199 99" +test scan-7.8 {string and character scanning, unicode} -setup { set a {}; set b {} +} -body { list [scan "ab\ufeffdef" "%\[ab\ufeff\]" a] $a -} "1 ab\ufeff" +} -result "1 ab\ufeff" -test scan-8.1 {error conditions} { - catch {scan a} -} 1 -test scan-8.2 {error conditions} { - catch {scan a} msg - set msg -} {wrong # args: should be "scan string format ?varName ...?"} -test scan-8.3 {error conditions} { - list [catch {scan a %D x} msg] $msg -} {1 {bad scan conversion character "D"}} -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"}} -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"}} -test scan-8.8 {error conditions} { - list [catch {scan a "%d %d" a} msg] $msg -} {1 {different numbers of variable names and field specifiers}} -test scan-8.9 {error conditions} { - list [catch {scan a "%d %d" a b c} msg] $msg -} {1 {variable is not assigned by any conversion specifiers}} -test scan-8.10 {error conditions} { +test scan-8.1 {error conditions} -body { + scan a +} -returnCodes error -match glob -result * +test scan-8.2 {error conditions} -returnCodes error -body { + scan a +} -result {wrong # args: should be "scan string format ?varName ...?"} +test scan-8.3 {error conditions} -returnCodes error -body { + scan a %D x +} -result {bad scan conversion character "D"} +test scan-8.4 {error conditions} -returnCodes error -body { + scan a %O x +} -result {bad scan conversion character "O"} +test scan-8.5 {error conditions} -returnCodes error -body { + scan a %B x +} -result {bad scan conversion character "B"} +test scan-8.6 {error conditions} -returnCodes error -body { + scan a %F x +} -result {bad scan conversion character "F"} +test scan-8.7 {error conditions} -returnCodes error -body { + scan a %p x +} -result {bad scan conversion character "p"} +test scan-8.8 {error conditions} -returnCodes error -body { + scan a "%d %d" a +} -result {different numbers of variable names and field specifiers} +test scan-8.9 {error conditions} -returnCodes error -body { + scan a "%d %d" a b c +} -result {variable is not assigned by any conversion specifiers} +test scan-8.10 {error conditions} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [expr {[scan " a" " a %d %d %d %d" a b c d] <= 0}] $a $b $c $d -} {1 {} {} {} {}} -test scan-8.11 {error conditions} { +} -result {1 {} {} {} {}} +test scan-8.11 {error conditions} -setup { set a {}; set b {}; set c {}; set d {} +} -body { list [scan "1 2" "%d %d %d %d" a b c d] $a $b $c $d -} {2 1 2 {} {}} -test scan-8.12 {error conditions} { - catch {unset a} +} -result {2 1 2 {} {}} +test scan-8.12 {error conditions} -setup { + unset -nocomplain a +} -body { set a(0) 44 - list [catch {scan 44 %d a} msg] $msg -} {1 {can't set "a": variable is array}} -test scan-8.13 {error conditions} { - catch {unset a} + scan 44 %d a +} -returnCodes error -cleanup { + unset -nocomplain a +} -result {can't set "a": variable is array} +test scan-8.13 {error conditions} -setup { + unset -nocomplain a +} -body { set a(0) 44 - list [catch {scan 44 %c a} msg] $msg -} {1 {can't set "a": variable is array}} -test scan-8.14 {error conditions} { - catch {unset a} + scan 44 %c a +} -returnCodes error -cleanup { + unset -nocomplain a +} -result {can't set "a": variable is array} +test scan-8.14 {error conditions} -setup { + unset -nocomplain a +} -body { set a(0) 44 - list [catch {scan 44 %s a} msg] $msg -} {1 {can't set "a": variable is array}} -test scan-8.15 {error conditions} { - catch {unset a} + scan 44 %s a +} -returnCodes error -cleanup { + unset -nocomplain a +} -result {can't set "a": variable is array} +test scan-8.15 {error conditions} -setup { + unset -nocomplain a +} -body { set a(0) 44 - list [catch {scan 44 %f a} msg] $msg -} {1 {can't set "a": variable is array}} -test scan-8.16 {error conditions} { - catch {unset a} + scan 44 %f a +} -returnCodes error -cleanup { + unset -nocomplain a +} -result {can't set "a": variable is array} +test scan-8.16 {error conditions} -setup { + unset -nocomplain a +} -body { set a(0) 44 - list [catch {scan 44 %f a} msg] $msg -} {1 {can't set "a": variable is array}} -catch {unset a} -test scan-8.17 {error conditions} { - list [catch {scan 44 %2c a} msg] $msg -} {1 {field width may not be specified in %c conversion}} -test scan-8.18 {error conditions} { - list [catch {scan abc {%[} x} msg] $msg -} {1 {unmatched [ in format string}} -test scan-8.19 {error conditions} { - list [catch {scan abc {%[^a} x} msg] $msg -} {1 {unmatched [ in format string}} -test scan-8.20 {error conditions} { - list [catch {scan abc {%[^]a} x} msg] $msg -} {1 {unmatched [ in format string}} -test scan-8.21 {error conditions} { - list [catch {scan abc {%[]a} x} msg] $msg -} {1 {unmatched [ in format string}} + scan 44 %f a +} -returnCodes error -cleanup { + unset -nocomplain a +} -result {can't set "a": variable is array} +test scan-8.17 {error conditions} -returnCodes error -body { + scan 44 %2c a +} -result {field width may not be specified in %c conversion} +test scan-8.18 {error conditions} -returnCodes error -body { + scan abc {%[} x +} -result {unmatched [ in format string} +test scan-8.19 {error conditions} -returnCodes error -body { + scan abc {%[^a} x +} -result {unmatched [ in format string} +test scan-8.20 {error conditions} -returnCodes error -body { + scan abc {%[^]a} x +} -result {unmatched [ in format string} +test scan-8.21 {error conditions} -returnCodes error -body { + scan abc {%[]a} x +} -result {unmatched [ in format string} test scan-9.1 {lots of arguments} { scan "10 20 30 40 50 60 70 80 90 100 110 120 130 140 150 160 170 180 190 200" "%d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d" a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 @@ -591,27 +753,32 @@ test scan-9.2 {lots of arguments} { set a20 } 200 -test scan-10.1 {miscellaneous tests} { +test scan-10.1 {miscellaneous tests} -setup { set a {} +} -body { list [scan ab16c ab%dc a] $a -} {1 16} -test scan-10.2 {miscellaneous tests} { +} -result {1 16} +test scan-10.2 {miscellaneous tests} -setup { set a {} +} -body { list [scan ax16c ab%dc a] $a -} {0 {}} -test scan-10.3 {miscellaneous tests} { +} -result {0 {}} +test scan-10.3 {miscellaneous tests} -setup { set a {} +} -body { list [catch {scan ab%c114 ab%%c%d a} msg] $msg $a -} {0 1 114} -test scan-10.4 {miscellaneous tests} { +} -result {0 1 114} +test scan-10.4 {miscellaneous tests} -setup { set a {} +} -body { list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a -} {0 1 14} -test scan-10.5 {miscellaneous tests} { - catch {unset arr} +} -result {0 1 14} +test scan-10.5 {miscellaneous tests} -setup { + unset -nocomplain arr +} -body { set arr(2) {} list [catch {scan ab%c14 ab%%c%d arr(2)} msg] $msg $arr(2) -} {0 1 14} +} -result {0 1 14} test scan-10.6 {miscellaneous tests} { scan 5a {%i%[a]} } {5 a} @@ -671,9 +838,9 @@ test scan-13.1 {Tcl_ScanObjCmd, inline XPG case} { test scan-13.2 {Tcl_ScanObjCmd, inline XPG case} { scan abc {%1$c%2$c%3$c%4$c} } {97 98 99 {}} -test scan-13.3 {Tcl_ScanObjCmd, inline XPG case} { - list [catch {scan abc {%1$c%1$c}} msg] $msg -} {1 {variable is assigned by multiple "%n$" conversion specifiers}} +test scan-13.3 {Tcl_ScanObjCmd, inline XPG case} -returnCodes error -body { + scan abc {%1$c%1$c} +} -result {variable is assigned by multiple "%n$" conversion specifiers} test scan-13.4 {Tcl_ScanObjCmd, inline XPG case} { scan abc {%2$s%1$c} } {{} abc} @@ -692,77 +859,20 @@ test scan-13.8 {Tcl_ScanObjCmd, inline XPG case lots of arguments} { list [llength $msg] [lindex $msg 99] [lindex $msg 4] [lindex $msg 199] } {200 10 20 30} -# Big test for correct ordering of data in [expr] - -proc testIEEE {} { - variable ieeeValues - binary scan [binary format dd -1.0 1.0] c* c - switch -exact -- $c { - {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { - # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ - ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ - ieeeValues(-Normal) - binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ - ieeeValues(-Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ - ieeeValues(-0) - binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+0) - binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ - ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ - ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ - ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ - ieeeValues(NaN) - set ieeeValues(littleEndian) 1 - return 1 - } - {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(-Normal) - binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(-Subnormal) - binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(-0) - binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+0) - binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(NaN) - set ieeeValues(littleEndian) 0 - return 1 - } - default { - return 0 - } - } -} - -testConstraint ieeeFloatingPoint [testIEEE] - # scan infinities - not working -test scan-14.1 {infinity} { +test scan-14.1 {positive infinity} { scan Inf %g d - set d + return $d } Inf -test scan-14.2 {infinity} { +test scan-14.2 {negative infinity} { scan -Inf %g d - set d + return $d } -Inf # TODO - also need to scan NaN's + +catch {rename int_range {}} # cleanup ::tcltest::cleanupTests diff --git a/tests/security.test b/tests/security.test index eeabc9c..6aa7ccb 100644 --- a/tests/security.test +++ b/tests/security.test @@ -6,12 +6,12 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/set-old.test b/tests/set-old.test index 52dc0ff..052bd23 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -6,15 +6,15 @@ # into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -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. @@ -335,7 +340,7 @@ test set-old-8.6 {array command} { catch {unset a} set a(22) 3 list [catch {array gorp a} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}} +} {1 {unknown or ambiguous subcommand "gorp": must be anymore, default, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}} test set-old-8.7 {array command, anymore option} { catch {unset a} list [catch {array anymore a x} msg] $msg @@ -647,6 +652,13 @@ test set-old-8.52 {array command, array names -regexp on regexp pattern} { set a(11) 1 list [catch {lsort [array names a -regexp ^1]} msg] $msg } {0 {1*2 11 12}} +test set-old-8.52.1 {array command, array names -regexp, backrefs} { + catch {unset a} + set a(1*2) 1 + set a(12) 1 + set a(11) 1 + list [catch {lsort [array names a -regexp {^(.)\1}]} msg] $msg +} {0 11} test set-old-8.53 {array command, array names -regexp} { catch {unset a} set a(-glob) 1 @@ -678,12 +690,17 @@ test set-old-8.57 {array command, array get with trivial pattern} { set a(y) 2 array get a x } {x 1} +test set-old-8.58 {array command, array set with LVT and odd length literal} { + list [catch {apply {{} { + array set a {b c d} + }}} msg] $msg +} {1 {list must have an even number of elements}} test set-old-9.1 {ids for array enumeration} { catch {unset a} set a(a) 1 list [array star a] [array star a] [array done a s-1-a; array star a] \ - [array done a s-2-a; array d a s-3-a; array start a] + [array done a s-2-a; array do a s-3-a; array start a] } {s-1-a s-2-a s-3-a s-1-a} test set-old-9.2 {array enumeration} { catch {unset a} @@ -855,6 +872,8 @@ test set-old-10.13 {array enumeration errors} { list [catch {array done a b c} msg] $msg } {1 {wrong # args: should be "array donesearch arrayName searchId"}} test set-old-10.14 {array enumeration errors} { + catch {unset a} + set a(a) a list [catch {array done a b} msg] $msg } {1 {illegal search identifier "b"}} test set-old-10.15 {array enumeration errors} { @@ -921,7 +940,7 @@ catch {rename foo {}} # cleanup ::tcltest::cleanupTests -return +return # Local Variables: # mode: tcl diff --git a/tests/set.test b/tests/set.test index 1d88553..357e34b 100644 --- a/tests/set.test +++ b/tests/set.test @@ -4,25 +4,25 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testset2 [llength [info commands testset2]] catch {unset x} catch {unset i} - + test set-1.1 {TclCompileSetCmd: missing variable name} { list [catch {set} msg] $msg } {1 {wrong # args: should be "set varName ?newValue?"}} @@ -39,16 +39,18 @@ test set-1.4 {TclCompileSetCmd: simple variable name in quotes} { set i 17 list [set "i"] $i } {17 17} -test set-1.5 {TclCompileSetCmd: simple variable name in braces} { +test set-1.5 {TclCompileSetCmd: simple variable name in braces} -setup { catch {unset {a simple var}} +} -body { set {a simple var} 27 list [set {a simple var}] ${a simple var} -} {27 27} -test set-1.6 {TclCompileSetCmd: simple array variable name} { +} -result {27 27} +test set-1.6 {TclCompileSetCmd: simple array variable name} -setup { catch {unset a} +} -body { set a(foo) 37 list [set a(foo)] $a(foo) -} {37 37} +} -result {37 37} test set-1.7 {TclCompileSetCmd: non-simple (computed) variable name} { set x "i" set i 77 @@ -149,22 +151,24 @@ test set-1.14 {TclCompileSetCmd: simple local name, >255 locals} { } 260locals } {1234} -test set-1.15 {TclCompileSetCmd: variable is array} { +test set-1.15 {TclCompileSetCmd: variable is array} -setup { catch {unset a} +} -body { set x 27 set x [set a(foo) 11] catch {unset a} set x -} 11 -test set-1.16 {TclCompileSetCmd: variable is array, elem substitutions} { +} -result 11 +test set-1.16 {TclCompileSetCmd: variable is array, elem substitutions} -setup { catch {unset a} +} -body { set i 5 set x 789 set a(foo5) 27 set x [set a(foo$i)] catch {unset a} set x -} 27 +} -result 27 test set-1.17 {TclCompileSetCmd: doing assignment, simple int} { set i 5 @@ -211,7 +215,7 @@ test set-1.25 {TclCompileSetCmd: var is array, braced (no subs)} { test set-1.26 {TclCompileSetCmd: various array constructs} { # Test all kinds of array constructs that TclCompileSetCmd # may feel inclined to tamper with. - proc p {} { + apply {{} { set a x set be(hej) 1 ; # hej set be($a) 1 ; # x @@ -230,28 +234,33 @@ test set-1.26 {TclCompileSetCmd: various array constructs} { set [string range bet 0 1](foo) 1 ; # foo set be([set be(a:$a)][set b\e($a)]) 1 ; # 51 return [lsort [array names be]] - } - p + }} } [lsort {hej x $a x,hej x,x c(x ww a:x hej,1,hej hug {a a} {x ,ugg,hej} x,h"ej {b c} foo 51}]; # " just a matching end quote -test set-2.1 {set command: runtime error, bad variable name} { +test set-2.1 {set command: runtime error, bad variable name} -setup { unset -nocomplain {"foo} +} -body { list [catch {set {"foo}} msg] $msg $::errorInfo -} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable +} -result {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable while executing "set {"foo}"}} -test set-2.2 {set command: runtime error, not array variable} { - catch {unset b} +# Stop my editor highlighter " from being confused +test set-2.2 {set command: runtime error, not array variable} -setup { + unset -nocomplain b +} -body { set b 44 list [catch {set b(123)} msg] $msg -} {1 {can't read "b(123)": variable isn't array}} -test set-2.3 {set command: runtime error, errors in reading variables} { - catch {unset a} +} -result {1 {can't read "b(123)": variable isn't array}} +test set-2.3 {set command: runtime error, errors in reading variables} -setup { + unset -nocomplain a +} -body { set a(6) 44 list [catch {set a(18)} msg] $msg -} {1 {can't read "a(18)": no such element in array}} -test set-2.4 {set command: runtime error, readonly variable} -body { +} -result {1 {can't read "a(18)": no such element in array}} +test set-2.4 {set command: runtime error, readonly variable} -setup { + unset -nocomplain x +} -body { proc readonly args {error "variable is read-only"} set x 123 trace var x w readonly @@ -260,12 +269,18 @@ test set-2.4 {set command: runtime error, readonly variable} -body { while executing * "set x 1"}} -test set-2.5 {set command: runtime error, basic array operations} { +test set-2.5 {set command: runtime error, basic array operations} -setup { + unset -nocomplain a +} -body { + array set a {} list [catch {set a(other)} msg] $msg -} {1 {can't read "a(other)": no such element in array}} -test set-2.6 {set command: runtime error, basic array operations} { +} -result {1 {can't read "a(other)": no such element in array}} +test set-2.6 {set command: runtime error, basic array operations} -setup { + unset -nocomplain a +} -body { + array set a {} list [catch {set a} msg] $msg -} {1 {can't read "a": variable is array}} +} -result {1 {can't read "a": variable is array}} # Test the uncompiled version of set @@ -479,25 +494,29 @@ test set-3.24 {uncompiled set command: too many arguments} { $z msg } {wrong # args: should be "set varName ?newValue?"} -test set-4.1 {uncompiled set command: runtime error, bad variable name} { +test set-4.1 {uncompiled set command: runtime error, bad variable name} -setup { unset -nocomplain {"foo} +} -body { set z set list [catch {$z {"foo}} msg] $msg $::errorInfo -} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable +} -result {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable while executing "$z {"foo}"}} -test set-4.2 {uncompiled set command: runtime error, not array variable} { - set z set +# Stop my editor highlighter " from being confused +test set-4.2 {uncompiled set command: runtime error, not array variable} -setup { catch {unset b} +} -body { + set z set $z b 44 list [catch {$z b(123)} msg] $msg -} {1 {can't read "b(123)": variable isn't array}} -test set-4.3 {uncompiled set command: runtime error, errors in reading variables} { - set z set - catch {unset a} +} -result {1 {can't read "b(123)": variable isn't array}} +test set-4.3 {uncompiled set command: runtime error, errors in reading variables} -setup { + catch {unset a} +} -body { + set z set $z a(6) 44 list [catch {$z a(18)} msg] $msg -} {1 {can't read "a(18)": no such element in array}} +} -result {1 {can't read "a(18)": no such element in array}} test set-4.4 {uncompiled set command: runtime error, readonly variable} -body { set z set proc readonly args {error "variable is read-only"} @@ -508,22 +527,33 @@ test set-4.4 {uncompiled set command: runtime error, readonly variable} -body { while executing * "$z x 1"}} -test set-4.5 {uncompiled set command: runtime error, basic array operations} { +test set-4.5 {uncompiled set command: runtime error, basic array operations} -setup { + unset -nocomplain a + array set a {} +} -body { set z set list [catch {$z a(other)} msg] $msg -} {1 {can't read "a(other)": no such element in array}} -test set-4.6 {set command: runtime error, basic array operations} { +} -result {1 {can't read "a(other)": no such element in array}} +test set-4.6 {set command: runtime error, basic array operations} -setup { + unset -nocomplain a + array set a {} +} -body { set z set list [catch {$z a} msg] $msg -} {1 {can't read "a": variable is array}} +} -result {1 {can't read "a": variable is array}} -test set-5.1 {error on malformed array name} testset2 { +test set-5.1 {error on malformed array name} -constraints testset2 -setup { unset -nocomplain z +} -body { catch {testset2 z(a) b} msg catch {testset2 z(b) a} msg1 list $msg $msg1 -} {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}} - +} -result {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}} +# In a mem-debug build, this test will crash unless Bug 3602706 is fixed. +test set-5.2 {Bug 3602706} -body { + testset2 ::tcl_platform not-in-there +} -returnCodes error -result * -match glob + # cleanup catch {unset a} catch {unset b} @@ -531,4 +561,8 @@ catch {unset i} catch {unset x} catch {unset z} ::tcltest::cleanupTests -return +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/socket.test b/tests/socket.test index 9f1cc78..a1a66b5 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -4,8 +4,8 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 Ajuba Solutions. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -60,16 +60,55 @@ # listening at port 2048. If all fails, a message is printed and the tests # using the remote server are not performed. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] +::tcltest::loadTestedCommands + +# A bad interaction between socket creation, macOS, and unattended CI +# environments make this whole file impractical to run; too many weird hangs. +if {[info exists ::env(MAC_CI)]} { + return +} +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] # Some tests require the Thread package or exec command -testConstraint thread [expr {0 == [catch {package require Thread 2.6.6}]}] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] testConstraint exec [llength [info commands exec]] +testConstraint knownMsvcBug [expr {![info exists ::env(CI_BUILD_WITH_MSVC)]}] +testConstraint notWinCI [expr { + $tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] # Produce a random port number in the Dynamic/Private range # from 49152 through 65535. -proc randport {} { expr {int(rand()*16383+49152)} } +proc randport {} { + # firstly try dynamic port via server-socket(0): + set port 0x7fffffff + catch { + set port [lindex [fconfigure [set s [socket -server {} 0]] -sockname] 2] + close $s + } + while {[catch { + close [socket -server {} $port] + } msg]} { + if {[incr i] > 1000} {return -code error "too many iterations to get free random port: $msg"} + # try random port: + set port [expr {int(rand()*16383+49152)}] + } + return $port +} + +# Check if testsocket testflags is available +testConstraint testsocket_testflags [expr {![catch { + set h [socket -async localhost [randport]] + testsocket testflags $h 0 + close $h + }]}] + # Test the latency of tcp connections over the loopback interface. Some OSes # (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes @@ -86,8 +125,21 @@ puts $s2 test1; gets $s1 puts $s2 test2; gets $s1 close $s1; close $s2 set t2 [clock milliseconds] -set latency [expr {($t2-$t1)*2}]; # doubled as a safety margin -unset t1 t2 s1 s2 server +set lat1 [expr {($t2-$t1)*2}]; # doubled as a safety margin + +# Test the latency of failed connection attempts over the loopback +# interface. They can take more than a second under Windowos and requres +# additional [after]s in some tests that are not needed on systems that fail +# immediately. +set t1 [clock milliseconds] +catch {socket 127.0.0.1 [randport]} +set t2 [clock milliseconds] +set lat2 [expr {($t2-$t1)*3}] + +# Use the maximum of the two latency calculations, but at least 200ms +set latency [expr {$lat1 > $lat2 ? $lat1 : $lat2}] +set latency [expr {$latency > 200 ? $latency : 200}] +unset t1 t2 s1 s2 lat1 lat2 server # If remoteServerIP or remoteServerPort are not set, check in the environment # variables for externally set values. @@ -124,7 +176,6 @@ foreach {af localhost} { testConstraint supported_$af [expr {![catch {socket -server foo -myaddr $localhost 0} sock]}] catch {close $sock} } -testConstraint supported_any [expr {[testConstraint supported_inet] || [testConstraint supported_inet6]}] set sock [socket -server foo -myaddr localhost 0] set sockname [fconfigure $sock -sockname] @@ -138,6 +189,9 @@ foreach {af localhost} { inet 127.0.0.1 inet6 ::1 } { + if {![testConstraint supported_$af]} { + continue + } set ::tcl::unsupported::socketAF $af # # Check if we're supposed to do tests against the remote server @@ -199,7 +253,7 @@ if {$doTestsWithRemoteServer} { # Some tests are run only if we are doing testing against a remote server. testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer if {!$doTestsWithRemoteServer} { - if {[string first s $::tcltest::verbose] != -1} { + if {[string first s $::tcltest::verbose] >= 0} { puts "Skipping tests with remote server. See tests/socket.test for" puts "information on how to run remote server." puts "Reason for not doing remote tests: $noRemoteTestReason" @@ -242,6 +296,11 @@ proc getPort sock { lindex [fconfigure $sock -sockname] 2 } +# Some tests in this file are known to hang *occasionally* on OSX; stop the +# worst offenders. +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] +# Here "Windows" means derived platforms as Cygwin or Msys2 too. +testConstraint notWindows [expr {![regexp {^(Windows|MSYS|CYGWIN)} $::tcl_platform(os)]}] # ---------------------------------------------------------------------- @@ -250,13 +309,13 @@ test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket s } -returnCodes error -result {no argument given for -server option} test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.3 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr } -returnCodes error -result {no argument given for -myaddr option} test socket_$af-1.4 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr $localhost -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.5 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport } -returnCodes error -result {no argument given for -myport option} @@ -265,19 +324,19 @@ test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket s } -returnCodes error -result {expected integer but got "xxxx"} test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport 2522 -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -froboz -} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, or -server} +} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, -reuseaddr, -reuseport, or -server} test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -myport 2521 3333 } -returnCodes error -result {option -myport is not valid for servers} test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket host 2528 -junk -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server callback 2520 -- -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.12 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket foo badport } -returnCodes error -result {expected integer but got "badport"} @@ -287,6 +346,24 @@ test socket_$af-1.13 {arg parsing for socket command} -constraints [list socket test socket_$af-1.14 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -async } -returnCodes error -result {cannot set -async option for server sockets} +test socket_$af-1.15 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseaddr yes 4242 +} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} +test socket_$af-1.16 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseaddr no 4242 +} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} +test socket_$af-1.17 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseaddr +} -returnCodes error -result {no argument given for -reuseaddr option} +test socket_$af-1.18 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseport yes 4242 +} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} +test socket_$af-1.19 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseport no 4242 +} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} +test socket_$af-1.20 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseport +} -returnCodes error -result {no argument given for -reuseport option} set path(script) [makeFile {} script] @@ -607,7 +684,7 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a vwait sock puts $s2 one flush $s2 - after idle {set x 1} + after $latency {set x 1}; # Spurious failures in Travis CI, if we do [after idle] vwait x fconfigure $sock -blocking 0 set result a:[gets $sock] @@ -625,6 +702,86 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a close $s close $sock } -result {a:one b: c:two} +test socket_$af-2.12 {} [list socket stdio supported_$af] { + 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 $localhost $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_$af-2.13 {Bug 1758a0b603} {socket stdio notWine} { + 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_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup { file delete $path(script) @@ -786,7 +943,7 @@ test socket_$af-5.1 {byte order problems, socket numbers, htons} -body { return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} -} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner} +} -constraints [list socket supported_$af unix notRoot notOSX notWindows] -result {couldn't open socket: not owner} test socket_$af-5.2 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 0x10000} msg]} { close $msg @@ -800,7 +957,7 @@ test socket_$af-5.3 {byte order problems, socket numbers, htons} -body { return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} -} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner} +} -constraints [list socket supported_$af unix notRoot notOSX notWindows] -result {couldn't open socket: not owner} test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup { proc myHandler {msg options} { @@ -818,7 +975,7 @@ test socket_$af-6.1 {accept callback error} -constraints [list socket supported_ } close $f set f [open "|[list [interpreter] $path(script)]" r+] - proc accept {s a p} {expr 10 / 0} + proc accept {s a p} {expr {10 / 0}} set s [socket -server accept -myaddr $localhost 0] puts $f [lindex [fconfigure $s -sockname] 2] close $f @@ -938,7 +1095,7 @@ test socket_$af-7.4 {testing socket specific options} -constraints [list socket test socket_$af-7.5 {testing socket specific options} -setup { set timer [after 10000 "set x timed_out"] set l "" -} -constraints [list socket supported_$af unixOrPc] -body { +} -constraints [list socket supported_$af unixOrWin] -body { set s [socket -server accept 0] proc accept {s a p} { global x @@ -1393,7 +1550,7 @@ test socket_$af-11.11 {testing spurious events} -setup { after cancel $timer sendCommand {close $server} } -result {0 2690 1} -test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup { +test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer notWine] -setup { set counter 0 set done 0 set port [sendCommand { @@ -1560,8 +1717,8 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { close $f # If the socket doesn't hit end-of-file in 10 seconds, the script1 process # must have inherited the client. - set failed 0 - set after [after 10000 [list set failed 1]] + set timeout 0 + set after [after 10000 {set x "client socket was inherited"}] } -constraints [list socket supported_$af stdio exec] -body { # Create the server socket set server [socket -server accept -myaddr $localhost 0] @@ -1571,26 +1728,20 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { close $server fileevent $file readable [list getdata $file] fconfigure $file -buffering line -blocking 0 + set ::f $file } proc getdata { file } { # Read handler on the accepted socket. - global x failed + global x set status [catch {read $file} data] if {$status != 0} { - set x {read failed, error was $data} - catch { close $file } + set x "read failed, error was $data" } elseif {$data ne ""} { } elseif {[fblocked $file]} { } elseif {[eof $file]} { - if {$failed} { - set x {client socket was inherited} - } else { - set x {client socket was not inherited} - } - catch { close $file } + set x "client socket was not inherited" } else { - set x {impossible case} - catch { close $file } + set x "impossible case" } } # Launch the script2 process @@ -1600,6 +1751,8 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { vwait x return $x } -cleanup { + fconfigure $f -blocking 1 + close $f after cancel $after close $p } -result {client socket was not inherited} @@ -1641,35 +1794,30 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { # If the socket is still open after 5 seconds, the script1 process must # have inherited the accepted socket. set failed 0 - set after [after 5000 [list set failed 1]] + set after [after 5000 [list set x "accepted socket was inherited"]] proc getdata { file } { # Read handler on the client socket. global x global failed set status [catch {read $file} data] if {$status != 0} { - set x {read failed, error was $data} - catch { close $file } + set x "read failed, error was $data" } elseif {[string compare {} $data]} { } elseif {[fblocked $file]} { } elseif {[eof $file]} { - if {$failed} { - set x {accepted socket was inherited} - } else { - set x {accepted socket was not inherited} - } - catch { close $file } + set x "accepted socket was not inherited" } else { - set x {impossible case} - catch { close $file } + set x "impossible case" } return } vwait x - return $x + set x } -cleanup { + fconfigure $f -blocking 1 + close $f after cancel $after - catch {close $p} + close $p } -result {accepted socket was not inherited} test socket_$af-13.1 {Testing use of shared socket between two threads} -body { @@ -1696,7 +1844,6 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -body { set i 0 vwait x close $f - thread::wait }]] set port [thread::send $serverthread {set listen}] set s [socket $localhost $port] @@ -1708,7 +1855,106 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -body { close $s thread::release $serverthread append result " " [llength [thread::names]] -} -result {hello 1} -constraints [list socket supported_$af thread] +} -result {hello 1} -constraints [list socket supported_$af thread] + +proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { + try { + set ::count 0 + set ::testmode $testmode + set port 0 + set srvsock {} + # if binding on port 0 is not possible (system related, blocked on ISPs etc): + if {[catch {close [socket -async $::localhost $port]}]} { + # simplest server on random port (immediatelly closing a connect): + set port [randport] + set srvsock [socket -server {apply {{ch args} {close $ch}}} -myaddr $::localhost $port] + # socket on windows has some issues yet (e. g. bug [b6d0d8cc2c]), so we simply decrease iteration count (to 1/4): + if {$::tcl_platform(platform) eq "windows" && $maxIter > 50} { + set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations + } + } + tcltest::DebugPuts 2 "== test \[$::localhost\]:$port $testmode ==" + set ::parent [thread::id] + # helper thread creating async connection and initiating transfer (detach) to parent: + set ::helper [thread::create] + thread::send -async $::helper [list \ + lassign [list $::parent $::localhost $port $testmode] \ + ::parent ::localhost ::port ::testmode + ] + thread::send -async $::helper { + set ::helper [thread::id] + proc iteration {args} { + set fd [socket -async $::localhost $::port] + if {"helper-writable" in $::testmode} {;# to test both sides during connect + fileevent $fd writable [list apply {{fd} { + if {[thread::id] ne $::helper} { + thread::send -async $::parent {set ::count "ERROR: invalid thread, $::helper is expecting"} + close $fd + return + } + }} $fd] + };# + thread::detach $fd + thread::send -async $::parent [list transf_parent $fd {*}$args] + } + iteration first + } + # parent proc commiting transfer attempt (attach) and checking acquire was successful: + proc transf_parent {fd args} { + tcltest::DebugPuts 2 "** trma / $::count ** $args **" + thread::attach $fd + if {"parent-close" in $::testmode} {;# to test close during connect + set ::count $::count + close $fd + return + };# + fileevent $fd writable [list apply {{fd} { + if {[thread::id] ne $::parent} { + thread::send -async $::parent {set ::count "ERROR: invalid thread, $::parent is expecting"} + close $fd + return + } + set ::count $::count + close $fd + }} $fd] + } + # repeat maxIter times (up to maxTime ms as timeout): + set tout [after $maxTime {set ::count "TIMEOUT"}] + while 1 { + vwait ::count + if {![string is integer $::count]} { + # if timeout just skip (test was successful until now): + if {$::count eq "TIMEOUT"} {::tcltest::Skip "timing issue"} + break + } + if {[incr ::count] >= $maxIter} break + tcltest::DebugPuts 2 "** iter / $::count **" + thread::send -async $::helper [list iteration nr $::count] + } + update + set ::count + } finally { + catch {after cancel $tout} + if {$srvsock ne {}} {close $srvsock} + if {[info exists ::helper]} {thread::release -wait $::helper} + tcltest::DebugPuts 2 "== stop / $::count ==" + unset -nocomplain ::count ::testmode ::parent ::helper + } +} +test socket_$af-13.2.tr1 {Testing socket transfer between threads during async connect} -body { + transf_test {transfer} 1000 +} -result 1000 -constraints [list socket supported_$af thread] +test socket_$af-13.2.tr2 {Testing socket transfer between threads during async connect} -body { + transf_test {transfer helper-writable} 100 +} -result 100 -constraints [list socket supported_$af thread] +test socket_$af-13.2.cl1 {Testing socket transfer between threads during async connect} -body { + transf_test {parent-close} 100 +} -result 100 -constraints [list socket supported_$af thread] +test socket_$af-13.2.cl2 {Testing socket transfer between threads during async connect} -body { + transf_test {parent-close helper-writable} 100 +} -result 100 -constraints [list socket supported_$af thread] +catch {rename transf_parent {}} +rename transf_test {} # ---------------------------------------------------------------------- @@ -1723,8 +1969,8 @@ catch {close $commandSocket} catch {close $remoteProcChan} } unset ::tcl::unsupported::socketAF -test socket-14.0 {[socket -async] when server only listens on IPv4} \ - -constraints [list socket supported_any localhost_v4] \ +test socket-14.0.0 {[socket -async] when server only listens on IPv4} \ + -constraints {socket supported_inet localhost_v4} \ -setup { proc accept {s a p} { global x @@ -1736,7 +1982,29 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \ set port [lindex [fconfigure $server -sockname] 2] } -body { set client [socket -async localhost $port] - set after [after 1000 {set x [fconfigure $client -error]}] + set after [after $latency {set x [fconfigure $client -error]}] + vwait x + set x + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result ok +test socket-14.0.1 {[socket -async] when server only listens on IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set client [socket -async localhost $port] + set after [after $latency {set x [fconfigure $client -error]}] vwait x set x } -cleanup { @@ -1746,7 +2014,7 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \ unset x } -result ok test socket-14.1 {[socket -async] fileevent while still connecting} \ - -constraints [list socket supported_any] \ + -constraints {socket} \ -setup { proc accept {s a p} { global x @@ -1763,7 +2031,7 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ lappend x [fconfigure $client -error] fileevent $client writable {} } - set after [after 1000 {lappend x timeout}] + set after [after $latency {lappend x timeout}] while {[llength $x] < 2 && "timeout" ni $x} { vwait x } @@ -1775,26 +2043,21 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ unset x } -result {{} ok} test socket-14.2 {[socket -async] fileevent connection refused} \ - -constraints [list socket supported_any] \ + -constraints {socket} \ -body { - if {[catch {socket -async localhost [randport]} client]} { - regexp {[^:]*: (.*)} $client -> x - } else { - fileevent $client writable {set x [fconfigure $client -error]} - set after [after 1000 {set x timeout}] - vwait x - after cancel $after - if {$x eq "timeout"} { - append x ": [fconfigure $client -error]" - } - close $client - } - set x + set client [socket -async localhost [randport]] + fileevent $client writable {set x ok} + set after [after $latency {set x timeout}] + vwait x + after cancel $after + lappend x [fconfigure $client -error] } -cleanup { - unset x - } -result "connection refused" + after cancel $after + close $client + unset x after client + } -result {ok {connection refused}} test socket-14.3 {[socket -async] when server only listens on IPv6} \ - -constraints [list socket supported_any localhost_v6] \ + -constraints {socket supported_inet6 localhost_v6} \ -setup { proc accept {s a p} { global x @@ -1806,7 +2069,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \ set port [lindex [fconfigure $server -sockname] 2] } -body { set client [socket -async localhost $port] - set after [after 1000 {set x [fconfigure $client -error]}] + set after [after $latency {set x [fconfigure $client -error]}] vwait x set x } -cleanup { @@ -1816,7 +2079,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \ unset x } -result ok test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ - -constraints [list socket supported_any] \ + -constraints {socket} \ -setup { proc accept {s a p} { puts $s bye @@ -1832,7 +2095,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ fileevent $client writable {} } fileevent $client readable {lappend x [gets $client]} - set after [after 1000 {lappend x timeout}] + set after [after $latency {lappend x timeout}] while {[llength $x] < 2 && "timeout" ni $x} { vwait x } @@ -1841,15 +2104,484 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ after cancel $after close $client close $server + unset x } -result {{} bye} +# FIXME: we should also have an IPv6 counterpart of this test socket-14.5 {[socket -async] which fails before any connect() can be made} \ - -constraints [list socket supported_any] \ + -constraints {socket supported_inet notWine} \ -body { # address from rfc5737 socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] } \ -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} +test socket-14.6.0 {[socket -async] with no event loop and server listening on IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } \ + -body { + set client [socket -async localhost $port] + for {set i 0} {$i < 50} {incr i } { + update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 + } + set x + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result {ok bye} +test socket-14.6.1 {[socket -async] with no event loop and server listening on IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + set x ok + } + set server [socket -server accept -myaddr ::1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } \ + -body { + set client [socket -async localhost $port] + for {set i 0} {$i < 50} {incr i } { + update + if {$x ne ""} { + lappend x [gets $client] + break + } + after 100 + } + set x + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result {ok bye} +test socket-14.7.0 {pending [socket -async] and blocking [gets], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok {}} +test socket-14.7.1 {pending [socket -async] and blocking [gets], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + list [fconfigure $sock -error] [gets $sock] [fconfigure $sock -error] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok {}} +test socket-14.7.2 {pending [socket -async] and blocking [gets], no listener} \ + -constraints {socket} \ + -body { + set sock [socket -async localhost [randport]] + catch {gets $sock} x + list $x [fconfigure $sock -error] [fconfigure $sock -error] + } -cleanup { + close $sock + } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} +test socket-14.8.0 {pending [socket -async] and nonblocking [gets], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + set x + } -cleanup { + close $fd + close $sock + removeFile script + } -result {ok} +test socket-14.8.1 {pending [socket -async] and nonblocking [gets], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {puts $s ok; close $s; set ::x 1} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + set x + } -cleanup { + close $fd + close $sock + removeFile script + } -result {ok} +test socket-14.8.2 {pending [socket -async] and nonblocking [gets], no listener} \ + -constraints {socket} \ + -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + for {set i 0} {$i < 50} {incr i } { + if {[catch {gets $sock} x] || $x ne "" || ![fblocked $sock]} break + after 200 + } + list $x [fconfigure $sock -error] [fconfigure $sock -error] + } -cleanup { + close $sock + } -match glob -result {{error reading "sock*": socket is not connected} {connection refused} {}} +test socket-14.9.0 {pending [socket -async] and blocking [puts], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + puts $sock ok + flush $sock + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok} +test socket-14.9.1 {pending [socket -async] and blocking [puts], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + puts $sock ok + flush $sock + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok} +test socket-14.10.0 {pending [socket -async] and nonblocking [puts], server is IPv4} \ + -constraints {socket supported_inet localhost_v4} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr 127.0.0.1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $fd readable {set x 1} + vwait x + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok} +test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is IPv6} \ + -constraints {socket supported_inet6 localhost_v6} \ + -setup { + makeFile { + fileevent stdin readable exit + set server [socket -server accept -myaddr ::1 0] + proc accept {s h p} {set ::x $s} + puts [lindex [fconfigure $server -sockname] 2] + flush stdout + vwait x + puts [gets $x] + } script + set fd [open |[list [interpreter] script] RDWR] + set port [gets $fd] + } -body { + set sock [socket -async localhost $port] + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + fileevent $fd readable {set x 1} + vwait x + list [fconfigure $sock -error] [gets $fd] + } -cleanup { + close $fd + close $sock + removeFile script + } -result {{} ok} +test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \ + -constraints {socket notWinCI} \ + -body { + set sock [socket -async localhost [randport]] + fconfigure $sock -blocking 0 + puts $sock ok + fileevent $sock writable {set x 1} + vwait x + close $sock + } -cleanup { + catch {close $sock} + unset x + } -result {socket is not connected} -returnCodes 1 +test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \ + -constraints {socket testsocket_testflags} \ + -body { + set sock [socket -async localhost [randport]] + # Set the socket in async test mode. + # The async connect will not be continued on the following fconfigure + # and puts/flush. Thus, the connect will fail after them. + testsocket testflags $sock 1 + fconfigure $sock -blocking 0 + puts $sock ok + flush $sock + testsocket testflags $sock 0 + fileevent $sock writable {set x 1} + vwait x + close $sock + } -cleanup { + catch {close $sock} + catch {unset x} + } -result {socket is not connected} -returnCodes 1 +test socket-14.12 {[socket -async] background progress triggered by [fconfigure -error]} \ + -constraints {socket} \ + -body { + set s [socket -async localhost [randport]] + for {set i 0} {$i < 50} {incr i} { + set x [fconfigure $s -error] + if {$x != ""} break + after 200 + } + set x + } -cleanup { + close $s + unset x s + } -result {connection refused} + +test socket-14.13 {testing writable event when quick failure} \ + -constraints {socket win supported_inet notWine} \ + -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 {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 + +test socket-14.15 {blocking read on async socket should not trigger event handlers} \ + -constraints socket -body { + set s [socket -async localhost [randport]] + set x ok + fileevent $s writable {set x fail} + catch {read $s} + close $s + set x + } -result ok + +# v4 and v6 is required to prevent that the async connect does not terminate +# before the fconfigure command. There is always an additional ip to try. +test socket-14.16 {empty -peername while [socket -async] connecting} \ + -constraints {socket localhost_v4 localhost_v6} \ + -body { + set client [socket -async localhost [randport]] + fconfigure $client -peername + } -cleanup { + catch {close $client} + } -result {} + +# v4 and v6 is required to prevent that the async connect does not terminate +# before the fconfigure command. There is always an additional ip to try. +test socket-14.17 {empty -sockname while [socket -async] connecting} \ + -constraints {socket localhost_v4 localhost_v6} \ + -body { + set client [socket -async localhost [randport]] + fconfigure $client -sockname + } -cleanup { + catch {close $client} + } -result {} + +# test for bug c6ed4acfd8: running async socket connect with other connect +# established will block tcl as it goes in an infinite loop in vwait +test socket-14.18 {bug c6ed4acfd8: running async socket connect made other connect block} \ + -constraints {socket} \ + -body { + proc accept {channel address port} {} + set port [randport] + set ssock [socket -server accept $port] + set csock1 [socket -async localhost [randport]] + set csock2 [socket localhost $port] + after 1000 {set done ok} + vwait done +} -cleanup { + catch {close $ssock} + catch {close $csock1} + catch {close $csock2} + } -result {} + +test socket-14.19 {tip 456 -- introduce the -reuseport option} \ + -constraints {socket notWine} \ + -body { + proc accept {channel address port} {} + set port [randport] + set ssock1 [socket -server accept -reuseport yes $port] + set ssock2 [socket -server accept -reuseport yes $port] + return ok +} -cleanup { + catch {close $ssock1} + catch {close $ssock2} + } -result ok + +set num 0 + +set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}} +set resultok {-result "sock*" -match glob} +set resulterr { + -result {couldn't open socket: connection refused} + -returnCodes 1 +} +foreach {servip sc} $x { + foreach {cliip cc} $x { + set constraints socket + lappend constraints $sc $cc + set result $resulterr + switch -- [lsort -unique [list $servip $cliip]] { + localhost - 127.0.0.1 - ::1 { + set result $resultok + } + {127.0.0.1 localhost} { + if {[testConstraint localhost_v4]} { + set result $resultok + } + } + {::1 localhost} { + if {[testConstraint localhost_v6]} { + set result $resultok + } + } + } + test socket-15.1.$num "Connect to $servip from $cliip" \ + -constraints $constraints -setup { + set server [socket -server accept -myaddr $servip 0] + proc accept {s h p} { close $s } + set port [lindex [fconfigure $server -sockname] 2] + } -body { + set s [socket $cliip $port] + } -cleanup { + close $server + catch {close $s} + } {*}$result + incr num + } +} + ::tcltest::cleanupTests flush stdout return diff --git a/tests/source.test b/tests/source.test index d71212d..47f1486 100644 --- a/tests/source.test +++ b/tests/source.test @@ -4,16 +4,16 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-2000 Scriptics Corporation. # Contributions from Don Porter, NIST, 2003. (not subject to US copyright) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." +if {[catch {package require tcltest 2.5}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.5 required." return } @@ -103,10 +103,9 @@ test source-2.6 {source error conditions} -setup { set sourcefile [makeFile {} _non_existent_] removeFile _non_existent_ } -body { - list [catch {source $sourcefile} msg] $msg $::errorCode -} -match listGlob -result [list 1 \ - {couldn't read file "*_non_existent_": no such file or directory} \ - {POSIX ENOENT {no such file or directory}}] + source $sourcefile +} -match glob -result {couldn't read file "*_non_existent_": no such file or directory} \ + -errorCode {POSIX ENOENT {no such file or directory}} test source-2.7 {utf-8 with BOM} -setup { set sourcefile [makeFile {} source.file] } -body { @@ -187,6 +186,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. @@ -231,12 +240,12 @@ test source-7.2 {source -encoding test} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] - fconfigure $f -encoding unicode + fconfigure $f -encoding utf-16 puts $f "set symbol(square-root) \u221A; set x correct" close $f } -body { set x unset - source -encoding unicode $sourcefile + source -encoding utf-16 $sourcefile set x } -cleanup { removeFile source.file diff --git a/tests/split.test b/tests/split.test index 778131f..74879cf 100644 --- a/tests/split.test +++ b/tests/split.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -43,7 +43,7 @@ test split-1.8 {basic split commands} { foreach f [split {]\n} {}] { append x $f } - return $x + return $x } foo } {]\n} @@ -70,6 +70,12 @@ test split-1.13 {basic split commands} { test split-1.14 {basic split commands} { split ",12,,,34,56," {,} } {{} 12 {} {} 34 56 {}} +test split-1.15 {basic split commands} -body { + split "a\U1F4A9b" {} +} -result "a \U1F4A9 b" +test split-1.16 {basic split commands} -body { + split "a\U1F4A9b" \U1F4A9 +} -result "a b" test split-2.1 {split errors} { list [catch split msg] $msg $errorCode diff --git a/tests/stack.test b/tests/stack.test index 873cb08..461e8d3 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -4,13 +4,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1998-2000 Ajuba Solutions. +# Copyright © 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -33,7 +33,7 @@ test stack-2.1 {maxNestingDepth reached on infinite recursion} -body { puts $msg } } -result {too many nested evaluations (infinite loop?)} - + # Make sure that there is enough stack to run regexp even if we're # close to the recursion limit. [Bug 947070] [Patch 746378] test stack-3.1 {enough room for regexp near recursion limit} -body { diff --git a/tests/string.test b/tests/string.test index 8cacd07..11bc573 100644 --- a/tests/string.test +++ b/tests/string.test @@ -4,1801 +4,2151 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2001 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] + +# Helper commands to test various optimizations, code paths, and special cases. +proc makeByteArray {s} {binary format a* $s} +proc makeUnicode {s} {lindex [regexp -inline .* $s] 0} +proc makeList {args} {return $args} +proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s} # Some tests require the testobj command -testConstraint testobj [expr {[info commands testobj] != {}}] -testConstraint testindexobj [expr {[info commands testindexobj] != {}}] +testConstraint testobj [expr {[info commands testobj] ne {}}] +testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] +testConstraint testevalex [expr {[info commands testevalex] ne {}}] +testConstraint utf16 [expr {[string length \U010000] == 2}] +testConstraint testbytestring [llength [info commands testbytestring]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} -test string-1.1 {error conditions} { - list [catch {string gorp a b} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test string-1.2 {error conditions} { - list [catch {string} msg] $msg +proc representationpoke s { + set r [::tcl::unsupported::representation $s] + list [lindex $r 3] [string match {*, string representation "*"} $r] +} + +foreach noComp {0 1} { + +if {$noComp} { + if {[info commands testevalex] eq {}} { + test string-0.1.$noComp "show testevalex availability" {testevalex} {list} {} + continue + } + interp alias {} run {} testevalex + set constraints testevalex +} else { + interp alias {} run {} try + set constraints {} +} + + +test string-1.1.$noComp {error conditions} { + list [catch {run {string gorp a b}} msg] $msg +} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-1.2.$noComp {error conditions} { + list [catch {run {string}} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} +test stringComp-1.3.$noComp {error condition - undefined method during compile} { + # We don't want this to complain about 'never' because it may never + # be called, or string may get redefined. This must compile OK. + proc foo {str i} { + if {"yes" == "no"} { string never called but complains here } + string index $str $i + } + foo abc 0 +} a -test string-2.1 {string compare, too few args} { - list [catch {string compare a} msg] $msg +test string-2.1.$noComp {string compare, not enough args} { + list [catch {run {string compare a}} msg] $msg } {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test string-2.2 {string compare, bad args} { - list [catch {string compare a b c} msg] $msg +test string-2.2.$noComp {string compare, bad args} { + list [catch {run {string compare a b c}} msg] $msg } {1 {bad option "a": must be -nocase or -length}} -test string-2.3 {string compare, bad args} { - list [catch {string compare -length -nocase str1 str2} msg] $msg +test string-2.3.$noComp {string compare, bad args} { + list [catch {run {string compare -length -nocase str1 str2}} msg] $msg } {1 {expected integer but got "-nocase"}} -test string-2.4 {string compare, too many args} { - list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg +test string-2.4.$noComp {string compare, too many args} { + list [catch {run {string compare -length 10 -nocase str1 str2 str3}} msg] $msg } {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test string-2.5 {string compare with length unspecified} { - list [catch {string compare -length 10 10} msg] $msg +test string-2.5.$noComp {string compare with length unspecified} { + list [catch {run {string compare -length 10 10}} msg] $msg } {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test string-2.6 {string compare} { - string compare abcde abdef +test string-2.6.$noComp {string compare} { + run {string compare abcde abdef} } -1 -test string-2.7 {string compare, shortest method name} { - string c abcde ABCDE +test string-2.7.$noComp {string compare, shortest method name} { + run {string co abcde ABCDE} } 1 -test string-2.8 {string compare} { - string compare abcde abcde +test string-2.8.$noComp {string compare} { + run {string compare abcde abcde} } 0 -test string-2.9 {string compare with length} { - string compare -length 2 abcde abxyz +test string-2.9.$noComp {string compare with length} { + run {string compare -length 2 abcde abxyz} } 0 -test string-2.10 {string compare with special index} { - list [catch {string compare -length end-3 abcde abxyz} msg] $msg +test string-2.10.$noComp {string compare with special index} { + list [catch {run {string compare -length end-3 abcde abxyz}} msg] $msg } {1 {expected integer but got "end-3"}} -test string-2.11 {string compare, unicode} { - string compare ab\u7266 ab\u7267 +test string-2.11.$noComp {string compare, unicode} { + run {string compare ab\u7266 ab\u7267} } -1 -test string-2.12 {string compare, high bit} { - # This test will fail if the underlying comparaison +test string-2.11.1.$noComp {string compare, unicode} { + run {string compare \334 \xDC} +} 0 +test string-2.11.2.$noComp {string compare, unicode} { + run {string compare \334 \xFC} +} -1 +test string-2.11.3.$noComp {string compare, unicode} { + run {string compare \334\334\334\374\374 \334\334\334\334\334} +} 1 +test string-2.12.$noComp {string compare, high bit} { + # This test will fail if the underlying comparison # is using signed chars instead of unsigned chars. # (like SunOS's default memcmp thus the compat/memcmp.c) - string compare "\x80" "@" - # Nb this tests works also in utf8 space because \x80 is + run {string compare "\x80" "@"} + # Nb this tests works also in utf-8 space because \x80 is # translated into a 2 or more bytelength but whose first byte has # the high bit set. } 1 -test string-2.13 {string compare -nocase} { - string compare -nocase abcde abdef +test string-2.13.$noComp {string compare -nocase} { + run {string compare -nocase abcde abdef} } -1 -test string-2.14 {string compare -nocase} { - string c -nocase abcde ABCDE +test string-2.13.1.$noComp {string compare -nocase} { + run {string compare -nocase abcde Abdef} +} -1 +test string-2.14.$noComp {string compare -nocase} { + run {string compare -nocase abcde ABCDE} +} 0 +test string-2.15.$noComp {string compare -nocase} { + run {string compare -nocase abcde abcde} } 0 -test string-2.15 {string compare -nocase} { - string compare -nocase abcde abcde +test string-2.15.1.$noComp {string compare -nocase} { + run {string compare -nocase \334 \xDC} } 0 -test string-2.16 {string compare -nocase with length} { - string compare -length 2 -nocase abcde Abxyz +test string-2.15.2.$noComp {string compare -nocase} { + run {string compare -nocase \334\334\334\374\xFC \334\334\334\334\334} } 0 -test string-2.17 {string compare -nocase with length} { - string compare -nocase -length 3 abcde Abxyz +test string-2.16.$noComp {string compare -nocase with length} { + run {string compare -length 2 -nocase abcde Abxyz} +} 0 +test string-2.17.$noComp {string compare -nocase with length} { + run {string compare -nocase -length 3 abcde Abxyz} } -1 -test string-2.18 {string compare -nocase with length <= 0} { - string compare -nocase -length -1 abcde AbCdEf +test string-2.18.$noComp {string compare -nocase with length <= 0} { + run {string compare -nocase -length -1 abcde AbCdEf} } -1 -test string-2.19 {string compare -nocase with excessive length} { - string compare -nocase -length 50 AbCdEf abcde +test string-2.19.$noComp {string compare -nocase with excessive length} { + run {string compare -nocase -length 50 AbCdEf abcde} } 1 -test string-2.20 {string compare -len unicode} { +test string-2.20.$noComp {string compare -len unicode} { # These are strings that are 6 BYTELENGTH long, but the length # shouldn't make a different because there are actually 3 CHARS long - string compare -len 5 \334\334\334 \334\334\374 + run {string compare -len 5 \334\334\334 \334\334\374} } -1 -test string-2.21 {string compare -nocase with special index} { - list [catch {string compare -nocase -length end-3 Abcde abxyz} msg] $msg +test string-2.21.$noComp {string compare -nocase with special index} { + list [catch {run {string compare -nocase -length end-3 Abcde abxyz}} msg] $msg } {1 {expected integer but got "end-3"}} -test string-2.22 {string compare, null strings} { - string compare "" "" +test string-2.22.$noComp {string compare, null strings} { + run {string compare "" ""} } 0 -test string-2.23 {string compare, null strings} { - string compare "" foo +test string-2.23.$noComp {string compare, null strings} { + run {string compare "" foo} } -1 -test string-2.24 {string compare, null strings} { - string compare foo "" +test string-2.24.$noComp {string compare, null strings} { + run {string compare foo ""} } 1 -test string-2.25 {string compare -nocase, null strings} { - string compare -nocase "" "" +test string-2.25.$noComp {string compare -nocase, null strings} { + run {string compare -nocase "" ""} } 0 -test string-2.26 {string compare -nocase, null strings} { - string compare -nocase "" foo +test string-2.26.$noComp {string compare -nocase, null strings} { + run {string compare -nocase "" foo} } -1 -test string-2.27 {string compare -nocase, null strings} { - string compare -nocase foo "" +test string-2.27.$noComp {string compare -nocase, null strings} { + run {string compare -nocase foo ""} } 1 -test string-2.28 {string compare with length, unequal strings} { - string compare -length 2 abc abde +test string-2.28.$noComp {string compare with length, unequal strings} { + run {string compare -length 2 abc abde} } 0 -test string-2.29 {string compare with length, unequal strings} { - string compare -length 2 ab abde +test string-2.29.$noComp {string compare with length, unequal strings} { + run {string compare -length 2 ab abde} } 0 -test string-2.30 {string compare with NUL character vs. other ASCII} { +test string-2.30.$noComp {string compare with NUL character vs. other ASCII} { # Be careful here, since UTF-8 rep comparison with memcmp() of # these puts chars in the wrong order - string compare \x00 \x01 + run {string compare \x00 \x01} } -1 -test string-2.31 {string compare, high bit} { - proc foo {} {string compare "a\x80" "a@"} - foo +test string-2.31.$noComp {string compare, high bit} { + run {string compare "a\x80" "a@"} } 1 -test string-2.32 {string compare, high bit} { - proc foo {} {string compare "a\x00" "a\x01"} - foo +test string-2.32.$noComp {string compare, high bit} { + run {string compare "a\x00" "a\x01"} } -1 -test string-2.33 {string compare, high bit} { - proc foo {} {string compare "\x00\x00" "\x00\x01"} - foo +test string-2.33.$noComp {string compare, high bit} { + run {string compare "\x00\x00" "\x00\x01"} } -1 +test string-2.34.$noComp {string compare, binary equal} { + run {string compare [binary format a100 0] [binary format a100 0]} +} 0 +test string-2.35.$noComp {string compare, binary neq} { + run {string compare [binary format a100a 0 1] [binary format a100a 0 0]} +} 1 +test string-2.36.$noComp {string compare, binary neq unequal length} { + run {string compare [binary format a20a 0 1] [binary format a100a 0 0]} +} 1 # only need a few tests on equal, since it uses the same code as # string compare, but just modifies the return output -test string-3.1 {string equal} { - string equal abcde abdef +test string-3.1.$noComp {string equal} { + run {string equal abcde abdef} } 0 -test string-3.2 {string equal} { - string eq abcde ABCDE +test string-3.2.$noComp {string equal} { + run {string e abcde ABCDE} } 0 -test string-3.3 {string equal} { - string equal abcde abcde +test string-3.3.$noComp {string equal} { + run {string equal abcde abcde} } 1 -test string-3.4 {string equal -nocase} { - string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334 +test string-3.4.$noComp {string equal -nocase} { + run {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334} } 1 -test string-3.5 {string equal -nocase} { - string equal -nocase abcde abdef +test string-3.5.$noComp {string equal -nocase} { + run {string equal -nocase abcde abdef} } 0 -test string-3.6 {string equal -nocase} { - string eq -nocase abcde ABCDE +test string-3.6.$noComp {string equal -nocase} { + run {string eq -nocase abcde ABCDE} } 1 -test string-3.7 {string equal -nocase} { - string equal -nocase abcde abcde +test string-3.7.$noComp {string equal -nocase} { + run {string equal -nocase abcde abcde} } 1 -test string-3.8 {string equal with length, unequal strings} { - string equal -length 2 abc abde +test string-3.8.$noComp {string equal with length, unequal strings} { + run {string equal -length 2 abc abde} } 1 +test string-3.9.$noComp {string equal, not enough args} { + list [catch {run {string equal a}} msg] $msg +} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} +test string-3.10.$noComp {string equal, bad args} { + list [catch {run {string equal a b c}} msg] $msg +} {1 {bad option "a": must be -nocase or -length}} +test string-3.11.$noComp {string equal, bad args} { + list [catch {run {string equal -length -nocase str1 str2}} msg] $msg +} {1 {expected integer but got "-nocase"}} +test string-3.12.$noComp {string equal, too many args} { + list [catch {run {string equal -length 10 -nocase str1 str2 str3}} msg] $msg +} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} +test string-3.13.$noComp {string equal with length unspecified} { + list [catch {run {string equal -length 10 10}} msg] $msg +} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} +test string-3.14.$noComp {string equal with length} { + run {string equal -length 2 abcde abxyz} +} 1 +test string-3.15.$noComp {string equal with special index} { + list [catch {run {string equal -length end-3 abcde abxyz}} msg] $msg +} {1 {expected integer but got "end-3"}} -test string-4.1 {string first, too few args} { - list [catch {string first a} msg] $msg +test string-3.16.$noComp {string equal, unicode} { + run {string equal ab\u7266 ab\u7267} +} 0 +test string-3.17.$noComp {string equal, unicode} { + run {string equal \334 \xDC} +} 1 +test string-3.18.$noComp {string equal, unicode} { + run {string equal \334 \xFC} +} 0 +test string-3.19.$noComp {string equal, unicode} { + run {string equal \334\334\334\374\374 \334\334\334\334\334} +} 0 +test string-3.20.$noComp {string equal, high bit} { + # This test will fail if the underlying comparaison + # is using signed chars instead of unsigned chars. + # (like SunOS's default memcmp thus the compat/memcmp.c) + run {string equal "\x80" "@"} + # Nb this tests works also in utf8 space because \x80 is + # translated into a 2 or more bytelength but whose first byte has + # the high bit set. +} 0 +test string-3.21.$noComp {string equal -nocase} { + run {string equal -nocase abcde Abdef} +} 0 +test string-3.22.$noComp {string equal, -nocase unicode} { + run {string equal -nocase \334 \xDC} +} 1 +test string-3.23.$noComp {string equal, -nocase unicode} { + run {string equal -nocase \334\334\334\374\xFC \334\334\334\334\334} +} 1 +test string-3.24.$noComp {string equal -nocase with length} { + run {string equal -length 2 -nocase abcde Abxyz} +} 1 +test string-3.25.$noComp {string equal -nocase with length} { + run {string equal -nocase -length 3 abcde Abxyz} +} 0 +test string-3.26.$noComp {string equal -nocase with length <= 0} { + run {string equal -nocase -length -1 abcde AbCdEf} +} 0 +test string-3.27.$noComp {string equal -nocase with excessive length} { + run {string equal -nocase -length 50 AbCdEf abcde} +} 0 +test string-3.28.$noComp {string equal -len unicode} { + # These are strings that are 6 BYTELENGTH long, but the length + # shouldn't make a different because there are actually 3 CHARS long + run {string equal -len 5 \334\334\334 \334\334\374} +} 0 +test string-3.29.$noComp {string equal -nocase with special index} { + list [catch {run {string equal -nocase -length end-3 Abcde abxyz}} msg] $msg +} {1 {expected integer but got "end-3"}} +test string-3.30.$noComp {string equal, null strings} { + run {string equal "" ""} +} 1 +test string-3.31.$noComp {string equal, null strings} { + run {string equal "" foo} +} 0 +test string-3.32.$noComp {string equal, null strings} { + run {string equal foo ""} +} 0 +test string-3.33.$noComp {string equal -nocase, null strings} { + run {string equal -nocase "" ""} +} 1 +test string-3.34.$noComp {string equal -nocase, null strings} { + run {string equal -nocase "" foo} +} 0 +test string-3.35.$noComp {string equal -nocase, null strings} { + run {string equal -nocase foo ""} +} 0 +test string-3.36.$noComp {string equal with NUL character vs. other ASCII} { + # Be careful here, since UTF-8 rep comparison with memcmp() of + # these puts chars in the wrong order + run {string equal \x00 \x01} +} 0 +test string-3.37.$noComp {string equal, high bit} { + run {string equal "a\x80" "a@"} +} 0 +test string-3.38.$noComp {string equal, high bit} { + run {string equal "a\x00" "a\x01"} +} 0 +test string-3.39.$noComp {string equal, high bit} { + run {string equal "a\x00\x00" "a\x00\x01"} +} 0 +test string-3.40.$noComp {string equal, binary equal} { + run {string equal [binary format a100 0] [binary format a100 0]} +} 1 +test string-3.41.$noComp {string equal, binary neq} { + run {string equal [binary format a100a 0 1] [binary format a100a 0 0]} +} 0 +test string-3.42.$noComp {string equal, binary neq inequal length} { + run {string equal [binary format a20a 0 1] [binary format a100a 0 0]} +} 0 + + +test string-4.1.$noComp {string first, not enough args} { + list [catch {run {string first a}} msg] $msg } {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test string-4.2 {string first, bad args} { - list [catch {string first a b c} msg] $msg +test string-4.2.$noComp {string first, bad args} { + list [catch {run {string first a b c}} msg] $msg } {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} -test string-4.3 {string first, too many args} { - list [catch {string first a b 5 d} msg] $msg +test string-4.3.$noComp {string first, too many args} { + list [catch {run {string first a b 5 d}} msg] $msg } {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test string-4.4 {string first} { - string first bq abcdefgbcefgbqrs +test string-4.4.$noComp {string first} { + run {string first bq abcdefgbcefgbqrs} } 12 -test string-4.5 {string first} { - string fir bcd abcdefgbcefgbqrs +test string-4.5.$noComp {string first} { + run {string fir bcd abcdefgbcefgbqrs} } 1 -test string-4.6 {string first} { - string f b abcdefgbcefgbqrs +test string-4.6.$noComp {string first} { + run {string f b abcdefgbcefgbqrs} } 1 -test string-4.7 {string first} { - string first xxx x123xx345xxx789xxx012 +test string-4.7.$noComp {string first} { + run {string first xxx x123xx345xxx789xxx012} } 9 -test string-4.8 {string first} { - string first "" x123xx345xxx789xxx012 +test string-4.8.$noComp {string first} { + run {string first "" x123xx345xxx789xxx012} } -1 -test string-4.9 {string first, unicode} { - string first x abc\u7266x +test string-4.9.$noComp {string first, unicode} { + run {string first x abc\u7266x} } 4 -test string-4.10 {string first, unicode} { - string first \u7266 abc\u7266x -} 3 -test string-4.11 {string first, start index} { - string first \u7266 abc\u7266x 3 +test string-4.10.$noComp {string first, unicode} { + run {string first \u7266 abc\u7266x} } 3 -test string-4.12 {string first, start index} { - string first \u7266 abc\u7266x 4 -} -1 -test string-4.13 {string first, start index} { - string first \u7266 abc\u7266x end-2 +test string-4.11.$noComp {string first, start index} { + run {string first \u7266 abc\u7266x 3} } 3 -test string-4.14 {string first, negative start index} { - string first b abc -1 -} 1 -test string-4.15 {string first, ability to two-byte encoded utf-8 chars} { +test string-4.12.$noComp {string first, start index} -body { + run {string first \u7266 abc\u7266x 4} +} -result -1 +test string-4.13.$noComp {string first, start index} -body { + run {string first \u7266 abc\u7266x end-2} +} -result 3 +test string-4.14.$noComp {string first, negative start index} -body { + run {string first b abc -1} +} -result 1 +test string-4.15.$noComp {string first, ability to two-byte encoded utf-8 chars} -body { # Test for a bug in Tcl 8.3 where test for all-single-byte-encoded - # strings was incorrect, leading to an index returned by [string first] + # strings was incorrect, leading to an index returned by [string first] # which pointed past the end of the string. - set uchar \u057e ;# character with two-byte encoding in utf-8 - string first % %#$uchar$uchar#$uchar$uchar#% 3 -} 8 + set uchar \u057E ;# character with two-byte encoding in utf-8 + run {string first % %#$uchar$uchar#$uchar$uchar#% 3} +} -result 8 +test string-4.16.$noComp {string first, normal string vs pure unicode string} -body { + set s hello + regexp ll $s m + # Representation checks are canaries + run {list [representationpoke $s] [representationpoke $m] \ + [string first $m $s]} +} -result {{string 1} {string 0} 2} +test string-4.17.$noComp {string first, corner case} -body { + run {string first a aaa 4294967295} +} -result {-1} +test string-4.18.$noComp {string first, corner case} -body { + run {string first a aaa -1} +} -result {0} +test string-4.19.$noComp {string first, corner case} -body { + run {string first a aaa end-5} +} -result {0} +test string-4.20.$noComp {string last, corner case} -body { + run {string last a aaa 4294967295} +} -result {2} +test string-4.21.$noComp {string last, corner case} -body { + run {string last a aaa -1} +} -result {-1} +test string-4.22.$noComp {string last, corner case} { + run {string last a aaa end-5} +} {-1} -test string-5.1 {string index} { - list [catch {string index} msg] $msg +test string-5.1.$noComp {string index} { + list [catch {run {string index}} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} -test string-5.2 {string index} { - list [catch {string index a b c} msg] $msg +test string-5.2.$noComp {string index} { + list [catch {run {string index a b c}} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} -test string-5.3 {string index} { - string index abcde 0 +test string-5.3.$noComp {string index} { + run {string index abcde 0} } a -test string-5.4 {string index} { - string in abcde 4 +test string-5.4.$noComp {string index} { + run {string ind abcde 4} } e -test string-5.5 {string index} { - string index abcde 5 +test string-5.5.$noComp {string index} { + run {string index abcde 5} } {} -test string-5.6 {string index} { - list [catch {string index abcde -10} msg] $msg +test string-5.6.$noComp {string index} { + list [catch {run {string index abcde -10}} msg] $msg } {0 {}} -test string-5.7 {string index} { - list [catch {string index a xyz} msg] $msg +test string-5.7.$noComp {string index} { + list [catch {run {string index a xyz}} msg] $msg } {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} -test string-5.8 {string index} { - string index abc end +test string-5.8.$noComp {string index} { + run {string index abc end} } c -test string-5.9 {string index} { - string index abc end-1 +test string-5.9.$noComp {string index} { + run {string index abc end-1} } b -test string-5.10 {string index, unicode} { - string index abc\u7266d 4 +test string-5.10.$noComp {string index, unicode} { + run {string index abc\u7266d 4} } d -test string-5.11 {string index, unicode} { - string index abc\u7266d 3 +test string-5.11.$noComp {string index, unicode} { + run {string index abc\u7266d 3} } \u7266 -test string-5.12 {string index, unicode over char length, under byte length} { - string index \334\374\334\374 6 -} {} -test string-5.13 {string index, bytearray object} { - string index [binary format a5 fuz] 0 +test string-5.12.$noComp {string index, unicode over char length, under byte length} -body { + run {string index \334\374\334\374 6} +} -result {} +test string-5.13.$noComp {string index, bytearray object} { + run {string index [binary format a5 fuz] 0} } f -test string-5.14 {string index, bytearray object} { - string index [binary format I* {0x50515253 0x52}] 3 +test string-5.14.$noComp {string index, bytearray object} { + run {string index [binary format I* {0x50515253 0x52}] 3} } S -test string-5.15 {string index, bytearray object} { +test string-5.15.$noComp {string index, bytearray object} { set b [binary format I* {0x50515253 0x52}] - set i1 [string index $b end-6] - set i2 [string index $b 1] - string compare $i1 $i2 + set i1 [run {string index $b end-6}] + set i2 [run {string index $b 1}] + run {string compare $i1 $i2} } 0 -test string-5.16 {string index, bytearray object with string obj shimmering} { +test string-5.16.$noComp {string index, bytearray object with string obj shimmering} { set str "0123456789\x00 abcdedfghi" binary scan $str H* dump - string compare [string index $str 10] \x00 + run {string compare [run {string index $str 10}] \x00} } 0 -test string-5.17 {string index, bad integer} -body { - list [catch {string index "abc" 0o8} msg] $msg +test string-5.17.$noComp {string index, bad integer} -body { + list [catch {run {string index "abc" 0o8}} msg] $msg } -match glob -result {1 {*invalid octal number*}} -test string-5.18 {string index, bad integer} -body { - list [catch {string index "abc" end-0o0289} msg] $msg +test string-5.18.$noComp {string index, bad integer} -body { + list [catch {run {string index "abc" end-0o0289}} msg] $msg } -match glob -result {1 {*invalid octal number*}} -test string-5.19 {string index, bytearray object out of bounds} { - string index [binary format I* {0x50515253 0x52}] -1 -} {} -test string-5.20 {string index, bytearray object out of bounds} { - string index [binary format I* {0x50515253 0x52}] 20 +test string-5.19.$noComp {string index, bytearray object out of bounds} { + run {string index [binary format I* {0x50515253 0x52}] -1} } {} +test string-5.20.$noComp {string index, bytearray object out of bounds} -body { + run {string index [binary format I* {0x50515253 0x52}] 20} +} -result {} +test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} -constraints utf16 -body { + run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]} +} -result [list \U100000 {} b] -proc largest_int {} { - # This will give us what the largest valid int on this machine is, - # so we can test for overflow properly below on >32 bit systems - set int 1 - set exp 7; # assume we get at least 8 bits - while {wide($int) > 0} { set int [expr {wide(1) << [incr exp]}] } - return [expr {$int-1}] -} - -test string-6.1 {string is, too few args} { - list [catch {string is} msg] $msg +test string-6.1.$noComp {string is, not enough args} { + list [catch {run {string is}} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.2 {string is, too few args} { - list [catch {string is alpha} msg] $msg +test string-6.2.$noComp {string is, not enough args} { + list [catch {run {string is alpha}} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.3 {string is, bad args} { - list [catch {string is alpha -failin str} msg] $msg +test string-6.3.$noComp {string is, bad args} { + list [catch {run {string is alpha -failin str}} msg] $msg } {1 {wrong # args: should be "string is alpha ?-strict? ?-failindex var? str"}} -test string-6.4 {string is, too many args} { - list [catch {string is alpha -failin var -strict str more} msg] $msg +test string-6.4.$noComp {string is, too many args} { + list [catch {run {string is alpha -failin var -strict str more}} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.5 {string is, class check} { - list [catch {string is bogus str} msg] $msg -} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} -test string-6.6 {string is, ambiguous class} { - list [catch {string is al str} msg] $msg -} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} -test string-6.7 {string is alpha, all ok} { - string is alpha -strict -failindex var abc -} 1 -test string-6.8 {string is, error in var} { - list [string is alpha -failindex var abc5def] $var +test string-6.5.$noComp {string is, class check} { + list [catch {run {string is bogus str}} msg] $msg +} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} +test string-6.6.$noComp {string is, ambiguous class} { + list [catch {run {string is al str}} msg] $msg +} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} +test string-6.7.$noComp {string is alpha, all ok} { + run {string is alpha -strict -failindex var abc} +} 1 +test string-6.8.$noComp {string is, error in var} { + list [run {string is alpha -failindex var abc5def}] $var } {0 3} -test string-6.9 {string is, var shouldn't get set} { +test string-6.9.$noComp {string is, var shouldn't get set} { catch {unset var} - list [catch {string is alpha -failindex var abc; set var} msg] $msg + list [catch {run {string is alpha -failindex var abc; set var}} msg] $msg } {1 {can't read "var": no such variable}} -test string-6.10 {string is, ok on empty} { - string is alpha {} +test string-6.10.$noComp {string is, ok on empty} { + run {string is alpha {}} } 1 -test string-6.11 {string is, -strict check against empty} { - string is alpha -strict {} +test string-6.11.$noComp {string is, -strict check against empty} { + run {string is alpha -strict {}} } 0 -test string-6.12 {string is alnum, true} { - string is alnum abc123 +test string-6.12.$noComp {string is alnum, true} { + run {string is alnum abc123} } 1 -test string-6.13 {string is alnum, false} { - list [string is alnum -failindex var abc1.23] $var +test string-6.13.$noComp {string is alnum, false} { + list [run {string is alnum -failindex var abc1.23}] $var } {0 4} -test string-6.14 {string is alnum, unicode} "string is alnum abc\xfc" 1 -test string-6.15 {string is alpha, true} { - string is alpha abc +test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abc\xFC}" 1 +test string-6.15.$noComp {string is alpha, true} { + run {string is alpha abc} } 1 -test string-6.16 {string is alpha, false} { - list [string is alpha -fail var a1bcde] $var +test string-6.16.$noComp {string is alpha, false} { + list [run {string is alpha -fail var a1bcde}] $var } {0 1} -test string-6.17 {string is alpha, unicode} { - string is alpha abc\374 +test string-6.17.$noComp {string is alpha, unicode} { + run {string is alpha abc\374} } 1 -test string-6.18 {string is ascii, true} { - string is ascii abc\u007Fend\u0000 +test string-6.18.$noComp {string is ascii, true} { + run {string is ascii abc\x7Fend\x00} } 1 -test string-6.19 {string is ascii, false} { - list [string is ascii -fail var abc\u0000def\u0080more] $var +test string-6.19.$noComp {string is ascii, false} { + list [run {string is ascii -fail var abc\x00def\x80more}] $var } {0 7} -test string-6.20 {string is boolean, true} { - string is boolean true +test string-6.20.$noComp {string is boolean, true} { + run {string is boolean true} } 1 -test string-6.21 {string is boolean, true} { - string is boolean f +test string-6.21.$noComp {string is boolean, true} { + run {string is boolean f} } 1 -test string-6.22 {string is boolean, true based on type} { - string is bool [string compare a a] +test string-6.22.$noComp {string is boolean, true based on type} { + run {string is bool [run {string compare a a}]} } 1 -test string-6.23 {string is boolean, false} { - list [string is bool -fail var yada] $var +test string-6.23.$noComp {string is boolean, false} { + list [run {string is bool -fail var yada}] $var } {0 0} -test string-6.24 {string is digit, true} { - string is digit 0123456789 +test string-6.24.$noComp {string is digit, true} { + run {string is digit 0123456789} } 1 -test string-6.25 {string is digit, false} { - list [string is digit -fail var 0123\u00dc567] $var +test string-6.25.$noComp {string is digit, false} { + list [run {string is digit -fail var 0123\xDC567}] $var } {0 4} -test string-6.26 {string is digit, false} { - list [string is digit -fail var +123567] $var +test string-6.26.$noComp {string is digit, false} { + list [run {string is digit -fail var +123567}] $var } {0 0} -test string-6.27 {string is double, true} { - string is double 1 +test string-6.27.$noComp {string is double, true} { + run {string is double 1} } 1 -test string-6.28 {string is double, true} { - string is double [expr double(1)] +test string-6.28.$noComp {string is double, true} { + run {string is double [expr double(1)]} } 1 -test string-6.29 {string is double, true} { - string is double 1.0 +test string-6.29.$noComp {string is double, true} { + run {string is double 1.0} } 1 -test string-6.30 {string is double, true} { - string is double [string compare a a] +test string-6.30.$noComp {string is double, true} { + run {string is double [run {string compare a a}]} } 1 -test string-6.31 {string is double, true} { - string is double " +1.0e-1 " +test string-6.31.$noComp {string is double, true} { + run {string is double " +1.0e-1 "} } 1 -test string-6.32 {string is double, true} { - string is double "\n1.0\v" +test string-6.32.$noComp {string is double, true} { + run {string is double "\n1.0\v"} } 1 -test string-6.33 {string is double, false} { - list [string is double -fail var 1abc] $var +test string-6.33.$noComp {string is double, false} { + list [run {string is double -fail var 1abc}] $var } {0 1} -test string-6.34 {string is double, false} { - list [string is double -fail var abc] $var +test string-6.34.$noComp {string is double, false} { + list [run {string is double -fail var abc}] $var } {0 0} -test string-6.35 {string is double, false} { - list [string is double -fail var " 1.0e4e4 "] $var +test string-6.35.$noComp {string is double, false} { + list [run {string is double -fail var " 1.0e4e4 "}] $var } {0 8} -test string-6.36 {string is double, false} { - list [string is double -fail var "\n"] $var +test string-6.36.$noComp {string is double, false} { + list [run {string is double -fail var "\n"}] $var } {0 0} -test string-6.37 {string is double, false on int overflow} { +test string-6.37.$noComp {string is double, false on int overflow} -setup { + set var priorValue +} -body { # Make it the largest int recognizable, with one more digit for overflow # Since bignums arrived in Tcl 8.5, the sense of this test changed. # Now integer values that exceed native limits become bignums, and # bignums can convert to doubles without error. - list [string is double -fail var [largest_int]0] $var -} {1 0} + list [run {string is double -fail var 9223372036854775808}] $var +} -result {1 priorValue} # string-6.38 removed, underflow on input is no longer an error. -test string-6.39 {string is double, false} { - # This test is non-portable because IRIX thinks +test string-6.39.$noComp {string is double, false} { + # This test is non-portable because IRIX thinks # that .e1 is a valid double - this is really a bug # on IRIX as .e1 should NOT be a valid double # # Portable now. Tcl 8.5 does its own double parsing. - list [string is double -fail var .e1] $var + list [run {string is double -fail var .e1}] $var } {0 0} -test string-6.40 {string is false, true} { - string is false false +test string-6.40.$noComp {string is false, true} { + run {string is false false} } 1 -test string-6.41 {string is false, true} { - string is false FaLsE +test string-6.41.$noComp {string is false, true} { + run {string is false FaLsE} } 1 -test string-6.42 {string is false, true} { - string is false N +test string-6.42.$noComp {string is false, true} { + run {string is false N} } 1 -test string-6.43 {string is false, true} { - string is false 0 +test string-6.43.$noComp {string is false, true} { + run {string is false 0} } 1 -test string-6.44 {string is false, true} { - string is false off +test string-6.44.$noComp {string is false, true} { + run {string is false off} } 1 -test string-6.45 {string is false, false} { - list [string is false -fail var abc] $var +test string-6.45.$noComp {string is false, false} { + list [run {string is false -fail var abc}] $var } {0 0} -test string-6.46 {string is false, false} { +test string-6.46.$noComp {string is false, false} { catch {unset var} - list [string is false -fail var Y] $var + list [run {string is false -fail var Y}] $var } {0 0} -test string-6.47 {string is false, false} { +test string-6.47.$noComp {string is false, false} { catch {unset var} - list [string is false -fail var offensive] $var + list [run {string is false -fail var offensive}] $var } {0 0} -test string-6.48 {string is integer, true} { - string is integer +1234567890 +test string-6.48.$noComp {string is integer, true} { + run {string is integer +1234567890} } 1 -test string-6.49 {string is integer, true on type} { - string is integer [expr int(50.0)] +test string-6.49.$noComp {string is integer, true on type} { + run {string is integer [expr int(50.0)]} } 1 -test string-6.50 {string is integer, true} { - string is integer [list -10] +test string-6.50.$noComp {string is integer, true} { + run {string is integer [list -10]} } 1 -test string-6.51 {string is integer, true as hex} { - string is integer 0xabcdef +test string-6.51.$noComp {string is integer, true as hex} { + run {string is integer 0xabcdef} } 1 -test string-6.52 {string is integer, true as octal} { - string is integer 012345 +test string-6.52.$noComp {string is integer, true as octal} { + run {string is integer 012345} } 1 -test string-6.53 {string is integer, true with whitespace} { - string is integer " \n1234\v" +test string-6.53.$noComp {string is integer, true with whitespace} { + run {string is integer " \n1234\v"} } 1 -test string-6.54 {string is integer, false} { - list [string is integer -fail var 123abc] $var +test string-6.54.$noComp {string is integer, false} { + list [run {string is integer -fail var 123abc}] $var } {0 3} -test string-6.55 {string is integer, false on overflow} { - list [string is integer -fail var +[largest_int]0] $var -} {0 -1} -test string-6.56 {string is integer, false} { - list [string is integer -fail var [expr double(1)]] $var +test string-6.55.$noComp {string is integer, no overflow possible} { + run {string is integer +9223372036854775808} +} 1 +test string-6.56.$noComp {string is integer, false} { + list [run {string is integer -fail var [expr double(1)]}] $var } {0 1} -test string-6.57 {string is integer, false} { - list [string is integer -fail var " "] $var +test string-6.57.$noComp {string is integer, false} { + list [run {string is integer -fail var " "}] $var } {0 0} -test string-6.58 {string is integer, false on bad octal} { - list [string is integer -fail var 0o36963] $var +test string-6.58.$noComp {string is integer, false on bad octal} { + list [run {string is integer -fail var 0o36963}] $var } {0 4} -test string-6.58.1 {string is integer, false on bad octal} { - list [string is integer -fail var 0o36963] $var +test string-6.58.1.$noComp {string is integer, false on bad octal} { + list [run {string is integer -fail var 0o36963}] $var } {0 4} -test string-6.59 {string is integer, false on bad hex} { - list [string is integer -fail var 0X345XYZ] $var +test string-6.59.$noComp {string is integer, false on bad hex} { + list [run {string is integer -fail var 0X345XYZ}] $var } {0 5} -test string-6.60 {string is lower, true} { - string is lower abc +test string-6.60.$noComp {string is lower, true} { + run {string is lower abc} } 1 -test string-6.61 {string is lower, unicode true} { - string is lower abc\u00fcue +test string-6.61.$noComp {string is lower, unicode true} { + run {string is lower abc\xFCue} } 1 -test string-6.62 {string is lower, false} { - list [string is lower -fail var aBc] $var +test string-6.62.$noComp {string is lower, false} { + list [run {string is lower -fail var aBc}] $var } {0 1} -test string-6.63 {string is lower, false} { - list [string is lower -fail var abc1] $var +test string-6.63.$noComp {string is lower, false} { + list [run {string is lower -fail var abc1}] $var } {0 3} -test string-6.64 {string is lower, unicode false} { - list [string is lower -fail var ab\u00dcUE] $var +test string-6.64.$noComp {string is lower, unicode false} { + list [run {string is lower -fail var ab\xDCUE}] $var } {0 2} -test string-6.65 {string is space, true} { - string is space " \t\n\v\f" +test string-6.65.$noComp {string is space, true} { + run {string is space " \t\n\v\f"} } 1 -test string-6.66 {string is space, false} { - list [string is space -fail var " \t\n\v1\f"] $var +test string-6.66.$noComp {string is space, false} { + list [run {string is space -fail var " \t\n\v1\f"}] $var } {0 4} -test string-6.67 {string is true, true} { - string is true true +test string-6.67.$noComp {string is true, true} { + run {string is true true} } 1 -test string-6.68 {string is true, true} { - string is true TrU +test string-6.68.$noComp {string is true, true} { + run {string is true TrU} } 1 -test string-6.69 {string is true, true} { - string is true ye +test string-6.69.$noComp {string is true, true} { + run {string is true ye} } 1 -test string-6.70 {string is true, true} { - string is true 1 +test string-6.70.$noComp {string is true, true} { + run {string is true 1} } 1 -test string-6.71 {string is true, true} { - string is true on +test string-6.71.$noComp {string is true, true} { + run {string is true on} } 1 -test string-6.72 {string is true, false} { - list [string is true -fail var onto] $var +test string-6.72.$noComp {string is true, false} { + list [run {string is true -fail var onto}] $var } {0 0} -test string-6.73 {string is true, false} { +test string-6.73.$noComp {string is true, false} { catch {unset var} - list [string is true -fail var 25] $var + list [run {string is true -fail var 25}] $var } {0 0} -test string-6.74 {string is true, false} { +test string-6.74.$noComp {string is true, false} { catch {unset var} - list [string is true -fail var no] $var + list [run {string is true -fail var no}] $var } {0 0} -test string-6.75 {string is upper, true} { - string is upper ABC +test string-6.75.$noComp {string is upper, true} { + run {string is upper ABC} } 1 -test string-6.76 {string is upper, unicode true} { - string is upper ABC\u00dcUE +test string-6.76.$noComp {string is upper, unicode true} { + run {string is upper ABC\xDCUE} } 1 -test string-6.77 {string is upper, false} { - list [string is upper -fail var AbC] $var +test string-6.77.$noComp {string is upper, false} { + list [run {string is upper -fail var AbC}] $var } {0 1} -test string-6.78 {string is upper, false} { - list [string is upper -fail var AB2C] $var +test string-6.78.$noComp {string is upper, false} { + list [run {string is upper -fail var AB2C}] $var } {0 2} -test string-6.79 {string is upper, unicode false} { - list [string is upper -fail var ABC\u00fcue] $var +test string-6.79.$noComp {string is upper, unicode false} { + list [run {string is upper -fail var ABC\xFCue}] $var } {0 3} -test string-6.80 {string is wordchar, true} { - string is wordchar abc_123 +test string-6.80.$noComp {string is wordchar, true} { + run {string is wordchar abc_123} } 1 -test string-6.81 {string is wordchar, unicode true} { - string is wordchar abc\u00fcab\u00dcAB\u5001 +test string-6.81.$noComp {string is wordchar, unicode true} { + run {string is wordchar abc\xFCab\xDCAB\u5001\U1D7CA} } 1 -test string-6.82 {string is wordchar, false} { - list [string is wordchar -fail var abcd.ef] $var +test string-6.82.$noComp {string is wordchar, false} { + list [run {string is wordchar -fail var abcd.ef}] $var } {0 4} -test string-6.83 {string is wordchar, unicode false} { - list [string is wordchar -fail var abc\u0080def] $var +test string-6.83.$noComp {string is wordchar, unicode false} { + list [run {string is wordchar -fail var abc\x80def}] $var } {0 3} -test string-6.84 {string is control} { +test string-6.84.$noComp {string is control} { ## Control chars are in the ranges ## 00..1F && 7F..9F - list [string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60] $var + list [run {string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60}] $var } {0 7} -test string-6.85 {string is control} { - string is control \u0100 +test string-6.85.$noComp {string is control} { + run {string is control \u0100} } 0 -test string-6.86 {string is graph} { +test string-6.86.$noComp {string is graph} { ## graph is any print char, except space - list [string is gra -fail var "0123abc!@#\$\u0100 "] $var -} {0 12} -test string-6.87 {string is print} { + list [run {string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "}] $var +} {0 14} +test string-6.87.$noComp {string is print} { ## basically any printable char - list [string is print -fail var "0123abc!@#\$\u0100 \u0010"] $var -} {0 13} -test string-6.88 {string is punct} { + list [run {string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\x10"}] $var +} {0 15} +test string-6.88.$noComp {string is punct} { ## any graph char that isn't alnum - list [string is punct -fail var "_!@#\u00beq0"] $var + list [run {string is punct -fail var "_!@#\xBEq0"}] $var } {0 4} -test string-6.89 {string is xdigit} { - list [string is xdigit -fail var 0123456789\u0061bcdefABCDEFg] $var +test string-6.89.$noComp {string is xdigit} { + list [run {string is xdigit -fail var 0123456789\x61bcdefABCDEFg}] $var } {0 22} -test string-6.90 {string is integer, bad integers} { +test string-6.90.$noComp {string is integer, bad integers} { # SF bug #634856 set result "" set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] foreach num $numbers { - lappend result [string is int -strict $num] + lappend result [run {string is int -strict $num}] } return $result } {1 1 0 0 0 1 0 0} -test string-6.91 {string is double, bad doubles} { +test string-6.91.$noComp {string is double, bad doubles} { set result "" set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"] foreach num $numbers { - lappend result [string is double -strict $num] + lappend result [run {string is double -strict $num}] } return $result } {1 1 0 0 0 1 0 0} -test string-6.92 {string is integer, 32-bit overflow} { +test string-6.92.$noComp {string is integer, no 64-bit overflow} { # Bug 718878 - set x 0x100000000 - list [string is integer -failindex var $x] $var -} {0 -1} -test string-6.93 {string is integer, 32-bit overflow} { + set x 0x10000000000000000 + run {string is integer $x} +} 1 +test string-6.93.$noComp {string is integer, no 64-bit overflow} { # Bug 718878 - set x 0x100000000 + set x 0x10000000000000000 append x "" - list [string is integer -failindex var $x] $var -} {0 -1} -test string-6.94 {string is integer, 32-bit overflow} { + run {string is integer $x} +} 1 +test string-6.94.$noComp {string is integer, no 64-bit overflow} { # Bug 718878 - set x 0x100000000 - list [string is integer -failindex var [expr {$x}]] $var -} {0 -1} -test string-6.95 {string is wideinteger, true} { - string is wideinteger +1234567890 + set x 0x10000000000000000 + run {string is integer [expr {$x}]} } 1 -test string-6.96 {string is wideinteger, true on type} { - string is wideinteger [expr wide(50.0)] +test string-6.95.$noComp {string is wideinteger, true} { + run {string is wideinteger +1234567890} } 1 -test string-6.97 {string is wideinteger, true} { - string is wideinteger [list -10] +test string-6.96.$noComp {string is wideinteger, true on type} { + run {string is wideinteger [expr wide(50.0)]} } 1 -test string-6.98 {string is wideinteger, true as hex} { - string is wideinteger 0xabcdef +test string-6.97.$noComp {string is wideinteger, true} { + run {string is wideinteger [list -10]} } 1 -test string-6.99 {string is wideinteger, true as octal} { - string is wideinteger 0123456 +test string-6.98.$noComp {string is wideinteger, true as hex} { + run {string is wideinteger 0xabcdef} } 1 -test string-6.100 {string is wideinteger, true with whitespace} { - string is wideinteger " \n1234\v" +test string-6.99.$noComp {string is wideinteger, true as octal} { + run {string is wideinteger 0123456} } 1 -test string-6.101 {string is wideinteger, false} { - list [string is wideinteger -fail var 123abc] $var +test string-6.100.$noComp {string is wideinteger, true with whitespace} { + run {string is wideinteger " \n1234\v"} +} 1 +test string-6.101.$noComp {string is wideinteger, false} { + list [run {string is wideinteger -fail var 123abc}] $var } {0 3} -test string-6.102 {string is wideinteger, false on overflow} { - list [string is wideinteger -fail var +[largest_int]0] $var +test string-6.102.$noComp {string is wideinteger, false on overflow} { + list [run {string is wideinteger -fail var +9223372036854775808}] $var } {0 -1} -test string-6.103 {string is wideinteger, false} { - list [string is wideinteger -fail var [expr double(1)]] $var +test string-6.103.$noComp {string is wideinteger, false} { + list [run {string is wideinteger -fail var [expr double(1)]}] $var } {0 1} -test string-6.104 {string is wideinteger, false} { - list [string is wideinteger -fail var " "] $var +test string-6.104.$noComp {string is wideinteger, false} { + list [run {string is wideinteger -fail var " "}] $var } {0 0} -test string-6.105 {string is wideinteger, false on bad octal} { - list [string is wideinteger -fail var 0o36963] $var +test string-6.105.$noComp {string is wideinteger, false on bad octal} { + list [run {string is wideinteger -fail var 0o36963}] $var } {0 4} -test string-6.105.1 {string is wideinteger, false on bad octal} { - list [string is wideinteger -fail var 0o36963] $var +test string-6.105.1.$noComp {string is wideinteger, false on bad octal} { + list [run {string is wideinteger -fail var 0o36963}] $var } {0 4} -test string-6.106 {string is wideinteger, false on bad hex} { - list [string is wideinteger -fail var 0X345XYZ] $var +test string-6.106.$noComp {string is wideinteger, false on bad hex} { + list [run {string is wideinteger -fail var 0X345XYZ}] $var } {0 5} -test string-6.107 {string is integer, bad integers} { +test string-6.107.$noComp {string is integer, bad integers} { # SF bug #634856 set result "" set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] foreach num $numbers { - lappend result [string is wideinteger -strict $num] + lappend result [run {string is wideinteger -strict $num}] } return $result } {1 1 0 0 0 1 0 0} -test string-6.108 {string is double, Bug 1382287} { +test string-6.108.$noComp {string is double, Bug 1382287} { set x 2turtledoves - string is double $x - string is double $x + run {string is double $x} + run {string is double $x} } 0 -test string-6.109 {string is double, Bug 1360532} { - string is double 1\u00a0 +test string-6.109.$noComp {string is double, Bug 1360532} { + run {string is double 1\xA0} } 0 -test string-6.110 {string is entier, true} { - string is entier +1234567890 +test string-6.110.$noComp {string is entier, true} { + run {string is entier +1234567890} } 1 -test string-6.111 {string is entier, true on type} { - string is entier [expr wide(50.0)] +test string-6.111.$noComp {string is entier, true on type} { + run {string is entier [expr wide(50.0)]} } 1 -test string-6.112 {string is entier, true} { - string is entier [list -10] +test string-6.112.$noComp {string is entier, true} { + run {string is entier [list -10]} } 1 -test string-6.113 {string is entier, true as hex} { - string is entier 0xabcdef +test string-6.113.$noComp {string is entier, true as hex} { + run {string is entier 0xabcdef} } 1 -test string-6.114 {string is entier, true as octal} { - string is entier 0123456 +test string-6.114.$noComp {string is entier, true as octal} { + run {string is entier 0123456} } 1 -test string-6.115 {string is entier, true with whitespace} { - string is entier " \n1234\v" +test string-6.115.$noComp {string is entier, true with whitespace} { + run {string is entier " \n1234\v"} } 1 -test string-6.116 {string is entier, false} { - list [string is entier -fail var 123abc] $var +test string-6.116.$noComp {string is entier, false} { + list [run {string is entier -fail var 123abc}] $var } {0 3} -test string-6.117 {string is entier, false} { - list [string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc] $var +test string-6.117.$noComp {string is entier, false} { + list [run {string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc}] $var } {0 84} -test string-6.118 {string is entier, false} { - list [string is entier -fail var [expr double(1)]] $var +test string-6.118.$noComp {string is entier, false} { + list [run {string is entier -fail var [expr double(1)]}] $var } {0 1} -test string-6.119 {string is entier, false} { - list [string is entier -fail var " "] $var +test string-6.119.$noComp {string is entier, false} { + list [run {string is entier -fail var " "}] $var } {0 0} -test string-6.120 {string is entier, false on bad octal} { - list [string is entier -fail var 0o36963] $var +test string-6.120.$noComp {string is entier, false on bad octal} { + list [run {string is entier -fail var 0o36963}] $var } {0 4} -test string-6.121.1 {string is entier, false on bad octal} { - list [string is entier -fail var 0o36963] $var +test string-6.121.1.$noComp {string is entier, false on bad octal} { + list [run {string is entier -fail var 0o36963}] $var } {0 4} -test string-6.122 {string is entier, false on bad hex} { - list [string is entier -fail var 0X345XYZ] $var +test string-6.122.$noComp {string is entier, false on bad hex} { + list [run {string is entier -fail var 0X345XYZ}] $var } {0 5} -test string-6.123 {string is entier, bad integers} { +test string-6.123.$noComp {string is entier, bad integers} { # SF bug #634856 set result "" set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] foreach num $numbers { - lappend result [string is entier -strict $num] + lappend result [run {string is entier -strict $num}] } return $result } {1 1 0 0 0 1 0 0} -test string-6.124 {string is entier, true} { - string is entier +1234567890123456789012345678901234567890 +test string-6.124.$noComp {string is entier, true} { + run {string is entier +1234567890123456789012345678901234567890} } 1 -test string-6.125 {string is entier, true} { - string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000] +test string-6.125.$noComp {string is entier, true} { + run {string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000]} } 1 -test string-6.126 {string is entier, true as hex} { - string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef +test string-6.126.$noComp {string is entier, true as hex} { + run {string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef} } 1 -test string-6.127 {string is entier, true as octal} { - string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456 +test string-6.127.$noComp {string is entier, true as octal} { + run {string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456} } 1 -test string-6.128 {string is entier, true with whitespace} { - string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v" +test string-6.128.$noComp {string is entier, true with whitespace} { + run {string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v"} } 1 -test string-6.129 {string is entier, false on bad octal} { - list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var +test string-6.129.$noComp {string is entier, false on bad octal} { + list [run {string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963}] $var } {0 87} -test string-6.130.1 {string is entier, false on bad octal} { - list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var +test string-6.130.1.$noComp {string is entier, false on bad octal} { + list [run {string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963}] $var } {0 87} -test string-6.131 {string is entier, false on bad hex} { - list [string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ] $var +test string-6.131.$noComp {string is entier, false on bad hex} { + list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var } {0 88} -catch {rename largest_int {}} - -test string-7.1 {string last, too few args} { - list [catch {string last a} msg] $msg -} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}} -test string-7.2 {string last, bad args} { - list [catch {string last a b c} msg] $msg +test string-7.1.$noComp {string last, not enough args} { + list [catch {run {string last a}} msg] $msg +} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} +test string-7.2.$noComp {string last, bad args} { + list [catch {run {string last a b c}} msg] $msg } {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} -test string-7.3 {string last, too many args} { - list [catch {string last a b c d} msg] $msg -} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}} -test string-7.4 {string last} { - string la xxx xxxx123xx345x678 -} 1 -test string-7.5 {string last} { - string last xx xxxx123xx345x678 +test string-7.3.$noComp {string last, too many args} { + list [catch {run {string last a b c d}} msg] $msg +} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} +test string-7.4.$noComp {string last} { + run {string la xxx xxxx123xx345x678} +} 1 +test string-7.5.$noComp {string last} { + run {string last xx xxxx123xx345x678} } 7 -test string-7.6 {string last} { - string las x xxxx123xx345x678 +test string-7.6.$noComp {string last} { + run {string las x xxxx123xx345x678} } 12 -test string-7.7 {string last, unicode} { - string las x xxxx12\u7266xx345x678 +test string-7.7.$noComp {string last, unicode} { + run {string las x xxxx12\u7266xx345x678} } 12 -test string-7.8 {string last, unicode} { - string las \u7266 xxxx12\u7266xx345x678 +test string-7.8.$noComp {string last, unicode} { + run {string las \u7266 xxxx12\u7266xx345x678} } 6 -test string-7.9 {string last, stop index} { - string las \u7266 xxxx12\u7266xx345x678 +test string-7.9.$noComp {string last, stop index} { + run {string las \u7266 xxxx12\u7266xx345x678} } 6 -test string-7.10 {string last, unicode} { - string las \u7266 xxxx12\u7266xx345x678 +test string-7.10.$noComp {string last, unicode} { + run {string las \u7266 xxxx12\u7266xx345x678} } 6 -test string-7.11 {string last, start index} { - string last \u7266 abc\u7266x 3 +test string-7.11.$noComp {string last, start index} { + run {string last \u7266 abc\u7266x 3} } 3 -test string-7.12 {string last, start index} { - string last \u7266 abc\u7266x 2 +test string-7.12.$noComp {string last, start index} { + run {string last \u7266 abc\u7266x 2} } -1 -test string-7.13 {string last, start index} { +test string-7.13.$noComp {string last, start index} { ## Constrain to last 'a' should work - string last ba badbad end-1 + run {string last ba badbad end-1} } 3 -test string-7.14 {string last, start index} { +test string-7.14.$noComp {string last, start index} { ## Constrain to last 'b' should skip last 'ba' - string last ba badbad end-2 + run {string last ba badbad end-2} } 0 -test string-7.15 {string last, start index} { - string last \334a \334ad\334ad 0 +test string-7.15.$noComp {string last, start index} { + run {string last \334a \334ad\334ad 0} } -1 -test string-7.16 {string last, start index} { - string last \334a \334ad\334ad end-1 +test string-7.16.$noComp {string last, start index} { + run {string last \334a \334ad\334ad end-1} } 3 -test string-8.1 {string bytelength} { - list [catch {string bytelength} msg] $msg +test string-8.1.$noComp {string bytelength} { + list [catch {run {string bytelength}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.2 {string bytelength} { - list [catch {string bytelength a b} msg] $msg +test string-8.2.$noComp {string bytelength} { + list [catch {run {string bytelength a b}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.3 {string bytelength} { - string bytelength "\u00c7" +test string-8.3.$noComp {string bytelength} { + run {string bytelength "\xC7"} } 2 -test string-8.4 {string bytelength} { - string b "" +test string-8.4.$noComp {string bytelength} { + run {string b ""} } 0 -test string-9.1 {string length} { - list [catch {string length} msg] $msg +test string-9.1.$noComp {string length} { + list [catch {run {string length}} msg] $msg } {1 {wrong # args: should be "string length string"}} -test string-9.2 {string length} { - list [catch {string length a b} msg] $msg +test string-9.2.$noComp {string length} { + list [catch {run {string length a b}} msg] $msg } {1 {wrong # args: should be "string length string"}} -test string-9.3 {string length} { - string length "a little string" +test string-9.3.$noComp {string length} { + run {string length "a little string"} } 15 -test string-9.4 {string length} { - string le "" +test string-9.4.$noComp {string length} { + run {string le ""} } 0 -test string-9.5 {string length, unicode} { - string le "abcd\u7266" +test string-9.5.$noComp {string length, unicode} { + run {string le "abcd\u7266"} } 5 -test string-9.6 {string length, bytearray object} { - string length [binary format a5 foo] +test string-9.6.$noComp {string length, bytearray object} { + run {string length [binary format a5 foo]} } 5 -test string-9.7 {string length, bytearray object} { - string length [binary format I* {0x50515253 0x52}] +test string-9.7.$noComp {string length, bytearray object} { + run {string length [binary format I* {0x50515253 0x52}]} } 8 -test string-10.1 {string map, too few args} { - list [catch {string map} msg] $msg +test string-10.1.$noComp {string map, not enough args} { + list [catch {run {string map}} msg] $msg } {1 {wrong # args: should be "string map ?-nocase? charMap string"}} -test string-10.2 {string map, bad args} { - list [catch {string map {a b} abba oops} msg] $msg +test string-10.2.$noComp {string map, bad args} { + list [catch {run {string map {a b} abba oops}} msg] $msg } {1 {bad option "a b": must be -nocase}} -test string-10.3 {string map, too many args} { - list [catch {string map -nocase {a b} str1 str2} msg] $msg +test string-10.3.$noComp {string map, too many args} { + list [catch {run {string map -nocase {a b} str1 str2}} msg] $msg } {1 {wrong # args: should be "string map ?-nocase? charMap string"}} -test string-10.4 {string map} { - string map {a b} abba +test string-10.4.$noComp {string map} { + run {string map {a b} abba} } {bbbb} -test string-10.5 {string map} { - string map {a b} a +test string-10.5.$noComp {string map} { + run {string map {a b} a} } {b} -test string-10.6 {string map -nocase} { - string map -nocase {a b} Abba +test string-10.6.$noComp {string map -nocase} { + run {string map -nocase {a b} Abba} } {bbbb} -test string-10.7 {string map} { - string map {abc 321 ab * a A} aabcabaababcab +test string-10.7.$noComp {string map} { + run {string map {abc 321 ab * a A} aabcabaababcab} } {A321*A*321*} -test string-10.8 {string map -nocase} { - string map -nocase {aBc 321 Ab * a A} aabcabaababcab +test string-10.8.$noComp {string map -nocase} { + run {string map -nocase {aBc 321 Ab * a A} aabcabaababcab} } {A321*A*321*} -test string-10.9 {string map -nocase} { - string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb +test string-10.9.$noComp {string map -nocase} { + run {string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb} } {A321*A*321*} -test string-10.10 {string map} { - list [catch {string map {a b c} abba} msg] $msg +test string-10.10.$noComp {string map} { + list [catch {run {string map {a b c} abba}} msg] $msg } {1 {char map list unbalanced}} -test string-10.11 {string map, nulls} { - string map {\x00 NULL blah \x00nix} {qwerty} +test string-10.11.$noComp {string map, nulls} { + run {string map {\x00 NULL blah \x00nix} {qwerty}} } {qwerty} -test string-10.12 {string map, unicode} { - string map [list \374 ue UE \334] "a\374ueUE\000EU" +test string-10.12.$noComp {string map, unicode} { + run {string map [list \374 ue UE \334] "a\374ueUE\000EU"} } aueue\334\0EU -test string-10.13 {string map, -nocase unicode} { - string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU" +test string-10.13.$noComp {string map, -nocase unicode} { + run {string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU"} } aue\334\334\0EU -test string-10.14 {string map, -nocase null arguments} { - string map -nocase {{} abc} foo +test string-10.14.$noComp {string map, -nocase null arguments} { + run {string map -nocase {{} abc} foo} } foo -test string-10.15 {string map, one pair case} { - string map -nocase {abc 32} aAbCaBaAbAbcAb +test string-10.15.$noComp {string map, one pair case} { + run {string map -nocase {abc 32} aAbCaBaAbAbcAb} } {a32aBaAb32Ab} -test string-10.16 {string map, one pair case} { - string map -nocase {ab 4321} aAbCaBaAbAbcAb +test string-10.16.$noComp {string map, one pair case} { + run {string map -nocase {ab 4321} aAbCaBaAbAbcAb} } {a4321C4321a43214321c4321} -test string-10.17 {string map, one pair case} { - string map {Ab 4321} aAbCaBaAbAbcAb +test string-10.17.$noComp {string map, one pair case} { + run {string map {Ab 4321} aAbCaBaAbAbcAb} } {a4321CaBa43214321c4321} -test string-10.18 {string map, empty argument} { - string map -nocase {{} abc} foo +test string-10.18.$noComp {string map, empty argument} { + run {string map -nocase {{} abc} foo} } foo -test string-10.19 {string map, empty arguments} { - string map -nocase {{} abc f bar {} def} foo +test string-10.19.$noComp {string map, empty arguments} { + run {string map -nocase {{} abc f bar {} def} foo} } baroo -test string-10.20 {string map, dictionaries don't alter map ordering} { +test string-10.20.$noComp {string map, dictionaries don't alter map ordering} { set map {aa X a Y} - list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] + list [run {string map [dict create aa X a Y] aaa}] [run {string map $map aaa}] [dict size $map] [run {string map $map aaa}] } {XY XY 2 XY} -test string-10.21 {string map, ABR checks} { - string map {longstring foob} long +test string-10.20.1.$noComp {string map, dictionaries don't alter map ordering} { + set map {a X b Y a Z} + list [run {string map [dict create a X b Y a Z] aaa}] [run {string map $map aaa}] [dict size $map] [run {string map $map aaa}] +} {ZZZ XXX 2 XXX} +test string-10.21.$noComp {string map, ABR checks} { + run {string map {longstring foob} long} } long -test string-10.22 {string map, ABR checks} { - string map {long foob} long +test string-10.22.$noComp {string map, ABR checks} { + run {string map {long foob} long} } foob -test string-10.23 {string map, ABR checks} { - string map {lon foob} long +test string-10.23.$noComp {string map, ABR checks} { + run {string map {lon foob} long} } foobg -test string-10.24 {string map, ABR checks} { - string map {lon foob} longlo +test string-10.24.$noComp {string map, ABR checks} { + run {string map {lon foob} longlo} } foobglo -test string-10.25 {string map, ABR checks} { - string map {lon foob} longlon +test string-10.25.$noComp {string map, ABR checks} { + run {string map {lon foob} longlon} } foobgfoob -test string-10.26 {string map, ABR checks} { - string map {longstring foob longstring bar} long +test string-10.26.$noComp {string map, ABR checks} { + run {string map {longstring foob longstring bar} long} } long -test string-10.27 {string map, ABR checks} { - string map {long foob longstring bar} long +test string-10.27.$noComp {string map, ABR checks} { + run {string map {long foob longstring bar} long} } foob -test string-10.28 {string map, ABR checks} { - string map {lon foob longstring bar} long +test string-10.28.$noComp {string map, ABR checks} { + run {string map {lon foob longstring bar} long} } foobg -test string-10.29 {string map, ABR checks} { - string map {lon foob longstring bar} longlo +test string-10.29.$noComp {string map, ABR checks} { + run {string map {lon foob longstring bar} longlo} } foobglo -test string-10.30 {string map, ABR checks} { - string map {lon foob longstring bar} longlon +test string-10.30.$noComp {string map, ABR checks} { + run {string map {lon foob longstring bar} longlon} } foobgfoob -test string-10.31 {string map, nasty sharing crash from [Bug 1018562]} { +test string-10.31.$noComp {string map, nasty sharing crash from [Bug 1018562]} { set a {a b} - string map $a $a + run {string map $a $a} } {b b} -test string-11.1 {string match, too few args} { - list [catch {string match a} msg] $msg +test string-11.1.$noComp {string match, not enough args} { + list [catch {run {string match a}} msg] $msg } {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test string-11.2 {string match, too many args} { - list [catch {string match a b c d} msg] $msg +test string-11.2.$noComp {string match, too many args} { + list [catch {run {string match a b c d}} msg] $msg } {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test string-11.3 {string match} { - string match abc abc +test string-11.3.$noComp {string match} { + run {string match abc abc} } 1 -test string-11.4 {string match} { - string mat abc abd +test string-11.4.$noComp {string match} { + run {string mat abc abd} } 0 -test string-11.5 {string match} { - string match ab*c abc +test string-11.5.$noComp {string match} { + run {string match ab*c abc} } 1 -test string-11.6 {string match} { - string match ab**c abc +test string-11.6.$noComp {string match} { + run {string match ab**c abc} } 1 -test string-11.7 {string match} { - string match ab* abcdef +test string-11.7.$noComp {string match} { + run {string match ab* abcdef} } 1 -test string-11.8 {string match} { - string match *c abc +test string-11.8.$noComp {string match} { + run {string match *c abc} } 1 -test string-11.9 {string match} { - string match *3*6*9 0123456789 +test string-11.9.$noComp {string match} { + run {string match *3*6*9 0123456789} } 1 -test string-11.9.1 {string match} { - string match *3*6*89 0123456789 +test string-11.9.1.$noComp {string match} { + run {string match *3*6*89 0123456789} } 1 -test string-11.9.2 {string match} { - string match *3*456*89 0123456789 +test string-11.9.2.$noComp {string match} { + run {string match *3*456*89 0123456789} } 1 -test string-11.9.3 {string match} { - string match *3*6* 0123456789 +test string-11.9.3.$noComp {string match} { + run {string match *3*6* 0123456789} } 1 -test string-11.9.4 {string match} { - string match *3*56* 0123456789 +test string-11.9.4.$noComp {string match} { + run {string match *3*56* 0123456789} } 1 -test string-11.9.5 {string match} { - string match *3*456*** 0123456789 +test string-11.9.5.$noComp {string match} { + run {string match *3*456*** 0123456789} } 1 -test string-11.9.6 {string match} { - string match **3*456** 0123456789 +test string-11.9.6.$noComp {string match} { + run {string match **3*456** 0123456789} } 1 -test string-11.9.7 {string match} { - string match *3***456* 0123456789 +test string-11.9.7.$noComp {string match} { + run {string match *3***456* 0123456789} } 1 -test string-11.9.8 {string match} { - string match *3***\[456]* 0123456789 +test string-11.9.8.$noComp {string match} { + run {string match *3***\[456]* 0123456789} } 1 -test string-11.9.9 {string match} { - string match *3***\[4-6]* 0123456789 +test string-11.9.9.$noComp {string match} { + run {string match *3***\[4-6]* 0123456789} } 1 -test string-11.9.10 {string match} { - string match *3***\[4-6] 0123456789 +test string-11.9.10.$noComp {string match} { + run {string match *3***\[4-6] 0123456789} } 0 -test string-11.9.11 {string match} { - string match *3***\[4-6] 0123456 +test string-11.9.11.$noComp {string match} { + run {string match *3***\[4-6] 0123456} } 1 -test string-11.10 {string match} { - string match *3*6*9 01234567890 +test string-11.10.$noComp {string match} { + run {string match *3*6*9 01234567890} } 0 -test string-11.10.1 {string match} { - string match *3*6*89 01234567890 +test string-11.10.1.$noComp {string match} { + run {string match *3*6*89 01234567890} } 0 -test string-11.10.2 {string match} { - string match *3*456*89 01234567890 +test string-11.10.2.$noComp {string match} { + run {string match *3*456*89 01234567890} } 0 -test string-11.10.3 {string match} { - string match **3*456*89 01234567890 +test string-11.10.3.$noComp {string match} { + run {string match **3*456*89 01234567890} } 0 -test string-11.10.4 {string match} { - string match *3*456***89 01234567890 +test string-11.10.4.$noComp {string match} { + run {string match *3*456***89 01234567890} } 0 -test string-11.11 {string match} { - string match a?c abc +test string-11.11.$noComp {string match} { + run {string match a?c abc} } 1 -test string-11.12 {string match} { - string match a??c abc +test string-11.12.$noComp {string match} { + run {string match a??c abc} } 0 -test string-11.13 {string match} { - string match ?1??4???8? 0123456789 +test string-11.13.$noComp {string match} { + run {string match ?1??4???8? 0123456789} } 1 -test string-11.14 {string match} { - string match {[abc]bc} abc +test string-11.14.$noComp {string match} { + run {string match {[abc]bc} abc} } 1 -test string-11.15 {string match} { - string match {a[abc]c} abc +test string-11.15.$noComp {string match} { + run {string match {a[abc]c} abc} } 1 -test string-11.16 {string match} { - string match {a[xyz]c} abc +test string-11.16.$noComp {string match} { + run {string match {a[xyz]c} abc} } 0 -test string-11.17 {string match} { - string match {12[2-7]45} 12345 +test string-11.17.$noComp {string match} { + run {string match {12[2-7]45} 12345} } 1 -test string-11.18 {string match} { - string match {12[ab2-4cd]45} 12345 +test string-11.18.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12345} } 1 -test string-11.19 {string match} { - string match {12[ab2-4cd]45} 12b45 +test string-11.19.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12b45} } 1 -test string-11.20 {string match} { - string match {12[ab2-4cd]45} 12d45 +test string-11.20.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12d45} } 1 -test string-11.21 {string match} { - string match {12[ab2-4cd]45} 12145 +test string-11.21.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12145} } 0 -test string-11.22 {string match} { - string match {12[ab2-4cd]45} 12545 +test string-11.22.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12545} } 0 -test string-11.23 {string match} { - string match {a\*b} a*b +test string-11.23.$noComp {string match} { + run {string match {a\*b} a*b} } 1 -test string-11.24 {string match} { - string match {a\*b} ab +test string-11.24.$noComp {string match} { + run {string match {a\*b} ab} } 0 -test string-11.25 {string match} { - string match {a\*\?\[\]\\\x} "a*?\[\]\\x" +test string-11.25.$noComp {string match} { + run {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"} } 1 -test string-11.26 {string match} { - string match ** "" +test string-11.26.$noComp {string match} { + run {string match ** ""} } 1 -test string-11.27 {string match} { - string match *. "" +test string-11.27.$noComp {string match} { + run {string match *. ""} } 0 -test string-11.28 {string match} { - string match "" "" +test string-11.28.$noComp {string match} { + run {string match "" ""} } 1 -test string-11.29 {string match} { - string match \[a a +test string-11.29.$noComp {string match} { + run {string match \[a a} } 1 -test string-11.30 {string match, bad args} { - list [catch {string match - b c} msg] $msg +test string-11.30.$noComp {string match, bad args} { + list [catch {run {string match - b c}} msg] $msg } {1 {bad option "-": must be -nocase}} -test string-11.31 {string match case} { - string match a A +test string-11.31.$noComp {string match case} { + run {string match a A} } 0 -test string-11.32 {string match nocase} { - string match -n a A +test string-11.32.$noComp {string match nocase} { + run {string match -n a A} } 1 -test string-11.33 {string match nocase} { - string match -nocase a\334 A\374 +test string-11.33.$noComp {string match nocase} { + run {string match -nocase a\334 A\374} } 1 -test string-11.34 {string match nocase} { - string match -nocase a*f ABCDEf +test string-11.34.$noComp {string match nocase} { + run {string match -nocase a*f ABCDEf} } 1 -test string-11.35 {string match case, false hope} { +test string-11.35.$noComp {string match case, false hope} { # This is true because '_' lies between the A-Z and a-z ranges - string match {[A-z]} _ + run {string match {[A-z]} _} } 1 -test string-11.36 {string match nocase range} { +test string-11.36.$noComp {string match nocase range} { # This is false because although '_' lies between the A-Z and a-z ranges, # we lower case the end points before checking the ranges. - string match -nocase {[A-z]} _ + run {string match -nocase {[A-z]} _} } 0 -test string-11.37 {string match nocase} { - string match -nocase {[A-fh-Z]} g +test string-11.37.$noComp {string match nocase} { + run {string match -nocase {[A-fh-Z]} g} } 0 -test string-11.38 {string match case, reverse range} { - string match {[A-fh-Z]} g +test string-11.38.$noComp {string match case, reverse range} { + run {string match {[A-fh-Z]} g} } 1 -test string-11.39 {string match, *\ case} { - string match {*\abc} abc +test string-11.39.$noComp {string match, *\ case} { + run {string match {*\abc} abc} } 1 -test string-11.39.1 {string match, *\ case} { - string match {*ab\c} abc +test string-11.39.1.$noComp {string match, *\ case} { + run {string match {*ab\c} abc} } 1 -test string-11.39.2 {string match, *\ case} { - string match {*ab\*} ab* +test string-11.39.2.$noComp {string match, *\ case} { + run {string match {*ab\*} ab*} } 1 -test string-11.39.3 {string match, *\ case} { - string match {*ab\*} abc +test string-11.39.3.$noComp {string match, *\ case} { + run {string match {*ab\*} abc} } 0 -test string-11.39.4 {string match, *\ case} { - string match {*ab\\*} {ab\c} +test string-11.39.4.$noComp {string match, *\ case} { + run {string match {*ab\\*} {ab\c}} } 1 -test string-11.39.5 {string match, *\ case} { - string match {*ab\\*} {ab\*} +test string-11.39.5.$noComp {string match, *\ case} { + run {string match {*ab\\*} {ab\*}} } 1 -test string-11.40 {string match, *special case} { - string match {*[ab]} abc +test string-11.40.$noComp {string match, *special case} { + run {string match {*[ab]} abc} } 0 -test string-11.41 {string match, *special case} { - string match {*[ab]*} abc +test string-11.41.$noComp {string match, *special case} { + run {string match {*[ab]*} abc} } 1 -test string-11.42 {string match, *special case} { - string match "*\\" "\\" +test string-11.42.$noComp {string match, *special case} { + run {string match "*\\" "\\"} } 0 -test string-11.43 {string match, *special case} { - string match "*\\\\" "\\" +test string-11.43.$noComp {string match, *special case} { + run {string match "*\\\\" "\\"} } 1 -test string-11.44 {string match, *special case} { - string match "*???" "12345" +test string-11.44.$noComp {string match, *special case} { + run {string match "*???" "12345"} } 1 -test string-11.45 {string match, *special case} { - string match "*???" "12" +test string-11.45.$noComp {string match, *special case} { + run {string match "*???" "12"} } 0 -test string-11.46 {string match, *special case} { - string match "*\\*" "abc*" +test string-11.46.$noComp {string match, *special case} { + run {string match "*\\*" "abc*"} } 1 -test string-11.47 {string match, *special case} { - string match "*\\*" "*" +test string-11.47.$noComp {string match, *special case} { + run {string match "*\\*" "*"} } 1 -test string-11.48 {string match, *special case} { - string match "*\\*" "*abc" +test string-11.48.$noComp {string match, *special case} { + run {string match "*\\*" "*abc"} } 0 -test string-11.49 {string match, *special case} { - string match "?\\*" "a*" +test string-11.49.$noComp {string match, *special case} { + run {string match "?\\*" "a*"} } 1 -test string-11.50 {string match, *special case} { - string match "\\" "\\" +test string-11.50.$noComp {string match, *special case} { + run {string match "\\" "\\"} } 0 -test string-11.51 {string match; *, -nocase and UTF-8} { - string match -nocase [binary format I 717316707] \ - [binary format I 2028036707] +test string-11.51.$noComp {string match; *, -nocase and UTF-8} { + run {string match -nocase [binary format I 717316707] \ + [binary format I 2028036707]} } 1 -test string-11.52 {string match, null char in string} { +test string-11.52.$noComp {string match, null char in string} { set out "" set ptn "*abc*" - foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] { - lappend out [string match $ptn $elem] + foreach elem [list "\x00@abc" "@abc" "\x00@abc\x00" "blahabcblah"] { + lappend out [run {string match $ptn $elem}] } set out } {1 1 1 1} -test string-11.53 {string match, null char in pattern} { +test string-11.53.$noComp {string match, null char in pattern} { set out "" foreach {ptn elem} [list \ - "*\u0000abc\u0000" "\u0000abc\u0000" \ - "*\u0000abc\u0000" "\u0000abc\u0000ef" \ - "*\u0000abc\u0000*" "\u0000abc\u0000ef" \ - "*\u0000abc\u0000" "@\u0000abc\u0000ef" \ - "*\u0000abc\u0000*" "@\u0000abc\u0000ef" \ + "*\x00abc\x00" "\x00abc\x00" \ + "*\x00abc\x00" "\x00abc\x00ef" \ + "*\x00abc\x00*" "\x00abc\x00ef" \ + "*\x00abc\x00" "@\x00abc\x00ef" \ + "*\x00abc\x00*" "@\x00abc\x00ef" \ ] { - lappend out [string match $ptn $elem] + lappend out [run {string match $ptn $elem}] } set out } {1 0 1 0 1} -test string-11.54 {string match, failure} { +test string-11.54.$noComp {string match, failure} { set longString "" for {set i 0} {$i < 10} {incr i} { - append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123" + append longString "abcdefghijklmnopqrstuvwxy\x00z01234567890123" } - string first $longString 123 - list [string match *cba* $longString] \ - [string match *a*l*\u0000* $longString] \ - [string match *a*l*\u0000*123 $longString] \ - [string match *a*l*\u0000*123* $longString] \ - [string match *a*l*\u0000*cba* $longString] \ - [string match *===* $longString] + run {string first $longString 123} + list [run {string match *cba* $longString}] \ + [run {string match *a*l*\x00* $longString}] \ + [run {string match *a*l*\x00*123 $longString}] \ + [run {string match *a*l*\x00*123* $longString}] \ + [run {string match *a*l*\x00*cba* $longString}] \ + [run {string match *===* $longString}] } {0 1 1 1 0 0} +test string-11.55.$noComp {string match, invalid binary optimization} { + [format string] match \u0141 [binary format c 65] +} 0 -test string-12.1 {string range} { - list [catch {string range} msg] $msg +test stringComp-12.1.0.$noComp {Bug 3588366: end-offsets before start} { + apply {s { + string range $s 0 end-5 + }} 12345 +} {} +test string-12.1.$noComp {string range} { + list [catch {run {string range}} msg] $msg } {1 {wrong # args: should be "string range string first last"}} -test string-12.2 {string range} { - list [catch {string range a 1} msg] $msg +test string-12.2.$noComp {string range} { + list [catch {run {string range a 1}} msg] $msg } {1 {wrong # args: should be "string range string first last"}} -test string-12.3 {string range} { - list [catch {string range a 1 2 3} msg] $msg +test string-12.3.$noComp {string range} { + list [catch {run {string range a 1 2 3}} msg] $msg } {1 {wrong # args: should be "string range string first last"}} -test string-12.4 {string range} { - string range abcdefghijklmnop 2 14 +test string-12.4.$noComp {string range} { + run {string range abcdefghijklmnop 2 14} } {cdefghijklmno} -test string-12.5 {string range, last > length} { - string range abcdefghijklmnop 7 1000 +test string-12.5.$noComp {string range, last > length} { + run {string range abcdefghijklmnop 7 1000} } {hijklmnop} -test string-12.6 {string range} { - string range abcdefghijklmnop 10 end +test string-12.6.$noComp {string range} { + run {string range abcdefghijklmnop 10 end} } {klmnop} -test string-12.7 {string range, last < first} { - string range abcdefghijklmnop 10 9 +test string-12.7.$noComp {string range, last < first} { + run {string range abcdefghijklmnop 10 9} } {} -test string-12.8 {string range, first < 0} { - string range abcdefghijklmnop -3 2 +test string-12.8.$noComp {string range, first < 0} { + run {string range abcdefghijklmnop -3 2} } {abc} -test string-12.9 {string range} { - string range abcdefghijklmnop -3 -2 +test string-12.9.$noComp {string range} { + run {string range abcdefghijklmnop -3 -2} } {} -test string-12.10 {string range} { - string range abcdefghijklmnop 1000 1010 +test string-12.10.$noComp {string range} { + run {string range abcdefghijklmnop 1000 1010} } {} -test string-12.11 {string range} { - string range abcdefghijklmnop -100 end +test string-12.11.$noComp {string range} { + run {string range abcdefghijklmnop -100 end} } {abcdefghijklmnop} -test string-12.12 {string range} { - list [catch {string range abc abc 1} msg] $msg +test string-12.12.$noComp {string range} { + list [catch {run {string range abc abc 1}} msg] $msg } {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} -test string-12.13 {string range} { - list [catch {string range abc 1 eof} msg] $msg +test string-12.13.$noComp {string range} { + list [catch {run {string range abc 1 eof}} msg] $msg } {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}} -test string-12.14 {string range} { - string range abcdefghijklmnop end-1 end +test string-12.14.$noComp {string range} { + run {string range abcdefghijklmnop end-1 end} } {op} -test string-12.15 {string range} { - string range abcdefghijklmnop end 1000 +test string-12.15.$noComp {string range} { + run {string range abcdefghijklmnop end 1000} } {p} -test string-12.16 {string range} { - string range abcdefghijklmnop end end-1 +test string-12.16.$noComp {string range} { + run {string range abcdefghijklmnop end end-1} } {} -test string-12.17 {string range, unicode} { - string range ab\u7266cdefghijklmnop 5 5 +test string-12.17.$noComp {string range, unicode} { + run {string range ab\u7266cdefghijklmnop 5 5} } e -test string-12.18 {string range, unicode} { - string range ab\u7266cdefghijklmnop 2 3 +test string-12.18.$noComp {string range, unicode} { + run {string range ab\u7266cdefghijklmnop 2 3} } \u7266c -test string-12.19 {string range, bytearray object} { +test string-12.19.$noComp {string range, bytearray object} { set b [binary format I* {0x50515253 0x52}] - set r1 [string range $b 1 end-1] - set r2 [string range $b 1 6] - string equal $r1 $r2 + set r1 [run {string range $b 1 end-1}] + set r2 [run {string range $b 1 6}] + run {string equal $r1 $r2} } 1 -test string-12.20 {string range, out of bounds indices} { - string range \u00ff 0 1 -} \u00ff +test string-12.20.$noComp {string range, out of bounds indices} { + run {string range \xFF 0 1} +} \xFF # Bug 1410553 -test string-12.21 {string range, regenerates correct reps, bug 1410553} { +test string-12.21.$noComp {string range, regenerates correct reps, bug 1410553} { set bytes "\x00 \x03 \x41" set rxBuffer {} foreach ch $bytes { append rxBuffer $ch if {$ch eq "\x03"} { - string length $rxBuffer + run {string length $rxBuffer} } } - set rxCRC [string range $rxBuffer end-1 end] + set rxCRC [run {string range $rxBuffer end-1 end}] binary scan [join $bytes {}] "H*" input_hex binary scan $rxBuffer "H*" rxBuffer_hex binary scan $rxCRC "H*" rxCRC_hex list $input_hex $rxBuffer_hex $rxCRC_hex } {000341 000341 0341} -test string-12.22 {string range, shimmering binary/index} { +test string-12.22.$noComp {string range, shimmering binary/index} { set s 0000000001 binary scan $s a* x - string range $s $s end + run {string range $s $s end} } 000000001 +test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} utf16 { + run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]} +} [list \U100000 {} b] +test string-12.24.$noComp {bignum index arithmetic} -setup { + proc demo {i j} {string range fubar $i $j} +} -cleanup { + rename demo {} +} -body { + demo 2 0+0x10000000000000000 +} -result bar +test string-12.25.$noComp {bignum index arithmetic} -setup { + proc demo {i j} {string range fubar $i $j} +} -cleanup { + rename demo {} +} -body { + demo 0x10000000000000000-0xffffffffffffffff 3 +} -result uba -test string-13.1 {string repeat} { - list [catch {string repeat} msg] $msg +test string-13.1.$noComp {string repeat} { + list [catch {run {string repeat}} msg] $msg } {1 {wrong # args: should be "string repeat string count"}} -test string-13.2 {string repeat} { - list [catch {string repeat abc 10 oops} msg] $msg +test string-13.2.$noComp {string repeat} { + list [catch {run {string repeat abc 10 oops}} msg] $msg } {1 {wrong # args: should be "string repeat string count"}} -test string-13.3 {string repeat} { - string repeat {} 100 +test string-13.3.$noComp {string repeat} { + run {string repeat {} 100} } {} -test string-13.4 {string repeat} { - string repeat { } 5 +test string-13.4.$noComp {string repeat} { + run {string repeat { } 5} } { } -test string-13.5 {string repeat} { - string repeat abc 3 +test string-13.5.$noComp {string repeat} { + run {string repeat abc 3} } {abcabcabc} -test string-13.6 {string repeat} { - string repeat abc -1 +test string-13.6.$noComp {string repeat} { + run {string repeat abc -1} } {} -test string-13.7 {string repeat} { - list [catch {string repeat abc end} msg] $msg +test string-13.7.$noComp {string repeat} { + list [catch {run {string repeat abc end}} msg] $msg } {1 {expected integer but got "end"}} -test string-13.8 {string repeat} { - string repeat {} -1000 +test string-13.8.$noComp {string repeat} { + run {string repeat {} -1000} } {} -test string-13.9 {string repeat} { - string repeat {} 0 +test string-13.9.$noComp {string repeat} { + run {string repeat {} 0} } {} -test string-13.10 {string repeat} { - string repeat def 0 +test string-13.10.$noComp {string repeat} { + run {string repeat def 0} } {} -test string-13.11 {string repeat} { - string repeat def 1 +test string-13.11.$noComp {string repeat} { + run {string repeat def 1} } def -test string-13.12 {string repeat} { - string repeat ab\u7266cd 3 +test string-13.12.$noComp {string repeat} { + run {string repeat ab\u7266cd 3} } ab\u7266cdab\u7266cdab\u7266cd -test string-13.13 {string repeat} { - string repeat \x00 3 +test string-13.13.$noComp {string repeat} { + run {string repeat \x00 3} } \x00\x00\x00 -test string-13.14 {string repeat} { +test string-13.14.$noComp {string repeat} { # The string range will ensure us that string repeat gets a unicode string - string repeat [string range ab\u7266cd 2 3] 3 + run {string repeat [run {string range ab\u7266cd 2 3}] 3} } \u7266c\u7266c\u7266c -test string-14.1 {string replace} { - list [catch {string replace} msg] $msg +test string-14.1.$noComp {string replace} { + list [catch {run {string replace}} msg] $msg } {1 {wrong # args: should be "string replace string first last ?string?"}} -test string-14.2 {string replace} { - list [catch {string replace a 1} msg] $msg +test string-14.2.$noComp {string replace} { + list [catch {run {string replace a 1}} msg] $msg } {1 {wrong # args: should be "string replace string first last ?string?"}} -test string-14.3 {string replace} { - list [catch {string replace a 1 2 3 4} msg] $msg +test string-14.3.$noComp {string replace} { + list [catch {run {string replace a 1 2 3 4}} msg] $msg } {1 {wrong # args: should be "string replace string first last ?string?"}} -test string-14.4 {string replace} { +test string-14.4.$noComp {string replace} { } {} -test string-14.5 {string replace} { - string replace abcdefghijklmnop 2 14 +test string-14.5.$noComp {string replace} { + run {string replace abcdefghijklmnop 2 14} } {abp} -test string-14.6 {string replace} { - string replace abcdefghijklmnop 7 1000 -} {abcdefg} -test string-14.7 {string replace} { - string replace abcdefghijklmnop 10 end +test string-14.6.$noComp {string replace} -body { + run {string replace abcdefghijklmnop 7 1000} +} -result {abcdefg} +test string-14.7.$noComp {string replace} { + run {string replace abcdefghijklmnop 10 end} } {abcdefghij} -test string-14.8 {string replace} { - string replace abcdefghijklmnop 10 9 +test string-14.8.$noComp {string replace} { + run {string replace abcdefghijklmnop 10 9} } {abcdefghijklmnop} -test string-14.9 {string replace} { - string replace abcdefghijklmnop -3 2 +test string-14.9.$noComp {string replace} { + run {string replace abcdefghijklmnop -3 2} } {defghijklmnop} -test string-14.10 {string replace} { - string replace abcdefghijklmnop -3 -2 +test string-14.10.$noComp {string replace} { + run {string replace abcdefghijklmnop -3 -2} } {abcdefghijklmnop} -test string-14.11 {string replace} { - string replace abcdefghijklmnop 1000 1010 -} {abcdefghijklmnop} -test string-14.12 {string replace} { - string replace abcdefghijklmnop -100 end +test string-14.11.$noComp {string replace} -body { + run {string replace abcdefghijklmnop 1000 1010} +} -result {abcdefghijklmnop} +test string-14.12.$noComp {string replace} { + run {string replace abcdefghijklmnop -100 end} } {} -test string-14.13 {string replace} { - list [catch {string replace abc abc 1} msg] $msg +test string-14.13.$noComp {string replace} { + list [catch {run {string replace abc abc 1}} msg] $msg } {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} -test string-14.14 {string replace} { - list [catch {string replace abc 1 eof} msg] $msg +test string-14.14.$noComp {string replace} { + list [catch {run {string replace abc 1 eof}} msg] $msg } {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}} -test string-14.15 {string replace} { - string replace abcdefghijklmnop end-10 end-2 NEW +test string-14.15.$noComp {string replace} { + run {string replace abcdefghijklmnop end-10 end-2 NEW} } {abcdeNEWop} -test string-14.16 {string replace} { - string replace abcdefghijklmnop 0 end foo +test string-14.16.$noComp {string replace} { + run {string replace abcdefghijklmnop 0 end foo} } {foo} -test string-14.17 {string replace} { - string replace abcdefghijklmnop end end-1 +test string-14.17.$noComp {string replace} { + run {string replace abcdefghijklmnop end end-1} +} {abcdefghijklmnop} +test string-14.18.$noComp {string replace} { + run {string replace abcdefghijklmnop 10 9 XXX} } {abcdefghijklmnop} +test string-14.19.$noComp {string replace} { + run {string replace {} -1 0 A} +} A +test string-14.20.$noComp {string replace} { + run {string replace [makeByteArray abcdefghijklmnop] end-10 end-2\ + [makeByteArray NEW]} +} {abcdeNEWop} + + +test stringComp-14.21.$noComp {Bug 82e7f67325} { + apply {x { + set a [join $x {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} {a b} +} {3 3} +test stringComp-14.22.$noComp {Bug 82e7f67325} memory { + # As in stringComp-14.1, but make sure we don't retain too many refs + leaktest { + apply {x { + set a [join $x {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} {a b} + } +} {0} +test stringComp-14.23.$noComp {Bug 0dca3bfa8f} { + apply {arg { + set argCopy $arg + set arg [string replace $arg 1 2 aa] + # Crashes in comparison before fix + expr {$arg ne $argCopy} + }} abcde +} 1 +test stringComp-14.24.$noComp {Bug 1af8de570511} { + apply {{x y} { + # Generate an unshared string value + set val "" + for { set i 0 } { $i < $x } { incr i } { + set val [format "0%s" $val] + } + string replace $val[unset val] 1 1 $y + }} 4 x +} 0x00 +test stringComp-14.25.$noComp {} { + string length [string replace [string repeat a\xFE 2] 3 end {}] +} 3 +test stringComp-14.26.$noComp {} { + run {string replace abcd 0x10000000000000000-0xffffffffffffffff 2 e} +} aed -test string-15.1 {string tolower too few args} { - list [catch {string tolower} msg] $msg +test string-15.1.$noComp {string tolower not enough args} { + list [catch {run {string tolower}} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} -test string-15.2 {string tolower bad args} { - list [catch {string tolower a b} msg] $msg +test string-15.2.$noComp {string tolower bad args} { + list [catch {run {string tolower a b}} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} -test string-15.3 {string tolower too many args} { - list [catch {string tolower ABC 1 end oops} msg] $msg +test string-15.3.$noComp {string tolower too many args} { + list [catch {run {string tolower ABC 1 end oops}} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} -test string-15.4 {string tolower} { - string tolower ABCDeF +test string-15.4.$noComp {string tolower} { + run {string tolower ABCDeF} } {abcdef} -test string-15.5 {string tolower} { - string tolower "ABC XyZ" +test string-15.5.$noComp {string tolower} { + run {string tolower "ABC XyZ"} } {abc xyz} -test string-15.6 {string tolower} { - string tolower {123#$&*()} +test string-15.6.$noComp {string tolower} { + run {string tolower {123#$&*()}} } {123#$&*()} -test string-15.7 {string tolower} { - string tolower ABC 1 +test string-15.7.$noComp {string tolower} { + run {string tolower ABC 1} } AbC -test string-15.8 {string tolower} { - string tolower ABC 1 end +test string-15.8.$noComp {string tolower} { + run {string tolower ABC 1 end} } Abc -test string-15.9 {string tolower} { - string tolower ABC 0 end-1 +test string-15.9.$noComp {string tolower} { + run {string tolower ABC 0 end-1} } abC -test string-15.10 {string tolower, unicode} { - string tolower ABCabc\xc7\xe7 -} "abcabc\xe7\xe7" +test string-15.10.$noComp {string tolower, unicode} { + run {string tolower ABCabc\xC7\xE7} +} "abcabc\xE7\xE7" +test string-15.11.$noComp {string tolower, compiled} { + lindex [run {string tolower [list A B [list C]]}] 1 +} b -test string-16.1 {string toupper} { - list [catch {string toupper} msg] $msg +test string-16.1.$noComp {string toupper} { + list [catch {run {string toupper}} msg] $msg } {1 {wrong # args: should be "string toupper string ?first? ?last?"}} -test string-16.2 {string toupper} { - list [catch {string toupper a b} msg] $msg +test string-16.2.$noComp {string toupper} { + list [catch {run {string toupper a b}} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} -test string-16.3 {string toupper} { - list [catch {string toupper a 1 end oops} msg] $msg +test string-16.3.$noComp {string toupper} { + list [catch {run {string toupper a 1 end oops}} msg] $msg } {1 {wrong # args: should be "string toupper string ?first? ?last?"}} -test string-16.4 {string toupper} { - string toupper abCDEf +test string-16.4.$noComp {string toupper} { + run {string toupper abCDEf} } {ABCDEF} -test string-16.5 {string toupper} { - string toupper "abc xYz" +test string-16.5.$noComp {string toupper} { + run {string toupper "abc xYz"} } {ABC XYZ} -test string-16.6 {string toupper} { - string toupper {123#$&*()} +test string-16.6.$noComp {string toupper} { + run {string toupper {123#$&*()}} } {123#$&*()} -test string-16.7 {string toupper} { - string toupper abc 1 +test string-16.7.$noComp {string toupper} { + run {string toupper abc 1} } aBc -test string-16.8 {string toupper} { - string toupper abc 1 end +test string-16.8.$noComp {string toupper} { + run {string toupper abc 1 end} } aBC -test string-16.9 {string toupper} { - string toupper abc 0 end-1 +test string-16.9.$noComp {string toupper} { + run {string toupper abc 0 end-1} } ABc -test string-16.10 {string toupper, unicode} { - string toupper ABCabc\xc7\xe7 -} "ABCABC\xc7\xc7" +test string-16.10.$noComp {string toupper, unicode} { + run {string toupper ABCabc\xC7\xE7} +} "ABCABC\xC7\xC7" +test string-16.11.$noComp {string toupper, compiled} { + lindex [run {string toupper [list a b [list c]]}] 1 +} B -test string-17.1 {string totitle} { - list [catch {string totitle} msg] $msg +test string-17.1.$noComp {string totitle} { + list [catch {run {string totitle}} msg] $msg } {1 {wrong # args: should be "string totitle string ?first? ?last?"}} -test string-17.2 {string totitle} { - list [catch {string totitle a b} msg] $msg +test string-17.2.$noComp {string totitle} { + list [catch {run {string totitle a b}} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} -test string-17.3 {string totitle} { - string totitle abCDEf +test string-17.3.$noComp {string totitle} { + run {string totitle abCDEf} } {Abcdef} -test string-17.4 {string totitle} { - string totitle "abc xYz" +test string-17.4.$noComp {string totitle} { + run {string totitle "abc xYz"} } {Abc xyz} -test string-17.5 {string totitle} { - string totitle {123#$&*()} +test string-17.5.$noComp {string totitle} { + run {string totitle {123#$&*()}} } {123#$&*()} -test string-17.6 {string totitle, unicode} { - string totitle ABCabc\xc7\xe7 -} "Abcabc\xe7\xe7" -test string-17.7 {string totitle, unicode} { - string totitle \u01f3BCabc\xc7\xe7 -} "\u01f2bcabc\xe7\xe7" +test string-17.6.$noComp {string totitle, unicode} { + run {string totitle ABCabc\xC7\xE7} +} "Abcabc\xE7\xE7" +test string-17.7.$noComp {string totitle, unicode} { + run {string totitle \u01F3BCabc\xC7\xE7} +} "\u01F2bcabc\xE7\xE7" +test string-17.8.$noComp {string totitle, compiled} { + lindex [run {string totitle [list aa bb [list cc]]}] 0 +} Aa +test string-17.9.$noComp {string totitle, surrogates, bug [11ae2be95dac9417]} utf16 { + run {list [string totitle a\U118c0c 1 1] [string totitle a\U118c0c 2 2] \ + [string totitle a\U118c0c 3 3]} +} [list a\U118a0c a\U118c0C a\U118c0C] -test string-18.1 {string trim} { - list [catch {string trim} msg] $msg +test string-18.1.$noComp {string trim} { + list [catch {run {string trim}} msg] $msg } {1 {wrong # args: should be "string trim string ?chars?"}} -test string-18.2 {string trim} { - list [catch {string trim a b c} msg] $msg +test string-18.2.$noComp {string trim} { + list [catch {run {string trim a b c}} msg] $msg } {1 {wrong # args: should be "string trim string ?chars?"}} -test string-18.3 {string trim} { - string trim " XYZ " +test string-18.3.$noComp {string trim} { + run {string trim " XYZ "} } {XYZ} -test string-18.4 {string trim} { - string trim "\t\nXYZ\t\n\r\n" +test string-18.4.$noComp {string trim} { + run {string trim "\t\nXYZ\t\n\r\n"} } {XYZ} -test string-18.5 {string trim} { - string trim " A XYZ A " +test string-18.5.$noComp {string trim} { + run {string trim " A XYZ A "} } {A XYZ A} -test string-18.6 {string trim} { - string trim "XXYYZZABC XXYYZZ" ZYX +test string-18.6.$noComp {string trim} { + run {string trim "XXYYZZABC XXYYZZ" ZYX} } {ABC } -test string-18.7 {string trim} { - string trim " \t\r " +test string-18.7.$noComp {string trim} { + run {string trim " \t\r "} } {} -test string-18.8 {string trim} { - string trim {abcdefg} {} +test string-18.8.$noComp {string trim} { + run {string trim {abcdefg} {}} } {abcdefg} -test string-18.9 {string trim} { - string trim {} +test string-18.9.$noComp {string trim} { + run {string trim {}} } {} -test string-18.10 {string trim} { - string trim ABC DEF +test string-18.10.$noComp {string trim} { + run {string trim ABC DEF} } {ABC} -test string-18.11 {string trim, unicode} { - string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8 -} " AB\xe7C " -test string-18.12 {string trim, unicode default} { - string trim ABC\u1361\u1680\u3000 -} ABC +test string-18.11.$noComp {string trim, unicode} { + run {string trim "\xE7\xE8 AB\xE7C \xE8\xE7" \xE7\xE8} +} " AB\xE7C " +test string-18.12.$noComp {string trim, unicode default} { + run {string trim \uFEFF\x00\x85\xA0\u1680\u180EABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000} +} ABC\u1361 -test string-19.1 {string trimleft} { - list [catch {string trimleft} msg] $msg +test string-19.1.$noComp {string trimleft} { + list [catch {run {string trimleft}} msg] $msg } {1 {wrong # args: should be "string trimleft string ?chars?"}} -test string-19.2 {string trimleft} { - string trimleft " XYZ " +test string-19.2.$noComp {string trimleft} { + run {string trimleft " XYZ "} } {XYZ } -test string-19.3 {string trimleft, unicode default} { - string trimleft \u1361\u1680\u3000ABC -} ABC +test string-19.3.$noComp {string trimleft, unicode default} { + run {string trimleft \uFEFF\x85\xA0\x00\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000\u1361ABC} +} \u1361ABC -test string-20.1 {string trimright errors} { - list [catch {string trimright} msg] $msg +test string-20.1.$noComp {string trimright errors} { + list [catch {run {string trimright}} msg] $msg } {1 {wrong # args: should be "string trimright string ?chars?"}} -test string-20.2 {string trimright errors} { - list [catch {string trimg a} msg] $msg -} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test string-20.3 {string trimright} { - string trimright " XYZ " +test string-20.2.$noComp {string trimright errors} { + list [catch {run {string trimg a}} msg] $msg +} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-20.3.$noComp {string trimright} { + run {string trimright " XYZ "} } { XYZ} -test string-20.4 {string trimright} { - string trimright " " +test string-20.4.$noComp {string trimright} { + run {string trimright " "} } {} -test string-20.5 {string trimright} { - string trimright "" +test string-20.5.$noComp {string trimright} { + run {string trimright ""} } {} -test string-20.6 {string trimright, unicode default} { - string trimright ABC\u1361\u1680\u3000 -} ABC +test string-20.6.$noComp {string trimright, unicode default} { + run {string trimright ABC\u1361\x85\x00\xA0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000} +} ABC\u1361 +test string-20.7.$noComp {string trim on not valid utf-8 sequence (consider NTS as continuation char), bug [c61818e4c9]} {testbytestring} { + set result {} + set a [testbytestring \xC0\x80\xA0] + set b foo$a + set m [list \x00 U \xA0 V [testbytestring \xA0] W] + lappend result [string map $m $b] + lappend result [string map $m [run {string trimright $b x}]] + lappend result [string map $m [run {string trimright $b \x00}]] + lappend result [string map $m [run {string trimleft $b fox}]] + lappend result [string map $m [run {string trimleft $b fo\x00}]] + lappend result [string map $m [run {string trim $b fox}]] + lappend result [string map $m [run {string trim $b fo\x00}]] +} [list {*}[lrepeat 3 fooUV] {*}[lrepeat 2 UV V]] +test string-20.8.$noComp {[c61818e4c9] [string trimright] fails when UtfPrev is ok} {testbytestring} { + set result {} + set a [testbytestring \xE8\xA0] + set b foo$a + set m [list \xE8 U \xA0 V [testbytestring \xE8] W [testbytestring \xA0] X]] + lappend result [string map $m $b] + lappend result [string map $m [run {string trimright $b x}]] + lappend result [string map $m [run {string trimright $b \xE8}]] + lappend result [string map $m [run {string trimright $b [testbytestring \xE8]}]] + lappend result [string map $m [run {string trimright $b \xA0}]] + lappend result [string map $m [run {string trimright $b [testbytestring \xA0]}]] + lappend result [string map $m [run {string trimright $b \xE8\xA0}]] + lappend result [string map $m [run {string trimright $b [testbytestring \xE8\xA0]}]] + lappend result [string map $m [run {string trimright $b \u0000}]] +} [list {*}[lrepeat 4 fooUV] {*}[lrepeat 2 fooU] {*}[lrepeat 2 foo] fooUV] -test string-21.1 {string wordend} { - list [catch {string wordend a} msg] $msg -} {1 {wrong # args: should be "string wordend string index"}} -test string-21.2 {string wordend} { - list [catch {string wordend a b c} msg] $msg -} {1 {wrong # args: should be "string wordend string index"}} -test string-21.3 {string wordend} { - list [catch {string wordend a gorp} msg] $msg -} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} -test string-21.4 {string wordend} { - string wordend abc. -1 -} 3 -test string-21.5 {string wordend} { - string wordend abc. 100 -} 4 -test string-21.6 {string wordend} { - string wordend "word_one two three" 2 -} 8 -test string-21.7 {string wordend} { - string wordend "one .&# three" 5 -} 6 -test string-21.8 {string wordend} { - string worde "x.y" 0 -} 1 -test string-21.9 {string wordend} { - string worde "x.y" end-1 -} 2 -test string-21.10 {string wordend, unicode} { - string wordend "xyz\u00c7de fg" 0 -} 6 -test string-21.11 {string wordend, unicode} { - string wordend "xyz\uc700de fg" 0 -} 6 -test string-21.12 {string wordend, unicode} { - string wordend "xyz\u203fde fg" 0 -} 6 -test string-21.13 {string wordend, unicode} { - string wordend "xyz\u2045de fg" 0 -} 3 -test string-21.14 {string wordend, unicode} { - string wordend "\uc700\uc700 abc" 8 -} 6 +test string-21.1.$noComp {string wordend} -body { + list [catch {run {string wordend a}} msg] $msg +} -result {1 {wrong # args: should be "string wordend string index"}} +test string-21.2.$noComp {string wordend} -body { + list [catch {run {string wordend a b c}} msg] $msg +} -result {1 {wrong # args: should be "string wordend string index"}} +test string-21.3.$noComp {string wordend} -body { + list [catch {run {string wordend a gorp}} msg] $msg +} -result {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} +test string-21.4.$noComp {string wordend} -body { + run {string wordend abc. -1} +} -result 3 +test string-21.5.$noComp {string wordend} -body { + run {string wordend abc. 100} +} -result 4 +test string-21.6.$noComp {string wordend} -body { + run {string wordend "word_one two three" 2} +} -result 8 +test string-21.7.$noComp {string wordend} -body { + run {string wordend "one .&# three" 5} +} -result 6 +test string-21.8.$noComp {string wordend} -body { + run {string worde "x.y" 0} +} -result 1 +test string-21.9.$noComp {string wordend} -body { + run {string worde "x.y" end-1} +} -result 2 +test string-21.10.$noComp {string wordend, unicode} -body { + run {string wordend "xyz\xC7de fg" 0} +} -result 6 +test string-21.11.$noComp {string wordend, unicode} -body { + run {string wordend "xyz\uC700de fg" 0} +} -result 6 +test string-21.12.$noComp {string wordend, unicode} -body { + run {string wordend "xyz\u203Fde fg" 0} +} -result 6 +test string-21.13.$noComp {string wordend, unicode} -body { + run {string wordend "xyz\u2045de fg" 0} +} -result 3 +test string-21.14.$noComp {string wordend, unicode} -body { + run {string wordend "\uC700\uC700 abc" 8} +} -result 6 +test string-21.15.$noComp {string wordend, unicode} -body { + run {string wordend "\U1D7CA\U1D7CA abc" 0} +} -result 2 +test string-21.16.$noComp {string wordend, unicode} -constraints utf16 -body { + run {string wordend "\U1D7CA\U1D7CA abc" 10} +} -result 8 -test string-22.1 {string wordstart} { - list [catch {string word a} msg] $msg -} {1 {unknown or ambiguous subcommand "word": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test string-22.2 {string wordstart} { - list [catch {string wordstart a} msg] $msg -} {1 {wrong # args: should be "string wordstart string index"}} -test string-22.3 {string wordstart} { - list [catch {string wordstart a b c} msg] $msg -} {1 {wrong # args: should be "string wordstart string index"}} -test string-22.4 {string wordstart} { - list [catch {string wordstart a gorp} msg] $msg -} {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} -test string-22.5 {string wordstart} { - string wordstart "one two three_words" 400 -} 8 -test string-22.6 {string wordstart} { - string wordstart "one two three_words" 2 -} 0 -test string-22.7 {string wordstart} { - string wordstart "one two three_words" -2 -} 0 -test string-22.8 {string wordstart} { - string wordstart "one .*&^ three" 6 -} 6 -test string-22.9 {string wordstart} { - string wordstart "one two three" 4 -} 4 -test string-22.10 {string wordstart} { - string wordstart "one two three" end-5 -} 7 -test string-22.11 {string wordstart, unicode} { - string wordstart "one tw\u00c7o three" 7 -} 4 -test string-22.12 {string wordstart, unicode} { - string wordstart "ab\uc700\uc700 cdef ghi" 12 -} 10 -test string-22.13 {string wordstart, unicode} { - string wordstart "\uc700\uc700 abc" 8 -} 3 +test string-22.1.$noComp {string wordstart} -body { + list [catch {run {string word a}} msg] $msg +} -result {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +test string-22.2.$noComp {string wordstart} -body { + list [catch {run {string wordstart a}} msg] $msg +} -result {1 {wrong # args: should be "string wordstart string index"}} +test string-22.3.$noComp {string wordstart} -body { + list [catch {run {string wordstart a b c}} msg] $msg +} -result {1 {wrong # args: should be "string wordstart string index"}} +test string-22.4.$noComp {string wordstart} -body { + list [catch {run {string wordstart a gorp}} msg] $msg +} -result {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} +test string-22.5.$noComp {string wordstart} -body { + run {string wordstart "one two three_words" 400} +} -result 8 +test string-22.6.$noComp {string wordstart} -body { + run {string wordstart "one two three_words" 2} +} -result 0 +test string-22.7.$noComp {string wordstart} -body { + run {string wordstart "one two three_words" -2} +} -result 0 +test string-22.8.$noComp {string wordstart} -body { + run {string wordstart "one .*&^ three" 6} +} -result 6 +test string-22.9.$noComp {string wordstart} -body { + run {string wordstart "one two three" 4} +} -result 4 +test string-22.10.$noComp {string wordstart} -body { + run {string wordstart "one two three" end-5} +} -result 7 +test string-22.11.$noComp {string wordstart, unicode} -body { + run {string wordstart "one tw\xC7o three" 7} +} -result 4 +test string-22.12.$noComp {string wordstart, unicode} -body { + run {string wordstart "ab\uC700\uC700 cdef ghi" 12} +} -result 10 +test string-22.13.$noComp {string wordstart, unicode} -body { + run {string wordstart "\uC700\uC700 abc" 8} +} -result 3 +test string-22.14.$noComp {string wordstart, invalid UTF-8} -constraints testbytestring -body { + # See Bug c61818e4c9 + set demo [testbytestring "abc def\xE0\xA9ghi"] + run {string index $demo [string wordstart $demo 10]} +} -result g +test string-22.15.$noComp {string wordstart, unicode} -body { + run {string wordstart "\U1D7CA\U1D7CA abc" 0} +} -result 0 +test string-22.16.$noComp {string wordstart, unicode} -constraints utf16 -body { + run {string wordstart "\U1D7CA\U1D7CA abc" 10} +} -result 5 -test string-23.0 {string is boolean, Bug 1187123} testindexobj { +test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj { set x 5 catch {testindexobj $x foo bar soom} - string is boolean $x + run {string is boolean $x} } 0 -test string-23.1 {string is command with empty string} { +test string-23.1.$noComp {string is command with empty string} { set s "" list \ - [string is alnum $s] \ - [string is alpha $s] \ - [string is ascii $s] \ - [string is control $s] \ - [string is boolean $s] \ - [string is digit $s] \ - [string is double $s] \ - [string is false $s] \ - [string is graph $s] \ - [string is integer $s] \ - [string is lower $s] \ - [string is print $s] \ - [string is punct $s] \ - [string is space $s] \ - [string is true $s] \ - [string is upper $s] \ - [string is wordchar $s] \ - [string is xdigit $s] \ + [run {string is alnum $s}] \ + [run {string is alpha $s}] \ + [run {string is ascii $s}] \ + [run {string is control $s}] \ + [run {string is boolean $s}] \ + [run {string is digit $s}] \ + [run {string is double $s}] \ + [run {string is false $s}] \ + [run {string is graph $s}] \ + [run {string is integer $s}] \ + [run {string is lower $s}] \ + [run {string is print $s}] \ + [run {string is punct $s}] \ + [run {string is space $s}] \ + [run {string is true $s}] \ + [run {string is upper $s}] \ + [run {string is wordchar $s}] \ + [run {string is xdigit $s}] \ } {1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1} -test string-23.2 {string is command with empty string} { +test string-23.2.$noComp {string is command with empty string} { set s "" list \ - [string is alnum -strict $s] \ - [string is alpha -strict $s] \ - [string is ascii -strict $s] \ - [string is control -strict $s] \ - [string is boolean -strict $s] \ - [string is digit -strict $s] \ - [string is double -strict $s] \ - [string is false -strict $s] \ - [string is graph -strict $s] \ - [string is integer -strict $s] \ - [string is lower -strict $s] \ - [string is print -strict $s] \ - [string is punct -strict $s] \ - [string is space -strict $s] \ - [string is true -strict $s] \ - [string is upper -strict $s] \ - [string is wordchar -strict $s] \ - [string is xdigit -strict $s] \ + [run {string is alnum -strict $s}] \ + [run {string is alpha -strict $s}] \ + [run {string is ascii -strict $s}] \ + [run {string is control -strict $s}] \ + [run {string is boolean -strict $s}] \ + [run {string is digit -strict $s}] \ + [run {string is double -strict $s}] \ + [run {string is false -strict $s}] \ + [run {string is graph -strict $s}] \ + [run {string is integer -strict $s}] \ + [run {string is lower -strict $s}] \ + [run {string is print -strict $s}] \ + [run {string is punct -strict $s}] \ + [run {string is space -strict $s}] \ + [run {string is true -strict $s}] \ + [run {string is upper -strict $s}] \ + [run {string is wordchar -strict $s}] \ + [run {string is xdigit -strict $s}] \ } {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} -test string-24.1 {string reverse command} -body { - string reverse +test string-24.1.$noComp {string reverse command} -body { + run {string reverse} } -returnCodes error -result "wrong # args: should be \"string reverse string\"" -test string-24.2 {string reverse command} -body { - string reverse a b +test string-24.2.$noComp {string reverse command} -body { + run {string reverse a b} } -returnCodes error -result "wrong # args: should be \"string reverse string\"" -test string-24.3 {string reverse command - shared string} { +test string-24.3.$noComp {string reverse command - shared string} { set x abcde - string reverse $x + run {string reverse $x} } edcba -test string-24.4 {string reverse command - unshared string} { +test string-24.4.$noComp {string reverse command - unshared string} { set x abc set y de - string reverse $x$y + run {string reverse $x$y} } edcba -test string-24.5 {string reverse command - shared unicode string} { - set x abcde\udead - string reverse $x -} \udeadedcba -test string-24.6 {string reverse command - unshared string} { +test string-24.5.$noComp {string reverse command - shared unicode string} { + set x abcde\uD0AD + run {string reverse $x} +} \uD0ADedcba +test string-24.6.$noComp {string reverse command - unshared string} { set x abc - set y de\udead - string reverse $x$y -} \udeadedcba -test string-24.7 {string reverse command - simple case} { - string reverse a + set y de\uD0AD + run {string reverse $x$y} +} \uD0ADedcba +test string-24.7.$noComp {string reverse command - simple case} { + run {string reverse a} } a -test string-24.8 {string reverse command - simple case} { - string reverse \udead -} \udead -test string-24.9 {string reverse command - simple case} { - string reverse {} +test string-24.8.$noComp {string reverse command - simple case} { + run {string reverse \uD0AD} +} \uD0AD +test string-24.9.$noComp {string reverse command - simple case} { + run {string reverse {}} } {} -test string-24.10 {string reverse command - corner case} { - set x \ubeef\udead - string reverse $x -} \udead\ubeef -test string-24.11 {string reverse command - corner case} { - set x \ubeef - set y \udead - string reverse $x$y -} \udead\ubeef -test string-24.12 {string reverse command - corner case} { - set x \ubeef - set y \udead - string is ascii [string reverse $x$y] -} 0 -test string-24.13 {string reverse command - pure Unicode string} { - string reverse [string range \ubeef\udead\ubeef\udead\ubeef\udead 1 5] -} \udead\ubeef\udead\ubeef\udead -test string-24.14 {string reverse command - pure bytearray} { - binary scan [string reverse [binary format H* 010203]] H* x +test string-24.10.$noComp {string reverse command - corner case} { + set x \uBEEF\uD0AD + run {string reverse $x} +} \uD0AD\uBEEF +test string-24.11.$noComp {string reverse command - corner case} { + set x \uBEEF + set y \uD0AD + run {string reverse $x$y} +} \uD0AD\uBEEF +test string-24.12.$noComp {string reverse command - corner case} { + set x \uBEEF + set y \uD0AD + run {string is ascii [run {string reverse $x$y}]} +} 0 +test string-24.13.$noComp {string reverse command - pure Unicode string} { + run {string reverse [run {string range \uBEEF\uD0AD\uBEEF\uD0AD\uBEEF\uD0AD 1 5}]} +} \uD0AD\uBEEF\uD0AD\uBEEF\uD0AD +test string-24.14.$noComp {string reverse command - pure bytearray} { + binary scan [run {string reverse [binary format H* 010203]}] H* x set x } 030201 -test string-24.15 {string reverse command - pure bytearray} { - binary scan [tcl::string::reverse [binary format H* 010203]] H* x +test string-24.15.$noComp {string reverse command - pure bytearray} { + binary scan [run {tcl::string::reverse [binary format H* 010203]}] H* x set x } 030201 -test string-25.1 {string is list} { - string is list {a b c} +test string-25.1.$noComp {string is list} { + run {string is list {a b c}} } 1 -test string-25.2 {string is list} { - string is list "a \{b c" +test string-25.2.$noComp {string is list} { + run {string is list "a \{b c"} } 0 -test string-25.3 {string is list} { - string is list {a {b c}d e} +test string-25.3.$noComp {string is list} { + run {string is list {a {b c}d e}} } 0 -test string-25.4 {string is list} { - string is list {} +test string-25.4.$noComp {string is list} { + run {string is list {}} } 1 -test string-25.5 {string is list} { - string is list -strict {a b c} +test string-25.5.$noComp {string is list} { + run {string is list -strict {a b c}} } 1 -test string-25.6 {string is list} { - string is list -strict "a \{b c" +test string-25.6.$noComp {string is list} { + run {string is list -strict "a \{b c"} } 0 -test string-25.7 {string is list} { - string is list -strict {a {b c}d e} +test string-25.7.$noComp {string is list} { + run {string is list -strict {a {b c}d e}} } 0 -test string-25.8 {string is list} { - string is list -strict {} +test string-25.8.$noComp {string is list} { + run {string is list -strict {}} } 1 -test string-25.9 {string is list} { +test string-25.9.$noComp {string is list} { set x {} - list [string is list -failindex x {a b c}] $x + list [run {string is list -failindex x {a b c}}] $x } {1 {}} -test string-25.10 {string is list} { +test string-25.10.$noComp {string is list} { set x {} - list [string is list -failindex x "a \{b c"] $x + list [run {string is list -failindex x "a \{b c"}] $x } {0 2} -test string-25.11 {string is list} { +test string-25.11.$noComp {string is list} { set x {} - list [string is list -failindex x {a b {b c}d e}] $x + list [run {string is list -failindex x {a b {b c}d e}}] $x } {0 4} -test string-25.12 {string is list} { +test string-25.12.$noComp {string is list} { set x {} - list [string is list -failindex x {}] $x + list [run {string is list -failindex x {}}] $x } {1 {}} -test string-25.13 {string is list} { +test string-25.13.$noComp {string is list} { set x {} - list [string is list -failindex x { {b c}d e}] $x + list [run {string is list -failindex x { {b c}d e}}] $x } {0 2} -test string-25.14 {string is list} { +test string-25.14.$noComp {string is list} { set x {} - list [string is list -failindex x "\uabcd {b c}d e"] $x + list [run {string is list -failindex x "\uABCD {b c}d e"}] $x } {0 2} -test string-26.1 {tcl::prefix, too few args} -body { +test string-26.1.$noComp {tcl::prefix, not enough args} -body { tcl::prefix match a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix match ?options? table string"} -test string-26.2 {tcl::prefix, bad args} -body { +test string-26.2.$noComp {tcl::prefix, bad args} -body { tcl::prefix match a b c } -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message} -test string-26.2.1 {tcl::prefix, empty table} -body { +test string-26.2.1.$noComp {tcl::prefix, empty table} -body { tcl::prefix match {} foo } -returnCodes 1 -result {bad option "foo": no valid options} -test string-26.3 {tcl::prefix, bad args} -body { +test string-26.3.$noComp {tcl::prefix, bad args} -body { tcl::prefix match -error "{}x" -exact str1 str2 } -returnCodes 1 -result {list element in braces followed by "x" instead of space} -test string-26.3.1 {tcl::prefix, bad args} -body { +test string-26.3.1.$noComp {tcl::prefix, bad args} -body { tcl::prefix match -error "x" -exact str1 str2 } -returnCodes 1 -result {error options must have an even number of elements} -test string-26.3.2 {tcl::prefix, bad args} -body { +test string-26.3.2.$noComp {tcl::prefix, bad args} -body { tcl::prefix match -error str1 str2 -} -returnCodes 1 -result {missing error options} -test string-26.4 {tcl::prefix, bad args} -body { +} -returnCodes 1 -result {missing value for -error} +test string-26.4.$noComp {tcl::prefix, bad args} -body { tcl::prefix match -message str1 str2 -} -returnCodes 1 -result {missing message} -test string-26.5 {tcl::prefix} { +} -returnCodes 1 -result {missing value for -message} +test string-26.5.$noComp {tcl::prefix} { tcl::prefix match {apa bepa cepa depa} cepa } cepa -test string-26.6 {tcl::prefix} { +test string-26.6.$noComp {tcl::prefix} { tcl::prefix match {apa bepa cepa depa} be } bepa -test string-26.7 {tcl::prefix} -body { +test string-26.7.$noComp {tcl::prefix} -body { tcl::prefix match -exact {apa bepa cepa depa} be } -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa} -test string-26.8 {tcl::prefix} -body { - tcl::prefix match -message switch {apa bepa bear depa} be -} -returnCodes 1 -result {ambiguous switch "be": must be apa, bepa, bear, or depa} -test string-26.9 {tcl::prefix} -body { +test string-26.8.$noComp {tcl::prefix} -body { + tcl::prefix match -message wombat {apa bepa bear depa} be +} -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa} +test string-26.9.$noComp {tcl::prefix} -body { tcl::prefix match -error {} {apa bepa bear depa} be } -returnCodes 0 -result {} -test string-26.10 {tcl::prefix} -body { +test string-26.10.$noComp {tcl::prefix} -body { tcl::prefix match -error {-level 1} {apa bepa bear depa} be } -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa} -test string-26.10.1 {tcl::prefix} -setup { +test string-26.10.1.$noComp {tcl::prefix} -setup { proc _testprefix {args} { array set opts {-a x -b y -c y} foreach {opt val} $args { @@ -1822,7 +2172,7 @@ proc MemStress {args} { set res {} foreach body $args { set end 0 - for {set i 0} {$i < 5} {incr i} { + for {set i 0} {$i < 5} {incr i} { proc MemStress_Body {} $body uplevel 1 MemStress_Body rename MemStress_Body {} @@ -1834,7 +2184,7 @@ proc MemStress {args} { return $res } -test string-26.11 {tcl::prefix: testing for leaks} -body { +test string-26.11.$noComp {tcl::prefix: testing for leaks} -body { # This test is made to stress object reference management MemStress { set table {hejj miff gurk} @@ -1855,7 +2205,7 @@ test string-26.11 {tcl::prefix: testing for leaks} -body { } } -constraints memory -result {0 0 0} -test string-26.12 {tcl::prefix: testing for leaks} -body { +test string-26.12.$noComp {tcl::prefix: testing for leaks} -body { # This is a memory leak test in a form that might actually happen # in real code. The shared literal "miff" causes a connection # between the item and the table. @@ -1873,7 +2223,7 @@ test string-26.12 {tcl::prefix: testing for leaks} -body { } } -constraints memory -result 0 -test string-26.13 {tcl::prefix: testing for leaks} -body { +test string-26.13.$noComp {tcl::prefix: testing for leaks} -body { # This test is made to stress object reference management MemStress { set table [list hejj miff] @@ -1886,80 +2236,324 @@ test string-26.13 {tcl::prefix: testing for leaks} -body { } } -constraints memory -result {0} -test string-27.1 {tcl::prefix all, too few args} -body { +test string-27.1.$noComp {tcl::prefix all, not enough args} -body { tcl::prefix all a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"} -test string-27.2 {tcl::prefix all, bad args} -body { +test string-27.2.$noComp {tcl::prefix all, bad args} -body { tcl::prefix all a b c } -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"} -test string-27.3 {tcl::prefix all, bad args} -body { +test string-27.3.$noComp {tcl::prefix all, bad args} -body { tcl::prefix all "{}x" str2 } -returnCodes 1 -result {list element in braces followed by "x" instead of space} -test string-27.4 {tcl::prefix all} { +test string-27.4.$noComp {tcl::prefix all} { tcl::prefix all {apa bepa cepa depa} c } cepa -test string-27.5 {tcl::prefix all} { +test string-27.5.$noComp {tcl::prefix all} { tcl::prefix all {apa bepa cepa depa} cepa } cepa -test string-27.6 {tcl::prefix all} { +test string-27.6.$noComp {tcl::prefix all} { tcl::prefix all {apa bepa cepa depa} cepax } {} -test string-27.7 {tcl::prefix all} { +test string-27.7.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} a } {apa aska appa} -test string-27.8 {tcl::prefix all} { +test string-27.8.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} ap } {apa appa} -test string-27.9 {tcl::prefix all} { +test string-27.9.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} p } {} -test string-27.10 {tcl::prefix all} { +test string-27.10.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} {} } {apa aska appa} -test string-28.1 {tcl::prefix longest, too few args} -body { +test string-28.1.$noComp {tcl::prefix longest, not enough args} -body { tcl::prefix longest a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"} -test string-28.2 {tcl::prefix longest, bad args} -body { +test string-28.2.$noComp {tcl::prefix longest, bad args} -body { tcl::prefix longest a b c } -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"} -test string-28.3 {tcl::prefix longest, bad args} -body { +test string-28.3.$noComp {tcl::prefix longest, bad args} -body { tcl::prefix longest "{}x" str2 } -returnCodes 1 -result {list element in braces followed by "x" instead of space} -test string-28.4 {tcl::prefix longest} { +test string-28.4.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bepa cepa depa} c } cepa -test string-28.5 {tcl::prefix longest} { +test string-28.5.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bepa cepa depa} cepa } cepa -test string-28.6 {tcl::prefix longest} { +test string-28.6.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bepa cepa depa} cepax } {} -test string-28.7 {tcl::prefix longest} { +test string-28.7.$noComp {tcl::prefix longest} { tcl::prefix longest {apa aska appa} a } a -test string-28.8 {tcl::prefix longest} { +test string-28.8.$noComp {tcl::prefix longest} { tcl::prefix longest {apa aska appa} ap } ap -test string-28.9 {tcl::prefix longest} { +test string-28.9.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bska appa} a } ap -test string-28.10 {tcl::prefix longest} { +test string-28.10.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bska appa} {} } {} -test string-28.11 {tcl::prefix longest} { +test string-28.11.$noComp {tcl::prefix longest} { tcl::prefix longest {{} bska appa} {} } {} -test string-28.12 {tcl::prefix longest} { +test string-28.12.$noComp {tcl::prefix longest} { tcl::prefix longest {apa {} appa} {} } {} -test string-28.13 {tcl::prefix longest} { - # Test UTF8 handling +test string-28.13.$noComp {tcl::prefix longest} { + # Test utf-8 handling tcl::prefix longest {ax\x90 bep ax\x91} a } ax +test string-29.1.$noComp {string cat, no arg} { + run {string cat} +} "" +test string-29.2.$noComp {string cat, single arg} { + set x FOO + run {string compare $x [run {string cat $x}]} +} 0 +test string-29.3.$noComp {string cat, two args} { + set x FOO + run {string compare $x$x [run {string cat $x $x}]} +} 0 +test string-29.4.$noComp {string cat, many args} { + set x FOO + set n 260 + set xx [run {string repeat $x $n}] + set vv [run {string repeat {$x} $n}] + set vvs [run {string repeat {$x } $n}] + set r1 [run {string compare $xx [subst $vv]}] + set r2 [run {string compare $xx [eval "run {string cat $vvs}"]}] + list $r1 $r2 +} {0 0} +if {$noComp} { +test string-29.5.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list x] [list]}] +} -match glob -result {*no string representation} +test string-29.6.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list] [list x]}] +} -match glob -result {*no string representation} +test string-29.7.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list x] [list] [list]}] +} -match glob -result {*no string representation} +test string-29.8.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list] [list x] [list]}] +} -match glob -result {*no string representation} +test string-29.9.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list] [list] [list x]}] +} -match glob -result {*no string representation} +test string-29.10.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list x] [list x]}] +} -match glob -result {*, string representation "xx"} +test string-29.11.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation \ + [run {string cat [list x] [encoding convertto utf-8 {}]}] +} -match glob -result {*no string representation} +test string-29.12.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation \ + [run {string cat [encoding convertto utf-8 {}] [list x]}] +} -match glob -result {*, string representation "x"} +test string-29.13.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat \ + [encoding convertto utf-8 {}] [encoding convertto utf-8 {}] [list x]}] +} -match glob -result {*, string representation "x"} +test string-29.14.$noComp {string cat, efficiency} -setup { + set e [encoding convertto utf-8 {}] +} -cleanup { + unset e +} -body { + tcl::unsupported::representation [run {string cat $e $e [list x]}] +} -match glob -result {*no string representation} +test string-29.15.$noComp {string cat, efficiency} -setup { + set e [encoding convertto utf-8 {}] + set f [encoding convertto utf-8 {}] +} -cleanup { + unset e f +} -body { + tcl::unsupported::representation [run {string cat $e $f $e $f [list x]}] +} -match glob -result {*no string representation} +} + +test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} { + run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]} +} hellohello +test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} { + run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"} +} hellohello + +# Note: string-31.* tests use [tcl::string::insert] rather than [string insert] +# to dodge ticket [3397978fff] which would cause all arguments to be shared, +# thereby preventing the optimizations from being tested. +test string-31.1.$noComp {string insert, start of string} { + run {tcl::string::insert 0123 0 _} +} _0123 +test string-31.2.$noComp {string insert, middle of string} { + run {tcl::string::insert 0123 2 _} +} 01_23 +test string-31.3.$noComp {string insert, end of string} { + run {tcl::string::insert 0123 4 _} +} 0123_ +test string-31.4.$noComp {string insert, start of string, end-relative} { + run {tcl::string::insert 0123 end-4 _} +} _0123 +test string-31.5.$noComp {string insert, middle of string, end-relative} { + run {tcl::string::insert 0123 end-2 _} +} 01_23 +test string-31.6.$noComp {string insert, end of string, end-relative} { + run {tcl::string::insert 0123 end _} +} 0123_ +test string-31.7.$noComp {string insert, empty target string} { + run {tcl::string::insert {} 0 _} +} _ +test string-31.8.$noComp {string insert, empty insert string} { + run {tcl::string::insert 0123 0 {}} +} 0123 +test string-31.9.$noComp {string insert, empty strings} { + run {tcl::string::insert {} 0 {}} +} {} +test string-31.10.$noComp {string insert, negative index} { + run {tcl::string::insert 0123 -1 _} +} _0123 +test string-31.11.$noComp {string insert, index beyond end} { + run {tcl::string::insert 0123 5 _} +} 0123_ +test string-31.12.$noComp {string insert, start of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 0 [makeByteArray _]} +} _0123 +test string-31.13.$noComp {string insert, middle of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]} +} 01_23 +test string-31.14.$noComp {string insert, end of string, pure byte array} { + run {tcl::string::insert [makeByteArray 0123] 4 [makeByteArray _]} +} 0123_ +test string-31.15.$noComp {string insert, pure byte array, neither shared} { + run {tcl::string::insert [makeByteArray 0123] 2 [makeByteArray _]} +} 01_23 +test string-31.16.$noComp {string insert, pure byte array, first shared} { + run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\ + [makeByteArray _]} +} 01_23 +test string-31.17.$noComp {string insert, pure byte array, second shared} { + run {tcl::string::insert [makeByteArray 0123] 2\ + [makeShared [makeByteArray _]]} +} 01_23 +test string-31.18.$noComp {string insert, pure byte array, both shared} { + run {tcl::string::insert [makeShared [makeByteArray 0123]] 2\ + [makeShared [makeByteArray _]]} +} 01_23 +test string-31.19.$noComp {string insert, start of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 0 [makeUnicode _]} +} _0123 +test string-31.20.$noComp {string insert, middle of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 2 [makeUnicode _]} +} 01_23 +test string-31.21.$noComp {string insert, end of string, pure Unicode} { + run {tcl::string::insert [makeUnicode 0123] 4 [makeUnicode _]} +} 0123_ +test string-31.22.$noComp {string insert, str start, pure Uni, first shared} { + run {tcl::string::insert [makeShared [makeUnicode 0123]] 0 [makeUnicode _]} +} _0123 +test string-31.23.$noComp {string insert, string mid, pure Uni, 2nd shared} { + run {tcl::string::insert [makeUnicode 0123] 2 [makeShared [makeUnicode _]]} +} 01_23 +test string-31.24.$noComp {string insert, string end, pure Uni, both shared} { + run {tcl::string::insert [makeShared [makeUnicode 0123]] 4\ + [makeShared [makeUnicode _]]} +} 0123_ +test string-31.25.$noComp {string insert, neither byte array nor Unicode} { + run {tcl::string::insert [makeList a b c] 1 zzzzzz} +} {azzzzzz b c} +test string-31.26.$noComp {[11229bad5f] string insert, compiler} -setup { + set i 2 +} -body { + run {tcl::string::insert abcd $i xyz} +} -cleanup { + unset i +} -result abxyzcd + +test string-32.1.$noComp {string is dict} { + string is dict {a b c d} +} 1 +test string-32.1a.$noComp {string is dict} { + string is dict {a b c} +} 0 +test string-32.2.$noComp {string is dict} { + string is dict "a \{b c" +} 0 +test string-32.3.$noComp {string is dict} { + string is dict {a {b c}d e} +} 0 +test string-32.4.$noComp {string is dict} { + string is dict {} +} 1 +test string-32.5.$noComp {string is dict} { + string is dict -strict {a b c d} +} 1 +test string-32.5a.$noComp {string is dict} { + string is dict -strict {a b c} +} 0 +test string-32.6.$noComp {string is dict} { + string is dict -strict "a \{b c" +} 0 +test string-32.7.$noComp {string is dict} { + string is dict -strict {a {b c}d e} +} 0 +test string-32.8.$noComp {string is dict} { + string is dict -strict {} +} 1 +test string-32.9.$noComp {string is dict} { + set x {} + list [string is dict -failindex x {a b c d}] $x +} {1 {}} +test string-32.9a.$noComp {string is dict} { + set x {} + list [string is dict -failindex x {a b c}] $x +} {0 -1} +test string-32.10.$noComp {string is dict} { + set x {} + list [string is dict -failindex x "a \{b c d"] $x +} {0 2} +test string-32.10a.$noComp {string is dict} { + set x {} + list [string is dict -failindex x "a \{b c"] $x +} {0 2} +test string-32.11.$noComp {string is dict} { + set x {} + list [string is dict -failindex x {a b {b c}d e}] $x +} {0 4} +test string-32.12.$noComp {string is dict} { + set x {} + list [string is dict -failindex x {}] $x +} {1 {}} +test string-32.13.$noComp {string is dict} { + set x {} + list [string is dict -failindex x { {b c}d e}] $x +} {0 2} +test string-32.14.$noComp {string is dict} { + set x {} + list [string is dict -failindex x "\uABCD {b c}d e"] $x +} {0 2} +test string-32.15.$noComp {string is dict, valid dict} { + string is dict {a b c d e f} +} 1 +test string-32.16.$noComp {string is dict, invalid dict} { + string is dict a +} 0 +test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} { + string is dict {{a b c d e f g h}} +} 0 + +}; # foreach noComp {0 1} + # cleanup rename MemStress {} +rename makeByteArray {} +rename makeUnicode {} +rename makeList {} +rename makeShared {} catch {rename foo {}} ::tcltest::cleanupTests return diff --git a/tests/stringComp.test b/tests/stringComp.test deleted file mode 100644 index 56fb69d..0000000 --- a/tests/stringComp.test +++ /dev/null @@ -1,706 +0,0 @@ -# Commands covered: string -# -# 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 -# generates output for errors. No output means no errors were found. -# -# This differs from the original string tests in that the tests call -# things in procs, which uses the compiled string code instead of -# the runtime parse string code. The tests of import should match -# their equivalent number in string.test. -# -# Copyright (c) 2001 by ActiveState Corporation. -# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -# Some tests require the testobj command - -testConstraint testobj [expr {[info commands testobj] != {}}] - -test stringComp-1.1 {error conditions} { - proc foo {} {string gorp a b} - list [catch {foo} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test stringComp-1.2 {error conditions} { - proc foo {} {string} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string subcommand ?arg ...?"}} -test stringComp-1.3 {error condition - undefined method during compile} { - # We don't want this to complain about 'never' because it may never - # be called, or string may get redefined. This must compile OK. - proc foo {str i} { - if {"yes" == "no"} { string never called but complains here } - string index $str $i - } - foo abc 0 -} a - -## Test string compare|equal over equal constraints -## Use result for string compare, and negate it for string equal -## The body will be tested both in and outside a proc -set i 0 -foreach {tname tbody tresult tcode} { - {too few args} { - string compare a - } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} - {bad args} { - string compare a b c - } {bad option "a": must be -nocase or -length} {error} - {bad args} { - string compare -length -nocase str1 str2 - } {expected integer but got "-nocase"} {error} - {too many args} { - string compare -length 10 -nocase str1 str2 str3 - } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} - {compare with length unspecified} { - string compare -length 10 10 - } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} - {basic operation fail} { - string compare abcde abdef - } {-1} {} - {basic operation success} { - string compare abcde abcde - } {0} {} - {with length} { - string compare -length 2 abcde abxyz - } {0} {} - {with special index} { - string compare -length end-3 abcde abxyz - } {expected integer but got "end-3"} {error} - {unicode} { - string compare ab\u7266 ab\u7267 - } {-1} {} - {unicode} {string compare \334 \u00dc} 0 {} - {unicode} {string compare \334 \u00fc} -1 {} - {unicode} {string compare \334\334\334\374\374 \334\334\334\334\334} 1 {} - {high bit} { - # This test will fail if the underlying comparaison - # is using signed chars instead of unsigned chars. - # (like SunOS's default memcmp thus the compat/memcmp.c) - string compare "\x80" "@" - # Nb this tests works also in utf8 space because \x80 is - # translated into a 2 or more bytelength but whose first byte has - # the high bit set. - } {1} {} - {-nocase 1} {string compare -nocase abcde abdef} {-1} {} - {-nocase 2} {string compare -nocase abcde Abdef} {-1} {} - {-nocase 3} {string compare -nocase abcde ABCDE} {0} {} - {-nocase 4} {string compare -nocase abcde abcde} {0} {} - {-nocase unicode} { - string compare -nocase \334 \u00dc - } 0 {} - {-nocase unicode} { - string compare -nocase \334\334\334\374\u00fc \334\334\334\334\334 - } 0 {} - {-nocase with length} { - string compare -length 2 -nocase abcde Abxyz - } {0} {} - {-nocase with length} { - string compare -nocase -length 3 abcde Abxyz - } {-1} {} - {-nocase with length <= 0} { - string compare -nocase -length -1 abcde AbCdEf - } {-1} {} - {-nocase with excessive length} { - string compare -nocase -length 50 AbCdEf abcde - } {1} {} - {-len unicode} { - # These are strings that are 6 BYTELENGTH long, but the length - # shouldn't make a different because there are actually 3 CHARS long - string compare -len 5 \334\334\334 \334\334\374 - } -1 {} - {-nocase with special index} { - string compare -nocase -length end-3 Abcde abxyz - } {expected integer but got "end-3"} error - {null strings} { - string compare "" "" - } 0 {} - {null strings} { - string compare "" foo - } -1 {} - {null strings} { - string compare foo "" - } 1 {} - {-nocase null strings} { - string compare -nocase "" "" - } 0 {} - {-nocase null strings} { - string compare -nocase "" foo - } -1 {} - {-nocase null strings} { - string compare -nocase foo "" - } 1 {} - {with length, unequal strings} { - string compare -length 2 abc abde - } 0 {} - {with length, unequal strings} { - string compare -length 2 ab abde - } 0 {} - {with NUL character vs. other ASCII} { - # Be careful here, since UTF-8 rep comparison with memcmp() of - # these puts chars in the wrong order - string compare \x00 \x01 - } -1 {} - {high bit} { - string compare "a\x80" "a@" - } 1 {} - {high bit} { - string compare "a\x00" "a\x01" - } -1 {} - {high bit} { - string compare "\x00\x00" "\x00\x01" - } -1 {} - {binary equal} { - string compare [binary format a100 0] [binary format a100 0] - } 0 {} - {binary neq} { - string compare [binary format a100a 0 1] [binary format a100a 0 0] - } 1 {} - {binary neq inequal length} { - string compare [binary format a20a 0 1] [binary format a100a 0 0] - } 1 {} -} { - if {$tname eq ""} { continue } - if {$tcode eq ""} { set tcode ok } - test stringComp-2.[incr i] "string compare, $tname" \ - -body [list eval $tbody] \ - -returnCodes $tcode -result $tresult - test stringComp-2.[incr i] "string compare bc, $tname" \ - -body "[list proc foo {} $tbody];foo" \ - -returnCodes $tcode -result $tresult - if {"error" ni $tcode} { - set tresult [expr {!$tresult}] - } else { - set tresult [string map {compare equal} $tresult] - } - set tbody [string map {compare equal} $tbody] - test stringComp-2.[incr i] "string equal, $tname" \ - -body [list eval $tbody] \ - -returnCodes $tcode -result $tresult - test stringComp-2.[incr i] "string equal bc, $tname" \ - -body "[list proc foo {} $tbody];foo" \ - -returnCodes $tcode -result $tresult -} - -# need a few extra tests short abbr cmd -test stringComp-3.1 {string compare, shortest method name} { - proc foo {} {string c abcde ABCDE} - foo -} 1 -test stringComp-3.2 {string equal, shortest method name} { - proc foo {} {string e abcde ABCDE} - foo -} 0 -test stringComp-3.3 {string equal -nocase} { - proc foo {} {string eq -nocase abcde ABCDE} - foo -} 1 - -test stringComp-4.1 {string first, too few args} { - proc foo {} {string first a} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test stringComp-4.2 {string first, bad args} { - proc foo {} {string first a b c} - list [catch {foo} msg] $msg -} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} -test stringComp-4.3 {string first, too many args} { - proc foo {} {string first a b 5 d} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test stringComp-4.4 {string first} { - proc foo {} {string first bq abcdefgbcefgbqrs} - foo -} 12 -test stringComp-4.5 {string first} { - proc foo {} {string fir bcd abcdefgbcefgbqrs} - foo -} 1 -test stringComp-4.6 {string first} { - proc foo {} {string f b abcdefgbcefgbqrs} - foo -} 1 -test stringComp-4.7 {string first} { - proc foo {} {string first xxx x123xx345xxx789xxx012} - foo -} 9 -test stringComp-4.8 {string first} { - proc foo {} {string first "" x123xx345xxx789xxx012} - foo -} -1 -test stringComp-4.9 {string first, unicode} { - proc foo {} {string first x abc\u7266x} - foo -} 4 -test stringComp-4.10 {string first, unicode} { - proc foo {} {string first \u7266 abc\u7266x} - foo -} 3 -test stringComp-4.11 {string first, start index} { - proc foo {} {string first \u7266 abc\u7266x 3} - foo -} 3 -test stringComp-4.12 {string first, start index} { - proc foo {} {string first \u7266 abc\u7266x 4} - foo -} -1 -test stringComp-4.13 {string first, start index} { - proc foo {} {string first \u7266 abc\u7266x end-2} - foo -} 3 -test stringComp-4.14 {string first, negative start index} { - proc foo {} {string first b abc -1} - foo -} 1 - -test stringComp-5.1 {string index} { - proc foo {} {string index} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string index string charIndex"}} -test stringComp-5.2 {string index} { - proc foo {} {string index a b c} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string index string charIndex"}} -test stringComp-5.3 {string index} { - proc foo {} {string index abcde 0} - foo -} a -test stringComp-5.4 {string index} { - proc foo {} {string in abcde 4} - foo -} e -test stringComp-5.5 {string index} { - proc foo {} {string index abcde 5} - foo -} {} -test stringComp-5.6 {string index} { - proc foo {} {string index abcde -10} - list [catch {foo} msg] $msg -} {0 {}} -test stringComp-5.7 {string index} { - proc foo {} {string index a xyz} - list [catch {foo} msg] $msg -} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} -test stringComp-5.8 {string index} { - proc foo {} {string index abc end} - foo -} c -test stringComp-5.9 {string index} { - proc foo {} {string index abc end-1} - foo -} b -test stringComp-5.10 {string index, unicode} { - proc foo {} {string index abc\u7266d 4} - foo -} d -test stringComp-5.11 {string index, unicode} { - proc foo {} {string index abc\u7266d 3} - foo -} \u7266 -test stringComp-5.12 {string index, unicode over char length, under byte length} { - proc foo {} {string index \334\374\334\374 6} - foo -} {} -test stringComp-5.13 {string index, bytearray object} { - proc foo {} {string index [binary format a5 fuz] 0} - foo -} f -test stringComp-5.14 {string index, bytearray object} { - proc foo {} {string index [binary format I* {0x50515253 0x52}] 3} - foo -} S -test stringComp-5.15 {string index, bytearray object} { - proc foo {} { - set b [binary format I* {0x50515253 0x52}] - set i1 [string index $b end-6] - set i2 [string index $b 1] - string compare $i1 $i2 - } - foo -} 0 -test stringComp-5.16 {string index, bytearray object with string obj shimmering} { - proc foo {} { - set str "0123456789\x00 abcdedfghi" - binary scan $str H* dump - string compare [string index $str 10] \x00 - } - foo -} 0 -test stringComp-5.17 {string index, bad integer} -body { - proc foo {} {string index "abc" 0o8} - list [catch {foo} msg] $msg -} -match glob -result {1 {*invalid octal number*}} -test stringComp-5.18 {string index, bad integer} -body { - proc foo {} {string index "abc" end-0o0289} - list [catch {foo} msg] $msg -} -match glob -result {1 {*invalid octal number*}} -test stringComp-5.19 {string index, bytearray object out of bounds} { - proc foo {} {string index [binary format I* {0x50515253 0x52}] -1} - foo -} {} -test stringComp-5.20 {string index, bytearray object out of bounds} { - proc foo {} {string index [binary format I* {0x50515253 0x52}] 20} - foo -} {} - - -proc largest_int {} { - # This will give us what the largest valid int on this machine is, - # so we can test for overflow properly below on >32 bit systems - set int 1 - set exp 7; # assume we get at least 8 bits - while {$int > 0} { set int [expr {1 << [incr exp]}] } - return [expr {$int-1}] -} - -## string is -## not yet bc - -catch {rename largest_int {}} - -## string last -## not yet bc - -## string length -## not yet bc -test stringComp-8.1 {string bytelength} { - proc foo {} {string bytelength} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string bytelength string"}} -test stringComp-8.2 {string bytelength} { - proc foo {} {string bytelength a b} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string bytelength string"}} -test stringComp-8.3 {string bytelength} { - proc foo {} {string bytelength "\u00c7"} - foo -} 2 -test stringComp-8.4 {string bytelength} { - proc foo {} {string b ""} - foo -} 0 - -## string length -## -test stringComp-9.1 {string length} { - proc foo {} {string length} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string length string"}} -test stringComp-9.2 {string length} { - proc foo {} {string length a b} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string length string"}} -test stringComp-9.3 {string length} { - proc foo {} {string length "a little string"} - foo -} 15 -test stringComp-9.4 {string length} { - proc foo {} {string le ""} - foo -} 0 -test stringComp-9.5 {string length, unicode} { - proc foo {} {string le "abcd\u7266"} - foo -} 5 -test stringComp-9.6 {string length, bytearray object} { - proc foo {} {string length [binary format a5 foo]} - foo -} 5 -test stringComp-9.7 {string length, bytearray object} { - proc foo {} {string length [binary format I* {0x50515253 0x52}]} - foo -} 8 - -## string map -## not yet bc - -## string match -## -test stringComp-11.1 {string match, too few args} { - proc foo {} {string match a} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test stringComp-11.2 {string match, too many args} { - proc foo {} {string match a b c d} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test stringComp-11.3 {string match} { - proc foo {} {string match abc abc} - foo -} 1 -test stringComp-11.4 {string match} { - proc foo {} {string mat abc abd} - foo -} 0 -test stringComp-11.5 {string match} { - proc foo {} {string match ab*c abc} - foo -} 1 -test stringComp-11.6 {string match} { - proc foo {} {string match ab**c abc} - foo -} 1 -test stringComp-11.7 {string match} { - proc foo {} {string match ab* abcdef} - foo -} 1 -test stringComp-11.8 {string match} { - proc foo {} {string match *c abc} - foo -} 1 -test stringComp-11.9 {string match} { - proc foo {} {string match *3*6*9 0123456789} - foo -} 1 -test stringComp-11.10 {string match} { - proc foo {} {string match *3*6*9 01234567890} - foo -} 0 -test stringComp-11.11 {string match} { - proc foo {} {string match a?c abc} - foo -} 1 -test stringComp-11.12 {string match} { - proc foo {} {string match a??c abc} - foo -} 0 -test stringComp-11.13 {string match} { - proc foo {} {string match ?1??4???8? 0123456789} - foo -} 1 -test stringComp-11.14 {string match} { - proc foo {} {string match {[abc]bc} abc} - foo -} 1 -test stringComp-11.15 {string match} { - proc foo {} {string match {a[abc]c} abc} - foo -} 1 -test stringComp-11.16 {string match} { - proc foo {} {string match {a[xyz]c} abc} - foo -} 0 -test stringComp-11.17 {string match} { - proc foo {} {string match {12[2-7]45} 12345} - foo -} 1 -test stringComp-11.18 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12345} - foo -} 1 -test stringComp-11.19 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12b45} - foo -} 1 -test stringComp-11.20 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12d45} - foo -} 1 -test stringComp-11.21 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12145} - foo -} 0 -test stringComp-11.22 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12545} - foo -} 0 -test stringComp-11.23 {string match} { - proc foo {} {string match {a\*b} a*b} - foo -} 1 -test stringComp-11.24 {string match} { - proc foo {} {string match {a\*b} ab} - foo -} 0 -test stringComp-11.25 {string match} { - proc foo {} {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"} - foo -} 1 -test stringComp-11.26 {string match} { - proc foo {} {string match ** ""} - foo -} 1 -test stringComp-11.27 {string match} { - proc foo {} {string match *. ""} - foo -} 0 -test stringComp-11.28 {string match} { - proc foo {} {string match "" ""} - foo -} 1 -test stringComp-11.29 {string match} { - proc foo {} {string match \[a a} - foo -} 1 -test stringComp-11.30 {string match, bad args} { - proc foo {} {string match - b c} - list [catch {foo} msg] $msg -} {1 {bad option "-": must be -nocase}} -test stringComp-11.31 {string match case} { - proc foo {} {string match a A} - foo -} 0 -test stringComp-11.32 {string match nocase} { - proc foo {} {string match -n a A} - foo -} 1 -test stringComp-11.33 {string match nocase} { - proc foo {} {string match -nocase a\334 A\374} - foo -} 1 -test stringComp-11.34 {string match nocase} { - proc foo {} {string match -nocase a*f ABCDEf} - foo -} 1 -test stringComp-11.35 {string match case, false hope} { - # This is true because '_' lies between the A-Z and a-z ranges - proc foo {} {string match {[A-z]} _} - foo -} 1 -test stringComp-11.36 {string match nocase range} { - # This is false because although '_' lies between the A-Z and a-z ranges, - # we lower case the end points before checking the ranges. - proc foo {} {string match -nocase {[A-z]} _} - foo -} 0 -test stringComp-11.37 {string match nocase} { - proc foo {} {string match -nocase {[A-fh-Z]} g} - foo -} 0 -test stringComp-11.38 {string match case, reverse range} { - proc foo {} {string match {[A-fh-Z]} g} - foo -} 1 -test stringComp-11.39 {string match, *\ case} { - proc foo {} {string match {*\abc} abc} - foo -} 1 -test stringComp-11.40 {string match, *special case} { - proc foo {} {string match {*[ab]} abc} - foo -} 0 -test stringComp-11.41 {string match, *special case} { - proc foo {} {string match {*[ab]*} abc} - foo -} 1 -test stringComp-11.42 {string match, *special case} { - proc foo {} {string match "*\\" "\\"} - foo -} 0 -test stringComp-11.43 {string match, *special case} { - proc foo {} {string match "*\\\\" "\\"} - foo -} 1 -test stringComp-11.44 {string match, *special case} { - proc foo {} {string match "*???" "12345"} - foo -} 1 -test stringComp-11.45 {string match, *special case} { - proc foo {} {string match "*???" "12"} - foo -} 0 -test stringComp-11.46 {string match, *special case} { - proc foo {} {string match "*\\*" "abc*"} - foo -} 1 -test stringComp-11.47 {string match, *special case} { - proc foo {} {string match "*\\*" "*"} - foo -} 1 -test stringComp-11.48 {string match, *special case} { - proc foo {} {string match "*\\*" "*abc"} - foo -} 0 -test stringComp-11.49 {string match, *special case} { - proc foo {} {string match "?\\*" "a*"} - foo -} 1 -test stringComp-11.50 {string match, *special case} { - proc foo {} {string match "\\" "\\"} - foo -} 0 -test stringComp-11.51 {string match; *, -nocase and UTF-8} { - proc foo {} {string match -nocase [binary format I 717316707] \ - [binary format I 2028036707]} - foo -} 1 -test stringComp-11.52 {string match, null char in string} { - proc foo {} { - set ptn "*abc*" - foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] { - lappend out [string match $ptn $elem] - } - set out - } - foo -} {1 1 1 1} -test stringComp-11.53 {string match, null char in pattern} { - proc foo {} { - set out "" - foreach {ptn elem} [list \ - "*\u0000abc\u0000" "\u0000abc\u0000" \ - "*\u0000abc\u0000" "\u0000abc\u0000ef" \ - "*\u0000abc\u0000*" "\u0000abc\u0000ef" \ - "*\u0000abc\u0000" "@\u0000abc\u0000ef" \ - "*\u0000abc\u0000*" "@\u0000abc\u0000ef" \ - ] { - lappend out [string match $ptn $elem] - } - set out - } - foo -} {1 0 1 0 1} -test stringComp-11.54 {string match, failure} { - proc foo {} { - set longString "" - for {set i 0} {$i < 10} {incr i} { - append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123" - } - list [string match *cba* $longString] \ - [string match *a*l*\u0000* $longString] \ - [string match *a*l*\u0000*123 $longString] \ - [string match *a*l*\u0000*123* $longString] \ - [string match *a*l*\u0000*cba* $longString] \ - [string match *===* $longString] - } - foo -} {0 1 1 1 0 0} - -## string range -## not yet bc - -## string repeat -## not yet bc - -## string replace -## not yet bc - -## string tolower -## not yet bc - -## string toupper -## not yet bc - -## string totitle -## not yet bc - -## string trim* -## not yet bc - -## string word* -## not yet bc - -# cleanup -catch {rename foo {}} -::tcltest::cleanupTests -return diff --git a/tests/stringObj.test b/tests/stringObj.test index 6f331d3..9937fa4 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -6,28 +6,31 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1995-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] +testConstraint tip389 [expr {[string length \U010000] == 2}] +testConstraint nodep [info exists tcl_precision] test stringObj-1.1 {string type registration} testobj { set t [testobj types] set first [string first "string" $t] - set result [expr {$first != -1}] -} {1} + set result [expr {$first >= 0}] +} 1 test stringObj-2.1 {Tcl_NewStringObj} testobj { set result "" @@ -338,7 +341,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstr # Because this test does not use \uXXXX notation below instead of # hardcoding the values, it may fail in multibyte locales. However, we # need to test that the parser produces untyped objects even when there - # are high-ASCII characters in the input (like ""). I don't know what + # are high-ASCII characters in the input (like "ï"). I don't know what # else to do but inline those characters here. testdstring free testdstring append "abc\u00ef\u00efdef" -1 @@ -347,7 +350,7 @@ test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstr [testobj objtype $x] [testobj objtype $y] } [list none "bc\u00EF\u00EFde" string string] test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { - # set x "abcdef" + # set x "abcïïdef" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set x "abc\u00EF\u00EFdef" @@ -356,7 +359,7 @@ test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { [testobj objtype $x] [testobj objtype $y] } [list string "bc\u00EF\u00EFde" string string] test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj { - # set a "abcd" + # set a "ïa¿b®cï¿d®" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" @@ -413,34 +416,34 @@ test stringObj-13.3 {Tcl_GetCharLength with byte-size chars} testobj { list [string length $a] [string length $a] } {6 6} test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj { - string length "\u00ae" + string length "\u00ae" } 1 test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj { - # string length "○○" + # string length "○○" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE" } 6 test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} testobj { - # set a "abcd" + # set a "ïa¿b®cï¿d®" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" list [string length $a] [string length $a] } {10 10} -test stringObj-13.7 {Tcl_GetCharLength with identity nulls} testobj { +test stringObj-13.7 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} { # SF bug #684699 - string length [encoding convertfrom identity \x00] + string length [testbytestring \x00] } 1 -test stringObj-13.8 {Tcl_GetCharLength with identity nulls} testobj { - string length [encoding convertfrom identity \x01\x00\x02] +test stringObj-13.8 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} { + string length [testbytestring \x01\x00\x02] } 3 test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} testobj { teststringobj set 1 foo - teststringobj getunicode 1 + teststringobj maxchars 1 teststringobj append 1 bar -1 - teststringobj getunicode 1 + teststringobj maxchars 1 teststringobj append 1 bar -1 teststringobj setlength 1 0 teststringobj append 1 bar -1 @@ -463,23 +466,22 @@ test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 3 } foo -test stringObj-15.5 {Tcl_Append*ToObj: self appends} testobj { +test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { teststringobj set 1 foo teststringobj appendself2 1 0 } foofoo -test stringObj-15.6 {Tcl_Append*ToObj: self appends} testobj { +test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { teststringobj set 1 foo teststringobj appendself2 1 1 } foooo -test stringObj-15.7 {Tcl_Append*ToObj: self appends} testobj { +test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { teststringobj set 1 foo teststringobj appendself2 1 2 } fooo -test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { +test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} { teststringobj set 1 foo teststringobj appendself2 1 3 } foo - if {[testConstraint testobj]} { testobj freeallvars @@ -488,3 +490,7 @@ if {[testConstraint testobj]} { # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/subst.test b/tests/subst.test index 4be4798..03a1ce2 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -4,24 +4,28 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 Ajuba Solutions. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.1 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] + +testConstraint testbytestring [llength [info commands testbytestring]] test subst-1.1 {basics} -returnCodes error -body { subst } -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"} test subst-1.2 {basics} -returnCodes error -body { subst a b c -} -result {bad switch "a": must be -nobackslashes, -nocommands, or -novariables} +} -result {bad option "a": must be -nobackslashes, -nocommands, or -novariables} test subst-2.1 {simple strings} { subst {} @@ -32,16 +36,16 @@ test subst-2.2 {simple strings} { test subst-2.3 {simple strings} { subst abcdefg } abcdefg -test subst-2.4 {simple strings} { +test subst-2.4 {simple strings} testbytestring { # Tcl Bug 685106 - subst [bytestring bar\x00soom] -} [bytestring bar\x00soom] + expr {[subst [testbytestring bar\x00soom]] eq [testbytestring bar\x00soom]} +} 1 test subst-3.1 {backslash substitutions} { subst {\x\$x\[foo bar]\\} } "x\$x\[foo bar]\\" test subst-3.2 {backslash substitutions with utf chars} { - # 'j' is just a char that doesn't mean anything, and \344 is '' + # 'j' is just a char that doesn't mean anything, and \344 is 'ä' # that also doesn't mean anything, but is multi-byte in UTF-8. list [subst \j] [subst \\j] [subst \\344] [subst \\\344] } "j j \344 \344" @@ -87,29 +91,29 @@ test subst-5.4 {command substitutions} { } {1 {invalid command name "bogus_command"}} test subst-5.5 {command substitutions} { set a 0 - list [catch {subst {[set a 1}} msg] $a $msg + list [catch {subst {[set a 1}} msg] $a $msg } {1 0 {missing close-bracket}} test subst-5.6 {command substitutions} { set a 0 - list [catch {subst {0[set a 1}} msg] $a $msg + list [catch {subst {0[set a 1}} msg] $a $msg } {1 0 {missing close-bracket}} test subst-5.7 {command substitutions} { set a 0 - list [catch {subst {0[set a 1; set a 2}} msg] $a $msg + list [catch {subst {0[set a 1; set a 2}} msg] $a $msg } {1 1 {missing close-bracket}} # repeat the tests above simulating cmd line input test subst-5.8 {command substitutions} { set script {[subst {[set a 1}]} - list [catch {exec [info nameofexecutable] << $script} msg] $msg + list [catch {exec [info nameofexecutable] << $script} msg] $msg } {1 {missing close-bracket}} test subst-5.9 {command substitutions} { set script {[subst {0[set a 1}]} - list [catch {exec [info nameofexecutable] << $script} msg] $msg + list [catch {exec [info nameofexecutable] << $script} msg] $msg } {1 {missing close-bracket}} test subst-5.10 {command substitutions} { set script {[subst {0[set a 1; set a 2}]} - list [catch {exec [info nameofexecutable] << $script} msg] $msg + list [catch {exec [info nameofexecutable] << $script} msg] $msg } {1 {missing close-bracket}} test subst-6.1 {clear the result after command substitution} -body { @@ -119,29 +123,29 @@ test subst-6.1 {clear the result after command substitution} -body { test subst-7.1 {switches} -returnCodes error -body { subst foo bar -} -result {bad switch "foo": must be -nobackslashes, -nocommands, or -novariables} +} -result {bad option "foo": must be -nobackslashes, -nocommands, or -novariables} test subst-7.2 {switches} -returnCodes error -body { subst -no bar -} -result {ambiguous switch "-no": must be -nobackslashes, -nocommands, or -novariables} +} -result {ambiguous option "-no": must be -nobackslashes, -nocommands, or -novariables} test subst-7.3 {switches} -returnCodes error -body { subst -bogus bar -} -result {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables} +} -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables} test subst-7.4 {switches} { set x 123 - subst -nobackslashes {abc $x [expr 1+2] \\\x41} + subst -nobackslashes {abc $x [expr {1 + 2}] \\\x41} } {abc 123 3 \\\x41} test subst-7.5 {switches} { set x 123 - subst -nocommands {abc $x [expr 1+2] \\\x41} -} {abc 123 [expr 1+2] \A} + subst -nocommands {abc $x [expr {1 + 2}] \\\x41} +} {abc 123 [expr {1 + 2}] \A} test subst-7.6 {switches} { set x 123 - subst -novariables {abc $x [expr 1+2] \\\x41} + subst -novariables {abc $x [expr {1 + 2}] \\\x41} } {abc $x 3 \A} test subst-7.7 {switches} { set x 123 - subst -nov -nob -noc {abc $x [expr 1+2] \\\x41} -} {abc $x [expr 1+2] \\\x41} + subst -nov -nob -noc {abc $x [expr {1 + 2}] \\\x41} +} {abc $x [expr {1 + 2}] \\\x41} test subst-8.1 {return in a subst} { subst {foo [return {x}; bogus code] bar} @@ -162,7 +166,7 @@ test subst-8.6 {return in a subst} -returnCodes error -body { subst "foo \[return {x}; bogus code bar" } -result {missing close-bracket} test subst-8.7 {return in a subst, parse error} -body { - subst {foo [return {x} ; set a {}"" ; stuff] bar} + subst {foo [return {x} ; set a {}"" ; stuff] bar} } -returnCodes error -result {extra characters after close-brace} test subst-8.8 {return in a subst, parse error} -body { subst {foo [return {x} ; set bar baz ; set a {}"" ; stuff] bar} @@ -278,21 +282,25 @@ test subst-13.1 {Bug 3081065} -setup { demo name2 } subst13.tcl] } -body { - interp create slave - slave eval [list source $script] - interp delete slave - interp create slave - slave eval { + interp create child + child eval [list source $script] + interp delete child + interp create child + child eval { set count 400 while {[incr count -1]} { lappend bloat [expr {rand()}] } } - slave eval [list source $script] - interp delete slave + child eval [list source $script] + interp delete child } -cleanup { removeFile subst13.tcl } +test subst-13.2 {Test for segfault} -body { + subst {[} +} -returnCodes error -result * -match glob + # cleanup ::tcltest::cleanupTests diff --git a/tests/switch.test b/tests/switch.test index a03948b..2fce108 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -169,7 +169,7 @@ test switch-4.1 {error in executed command} { "switch a a {error "Just a test"} default {subst 1}"}} test switch-4.2 {error: not enough args} -returnCodes error -body { switch -} -result {wrong # args: should be "switch ?-switch ...? string ?pattern body ...? ?default body?"} +} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"} test switch-4.3 {error: pattern with no body} -body { switch a b } -returnCodes error -result {extra switch pattern with no body} @@ -269,16 +269,16 @@ test switch-8.3 {weird body text, variable} { test switch-9.1 {empty pattern/body list} -returnCodes error -body { switch x -} -result {wrong # args: should be "switch ?-switch ...? string ?pattern body ...? ?default body?"} +} -result {wrong # args: should be "switch ?-option ...? string ?pattern body ...? ?default body?"} test switch-9.2 {unpaired pattern} -returnCodes error -body { switch -- x } -result {extra switch pattern with no body} test switch-9.3 {empty pattern/body list} -body { switch x {} -} -returnCodes error -result {wrong # args: should be "switch ?-switch ...? string {?pattern body ...? ?default body?}"} +} -returnCodes error -result {wrong # args: should be "switch ?-option ...? string {?pattern body ...? ?default body?}"} test switch-9.4 {empty pattern/body list} -body { switch -- x {} -} -returnCodes error -result {wrong # args: should be "switch ?-switch ...? string {?pattern body ...? ?default body?}"} +} -returnCodes error -result {wrong # args: should be "switch ?-option ...? string {?pattern body ...? ?default body?}"} test switch-9.5 {unpaired pattern} -body { switch x a {} b } -returnCodes error -result {extra switch pattern with no body} diff --git a/tests/tailcall.test b/tests/tailcall.test index 2d04f82..c738bb3 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -4,18 +4,18 @@ # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. # -# Copyright (c) 2008 by Miguel Sofer. +# Copyright © 2008 Miguel Sofer. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testnrelevels [llength [info commands testnrelevels]] @@ -28,9 +28,9 @@ if {[testConstraint testnrelevels]} { namespace eval testnre { # # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, - # cmdFrame level, callFrame level, tosPtr and callback depth + # cmdFrame level, callFrame level, tosPtr and callback depth # - variable last [testnrelevels] + variable last [testnrelevels] proc depthDiff {} { variable last set depth [testnrelevels] @@ -147,6 +147,36 @@ test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup rename b {} } -result {0 0 0 0 0 0} +test tailcall-0.5.1 {tailcall is constant space} -constraints testnrelevels -setup { + # + # This test is related to [bug d87cb182053fd79b3]: the fix to that bug was + # to remove a call to TclSkipTailcall, which caused a violation of the + # constant-space property of tailcall in that particular + # configuration. This test was added to detect that, and insure that the + # problem is fixed. + # + + proc b i { + if {$i == 1} { + depthDiff + } + if {[incr i] > 10} { + return [depthDiff] + } + tailcall dict b $i + } + set map0 [namespace ensemble configure dict -map] + set map $map0 + dict set map b b + namespace ensemble configure dict -map $map +} -body { + dict b 0 +} -cleanup { + rename b {} + namespace ensemble configure dict -map $map0 + unset map map0 +} -result {0 0 0 0 0 0} + test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels knownBug} -setup { # # This test fails because ns-unknown is not NR-enabled @@ -215,7 +245,7 @@ test tailcall-1 {tailcall} -body { } variable x *:: proc xset args {error ::xset} - list [::b::moo] | $x $a::x $b::x | $::b::y + list [::b::moo] | $x $a::x $b::x | $::b::y } -cleanup { unset x rename xset {} @@ -589,7 +619,7 @@ test tailcall-12.3a3 {[Bug 2695587]} -body { set x } -cleanup { unset x -} -result {0 1} +} -result {0 1} test tailcall-12.3b0 {[Bug 2695587]} -body { apply {{} { @@ -624,7 +654,7 @@ test tailcall-12.3b3 {[Bug 2695587]} -body { set x } -cleanup { unset x -} -result {0 1} +} -result {0 1} # MORE VARIANTS MISSING: bc'ed caught script vs (bc'ed, not-bc'ed) # catch. Actually superfluous now, as tailcall just returns TCL_RETURN so that @@ -658,6 +688,26 @@ if {[testConstraint testnrelevels]} { namespace delete testnre } +test tailcall-14.1 {in a deleted namespace} -body { + namespace eval ns { + proc p args { + tailcall [namespace current] $args + } + namespace delete [namespace current] + p + } +} -returnCodes 1 -result {namespace "::ns" not found} + +test tailcall-14.1-bc {{in a deleted namespace} {byte compiled}} -body { + namespace eval ns { + proc p args { + tailcall [namespace current] {*}$args + } + namespace delete [namespace current] + p + } +} -returnCodes 1 -result {namespace "::ns" not found} + # cleanup ::tcltest::cleanupTests diff --git a/tests/tcltest.test b/tests/tcltest.test index 86aca6f..3177580 100755 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -2,8 +2,8 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2000 by Ajuba Solutions +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2000 Ajuba Solutions # All rights reserved. # Note that there are several places where the value of @@ -13,13 +13,13 @@ # testing to run the test itself. Ditto on things like [verbose]. # # It would be better to have the -body of the tests run the tcltest -# commands in a slave interp so the [test] being tested would not +# commands in a child interp so the [test] being tested would not # interfere with the [test] doing the testing. # -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcltest::test { @@ -27,7 +27,7 @@ namespace eval ::tcltest::test { namespace import ::tcltest::* makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::test test a-1.0 {test a} { list 0 @@ -46,6 +46,7 @@ makeFile { cd [temporaryDirectory] testConstraint exec [llength [info commands exec]] + # test -help # Child processes because -help [exit]s. test tcltest-1.1 {tcltest -help} {exec} { @@ -62,11 +63,11 @@ test tcltest-1.3 {tcltest -h} {exec} { } {1 0} # -verbose, implicit & explicit testing of [verbose] -proc slave {msgVar args} { +proc child {msgVar args} { upvar 1 $msgVar msg interp create [namespace current]::i - # Fake the slave interp into dumping output to a file + # Fake the child interp into dumping output to a file i eval {namespace eval ::tcltest {}} i eval "set tcltest::outputChannel\ \[[list open [set of [makeFile {} output]] w]]" @@ -80,10 +81,7 @@ proc slave {msgVar args} { # Need to capture output in msg - set code [catch {i eval {source $argv0}} foo] -if $code { -#puts "$code: $foo\n$::errorInfo" -} + set code [catch {i eval {source $argv0}}] i eval {close $tcltest::outputChannel} interp delete [namespace current]::i set f [open $of] @@ -99,57 +97,55 @@ if $code { append msg \n$err } return $code - -# return [catch {uplevel 1 [linsert $args 0 exec [interpreter]]} msg] } -test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} { - set result [slave msg test.tcl] +test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} { + set result [child msg test.tcl] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} -test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} { - set result [slave msg test.tcl -verbose 'b'] +test tcltest-2.1 {tcltest -verbose 'b'} {unixOrWin} { + set result [child msg test.tcl -verbose 'b'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} -test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} { - set result [slave msg test.tcl -verbose 'p'] +test tcltest-2.2 {tcltest -verbose 'p'} {unixOrWin} { + set result [child msg test.tcl -verbose 'p'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 0 1} -test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} { - set result [slave msg test.tcl -verbose 's'] +test tcltest-2.3 {tcltest -verbose 's'} {unixOrWin} { + set result [child msg test.tcl -verbose 's'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 0 1 1} -test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} { - set result [slave msg test.tcl -verbose 'ps'] +test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrWin} { + set result [child msg test.tcl -verbose 'ps'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 1 1} -test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} { - set result [slave msg test.tcl -verbose 'psb'] +test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrWin} { + set result [child msg test.tcl -verbose 'psb'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 1 1} -test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} { - set result [slave msg test.tcl -verbose "pass skip body"] +test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} { + set result [child msg test.tcl -verbose "pass skip body"] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 1 1} test tcltest-2.6 {tcltest -verbose 't'} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose 't'] + set result [child msg test.tcl -verbose 't'] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} @@ -157,9 +153,9 @@ test tcltest-2.6 {tcltest -verbose 't'} { } test tcltest-2.6a {tcltest -verbose 'start'} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose start] + set result [child msg test.tcl -verbose start] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} @@ -174,38 +170,38 @@ test tcltest-2.7 {tcltest::verbose} { verbose foo set newVerbosity [verbose] verbose $oldVerbosity - list $currentVerbosity $newVerbosity + list $currentVerbosity $newVerbosity } -result {body {}} } test tcltest-2.8 {tcltest -verbose 'error'} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose error] + set result [child msg test.tcl -verbose error] list $result $msg } -result {errorInfo: foo.*errorCode: 9} -match regexp } # -match, [match] -test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} { - set result [slave msg test.tcl -match a* -verbose 'ps'] +test tcltest-3.1 {tcltest -match 'a*'} {unixOrWin} { + set result [child msg test.tcl -match a* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} -test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} { - set result [slave msg test.tcl -match b* -verbose 'ps'] +test tcltest-3.2 {tcltest -match 'b*'} {unixOrWin} { + set result [child msg test.tcl -match b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 1 0 1} -test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} { - set result [slave msg test.tcl -match c* -verbose 'ps'] +test tcltest-3.3 {tcltest -match 'c*'} {unixOrWin} { + set result [child msg test.tcl -match c* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg] } {0 0 0 1 1} -test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} { - set result [slave msg test.tcl -match {a* b*} -verbose 'ps'] +test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrWin} { + set result [child msg test.tcl -match {a* b*} -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 1 0 1} @@ -222,30 +218,30 @@ test tcltest-3.5 {tcltest::match} { } -result {foo bar} } - + # -skip, [skip] -test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} { - set result [slave msg test.tcl -skip a* -verbose 'ps'] +test tcltest-4.1 {tcltest -skip 'a*'} {unixOrWin} { + set result [child msg test.tcl -skip a* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg] } {0 0 1 1 1} -test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} { - set result [slave msg test.tcl -skip b* -verbose 'ps'] +test tcltest-4.2 {tcltest -skip 'b*'} {unixOrWin} { + set result [child msg test.tcl -skip b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 0 1 1} -test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} { - set result [slave msg test.tcl -skip c* -verbose 'ps'] +test tcltest-4.3 {tcltest -skip 'c*'} {unixOrWin} { + set result [child msg test.tcl -skip c* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 0 1} -test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} { - set result [slave msg test.tcl -skip {a* b*} -verbose 'ps'] +test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrWin} { + set result [child msg test.tcl -skip {a* b*} -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 0 1 1} -test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} { - set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] +test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrWin} { + set result [child msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} @@ -265,13 +261,13 @@ test tcltest-4.6 {tcltest::skip} { # -constraints, -limitconstraints, [testConstraint], # $constraintsSpecified, [limitConstraints] -test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} { - set result [slave msg test.tcl -constraints knownBug -verbose 'ps'] +test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrWin} { + set result [child msg test.tcl -constraints knownBug -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg] } {0 1 1 1 1} -test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} { - set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] +test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrWin} { + set result [child msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 0 0 1 1} @@ -304,8 +300,8 @@ test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} { # -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}} # -cleanup { # set ::tcltest::constraintsSpecified $constraintlist -# unset ::tcltest::testConstraints(tcltestFakeConstraint1) -# unset ::tcltest::testConstraints(tcltestFakeConstraint2) +# unset ::tcltest::testConstraints(tcltestFakeConstraint1) +# unset ::tcltest::testConstraints(tcltestFakeConstraint2) # } #} @@ -344,7 +340,7 @@ test tcltest-5.5 {InitConstraints: list of built-in constraints} \ # -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile] set printerror [makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::* puts [outputChannel] "a test" ::tcltest::PrintError "a really short string" @@ -353,36 +349,36 @@ set printerror [makeFile { ::tcltest::PrintError "a really really long string containing a \ \"Path/that/is/really/long/and/contains/no/spaces\"" ::tcltest::PrintError "a really really long string containing a \ - \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" + \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\"" exit } printerror.tcl] test tcltest-6.1 {tcltest -outfile, -errfile defaults} { - -constraints unixOrPc + -constraints unixOrWin -body { - slave msg $printerror + child msg $printerror return $msg } -result {a test.*a really} -match regexp } -test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} { - slave msg $printerror -outfile a.tmp +test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} { + child msg $printerror -outfile a.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ - $result1 $result2 [file exists a.tmp] [file delete a.tmp] + $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {0 1 0 1 1 {}} -test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} { - slave msg $printerror -errfile a.tmp +test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrWin unixExecs} { + child msg $printerror -errfile a.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {1 0 1 0 1 {}} -test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} { - slave msg $printerror -outfile a.tmp -errfile b.tmp +test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrWin unixExecs} { + child msg $printerror -outfile a.tmp -errfile b.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" b.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ @@ -418,7 +414,7 @@ test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} { set f2 [errorFile $ef] set f3 [errorChannel] set f4 [errorFile] - subst {$f0;$f1;$f2;$f3;$f4} + subst {$f0;$f1;$f2;$f3;$f4} } -result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile} -match regexp @@ -454,7 +450,7 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { set f2 [outputFile $ef] set f3 [outputChannel] set f4 [outputFile] - subst {$f0;$f1;$f2;$f3;$f4} + subst {$f0;$f1;$f2;$f3;$f4} } -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile} -match regexp @@ -467,26 +463,26 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { # -debug, [debug] # Must use child processes to test -debug because it always writes # messages to stdout, and we have no way to capture stdout of a -# slave interp -test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} { +# child interp +test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 0} msg regexp "Flags passed into tcltest" $msg } {0} -test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} { +test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg list [regexp userSpecifiedSkip $msg] \ [regexp "Flags passed into tcltest" $msg] } {1 0} -test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} { +test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 1 -match b*} msg list [regexp userSpecifiedNonMatch $msg] \ [regexp "Flags passed into tcltest" $msg] } {1 0} -test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} { +test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 2} msg list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] } {1 0} -test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} { +test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 3} msg list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] } {1 1} @@ -514,7 +510,7 @@ removeFile test.tcl # directory tests set a [makeFile { - package require tcltest + package require tcltest 2.5 tcltest::makeFile {} a.tmp puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]" exit @@ -526,18 +522,18 @@ set normaldirectory [makeDirectory normaldirectory] normalizePath normaldirectory # -tmpdir, [temporaryDirectory] -test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrPc -setup { +test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup { file delete -force thisdirectorydoesnotexist } -body { - slave msg $a -tmpdir thisdirectorydoesnotexist + child msg $a -tmpdir thisdirectorydoesnotexist file exists [file join thisdirectorydoesnotexist a.tmp] } -cleanup { file delete -force thisdirectorydoesnotexist } -result 1 test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} { - -constraints unixOrPc + -constraints unixOrWin -body { - slave msg $a -tmpdir $tdiaf + child msg $a -tmpdir $tdiaf return $msg } -result {*not a directory*} @@ -549,19 +545,20 @@ set notWriteableDir [file join [temporaryDirectory] notwriteable] makeDirectory notreadable makeDirectory notwriteable switch -- $::tcl_platform(platform) { - "unix" { - file attributes $notReadableDir -permissions 00333 - file attributes $notWriteableDir -permissions 00555 + unix { + file attributes $notReadableDir -permissions 0o333 + file attributes $notWriteableDir -permissions 0o555 } default { + # note in FAT/NTFS we won't be able to protect directory with read-only attribute... catch {file attributes $notWriteableDir -readonly 1} - catch {testchmod 000 $notWriteableDir} + catch {testchmod 0 $notWriteableDir} } } test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { -constraints {unix notRoot} -body { - slave msg $a -tmpdir $notReadableDir + child msg $a -tmpdir $notReadableDir return $msg } -result {*not readable*} @@ -570,22 +567,23 @@ test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { # This constraint doesn't go at the top of the file so that it doesn't # interfere with tcltest-5.5 testConstraint notFAT [expr { - ![string match "FAT*" [lindex [file system $notWriteableDir] 1]] + ![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]] + || $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]] }] -# FAT permissions are fairly hopeless; ignore this test if that FS is used +# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} { - -constraints {unixOrPc notRoot notFAT} + -constraints {unixOrWin notRoot notFAT} -body { - slave msg $a -tmpdir $notWriteableDir + child msg $a -tmpdir $notWriteableDir return $msg } -result {*not writeable*} -match glob } test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} { - -constraints unixOrPc + -constraints unixOrWin -body { - slave msg $a -tmpdir $normaldirectory + child msg $a -tmpdir $normaldirectory # The join is necessary because the message can be split on multiple # lines file exists [file join $normaldirectory a.tmp] @@ -626,21 +624,21 @@ test tcltest-8.6a {temporaryDirectory - test format 2} -setup { cd [temporaryDirectory] # -testdir, [testsDirectory] test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { - -constraints unixOrPc + -constraints unixOrWin -setup { file delete -force thisdirectorydoesnotexist } -body { - slave msg $a -testdir thisdirectorydoesnotexist + child msg $a -testdir thisdirectorydoesnotexist return $msg } -match glob -result {*does not exist*} } test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { - -constraints unixOrPc + -constraints unixOrWin -body { - slave msg $a -testdir $tdiaf + child msg $a -testdir $tdiaf return $msg } -match glob @@ -649,16 +647,16 @@ test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} { -constraints {unix notRoot} -body { - slave msg $a -testdir $notReadableDir + child msg $a -testdir $notReadableDir return $msg } -match glob -result {*not readable*} } test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} { - -constraints unixOrPc + -constraints unixOrWin -body { - slave msg $a -testdir $normaldirectory + child msg $a -testdir $normaldirectory # The join is necessary because the message can be split on multiple # lines list [string first "testdir: $normaldirectory" [join $msg]] \ @@ -716,38 +714,38 @@ test tcltest-8.60 {::workingDirectory} { # clean up from directory testing -switch $::tcl_platform(platform) { - "unix" { +switch -- $::tcl_platform(platform) { + unix { file attributes $notReadableDir -permissions 777 file attributes $notWriteableDir -permissions 777 } default { - catch {testchmod 777 $notWriteableDir} + catch {testchmod 0o777 $notWriteableDir} catch {file attributes $notWriteableDir -readonly 0} } } -file delete -force $notReadableDir $notWriteableDir +file delete -force -- $notReadableDir $notWriteableDir removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory # -file, -notfile, [matchFiles], [skipFiles] -test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup { +test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - slave msg [file join [testsDirectory] all.tcl] -file d*.test + child msg [file join [testsDirectory] all.tcl] -file d*.test return $msg } -cleanup { testsDirectory $old } -match regexp -result {dstring\.test} -test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup { +test tcltest-9.2 {-file d*.tcl} -constraints {unixOrWin} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - slave msg [file join [testsDirectory] all.tcl] \ + child msg [file join [testsDirectory] all.tcl] \ -file d*.test -notfile dstring* regexp {dstring\.test} $msg } -cleanup { @@ -763,7 +761,7 @@ test tcltest-9.3 {matchFiles} { set new [matchFiles] matchFiles $old list $current $new - } + } -result {foo bar} } @@ -776,7 +774,7 @@ test tcltest-9.4 {skipFiles} { set new [skipFiles] skipFiles $old list $current $new - } + } -result {foo bar} } @@ -786,7 +784,7 @@ test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { makeFile {} fee $d file copy [file join [file dirname [info script]] all.tcl] $d } -body { - slave msg [file join [temporaryDirectory] all.tcl] -file f* + child msg [file join [temporaryDirectory] all.tcl] -file f* regexp {exiting with errors:} $msg } -cleanup { file delete [file join $d all.tcl] @@ -797,7 +795,7 @@ test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { # -preservecore, [preserveCore] set mc [makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::test test makecore {make a core file} { set f [open core w] @@ -808,24 +806,24 @@ set mc [makeFile { } makecore.tcl] cd [temporaryDirectory] -test tcltest-10.1 {-preservecore 0} {unixOrPc} { - slave msg $mc -preservecore 0 +test tcltest-10.1 {-preservecore 0} {unixOrWin} { + child msg $mc -preservecore 0 file delete core regexp "Core file produced" $msg } {0} -test tcltest-10.2 {-preservecore 1} {unixOrPc} { - slave msg $mc -preservecore 1 +test tcltest-10.2 {-preservecore 1} {unixOrWin} { + child msg $mc -preservecore 1 file delete core regexp "Core file produced" $msg } {1} -test tcltest-10.3 {-preservecore 2} {unixOrPc} { - slave msg $mc -preservecore 2 +test tcltest-10.3 {-preservecore 2} {unixOrWin} { + child msg $mc -preservecore 2 file delete core list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] } {1 1 1 {}} -test tcltest-10.4 {-preservecore 3} {unixOrPc} { - slave msg $mc -preservecore 3 +test tcltest-10.4 {-preservecore 3} {unixOrWin} { + child msg $mc -preservecore 3 file delete core list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] @@ -848,20 +846,20 @@ removeFile makecore.tcl # -load, -loadfile, [loadScript], [loadFile] set contents { - package require tcltest + package require tcltest 2.5 namespace import tcltest::* puts [outputChannel] $::tcltest::loadScript exit } set loadfile [makeFile $contents load.tcl] -test tcltest-12.1 {-load xxx} {unixOrPc} { - slave msg $loadfile -load xxx +test tcltest-12.1 {-load xxx} {unixOrWin} { + child msg $loadfile -load xxx return $msg } {xxx} # Using child process because of -debug usage. -test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} { +test tcltest-12.2 {-loadfile load.tcl} {unixOrWin} { catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg list \ [regexp {tcltest} [join [list $msg] [split $msg \n]]] \ @@ -910,7 +908,9 @@ removeFile load.tcl # [interpreter] test tcltest-13.1 {interpreter} { + -constraints notValgrind -setup { + #to do: Why is $::tcltest::tcltest being saved and restored here? set old $::tcltest::tcltest set ::tcltest::tcltest tcltest } @@ -922,6 +922,11 @@ test tcltest-13.1 {interpreter} { } -result {tcltest tclsh tclsh} -cleanup { + # writing ::tcltest::tcltest triggers a trace that sets up the stdio + # constraint, which involves a call to [exec] that might fail after + # "fork" and before "exec", in which case the forked process will not + # have a chance to clean itself up before exiting, which causes + # valgrind to issue numerous "still reachable" reports. set ::tcltest::tcltest $old } } @@ -937,7 +942,7 @@ makeFile { } single2.test $spd set allfile [makeFile { - package require tcltest + package require tcltest 2.5 namespace import tcltest::* testsDirectory [file join [temporaryDirectory] singleprocdir] runAllTests @@ -945,9 +950,9 @@ set allfile [makeFile { cd [workingDirectory] test tcltest-14.1 {-singleproc - single process} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] + child msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] return $msg } -result {Test file error: can't unset .foo.: no such variable} @@ -955,9 +960,9 @@ test tcltest-14.1 {-singleproc - single process} { } test tcltest-14.2 {-singleproc - multiple process} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] + child msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] return $msg } -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0} @@ -994,34 +999,34 @@ set dtd1 [makeDirectory dirtestdir2.1 $dtd] set dtd2 [makeDirectory dirtestdir2.2 $dtd] set dtd3 [makeDirectory dirtestdir2.3 $dtd] makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir] runAllTests } all.tcl $dtd makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1] runAllTests } all.tcl $dtd1 makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2] runAllTests } all.tcl $dtd2 makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3] runAllTests } all.tcl $dtd3 test tcltest-15.1 {basic directory walking} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -tmpdir [temporaryDirectory]] == 1} { error $msg @@ -1033,9 +1038,9 @@ test tcltest-15.1 {basic directory walking} { } test tcltest-15.2 {-asidefromdir} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -asidefromdir dirtestdir2.3 \ -tmpdir [temporaryDirectory]] == 1} { @@ -1051,9 +1056,9 @@ Error: No test files remain after applying your match and skip patterns!$} } test tcltest-15.3 {-relateddir, non-existent dir} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir [file join [temporaryDirectory] dirtestdir0] \ -tmpdir [temporaryDirectory]] == 1} { @@ -1066,9 +1071,9 @@ test tcltest-15.3 {-relateddir, non-existent dir} { } test tcltest-15.4 {-relateddir, subdir} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} { error $msg @@ -1079,9 +1084,9 @@ test tcltest-15.4 {-relateddir, subdir} { -result {Tests located in:.*dirtestdir2.[^23]} } test tcltest-15.5 {-relateddir, -asidefromdir} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir "dirtestdir2.1 dirtestdir2.2" \ -asidefromdir dirtestdir2.2 \ @@ -1142,25 +1147,25 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { # set this to { } instead of just {} to get around quirk in # Windows env handling that removes empty elements from env array. set ::env(TCLTEST_OPTIONS) { } - interp create slave1 - slave1 eval [list set argv {-debug 2}] - slave1 alias puts puts - interp create slave2 - slave2 alias puts puts + interp create child1 + child1 eval [list set argv {-debug 2}] + child1 alias puts puts + interp create child2 + child2 alias puts puts } -cleanup { - interp delete slave2 - interp delete slave1 - if {$oldoptions == "none"} { - unset ::env(TCLTEST_OPTIONS) + interp delete child2 + interp delete child1 + if {$oldoptions eq "none"} { + unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } } -body { - slave1 eval [package ifneeded tcltest [package provide tcltest]] - slave1 eval tcltest::debug + child1 eval [package ifneeded tcltest [package provide tcltest]] + child1 eval tcltest::debug set ::env(TCLTEST_OPTIONS) "-debug 3" - slave2 eval [package ifneeded tcltest [package provide tcltest]] - slave2 eval tcltest::debug + child2 eval [package ifneeded tcltest [package provide tcltest]] + child2 eval tcltest::debug } -result {^3$} -match regexp -output\ {tcltest::debug\s+= 2.*tcltest::debug\s+= 3} @@ -1168,8 +1173,8 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { cd [temporaryDirectory] # PrintError -test tcltest-20.1 {PrintError} {unixOrPc} { - set result [slave msg $printerror] +test tcltest-20.1 {PrintError} {unixOrWin} { + set result [child msg $printerror] list $result [regexp "Error: a really short string" $msg] \ [regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \ [regexp " \"Really" $msg] [regexp Problem $msg] @@ -1202,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} { } {1} } -returnCodes 1 - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } test tcltest-21.3 {test command with setup} { @@ -1265,7 +1270,7 @@ test tcltest-21.6 {test command - setup occurs before cleanup & before script} { } set foo 1 set expected 2 - } + } -body { incr foo set foo @@ -1295,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} { } } -returnCodes 1 - -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } # alternate test command format (these are the same as 21.1-21.6, with the @@ -1315,7 +1320,7 @@ test tcltest-21.8 {force a test command failure} \ } \ -returnCodes 1 \ -cleanup {set ::tcltest::currentFailure $fail} \ - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} test tcltest-21.9 {test command with setup} \ -setup {set foo 1} \ @@ -1380,7 +1385,7 @@ test tcltest-21.12 { set atd [makeDirectory alltestdir] makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] alltestdir] runAllTests @@ -1392,7 +1397,7 @@ makeFile { error "throw an error" } error.test $atd makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* test foo-1.1 {foo} { -body { return 1 } @@ -1402,9 +1407,9 @@ makeFile { } test.test $atd # Must use a child process because stdout/stderr parsing can't be -# duplicated in slave interp. +# duplicated in child interp. test tcltest-22.1 {runAllTests} { - -constraints {unixOrPc} + -constraints {unixOrWin} -body { exec [interpreter] \ [file join $atd all.tcl] \ @@ -1429,7 +1434,7 @@ test tcltest-23.1 {makeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {1 1} } @@ -1439,7 +1444,7 @@ test tcltest-23.2 {removeFile} { file mkdir $mfdir makeFile {} t1.tmp makeFile {} et1.tmp $mfdir - if {![file exists [file join [temporaryDirectory] t1.tmp]] || \ + if {![file exists [file join [temporaryDirectory] t1.tmp]] || \ ![file exists [file join $mfdir et1.tmp]]} { error "file creation didn't work" } @@ -1452,7 +1457,7 @@ test tcltest-23.2 {removeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {0 0} } @@ -1791,7 +1796,7 @@ test tcltest-25.3 { test tcltest-26.1 {Bug/RFE 1017151} -setup { makeFile { - package require tcltest + package require tcltest 2.5 set ::errorInfo "Should never see this" tcltest::test tcltest-26.1.0 { no errorInfo when only return code mismatch @@ -1801,7 +1806,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup { tcltest::cleanupTests } test.tcl } -body { - slave msg [file join [temporaryDirectory] test.tcl] + child msg [file join [temporaryDirectory] test.tcl] return $msg } -cleanup { removeFile test.tcl @@ -1811,7 +1816,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup { test tcltest-26.2 {Bug/RFE 1017151} -setup { makeFile { - package require tcltest + package require tcltest 2.5 set ::errorInfo "Should never see this" tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body { error "body error" @@ -1821,7 +1826,7 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup { tcltest::cleanupTests } test.tcl } -body { - slave msg [file join [temporaryDirectory] test.tcl] + child msg [file join [temporaryDirectory] test.tcl] return $msg } -cleanup { removeFile test.tcl @@ -1829,9 +1834,13 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup { ---- errorInfo: body error * ---- errorInfo(cleanup): cleanup error*} - + cleanupTests } namespace delete ::tcltest::test return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl new file mode 100644 index 0000000..193ba0a --- /dev/null +++ b/tests/tcltests.tcl @@ -0,0 +1,46 @@ +#! /usr/bin/env tclsh + +package require tcltest 2.5 +namespace import ::tcltest::* +testConstraint exec [llength [info commands exec]] +testConstraint fcopy [llength [info commands fcopy]] +testConstraint fileevent [llength [info commands fileevent]] +testConstraint thread [ + expr {0 == [catch {package require Thread 2.7-}]}] +testConstraint notValgrind [expr {![testConstraint valgrind]}] + + +namespace eval ::tcltests { + + + proc init {} { + if {[namespace which ::tcl::file::tempdir] eq {}} { + interp alias {} [namespace current]::tempdir {} [ + namespace current]::tempdir_alternate + } else { + interp alias {} [namespace current]::tempdir {} ::tcl::file::tempdir + } + } + + + proc tempdir_alternate {} { + close [file tempfile tempfile] + set tmpdir [file dirname $tempfile] + set execname [info nameofexecutable] + regsub -all {[^[:alpha:][:digit:]]} $execname _ execname + for {set i 0} {$i < 10000} {incr i} { + set time [clock milliseconds] + set name $tmpdir/${execname}_${time}_$i + if {![file exists $name]} { + file mkdir $name + return $name + } + } + error [list {could not create temporary directory}] + } + + init + + package provide tcltests 0.1 +} + diff --git a/tests/thread.test b/tests/thread.test index f2735da..16e60ed 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -4,32 +4,29 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2006-2008 Joe Mistachkin. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } +# when thread::release is used, -wait is passed in order allow the thread to +# be fully finalized, which avoids valgrind "still reachable" reports. + ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] +package require tcltests # Some tests require the testthread command -testConstraint testthread [expr {[info commands testthread] != {}}] - -# Some tests require the Thread package - -testConstraint thread [expr {0 == [catch {package require Thread 2.7}]}] +testConstraint testthread [expr {[info commands testthread] ne {}}] -# Some tests may not work under valgrind - -testConstraint notValgrind [expr {![testConstraint valgrind]}] set threadSuperKillScript { rename catch "" @@ -42,11 +39,11 @@ set threadSuperKillScript { proc getThreadErrorFromInfo { info } { set list [split $info \n] set idx [lsearch -glob $list "*eval*unwound*"] - if {$idx != -1} then { + if {$idx >= 0} then { return [lindex $list $idx] } set idx [lsearch -glob $list "*eval*canceled*"] - if {$idx != -1} then { + if {$idx >= 0} then { return [lindex $list $idx] } return ""; # some other error we do not care about. @@ -72,6 +69,17 @@ proc ThreadError {id info} { set threadSawError($id) true; # signal main thread to exit [vwait]. } +proc threadSuperKill id { + variable threadSuperKillScript + try { + thread::send $id $::threadSuperKillScript + } on error {tres topts} { + if {$tres ne {target thread died}} { + return -options $topts $tres + } + } +} + if {[testConstraint thread]} { thread::errorproc ThreadError } @@ -79,33 +87,11 @@ if {[testConstraint thread]} { if {[testConstraint testthread]} { proc drainEventQueue {} { while {[set x [testthread event]]} { - puts "WARNING: drained $x event(s) on main thread" + #puts "WARNING: drained $x event(s) on main thread" } } testthread errorproc ThreadError - - set mainThread [testthread id] - - proc ThreadNullError {id info} { - # ignore - } - - proc threadReap {} { - testthread errorproc ThreadNullError - while {[llength [testthread names]] > 1} { - foreach tid [testthread names] { - if {$tid != [testthread id]} { - catch { - testthread send -async $tid {testthread exit} - } - } - } - after 1 - } - testthread errorproc ThreadError - return [llength [testthread names]] - } } # Some tests require manual draining of the event queue @@ -118,22 +104,22 @@ test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} { test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} { set serverthread [thread::create -preserved] set numthreads [llength [thread::names]] - thread::release $serverthread + thread::release -wait $serverthread set numthreads -} {2} +} 2 test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} { thread::create {set x 5} foreach try {0 1 2 4 5 6} { - # Try various ways to yield - update - after 10 - set l [llength [thread::names]] - if {$l == 1} { - break - } + # Try various ways to yield + update + after 10 + set l [llength [thread::names]] + if {$l == 1} { + break + } } set l -} {1} +} 1 test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { thread::create {{*}{}} update @@ -143,13 +129,13 @@ test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} { set serverthread [thread::create -preserved] set five [thread::send $serverthread {set x 5}] - thread::release $serverthread + thread::release -wait $serverthread set five } 5 test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} { set serverthread [thread::create -preserved {set z 5 ; thread::wait}] set five [thread::send $serverthread {set z}] - thread::release $serverthread + thread::release -wait $serverthread set five } 5 @@ -181,7 +167,7 @@ test thread-3.1 {TclThreadList} {thread} { set l2 [thread::names] set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]] foreach t $l1 { - thread::release $t + thread::release -wait $t } list $len $c } {1 0} @@ -586,7 +572,7 @@ test thread-7.14 {cancel: vwait} -constraints {thread drainEventQueue} -setup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ - [string map [list %ID [thread::id]] { + [string map [list %ID% [thread::id]] { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). @@ -638,7 +624,7 @@ test thread-7.16 {cancel: expr} -constraints {thread drainEventQueue} -setup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ - [string map [list %ID [thread::id]] { + [string map [list %ID% [thread::id]] { set i [interp create] $i eval "package require -exact Thread [package present Thread]" $i eval { @@ -819,7 +805,7 @@ test thread-7.21 {cancel: subst -unwind} -constraints {thread drainEventQueue} - } -cleanup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -result {{} 1 1 {eval unwound}} -test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -setup { +test thread-7.22 {cancel: child interp} -constraints {thread drainEventQueue} -setup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ @@ -849,7 +835,7 @@ test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -s } -cleanup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -result {{} 1 1 {eval canceled}} -test thread-7.23 {cancel: slave interp -unwind} -constraints {thread drainEventQueue} -setup { +test thread-7.23 {cancel: child interp -unwind} -constraints {thread drainEventQueue} -setup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ @@ -909,7 +895,7 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread drainE # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::cancel $serverthread] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -951,7 +937,7 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::cancel $serverthread] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1051,7 +1037,7 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {interp cancel}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1093,7 +1079,7 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {interp cancel}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1133,7 +1119,7 @@ test thread-7.30 {cancel: send async thread cancel nested catch inside pure byte # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {thread::cancel [thread::id]}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1175,7 +1161,7 @@ test thread-7.31 {cancel: send async thread cancel nested catch pure inside-comm # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {thread::cancel [thread::id]}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1394,7 +1380,7 @@ test thread-7.37 {cancel: send async thread cancel nested catch inside pure insi unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ - [string map [list %ID [thread::id]] { + [string map [list %ID% [thread::id]] { proc foobar {} { set catch catch set while while @@ -1434,6 +1420,32 @@ test thread-7.37 {cancel: send async thread cancel nested catch inside pure insi unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -result {{} 1 1 {eval unwound}} +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 diff --git a/tests/timer.test b/tests/timer.test index ab6efc9..1ad17ae 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -7,14 +7,14 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -205,11 +205,11 @@ test timer-6.4 {Tcl_AfterCmd procedure, ms argument} { } {before after} test timer-6.5 {Tcl_AfterCmd procedure, ms argument} { set x before - after 300 set x after + after 400 set x after after 200 update set y $x - after 200 + after 400 update list $y $x } {before after} @@ -568,15 +568,15 @@ test timer-9.1 {AfterCleanupProc procedure} -setup { } -result {before after2 after4} test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup { - interp create slave - slave eval namespace export after - slave eval namespace eval foo namespace import ::after + interp create child + child eval namespace export after + child eval namespace eval foo namespace import ::after } -body { - slave eval foo::after 1 - slave eval namespace origin foo::after + child eval foo::after 1 + child eval namespace origin foo::after } -cleanup { # Bug will cause crash here; would cause failure otherwise - interp delete slave + interp delete child } -result ::after test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} -body { diff --git a/tests/tm.test b/tests/tm.test index 149a65d..4dea27d 100644 --- a/tests/tm.test +++ b/tests/tm.test @@ -3,12 +3,11 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 2004 by Donal K. Fellows. +# Copyright © 2004 Donal K. Fellows. # All rights reserved. -package require Tcl 8.5 if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -200,7 +199,7 @@ test tm-3.11 {tm: module path management, remove ignores unknown path} -setup { proc genpaths {base} { # Normalizing picks up drive letters on windows [Bug 1053568] set base [file normalize $base] - foreach {major minor} [split [info tclversion] .] break + regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor set results {} set base [file join $base tcl$major] lappend results [file join $base site-tcl] diff --git a/tests/trace.test b/tests/trace.test index 0f48dcf..3f30048 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -4,20 +4,20 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testevalobjv [llength [info commands testevalobjv]] @@ -32,15 +32,15 @@ proc getbytes {} { proc traceScalar {name1 name2 op} { global info - set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg] + set info [list $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg] } proc traceScalarAppend {name1 name2 op} { global info - lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg + lappend info $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg } proc traceArray {name1 name2 op} { global info - set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg] + set info [list $name1 $name2 $op [catch {uplevel 1 set [set name1]($name2)} msg] $msg] } proc traceArray2 {name1 name2 op} { global info @@ -62,7 +62,7 @@ proc traceCheck {cmd args} { set info [list [catch $cmd msg] $msg] } proc traceCrtElement {value name1 name2 op} { - uplevel set ${name1}($name2) $value + uplevel 1 set ${name1}($name2) $value } proc traceCommand {oldName newName op} { global info @@ -72,10 +72,10 @@ proc traceCommand {oldName newName op} { test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} { # You may need Purify or Electric Fence to reliably # see this one fail. - catch {unset z} + unset -nocomplain z trace add variable z array {set z(foo) 1 ;#} set res "names: [array names z]" - catch {unset ::z} + unset -nocomplain ::z trace variable ::z w {unset ::z; error "memory corruption";#} list [catch {set ::z 1} msg] $msg } {1 {can't set "::z": memory corruption}} @@ -83,40 +83,40 @@ test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} { # Read-tracing on variables test trace-1.1 {trace variable reads} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceScalar list [catch {set x} msg] $msg $info } {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}} test trace-1.2 {trace variable reads} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x read traceScalar list [catch {set x} msg] $msg $info } {0 123 {x {} read 0 123}} test trace-1.3 {trace variable reads} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceScalar set x 123 set info } {} test trace-1.4 {trace array element reads} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such element in array} {x 2 read 1 {can't read "x(2)": no such element in array}}} test trace-1.5 {trace array element reads} { - catch {unset x} + unset -nocomplain x set x(2) zzz set info {} trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 read 0 zzz}} test trace-1.6 {trace array element reads} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceArray2 proc p {} { @@ -127,7 +127,7 @@ test trace-1.6 {trace array element reads} { list [catch {p} msg] $msg $info } {0 willi {x 2 read}} test trace-1.7 {trace array element reads, create element undefined if nonexistant} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read q proc q {name1 name2 op} { @@ -144,20 +144,20 @@ test trace-1.7 {trace array element reads, create element undefined if nonexista list [catch {p} msg] $msg $info } {0 wolf {x Y read}} test trace-1.8 {trace reads on whole arrays} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such variable} {}} test trace-1.9 {trace reads on whole arrays} { - catch {unset x} + unset -nocomplain x set x(2) zzz set info {} trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 read 0 zzz}} test trace-1.10 {trace variable reads} { - catch {unset x} + unset -nocomplain x set x 444 set info {} trace add variable x read traceScalar @@ -165,59 +165,59 @@ test trace-1.10 {trace variable reads} { set info } {} test trace-1.11 {read traces that modify the array structure} { - catch {unset x} - set x(bar) 0 - trace variable x r {set x(foo) 1 ;#} - trace variable x r {unset -nocomplain x(bar) ;#} + unset -nocomplain x + set x(bar) 0 + trace variable x r {set x(foo) 1 ;#} + trace variable x r {unset -nocomplain x(bar) ;#} array get x } {} test trace-1.12 {read traces that modify the array structure} { - catch {unset x} - set x(bar) 0 - trace variable x r {unset -nocomplain x(bar) ;#} - trace variable x r {set x(foo) 1 ;#} + unset -nocomplain x + set x(bar) 0 + trace variable x r {unset -nocomplain x(bar) ;#} + trace variable x r {set x(foo) 1 ;#} array get x } {} test trace-1.13 {read traces that modify the array structure} { - catch {unset x} - set x(bar) 0 - trace variable x r {set x(foo) 1 ;#} - trace variable x r {unset -nocomplain x;#} + unset -nocomplain x + set x(bar) 0 + trace variable x r {set x(foo) 1 ;#} + trace variable x r {unset -nocomplain x;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} test trace-1.14 {read traces that modify the array structure} { - catch {unset x} - set x(bar) 0 - trace variable x r {unset -nocomplain x;#} - trace variable x r {set x(foo) 1 ;#} + unset -nocomplain x + set x(bar) 0 + trace variable x r {unset -nocomplain x;#} + trace variable x r {set x(foo) 1 ;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} # Basic write-tracing on variables test trace-2.1 {trace variable writes} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceScalar set x 123 set info } {x {} write 0 123} test trace-2.2 {trace writes to array elements} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(33) write traceArray set x(33) 444 set info } {x 33 write 0 444} test trace-2.3 {trace writes on whole arrays} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceArray set x(abc) qq set info } {x abc write 0 qq} test trace-2.4 {trace variable writes} { - catch {unset x} + unset -nocomplain x set x 1234 set info {} trace add variable x write traceScalar @@ -225,7 +225,7 @@ test trace-2.4 {trace variable writes} { set info } {} test trace-2.5 {trace variable writes} { - catch {unset x} + unset -nocomplain x set x 1234 set info {} trace add variable x write traceScalar @@ -238,7 +238,7 @@ test trace-2.6 {trace variable writes on compiled local} { # arrays [Bug 1770591]. The corresponding function for read traces is # already indirectly tested in trace-1.7 # - catch {unset x} + unset -nocomplain x set info {} proc p {} { trace add variable x write traceArray @@ -267,7 +267,7 @@ test trace-2.7 {trace variable writes on errorInfo} -body { # trace: after appending all arguments to the list. test trace-3.1 {trace variable read-modify-writes} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read traceScalarAppend append x 123 @@ -276,7 +276,7 @@ test trace-3.1 {trace variable read-modify-writes} { set info } {x {} read 0 123456} test trace-3.2 {trace variable read-modify-writes} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x {read write} traceScalarAppend append x 123 @@ -287,14 +287,14 @@ test trace-3.2 {trace variable read-modify-writes} { # Basic unset-tracing on variables test trace-4.1 {trace variable unsets} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x unset traceScalar - catch {unset x} + unset -nocomplain x set info } {x {} unset 1 {can't read "x": no such variable}} test trace-4.2 {variable mustn't exist during unset trace} { - catch {unset x} + unset -nocomplain x set x 1234 set info {} trace add variable x unset traceScalar @@ -302,7 +302,7 @@ test trace-4.2 {variable mustn't exist during unset trace} { set info } {x {} unset 1 {can't read "x": no such variable}} test trace-4.3 {unset traces mustn't be called during reads and writes} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x unset traceScalar set x 44 @@ -310,15 +310,15 @@ test trace-4.3 {unset traces mustn't be called during reads and writes} { set info } {} test trace-4.4 {trace unsets on array elements} { - catch {unset x} + unset -nocomplain x set x(0) 18 set info {} trace add variable x(1) unset traceArray - catch {unset x(1)} + unset -nocomplain x(1) set info } {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.5 {trace unsets on array elements} { - catch {unset x} + unset -nocomplain x set x(1) 18 set info {} trace add variable x(1) unset traceArray @@ -326,7 +326,7 @@ test trace-4.5 {trace unsets on array elements} { set info } {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.6 {trace unsets on array elements} { - catch {unset x} + unset -nocomplain x set x(1) 18 set info {} trace add variable x(1) unset traceArray @@ -334,15 +334,15 @@ test trace-4.6 {trace unsets on array elements} { set info } {x 1 unset 1 {can't read "x(1)": no such variable}} test trace-4.7 {trace unsets on whole arrays} { - catch {unset x} + unset -nocomplain x set x(1) 18 set info {} trace add variable x unset traceProc - catch {unset x(0)} + unset -nocomplain x(0) set info } {} test trace-4.8 {trace unsets on whole arrays} { - catch {unset x} + unset -nocomplain x set x(1) 18 set x(2) 144 set x(3) 14 @@ -352,7 +352,7 @@ test trace-4.8 {trace unsets on whole arrays} { set info } {x 1 unset} test trace-4.9 {trace unsets on whole arrays} { - catch {unset x} + unset -nocomplain x set x(1) 18 set x(2) 144 set x(3) 14 @@ -364,7 +364,7 @@ test trace-4.9 {trace unsets on whole arrays} { # Array tracing on variables test trace-5.1 {array traces fire on accesses via [array]} { - catch {unset x} + unset -nocomplain x set x(b) 2 trace add variable x array traceArray2 set ::info {} @@ -372,7 +372,7 @@ test trace-5.1 {array traces fire on accesses via [array]} { set ::info } {x {} array} test trace-5.2 {array traces do not fire on normal accesses} { - catch {unset x} + unset -nocomplain x set x(b) 2 trace add variable x array traceArray2 set ::info {} @@ -381,7 +381,7 @@ test trace-5.2 {array traces do not fire on normal accesses} { set ::info } {} test trace-5.3 {array traces do not outlive variable} { - catch {unset x} + unset -nocomplain x trace add variable x array traceArray2 set ::info {} set x(a) 1 @@ -390,19 +390,19 @@ test trace-5.3 {array traces do not outlive variable} { set ::info } {} test trace-5.4 {array traces properly listed in trace information} { - catch {unset x} + unset -nocomplain x trace add variable x array traceArray2 set result [trace info variable x] set result } [list [list array traceArray2]] test trace-5.5 {array traces properly listed in trace information} { - catch {unset x} + unset -nocomplain x trace variable x a traceArray2 set result [trace vinfo x] set result } [list [list a traceArray2]] test trace-5.6 {array traces don't fire on scalar variables} { - catch {unset x} + unset -nocomplain x set x foo trace add variable x array traceArray2 set ::info {} @@ -410,22 +410,22 @@ test trace-5.6 {array traces don't fire on scalar variables} { set ::info } {} test trace-5.7 {array traces fire for undefined variables} { - catch {unset x} + unset -nocomplain x trace add variable x array traceArray2 set ::info {} array set x {a 1} set ::info } {x {} array} test trace-5.8 {array traces fire for undefined variables} { - catch {unset x} + unset -nocomplain x trace add variable x array {set x(foo) 1 ;#} set res "names: [array names x]" } {names: foo} - + # Trace multiple trace types at once. test trace-6.1 {multiple ops traced at once} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x {read write unset} traceProc catch {set x} @@ -436,7 +436,7 @@ test trace-6.1 {multiple ops traced at once} { set info } {x {} read x {} write x {} read x {} write x {} unset} test trace-6.2 {multiple ops traced on array element} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(0) {read write unset} traceProc catch {set x(0)} @@ -448,7 +448,7 @@ test trace-6.2 {multiple ops traced on array element} { set info } {x 0 read x 0 write x 0 read x 0 write x 0 unset} test trace-6.3 {multiple ops traced on whole array} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x {read write unset} traceProc catch {set x(0)} @@ -463,7 +463,7 @@ test trace-6.3 {multiple ops traced on whole array} { # Check order of invocation of traces test trace-7.1 {order of invocation of traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x read "traceTag 1" trace add variable x read "traceTag 2" @@ -474,7 +474,7 @@ test trace-7.1 {order of invocation of traces} { set info } {3 2 1 3 2 1} test trace-7.2 {order of invocation of traces} { - catch {unset x} + unset -nocomplain x set x(0) 44 set info {} trace add variable x(0) read "traceTag 1" @@ -484,7 +484,7 @@ test trace-7.2 {order of invocation of traces} { set info } {3 2 1} test trace-7.3 {order of invocation of traces} { - catch {unset x} + unset -nocomplain x set x(0) 44 set info {} trace add variable x(0) read "traceTag 1" @@ -500,7 +500,7 @@ test trace-7.3 {order of invocation of traces} { # Check effects of errors in trace procedures test trace-8.1 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x read "traceTag 1" @@ -508,7 +508,7 @@ test trace-8.1 {error returns from traces} { list [catch {set x} msg] $msg $info } {1 {can't read "x": trace returned error} {}} test trace-8.2 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x write "traceTag 1" @@ -516,14 +516,14 @@ test trace-8.2 {error returns from traces} { list [catch {set x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-8.3 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x write traceError list [catch {append x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-8.4 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 set info {} trace add variable x unset "traceTag 1" @@ -531,7 +531,7 @@ test trace-8.4 {error returns from traces} { list [catch {unset x} msg] $msg $info } {0 {} 1} test trace-8.5 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x(0) 123 set info {} trace add variable x(0) read "traceTag 1" @@ -541,7 +541,7 @@ test trace-8.5 {error returns from traces} { list [catch {set x(0)} msg] $msg $info } {1 {can't read "x(0)": trace returned error} 3} test trace-8.6 {error returns from traces} { - catch {unset x} + unset -nocomplain x set x 123 trace add variable x unset traceError list [catch {unset x} msg] $msg @@ -550,7 +550,7 @@ test trace-8.7 {error returns from traces} { # This test just makes sure that the memory for the error message # gets deallocated correctly when the trace is invoked again or # when the trace is deleted. - catch {unset x} + unset -nocomplain x set x 123 trace add variable x read traceError catch {set x} @@ -571,7 +571,7 @@ test trace-8.8 {error returns from traces} { trace add variable ::x write [list foo $::x] error "foo" } - catch {unset ::x ::y} + unset -nocomplain ::x ::y set x junk trace add variable ::x write [list foo $x] for {set y 0} {$y<100} {incr y} { @@ -585,31 +585,31 @@ test trace-8.8 {error returns from traces} { # a new copy of the variables. test trace-9.1 {be sure variable is unset before trace is called} { - catch {unset x} + unset -nocomplain x set x 33 set info {} - trace add variable x unset {traceCheck {uplevel set x}} + trace add variable x unset {traceCheck {uplevel 1 set x}} unset x set info } {1 {can't read "x": no such variable}} test trace-9.2 {be sure variable is unset before trace is called} { - catch {unset x} + unset -nocomplain x set x 33 set info {} - trace add variable x unset {traceCheck {uplevel set x 22}} + trace add variable x unset {traceCheck {uplevel 1 set x 22}} unset x concat $info [list [catch {set x} msg] $msg] } {0 22 0 22} test trace-9.3 {be sure traces are cleared before unset trace called} { - catch {unset x} + unset -nocomplain x set x 33 set info {} - trace add variable x unset {traceCheck {uplevel trace info variable x}} + trace add variable x unset {traceCheck {uplevel 1 trace info variable x}} unset x set info } {0 {}} test trace-9.4 {set new trace during unset trace} { - catch {unset x} + unset -nocomplain x set x 33 set info {} trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}} @@ -618,23 +618,23 @@ test trace-9.4 {set new trace during unset trace} { } {0 {} {unset traceProc}} test trace-10.1 {make sure array elements are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} - trace add variable x(0) unset {traceCheck {uplevel set x(0)}} + trace add variable x(0) unset {traceCheck {uplevel 1 set x(0)}} unset x(0) set info } {1 {can't read "x(0)": no such element in array}} test trace-10.2 {make sure array elements are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} - trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}} + trace add variable x(0) unset {traceCheck {uplevel 1 set x(0) zzz}} unset x(0) concat $info [list [catch {set x(0)} msg] $msg] } {0 zzz 0 zzz} test trace-10.3 {array elements are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}} @@ -642,49 +642,49 @@ test trace-10.3 {array elements are unset before traces are called} { set info } {0 {}} test trace-10.4 {set new array element trace during unset trace} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} - trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}} - catch {unset x(0)} + trace add variable x(0) unset {traceCheck {uplevel 1 {trace add variable x(0) read {}}}} + unset -nocomplain x(0) concat $info [trace info variable x(0)] } {0 {} {read {}}} test trace-11.1 {make sure arrays are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(0) 33 set info {} - trace add variable x unset {traceCheck {uplevel set x(0)}} + trace add variable x unset {traceCheck {uplevel 1 set x(0)}} unset x set info } {1 {can't read "x(0)": no such variable}} test trace-11.2 {make sure arrays are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} - trace add variable x unset {traceCheck {uplevel set x(y) 22}} + trace add variable x unset {traceCheck {uplevel 1 set x(y) 22}} unset x concat $info [list [catch {set x(y)} msg] $msg] } {0 22 0 22} test trace-11.3 {make sure arrays are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} - trace add variable x unset {traceCheck {uplevel array exists x}} + trace add variable x unset {traceCheck {uplevel 1 array exists x}} unset x set info } {0 0} test trace-11.4 {make sure arrays are unset before traces are called} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} - set cmd {traceCheck {uplevel {trace info variable x}}} + set cmd {traceCheck {uplevel 1 {trace info variable x}}} trace add variable x unset $cmd unset x set info } {0 {}} test trace-11.5 {set new array trace during unset trace} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} trace add variable x unset {traceCheck {global x; trace add variable x read {}}} @@ -692,7 +692,7 @@ test trace-11.5 {set new array trace during unset trace} { concat $info [trace info variable x] } {0 {} {read {}}} test trace-11.6 {create scalar during array unset trace} { - catch {unset x} + unset -nocomplain x set x(y) 33 set info {} trace add variable x unset {traceCheck {global x; set x 44}} @@ -703,52 +703,52 @@ test trace-11.6 {create scalar during array unset trace} { # Check special conditions (e.g. errors) in Tcl_TraceVar2. test trace-12.1 {creating array when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(0) write traceProc list [catch {set x 22} msg] $msg } {1 {can't set "x": variable is array}} test trace-12.2 {creating array when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(0) write traceProc list [catch {set x(0)} msg] $msg } {1 {can't read "x(0)": no such element in array}} test trace-12.3 {creating array when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x(0) write traceProc set x(0) 22 set info } {x 0 write} test trace-12.4 {creating variable when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc list [catch {set x} msg] $msg } {1 {can't read "x": no such variable}} test trace-12.5 {creating variable when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc set x 22 set info } {x {} write} test trace-12.6 {creating variable when setting variable traces} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc set x(0) 22 set info } {x 0 write} test trace-12.7 {create array element during read trace} { - catch {unset x} + unset -nocomplain x set x(2) zzz trace add variable x read {traceCrtElement xyzzy} list [catch {set x(3)} msg] $msg } {0 xyzzy} test trace-12.8 {errors when setting variable traces} { - catch {unset x} + unset -nocomplain x set x 44 list [catch {trace add variable x(0) write traceProc} msg] $msg } {1 {can't trace "x(0)": variable isn't array}} @@ -762,14 +762,14 @@ test trace-13.1 {delete one trace from another} { trace remove variable x read {traceTag 3} trace remove variable x read {traceTag 4} } - catch {unset x} + unset -nocomplain x set x 44 set info {} trace add variable x read {traceTag 1} trace add variable x read {traceTag 2} trace add variable x read {traceTag 3} trace add variable x read {traceTag 4} - trace add variable x read delTraces + trace add variable x read delTraces trace add variable x read {traceTag 5} set x set info @@ -874,7 +874,7 @@ test trace-14.5 {trace command, invalid option} { } [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"] # Again, [trace ... command] and [trace ... variable] share syntax and -# error message styles for their opList options; these loops test those +# error message styles for their opList options; these loops test those # error messages. set i 0 @@ -916,13 +916,13 @@ test trace-14.11 {trace command, "trace variable" errors} { test trace-14.12 {trace command ("remove variable" option)} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc trace remove variable x write traceProc } {} test trace-14.13 {trace command ("remove variable" option)} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write traceProc trace remove variable x write traceProc @@ -930,7 +930,7 @@ test trace-14.13 {trace command ("remove variable" option)} { set info } {} test trace-14.14 {trace command ("remove variable" option)} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write {traceTag 1} trace add variable x write traceProc @@ -945,7 +945,7 @@ test trace-14.14 {trace command ("remove variable" option)} { set info } {2 x {} write 1 2 1 2} test trace-14.15 {trace command ("remove variable" option)} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write {traceTag 1} trace remove variable x write non_existent @@ -953,27 +953,27 @@ test trace-14.15 {trace command ("remove variable" option)} { set info } {1} test trace-14.16 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x trace add variable x write {traceTag 1} trace add variable x write traceProc trace add variable x write {traceTag 2} trace info variable x } {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}} test trace-14.17 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x trace info variable x } {} test trace-14.18 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x trace info variable x(0) } {} test trace-14.19 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x set x 44 trace info variable x(0) } {} test trace-14.20 {trace command ("info variable" option)} { - catch {unset x} + unset -nocomplain x set x 44 trace add variable x write {traceTag 1} proc check {} {global x; trace info variable x} @@ -983,7 +983,7 @@ test trace-14.20 {trace command ("info variable" option)} { # Check fancy trace commands (long ones, weird arguments, etc.) test trace-15.1 {long trace command} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x write {traceTag {This is a very very long argument. It's \ designed to test out the facilities of TraceVarProc for dealing \ @@ -1001,14 +1001,14 @@ test trace-15.2 {long trace command result to ignore} { proc longResult {args} {return "quite a bit of text, designed to generate a core leak if this command file is invoked over and over again and memory isn't being recycled correctly"} - catch {unset x} + unset -nocomplain x trace add variable x write longResult set x 44 set x 5 set x abcde } abcde test trace-15.3 {special list-handling in trace commands} { - catch {unset "x y z"} + unset -nocomplain "x y z" set "x y z(a\n\{)" 44 set info {} trace add variable "x y z(a\n\{)" write traceProc @@ -1020,18 +1020,18 @@ test trace-15.3 {special list-handling in trace commands} { proc traceUnset {unsetName args} { global info - upvar $unsetName x + upvar 1 $unsetName x lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg } proc traceReset {unsetName resetName args} { global info - upvar $unsetName x $resetName y + upvar 1 $unsetName x $resetName y lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg } proc traceReset2 {unsetName resetName args} { global info - lappend info [catch {uplevel unset $unsetName} msg] $msg \ - [catch {uplevel set $resetName xyzzy} msg] $msg + lappend info [catch {uplevel 1 unset $unsetName} msg] $msg \ + [catch {uplevel 1 set $resetName xyzzy} msg] $msg } proc traceAppend {string name1 name2 op} { global info @@ -1039,7 +1039,7 @@ proc traceAppend {string name1 name2 op} { } test trace-16.1 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y read {traceUnset y} @@ -1047,49 +1047,49 @@ test trace-16.1 {unsets during read traces} { lappend info [catch {set y} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-16.2 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceUnset y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}} test trace-16.3 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceUnset y} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} test trace-16.4 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y read {traceReset y y} lappend info [catch {set y} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.5 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceReset y(0) y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.6 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceReset y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}} test trace-16.7 {unsets during read traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceReset2 y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy} test trace-16.8 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y write {traceUnset y} @@ -1097,91 +1097,91 @@ test trace-16.8 {unsets during write traces} { lappend info [catch {set y xxx} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.9 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceUnset y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.10 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceUnset y} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.11 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y write {traceReset y y} lappend info [catch {set y xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.12 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceReset y(0) y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.13 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceReset y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}} test trace-16.14 {unsets during write traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) write {traceReset2 y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-16.15 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y unset {traceUnset y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}} test trace-16.16 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceUnset y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}} test trace-16.17 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceUnset y} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}} test trace-16.18 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y unset {traceReset2 y y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy} test trace-16.19 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceReset2 y(0) y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy} test trace-16.20 {unsets during unset traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) unset {traceReset2 y y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-16.21 {unsets cancelling traces} { - catch {unset y} + unset -nocomplain y set y 1234 set info {} trace add variable y read {traceAppend first} @@ -1191,7 +1191,7 @@ test trace-16.21 {unsets cancelling traces} { lappend info [catch {set y} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-16.22 {unsets cancelling traces} { - catch {unset y} + unset -nocomplain y set y(0) 1234 set info {} trace add variable y(0) read {traceAppend first} @@ -1204,19 +1204,19 @@ test trace-16.22 {unsets cancelling traces} { # Check various non-interference between traces and other things. test trace-17.1 {trace doesn't prevent unset errors} { - catch {unset x} + unset -nocomplain x set info {} trace add variable x unset {traceProc} list [catch {unset x} msg] $msg $info } {1 {can't unset "x": no such variable} {x {} unset}} test trace-17.2 {traced variables must survive procedure exits} { - catch {unset x} + unset -nocomplain x proc p1 {} {global x; trace add variable x write traceProc} p1 trace info variable x } {{write traceProc}} test trace-17.3 {traced variables must survive procedure exits} { - catch {unset x} + unset -nocomplain x set info {} proc p1 {} {global x; trace add variable x write traceProc} p1 @@ -1229,7 +1229,7 @@ test trace-17.3 {traced variables must survive procedure exits} { test trace-18.1 {unset traces on procedure returns} { proc p1 {x y} {set a 44; p2 14} - proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}} + proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 1 {info vars}]}}} set info {} p1 foo bar set info @@ -1269,8 +1269,7 @@ test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} { # Delete arrays when done, so they can be re-used as scalars # elsewhere. -catch {unset x} -catch {unset y} +unset -nocomplain x y test trace-19.0.1 {trace add command (command existence)} { # Just in case! @@ -1312,6 +1311,7 @@ test trace-19.3 {command rename traces don't fire on command deletion} { test trace-19.4 {trace add command rename doesn't trace recreated commands} { proc foo {} {} catch {rename bar {}} + set info {} trace add command foo rename traceCommand proc foo {} {} rename foo bar @@ -1324,25 +1324,49 @@ test trace-19.5 {trace add command deleted removes traces} { trace info command foo } {} -namespace eval tc {} -proc tc::tcfoo {} {} -test trace-19.6 {trace add command rename in namespace} { +test trace-19.6 {trace add command rename in namespace} -setup { + namespace eval tc {} + proc tc::tcfoo {} {} +} -body { trace add command tc::tcfoo rename traceCommand rename tc::tcfoo tc::tcbar set info -} {::tc::tcfoo ::tc::tcbar rename} -test trace-19.7 {trace add command rename in namespace back again} { +} -cleanup { + namespace delete tc +} -result {::tc::tcfoo ::tc::tcbar rename} +test trace-19.7 {trace add command rename in namespace back again} -setup { + namespace eval tc {} + proc tc::tcfoo {} {} +} -body { + trace add command tc::tcfoo rename traceCommand + rename tc::tcfoo tc::tcbar rename tc::tcbar tc::tcfoo set info -} {::tc::tcbar ::tc::tcfoo rename} -test trace-19.8 {trace add command rename in namespace to out of namespace} { +} -cleanup { + namespace delete tc +} -result {::tc::tcbar ::tc::tcfoo rename} +test trace-19.8 {trace add command rename in namespace to out of namespace} -setup { + namespace eval tc {} + proc tc::tcfoo {} {} +} -body { + trace add command tc::tcfoo rename traceCommand rename tc::tcfoo tcbar set info -} {::tc::tcfoo ::tcbar rename} -test trace-19.9 {trace add command rename back into namespace} { +} -cleanup { + catch {rename tcbar {}} + namespace delete tc +} -result {::tc::tcfoo ::tcbar rename} +test trace-19.9 {trace add command rename back into namespace} -setup { + namespace eval tc {} + proc tc::tcfoo {} {} +} -body { + trace add command tc::tcfoo rename traceCommand + rename tc::tcfoo tcbar rename tcbar tc::tcfoo set info -} {::tcbar ::tc::tcfoo rename} +} -cleanup { + namespace delete tc +} -result {::tcbar ::tc::tcfoo rename} test trace-19.10 {trace add command failed rename doesn't trigger trace} { set info {} proc foo {} {} @@ -1353,11 +1377,18 @@ test trace-19.10 {trace add command failed rename doesn't trigger trace} { } {} catch {rename foo {}} catch {rename bar {}} -test trace-19.11 {trace add command qualifies when renamed in namespace} { + +test trace-19.11 {trace add command qualifies when renamed in namespace} -setup { + namespace eval tc {} + proc tc::tcfoo {} {} +} -body { set info {} + trace add command tc::tcfoo {rename delete} traceCommand namespace eval tc {rename tcfoo tcbar} set info -} {::tc::tcfoo ::tc::tcbar rename} +} -cleanup { + namespace delete tc +} -result {::tc::tcfoo ::tc::tcbar rename} # Make sure it exists again proc foo {} {} @@ -1542,8 +1573,7 @@ proc foo {b} { set a $b } # Delete arrays when done, so they can be re-used as scalars # elsewhere. -catch {unset x} -catch {unset y} +unset -nocomplain x y # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). @@ -1674,6 +1704,16 @@ test trace-21.11 {trace execution and alias} -setup { rename ::x {} } -result {:: ::} +proc set2 args { + set {*}$args +} + +test trace-21.12 {bug 2438181} -setup { + trace add execution set2 leave {puts one two three #;} +} -body { + set2 a hello +} -returnCodes 1 -result {wrong # args: should be "puts ?-nonewline? ?channelId? string"} + proc factorial {n} { if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] } return 1 @@ -2050,7 +2090,7 @@ test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} trace remove execution foo {enter enterstep leavestep leave} \ [list traceExecute foo] rename foo {} - catch {unset a} + unset -nocomplain a join $info "\n" } {foo foo enter foo {set a 1} enterstep @@ -2066,7 +2106,7 @@ foo foo 0 1 leave} test trace-28.2 {exec traces with 'error'} { set info {} set res {} - + proc foo {} { if {[catch {bar}]} { return "error" @@ -2088,7 +2128,7 @@ test trace-28.2 {exec traces with 'error'} { trace remove execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] - + list $res [join $info \n] } {{error error} {foo foo enter foo {if {[catch {bar}]} { @@ -2114,7 +2154,7 @@ foo foo 0 error leave}} test trace-28.3 {exec traces with 'return -code error'} { set info {} set res {} - + proc foo {} { if {[catch {bar}]} { return "error" @@ -2136,7 +2176,7 @@ test trace-28.3 {exec traces with 'return -code error'} { trace remove execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] - + list $res [join $info \n] } {{error error} {foo foo enter foo {if {[catch {bar}]} { @@ -2159,14 +2199,14 @@ foo {if {[catch {bar}]} { }} 2 error leavestep foo foo 0 error leave}} -test trace-28.4 {exec traces in slave with 'return -code error'} { - interp create slave - interp alias slave traceExecute {} traceExecute +test trace-28.4 {exec traces in child with 'return -code error'} { + interp create child + interp alias child traceExecute {} traceExecute set info {} - set res [interp eval slave { + set res [interp eval child { set info {} set res {} - + proc foo {} { if {[catch {bar}]} { return "error" @@ -2174,24 +2214,24 @@ test trace-28.4 {exec traces in slave with 'return -code error'} { return "ok" } } - + proc bar {} { return -code error "msg" } - + lappend res [foo] - + trace add execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] - + # With the trace active - + lappend res [foo] - + trace remove execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] - + list $res }] - interp delete slave + interp delete child lappend res [join $info \n] } {{error error} {foo foo enter foo {if {[catch {bar}]} { @@ -2274,8 +2314,8 @@ test trace-28.10 {exec trace info nonsense} { } {1 {wrong # args: should be "trace remove execution name opList command"}} test trace-29.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { - testcmdtrace tracetest {set stuff [expr 14 + 16]} -} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}} + testcmdtrace tracetest {set stuff [expr {14 + 16}]} +} {{expr {14 + 16}} {expr {14 + 16}} {set stuff [expr {14 + 16}]} {set stuff 30}} test trace-29.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { testcmdtrace tracetest {set stuff [info tclversion]} } [concat {{info tclversion} {info tclversion} ::tcl::info::tclversion {::tcl::info::tclversion} {set stuff [info tclversion]}} [list "set stuff [info tclversion]"]] @@ -2572,7 +2612,7 @@ test trace-39 {bug #3484621: tracing Bc'ed commands} -setup { proc foo {} { incr ::traceCalls # choose a BC'ed command that is 'unlikely' to interfere with tcltest's - # internals + # internals lset ::bar 1 2 } } -body { @@ -2593,7 +2633,7 @@ test trace-39 {bug #3484621: tracing Bc'ed commands} -setup { rename dotrace {} rename foo {} } -result {3 | 0 1 1} - + test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup { set ::traceLog 0 set ::traceCalls 0 @@ -2623,7 +2663,14 @@ test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup { rename dotrace {} rename foo {} } -result {3 | 0 1 1} - + +test trace-40.1 {execution trace errors become command errors} { + proc foo args {} + trace add execution foo enter {rename foo {}; error bar;#} + catch foo m + return -level 0 $m[unset m] +} bar + # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). catch {rename foobar {}} @@ -2634,9 +2681,8 @@ catch {rename traceproc {}} catch {rename runbase {}} # Unset the variable when done -catch {unset info} -catch {unset base} +unset -nocomplain info base # cleanup -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 2453e01..3eade4a 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -4,18 +4,18 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright © 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testchmod [llength [info commands testchmod]] @@ -59,7 +59,7 @@ if {[testConstraint unix]} { } proc openup {path} { - testchmod 777 $path + testchmod 0o777 $path if {[file isdirectory $path]} { catch { foreach p [glob -directory $path *] { @@ -96,10 +96,10 @@ test unixFCmd-1.1 {TclpRenameFile: EACCES} -setup { cleanup } -constraints {unix notRoot} -body { file mkdir td1/td2/td3 - file attributes td1/td2 -permissions 0000 + file attributes td1/td2 -permissions 0 file rename td1/td2/td3 td2 } -returnCodes error -cleanup { - file attributes td1/td2 -permissions 0755 + file attributes td1/td2 -permissions 0o755 cleanup } -result {error renaming "td1/td2/td3": permission denied} test unixFCmd-1.2 {TclpRenameFile: EEXIST} -setup { @@ -137,11 +137,11 @@ test unixFCmd-1.7 {TclpRenameFile: EXDEV} -setup { cleanup } -constraints {unix notRoot} -body { file mkdir foo/bar - file attr foo -perm 040555 + file attr foo -perm 0o40555 file rename foo/bar /tmp } -returnCodes error -cleanup { catch {file delete /tmp/bar} - catch {file attr foo -perm 040777} + catch {file attr foo -perm 0o40777} catch {file delete -force foo} } -match glob -result {*: permission denied} test unixFCmd-1.8 {Checking EINTR Bug} {unix notRoot nonPortable} { @@ -221,12 +221,12 @@ test unixFCmd-2.5 {TclpCopyFile: copy attributes} -setup { cleanup } -constraints {unix notRoot} -body { close [open tf1 a] - file attributes tf1 -permissions 0472 + file attributes tf1 -permissions 0o472 file copy tf1 tf2 file attributes tf2 -permissions } -cleanup { cleanup -} -result 00472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w- +} -result 0o472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w- test unixFCmd-3.1 {CopyFile not done} {emptyTest unix notRoot} { } {} @@ -336,7 +336,7 @@ test unixFCmd-17.1 {SetPermissionsAttribute} -setup { catch {file delete -force -- foo.test} } -constraints {unix notRoot} -body { close [open foo.test w] - list [file attributes foo.test -permissions 0000] \ + list [file attributes foo.test -permissions 0] \ [file attributes foo.test -permissions] } -cleanup { file delete -force -- foo.test @@ -344,7 +344,7 @@ test unixFCmd-17.1 {SetPermissionsAttribute} -setup { test unixFCmd-17.2 {SetPermissionsAttribute} -setup { catch {file delete -force -- foo.test} } -constraints {unix notRoot} -returnCodes error -body { - file attributes foo.test -permissions 0000 + file attributes foo.test -permissions 0 } -result {could not set permissions for file "foo.test": no such file or directory} test unixFCmd-17.3 {SetPermissionsAttribute} -setup { catch {file delete -force -- foo.test} @@ -365,35 +365,36 @@ test unixFCmd-17.4 {SetPermissionsAttribute} -setup { close [open foo.test w] set ::i 4 -proc permcheck {testnum permstr expected} { +proc permcheck {testnum permList expected} { test $testnum {SetPermissionsAttribute} {unix notRoot} { + set result {} + foreach permstr $permList { file attributes foo.test -permissions $permstr - file attributes foo.test -permissions + lappend result [file attributes foo.test -permissions] + } + set result } $expected } -permcheck unixFCmd-17.5 rwxrwxrwx 00777 -permcheck unixFCmd-17.6 r--r---w- 00442 -permcheck unixFCmd-17.7 0 00000 -permcheck unixFCmd-17.8 u+rwx,g+r 00740 -permcheck unixFCmd-17.9 u-w 00540 -permcheck unixFCmd-17.10 o+rwx 00547 -permcheck unixFCmd-17.11 --x--x--x 00111 -permcheck unixFCmd-17.12 a+rwx 00777 +permcheck unixFCmd-17.5 rwxrwxrwx 0o777 +permcheck unixFCmd-17.6 r--r---w- 0o442 +permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 0o740 0o540 0o547} +permcheck unixFCmd-17.11 --x--x--x 0o111 +permcheck unixFCmd-17.12 {0 a+rwx} {00000 0o777} file delete -force -- foo.test test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup { set cd [pwd] } -body { - # This test is nonportable because SunOS generates a weird error + # This test is nonPortable because SunOS generates a weird error # message when the current directory isn't readable. set nd $cd/tstdir file mkdir $nd cd $nd - file attributes $nd -permissions 0000 + file attributes $nd -permissions 0 pwd } -returnCodes error -cleanup { cd $cd - file attributes $nd -permissions 0755 + file attributes $nd -permissions 0o755 file delete $nd } -match glob -result {error getting working directory name:*} diff --git a/tests/unixFile.test b/tests/unixFile.test index 8147f48..e2a634a 100644 --- a/tests/unixFile.test +++ b/tests/unixFile.test @@ -4,18 +4,18 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testfindexecutable [llength [info commands testfindexecutable]] @@ -24,7 +24,7 @@ cd [temporaryDirectory] catch { set oldPath $env(PATH) - file attributes [makeFile "" junk] -perm 0777 + file attributes [makeFile "" junk] -perm 0o777 } set absPath [file join [temporaryDirectory] junk] diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test new file mode 100644 index 0000000..f321b10 --- /dev/null +++ b/tests/unixForkEvent.test @@ -0,0 +1,47 @@ +# This file contains a collection of tests for the procedures in the file +# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright © 1995-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +testConstraint testfork [llength [info commands testfork]] + +# Test if the notifier thread is well initialized in a forked interpreter +# by Tcl_InitNotifier +test unixforkevent-1.1 {fork and test writeable event} \ + -constraints {testfork nonPortable} \ + -body { + set myFolder [makeDirectory unixtestfork] + set pid [testfork] + if {$pid == 0} { + # we are the forked process + set result initialized + set h [open [file join $myFolder test.txt] w] + fileevent $h writable\ + "set result writable;\ + after cancel [after 1000 {set result timeout}]" + vwait result + close $h + makeFile $result result.txt $myFolder + exit + } + # we are the original process + while {![file readable [file join $myFolder result.txt]]} {} + viewFile result.txt $myFolder + } \ + -result {writable} \ + -cleanup { + catch { removeFolder $myFolder } + } + +::tcltest::cleanupTests +return diff --git a/tests/unixInit.test b/tests/unixInit.test index 9ba9c11..aa3d50a 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -4,17 +4,22 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2.2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C + +# Some tests require the testgetencpath command +testConstraint testgetencpath [llength [info commands testgetencpath]] test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { set x {} @@ -44,11 +49,11 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} set pipe1 [open "|[list [interpreter]]" r+] puts $pipe1 { proc accept {channel host port} { - puts $channel {puts [fconfigure stdin -peername]; exit} + puts $channel {puts [chan configure stdin -peername]; exit} close $channel exit } - puts [fconfigure [socket -server accept -myaddr 127.0.0.1 0] -sockname] + puts [chan configure [socket -server accept -myaddr 127.0.0.1 0] -sockname] vwait forever \ } # Note the backslash above; this is important to make sure that the whole @@ -64,8 +69,8 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} set pipe2 [open "|[list [interpreter] <@$sock]" r] set result [gets $pipe2] # Clear any pending data; stops certain kinds of (non-important) errors - fconfigure $pipe1 -blocking 0; gets $pipe1 - fconfigure $pipe2 -blocking 0; gets $pipe2 + chan configure $pipe1 -blocking 0; gets $pipe1 + chan configure $pipe2 -blocking 0; gets $pipe2 # Close the pipes and the socket. close $pipe2 close $pipe1 @@ -87,13 +92,15 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} skip [concat [skip] unixInit-2.*] -test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} { - set origDir [testgetdefenc] - testsetdefenc slappy - set path [testgetdefenc] - testsetdefenc $origDir +test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} -constraints { + testgetencpath +} -body { + set origPath [testgetencpath] + testsetencpath slappy + set path [testgetencpath] + testsetencpath $origPath set path -} {slappy} +} -result {slappy} test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { @@ -329,22 +336,21 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints { } -body { set env(LANG) C set f [open "|[list [interpreter]]" w+] - fconfigure $f -buffering none + chan configure $f -buffering none puts $f {puts [encoding system]; exit} set enc [gets $f] close $f - return $enc + set enc } -cleanup { unset -nocomplain env(LANG) -} -match regexp -result [expr { - ($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}] +} -match regexp -result {^(iso8859-15?|utf-8)$} test unixInit-3.2 {TclpSetInitialEncodings} -setup { catch {set oldlc_all $env(LC_ALL)} } -constraints {unix stdio} -body { set env(LANG) japanese set env(LC_ALL) japanese set f [open "|[list [interpreter]]" w+] - fconfigure $f -buffering none + chan configure $f -buffering none puts $f {puts [encoding system]; exit} set enc [gets $f] close $f @@ -390,7 +396,7 @@ test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { } -returnCodes 0 # cleanup -catch {unset env(LANG)} +unset -nocomplain env(LANG) catch {set env(LANG) $oldlang} unset -nocomplain path ::tcltest::cleanupTests diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 0646a3d..8ab0edb 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -4,41 +4,36 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # When run in a Tk shell, these tests hang. testConstraint noTk [expr {0 != [catch {package present Tk}]}] -testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] -# Darwin always uses a threaded notifier -testConstraint unthreaded [expr { - ![::tcl::pkgconfig get threaded] - && $tcl_platform(os) ne "Darwin" -}] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # The next two tests will hang if threads are enabled because the notifier # will not necessarily wait for ever in this case, so it does not generate # an error. -test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { +test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints nonPortable -body { catch {vwait x} set f [open [makeFile "" foo] w] fileevent $f writable {set x 1} vwait x close $f list [catch {vwait x} msg] $msg -} -result {1 {can't wait for variable "x": would wait forever}} -cleanup { +} -result {1 {can't wait for variable "x": would wait forever}} -cleanup { catch { close $f } catch { removeFile foo } } -test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { +test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints nonPortable -body { catch {vwait x} set f1 [open [makeFile "" foo] w] set f2 [open [makeFile "" foo2] w] @@ -90,7 +85,7 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \ set x } \ -result {ok} \ - -cleanup { + -cleanup { catch { close $f1 } catch { close $f2 } catch { removeFile foo } diff --git a/tests/unknown.test b/tests/unknown.test index 40be6602..cb0a7c4 100644 --- a/tests/unknown.test +++ b/tests/unknown.test @@ -4,19 +4,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } -catch {unset x} +unset -nocomplain x catch {rename unknown unknown.old} test unknown-1.1 {non-existent "unknown" command} { @@ -59,8 +59,8 @@ test unknown-4.1 {errors in "unknown" procedure} { # cleanup catch {rename unknown {}} catch {rename unknown.old unknown} -::tcltest::cleanupTests -return +cleanupTests +return # Local Variables: # mode: tcl diff --git a/tests/unload.test b/tests/unload.test index 5a374c4..29f534d 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -4,20 +4,20 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2003-2004 by Georgios Petasis +# Copyright © 1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2003-2004 Georgios Petasis # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Figure out what extension is used for shared libraries on this # platform. @@ -38,13 +38,18 @@ testConstraint $loaded [expr {![string match *pkgua* $alreadyLoaded]}] set alreadyTotalLoaded [info loaded] -# Certain tests require the 'teststaticpkg' command from tcltest -testConstraint teststaticpkg [llength [info commands teststaticpkg]] - # Certain tests need the 'testsimplefilsystem' in tcltest testConstraint testsimplefilesystem \ [llength [info commands testsimplefilesystem]] +proc loadIfNotPresent {pkg args} { + global testDir ext + set loaded [lmap x [info loaded {*}$args] {lindex $x 1}] + if {[string totitle $pkg] ni $loaded} { + load [file join $testDir $pkg$ext] + } +} + # Basic tests: parameter testing... test unload-1.1 {basic errors} -returnCodes error -body { unload @@ -72,38 +77,53 @@ set pkgua_loaded {} set pkgua_detached {} set pkgua_unloaded {} # Tests for loading/unloading in trusted (non-safe) interpreters... -test unload-2.1 {basic loading of non-unloadable package, with guess for package name} [list $dll $loaded] { - load [file join $testDir pkga$ext] +test unload-2.1 {basic loading of non-unloadable package, with guess for prefix} [list $dll $loaded] { + loadIfNotPresent pkga list [pkga_eq abc def] [lsort [info commands pkga_*]] } {0 {pkga_eq pkga_quote}} -test unload-2.2 {basic loading of unloadable package, with guess for package name} [list $dll $loaded] { +test unload-2.2 {basic loading of unloadable package, with guess for prefix} [list $dll $loaded] { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ [load [file join $testDir pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } {{} {} {} {} 0 {pkgua_eq pkgua_quote} . {} {}} -test unload-2.3 {basic unloading of non-unloadable package, with guess for package name} [list $dll $loaded] { - list [catch {unload [file join $testDir pkga$ext]} msg] \ - [string map [list [file join $testDir pkga$ext] file] $msg] -} {1 {file "file" cannot be unloaded under a trusted interpreter}} -test unload-2.4 {basic unloading of unloadable package, with guess for package name} [list $dll $loaded] { +test unload-2.3 {basic unloading of non-unloadable package, with guess for prefix} -setup { + loadIfNotPresent pkga +} -constraints [list $dll $loaded] -returnCodes error -match glob -body { + unload [file join $testDir pkga$ext] +} -result {file "*" cannot be unloaded under a trusted interpreter} +test unload-2.4 {basic unloading of unloadable package, with guess for prefix} -setup { + loadIfNotPresent pkgua +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ [unload [file join $testDir pkgua$ext]] \ [info commands pkgua_*] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded -} {. {} {} {} {} . . .} -test unload-2.5 {reloading of unloaded package, with guess for package name} [list $dll $loaded] { +} -result {. {} {} {} {} . . .} +test unload-2.5 {reloading of unloaded package, with guess for prefix} -setup { + if {$pkgua_loaded eq ""} { + loadIfNotPresent pkgua + unload [file join $testDir pkgua$ext] + } +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ [load [file join $testDir pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded -} {. . . {} 0 {pkgua_eq pkgua_quote} .. . .} -test unload-2.6 {basic unloading of re-loaded package, with guess for package name} [list $dll $loaded] { +} -result {. . . {} 0 {pkgua_eq pkgua_quote} .. . .} +test unload-2.6 {basic unloading of re-loaded package, with guess for prefix} -setup { + # Establish expected state + if {$pkgua_loaded eq ""} { + loadIfNotPresent pkgua + unload [file join $testDir pkgua$ext] + load [file join $testDir pkgua$ext] + } +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ [unload [file join $testDir pkgua$ext]] \ [info commands pkgua_*] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded -} {.. . . {} {} .. .. ..} +} -result {.. . . {} {} .. .. ..} # Tests for loading/unloading in safe interpreters... interp create -safe child @@ -112,53 +132,67 @@ child eval { set pkgua_detached {} set pkgua_unloaded {} } -test unload-3.1 {basic loading of non-unloadable package in a safe interpreter, with package name conversion} \ +test unload-3.1 {basic loading of non-unloadable package in a safe interpreter} \ [list $dll $loaded] { catch {rename pkgb_sub {}} - load [file join $testDir pkgb$ext] pKgB child + load [file join $testDir pkgb$ext] Pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} -test unload-3.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \ +test unload-3.2 {basic loading of unloadable package in a safe interpreter} \ [list $dll $loaded] { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pKgUA child] \ + [load [file join $testDir pkgua$ext] pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} -test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} \ - [list $dll $loaded] { - list [catch {unload [file join $testDir pkga$ext] {} child} msg] \ - [string map [list [file join $testDir pkga$ext] file] $msg] -} {1 {file "file" has never been loaded in this interpreter}} -test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} \ - [list $dll $loaded] { - list [catch {unload [file join $testDir pkgb$ext] {} child} msg] \ - [string map [list [file join $testDir pkgb$ext] file] $msg] -} {1 {file "file" cannot be unloaded under a safe interpreter}} -test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} -setup { + loadIfNotPresent pkga +} -constraints [list $dll $loaded] -returnCodes error -match glob -body { + unload [file join $testDir pkga$ext] {} child +} -result {file "*" has never been loaded in this interpreter} +test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for prefix} -setup { + if {[lsearch -index 1 [info loaded child] Pkgb] < 0} { + load [file join $testDir pkgb$ext] Pkgb child + } +} -constraints [list $dll $loaded] -returnCodes error -match glob -body { + unload [file join $testDir pkgb$ext] {} child +} -result {file "*" cannot be unloaded under a safe interpreter} +test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for prefix} -setup { + if {[lsearch -index 1 [info loaded child] Pkgua] < 0} { + load [file join $testDir pkgua$ext] Pkgua child + } +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] {} child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{. {} {}} {} {} {. . .}} -test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for package name} \ - [list $dll $loaded] { +} -result {{. {} {}} {} {} {. . .}} +test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for prefix} -setup { + if {[child eval set pkgua_loaded] eq ""} { + load [file join $testDir pkgua$ext] {} child + unload [file join $testDir pkgua$ext] {} child + } +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [load [file join $testDir pkgua$ext] {} child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}} -test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with package name conversion} \ - [list $dll $loaded] { +} -result {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}} +test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with prefix conversion} -setup { + if {[child eval set pkgua_loaded] eq ""} { + load [file join $testDir pkgua$ext] {} child + unload [file join $testDir pkgua$ext] {} child + load [file join $testDir pkgua$ext] {} child + } +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] pKgUa child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{.. . .} {} {} {.. .. ..}} +} -result {{.. . .} {} {} {.. .. ..}} # Tests for loading/unloading of a package among multiple interpreters... interp create child-trusted @@ -167,56 +201,89 @@ child-trusted eval { set pkgua_detached {} set pkgua_unloaded {} } +array set load {M 0 C 0 T 0} ## Load package in main trusted interpreter... -test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for prefix} -setup { + set pkgua_loaded "" + set pkgua_detached "" + set pkgua_unloaded "" + incr load(M) +} -constraints [list $dll $loaded] -body { list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \ [load [file join $testDir pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] -} {{.. .. ..} {} 0 {pkgua_eq pkgua_quote} {... .. ..}} +} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Load package in child-safe interpreter... -test unload-4.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \ - [list $dll $loaded] { +test unload-4.2 {basic loading of unloadable package in a safe interpreter} -setup { + child eval { + set pkgua_loaded "" + set pkgua_detached "" + set pkgua_unloaded "" + } + incr load(C) +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pKgUA child] \ + [load [file join $testDir pkgua$ext] pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{.. .. ..} {} 0 {pkgua_eq pkgua_quote} {... .. ..}} +} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Load package in child-trusted interpreter... -test unload-4.3 {basic loading of unloadable package in a second trusted interpreter, with package name conversion} \ - [list $dll $loaded] { +test unload-4.3 {basic loading of unloadable package in a second trusted interpreter} -setup { + incr load(T) +} -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pkguA child-trusted] \ + [load [file join $testDir pkgua$ext] pkgua child-trusted] \ [child-trusted eval pkgua_eq abc def] \ [lsort [child-trusted eval info commands pkgua_*]] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} +} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Unload the package from the main trusted interpreter... -test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for prefix} -setup { + if {!$load(M)} { + load [file join $testDir pkgua$ext] + } + if {!$load(C)} { + load [file join $testDir pkgua$ext] {} child + incr load(C) + } + if {!$load(T)} { + load [file join $testDir pkgua$ext] {} child-trusted + incr load(T) + } +} -constraints [list $dll $loaded] -body { list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \ [unload [file join $testDir pkgua$ext]] \ [info commands pkgua_*] \ [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] -} {{... .. ..} {} {} {... ... ..}} +} -result {{. {} {}} {} {} {. . {}}} ## Unload the package from the child safe interpreter... -test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup { + if {!$load(C)} { + load [file join $testDir pkgua$ext] {} child + } + if {!$load(T)} { + load [file join $testDir pkgua$ext] {} child-trusted + incr load(T) + } +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] {} child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{... .. ..} {} {} {... ... ..}} +} -result {{. {} {}} {} {} {. . {}}} ## Unload the package from the child trusted interpreter... -test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup { + if {!$load(T)} { + load [file join $testDir pkgua$ext] {} child-trusted + } +} -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] {} child-trusted] \ [child-trusted eval info commands pkgua_*] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{. {} {}} {} {} {. . .}} +} -result {{. {} {}} {} {} {. . .}} test unload-5.1 {unload a module loaded from vfs} \ -constraints [list $dll $loaded testsimplefilesystem] \ @@ -230,9 +297,7 @@ test unload-5.1 {unload a module loaded from vfs} \ list [catch {unload simplefs:/pkgua$ext} msg] $msg } \ -result {0 {}} - - - + # cleanup interp delete child interp delete child-trusted diff --git a/tests/uplevel.test b/tests/uplevel.test index 0410469..de21361 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -4,20 +4,20 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } proc a {x y} { - newset z [expr $x+$y] + newset z [expr {$x + $y}] return $z } proc newset {name value} { @@ -83,6 +83,16 @@ test uplevel-3.4 {uplevel to same level} { a1 } 55 +test uplevel-4.0.1 {error: non-existent level} -body { + uplevel #0 { uplevel { set y 222 } } +} -returnCodes error -result {bad level "1"} +test uplevel-4.0.2 {error: non-existent level} -setup { + interp create i +} -body { + i eval { uplevel { set y 222 } } +} -returnCodes error -result {bad level "1"} -cleanup { + interp delete i +} test uplevel-4.1 {error: non-existent level} -returnCodes error -body { apply {{} { uplevel #2 {set y 222} @@ -101,6 +111,105 @@ test uplevel-4.4 {error: not enough args} -returnCodes error -body { uplevel 1 }} } -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} +test uplevel-4.5 {level parsing} { + apply {{} {uplevel 0 {}}} +} {} +test uplevel-4.6 {level parsing} { + apply {{} {uplevel #0 {}}} +} {} +test uplevel-4.7 {level parsing} { + apply {{} {uplevel [expr 0] {}}} +} {} +test uplevel-4.8 {level parsing} { + apply {{} {uplevel #[expr 0] {}}} +} {} +test uplevel-4.9 {level parsing} { + apply {{} {uplevel -0 {}}} +} {} +test uplevel-4.10 {level parsing} { + apply {{} {uplevel #-0 {}}} +} {} +test uplevel-4.11 {level parsing} { + apply {{} {uplevel [expr -0] {}}} +} {} +test uplevel-4.12 {level parsing} { + apply {{} {uplevel #[expr -0] {}}} +} {} +test uplevel-4.13 {level parsing} { + apply {{} {uplevel 1 {}}} +} {} +test uplevel-4.14 {level parsing} { + apply {{} {uplevel #1 {}}} +} {} +test uplevel-4.15 {level parsing} { + apply {{} {uplevel [expr 1] {}}} +} {} +test uplevel-4.16 {level parsing} { + apply {{} {uplevel #[expr 1] {}}} +} {} +test uplevel-4.17 {level parsing} -returnCodes error -body { + apply {{} {uplevel -0xffffffff {}}} +} -result {bad level "-0xffffffff"} +test uplevel-4.18 {level parsing} -returnCodes error -body { + apply {{} {uplevel #-0xffffffff {}}} +} -result {bad level "#-0xffffffff"} +test uplevel-4.19 {level parsing} -returnCodes error -body { + apply {{} {uplevel [expr -0xffffffff] {}}} +} -result {bad level "-4294967295"} +test uplevel-4.20 {level parsing} -returnCodes error -body { + apply {{} {uplevel #[expr -0xffffffff] {}}} +} -result {bad level "#-4294967295"} +test uplevel-4.21 {level parsing} -body { + apply {{} {uplevel -1 {}}} +} -returnCodes error -result {bad level "-1"} +test uplevel-4.22 {level parsing} -body { + apply {{} {uplevel #-1 {}}} +} -returnCodes error -result {bad level "#-1"} +test uplevel-4.23 {level parsing} -body { + apply {{} {uplevel [expr -1] {}}} +} -returnCodes error -result {bad level "-1"} +test uplevel-4.24 {level parsing} -body { + apply {{} {uplevel #[expr -1] {}}} +} -returnCodes error -result {bad level "#-1"} +test uplevel-4.25 {level parsing} -body { + apply {{} {uplevel 0xffffffff {}}} +} -returnCodes error -result {bad level "0xffffffff"} +test uplevel-4.26 {level parsing} -body { + apply {{} {uplevel #0xffffffff {}}} +} -returnCodes error -result {bad level "#0xffffffff"} +test uplevel-4.27 {level parsing} -body { + apply {{} {uplevel [expr 0xffffffff] {}}} +} -returnCodes error -result {bad level "4294967295"} +test uplevel-4.28 {level parsing} -body { + apply {{} {uplevel #[expr 0xffffffff] {}}} +} -returnCodes error -result {bad level "#4294967295"} +test uplevel-4.29 {level parsing} -body { + apply {{} {uplevel 0.2 {}}} +} -returnCodes error -result {invalid command name "0.2"} +test uplevel-4.30 {level parsing} -body { + apply {{} {uplevel #0.2 {}}} +} -returnCodes error -result {bad level "#0.2"} +test uplevel-4.31 {level parsing} -body { + apply {{} {uplevel [expr 0.2] {}}} +} -returnCodes error -result {invalid command name "0.2"} +test uplevel-4.32 {level parsing} -body { + apply {{} {uplevel #[expr 0.2] {}}} +} -returnCodes error -result {bad level "#0.2"} +test uplevel-4.33 {level parsing} -body { + apply {{} {uplevel .2 {}}} +} -returnCodes error -result {invalid command name ".2"} +test uplevel-4.34 {level parsing} -body { + apply {{} {uplevel #.2 {}}} +} -returnCodes error -result {bad level "#.2"} +test uplevel-4.35 {level parsing} -body { + apply {{} {uplevel [expr .2] {}}} +} -returnCodes error -result {invalid command name "0.2"} +test uplevel-4.36 {level parsing} -body { + apply {{} {uplevel #[expr .2] {}}} +} -returnCodes error -result {bad level "#0.2"} + + + proc a2 {} { uplevel a3 @@ -138,7 +247,7 @@ test uplevel-7.1 {var access, no LVT in either level} -setup { unset -nocomplain y z } -body { namespace eval foo { - set x 2 + set x 2 set y 2 uplevel 1 { set x 3 @@ -157,7 +266,7 @@ test uplevel-7.2 {var access, no LVT in upper level} -setup { unset -nocomplain y z } -body { proc foo {} { - set x 2 + set x 2 set y 2 uplevel 1 { set x 3 @@ -181,7 +290,7 @@ test uplevel-7.3 {var access, LVT in upper level} -setup { } } -body { proc foo {} { - set x 2 + set x 2 set y 2 uplevel 1 { set x 3 @@ -195,7 +304,24 @@ test uplevel-7.3 {var access, LVT in upper level} -setup { rename foo {} rename moo {} } -result {3 3 3} + + +test uplevel-8.0 { + string representation isn't generated when there is only one argument +} -body { + set res {} + set script [list lindex 5] + lappend res [apply {script { + uplevel $script + }} $script] + lappend res [string match {value is a list *no string representation*} [ + ::tcl::unsupported::representation $script]] +} -cleanup { + unset script + unset res +} -result {5 1} + # cleanup ::tcltest::cleanupTests return diff --git a/tests/upvar.test b/tests/upvar.test index e2c9ffd..82079b1 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -4,20 +4,20 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testupvar [llength [info commands testupvar]] @@ -304,6 +304,17 @@ test upvar-8.3 {errors in upvar command} -returnCodes error -body { proc p1 {} {upvar a b c} p1 } -result {bad level "a"} +test upvar-8.3.1 {bad level for upvar (upvar at top-level, bug [775ee88560])} -body { + proc p1 {} { uplevel { upvar b b; lappend b UNEXPECTED } } + uplevel #0 { p1 } +} -returnCodes error -result {bad level "1"} +test upvar-8.3.2 {bad level for upvar (upvar at top-level, bug [775ee88560])} -setup { + interp create i +} -body { + i eval { upvar b b; lappend b UNEXPECTED } +} -returnCodes error -result {bad level "1"} -cleanup { + interp delete i +} test upvar-8.4 {errors in upvar command} -returnCodes error -body { proc p1 {} {upvar 0 b b} p1 @@ -339,7 +350,7 @@ test upvar-8.9 {upvar won't create namespace variable that refers to procedure v unset ::test_ns_1::a } MakeLink 1 -} -result {bad variable name "a": upvar won't create namespace variable that refers to procedure variable} +} -result {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} -setup { catch {unset upvarArray} } -body { @@ -355,7 +366,11 @@ test upvar-8.11 {upvar will not create a variable that looks like an array} -set test upvar-9.1 {Tcl_UpVar2 procedure} testupvar { list [catch {testupvar xyz a {} x global} msg] $msg -} {1 {bad level "xyz"}} +} {1 {bad level "1"}} +test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar { + apply {{} {testupvar xyz a {} x local; set x foo}} + set a +} foo test upvar-9.2 {Tcl_UpVar2 procedure} testupvar { catch {unset a} catch {unset x} @@ -414,6 +429,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 # for 'upvar', we only test that the variables are linked correctly, i.e., we @@ -466,7 +492,7 @@ test upvar-NS-1.4 {nsupvar links to correct variable} -body { } -returnCodes error -cleanup { namespace delete test_ns_1 } -result {namespace "test_ns_0" not found in "::test_ns_1"} - + test upvar-NS-1.5 {nsupvar links to correct variable} -body { namespace eval test_ns_1 { namespace eval test_ns_0 {} @@ -536,6 +562,37 @@ test upvar-NS-2.2 {TIP 323} -setup { } -cleanup { namespace delete test_ns_1 } -result {} + +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 diff --git a/tests/utf.test b/tests/utf.test index c41cfe3..b6c23ba 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -2,150 +2,982 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] + +testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}] +testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}] +testConstraint utf16 [expr {[string length [format %c 0x10000]] == 2}] +testConstraint ucs4 [expr {[testConstraint fullutf] + && [string length [format %c 0x10000]] == 1}] +testConstraint ucs2_utf16 [expr {![testConstraint ucs4]}] + +testConstraint Uesc [expr {"\U0041" eq "A"}] +testConstraint pre388 [expr {"\x741" eq "A"}] +testConstraint pairsTo4bytes [expr {[llength [info commands teststringbytes]] + && [string length [teststringbytes \uD83D\uDCA9]] == 4}] + +testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint testfindfirst [llength [info commands testfindfirst]] +testConstraint testfindlast [llength [info commands testfindlast]] +testConstraint testnumutfchars [llength [info commands testnumutfchars]] +testConstraint teststringobj [llength [info commands teststringobj]] +testConstraint testutfnext [llength [info commands testutfnext]] +testConstraint testutfprev [llength [info commands testutfprev]] + +testConstraint tip413 [expr {[string trim \x00] eq {}}] catch {unset x} -test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} { - set x \x01 -} [bytestring "\x01"] -test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} { - set x "\x00" -} [bytestring "\xc0\x80"] -test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} { - set x "\xe0" -} [bytestring "\xc3\xa0"] -test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} { - set x "\u4e4e" -} [bytestring "\xe4\xb9\x8e"] -test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} { - format %c 0x110000 -} [bytestring "\xef\xbf\xbd"] -test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} { - format %c -1 -} [bytestring "\xef\xbf\xbd"] +test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring { + expr {"\x01" eq [testbytestring \x01]} +} 1 +test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { + expr {"\x00" eq [testbytestring \xC0\x80]} +} 1 +test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { + expr {"\xE0" eq [testbytestring \xC3\xA0]} +} 1 +test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring { + expr {"\u4E4E" eq [testbytestring \xE4\xB9\x8E]} +} 1 +test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { + expr {[format %c 0x110000] eq [testbytestring \xEF\xBF\xBD]} +} 1 +test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { + expr {[format %c -1] eq [testbytestring \xEF\xBF\xBD]} +} 1 +test utf-1.7.0 {Tcl_UniCharToUtf: 4 byte sequences} {fullutf Uesc testbytestring} { + expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]} +} 1 +test utf-1.7.1 {Tcl_UniCharToUtf: 4 byte sequences} {ucs2 Uesc testbytestring} { + expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]} +} 0 +test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring { + expr {"\uD842" eq [testbytestring \xED\xA1\x82]} +} 1 +test utf-1.9 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring { + expr {"\uDC42" eq [testbytestring \xED\xB1\x82]} +} 1 +test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring { + expr {[format %c 0xD842] eq [testbytestring \xED\xA1\x82]} +} 1 +test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring { + expr {[format %c 0xDC42] eq [testbytestring \xED\xB1\x82]} +} 1 +test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} { + expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]} +} 1 +test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc testbytestring} { + expr {"\UD842" eq [testbytestring \xEF\xBF\xBD]} +} 1 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" -} {3} -test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} { - string length [bytestring "\x82\x83\x84"] -} {3} -test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} { - string length [bytestring "\xC2"] -} {1} +} 3 +test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} testbytestring { + string length [testbytestring \x82\x83\x84] +} 3 +test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} testbytestring { + string length [testbytestring \xC2] +} 1 test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} { - string length [bytestring "\xC2\xa2"] -} {1} -test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} { - string length [bytestring "\xE2"] -} {1} -test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} { - string length [bytestring "\xE2\xA2"] -} {2} -test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} { - string length [bytestring "\xE4\xb9\x8e"] -} {1} -test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} { - string length [bytestring "\xF4\xA2\xA2\xA2"] -} {4} + string length \xA2 +} 1 +test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} testbytestring { + string length [testbytestring \xE2] +} 1 +test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestring { + string length [testbytestring \xE2\xA2] +} 2 +test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { + string length [testbytestring \xE4\xB9\x8E] +} 1 +test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2_utf16} { + string length [testbytestring \xF0\x90\x80\x80] +} 2 +test utf-2.8.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs4} { + string length [testbytestring \xF0\x90\x80\x80] +} 1 +test utf-2.9.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2} { + string length [testbytestring \xF4\x8F\xBF\xBF] +} 2 +test utf-2.9.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {Uesc ucs4} { + string length \U10FFFF +} 1 +test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { + string length [testbytestring \xF0\x8F\xBF\xBF] +} 4 +test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring { + # Would decode to U+110000 but that is outside the Unicode range. + string length [testbytestring \xF4\x90\x80\x80] +} 4 +test utf-2.12 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring { + string length [testbytestring \xF8\xA2\xA2\xA2\xA2] +} 5 test utf-3.1 {Tcl_UtfCharComplete} { } {} -testConstraint testnumutfchars [llength [info commands testnumutfchars]] test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars { testnumutfchars "" -} {0} +} 0 test utf-4.2 {Tcl_NumUtfChars: length 1} testnumutfchars { - testnumutfchars [bytestring "\xC2\xA2"] -} {1} -test utf-4.3 {Tcl_NumUtfChars: long string} testnumutfchars { - testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] -} {7} -test utf-4.4 {Tcl_NumUtfChars: #u0000} testnumutfchars { - testnumutfchars [bytestring "\xC0\x80"] -} {1} + testnumutfchars \xA2 +} 1 +test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} { + testnumutfchars abc\xA2[testbytestring \xE4\xB9\x8E\xA2\x4E] +} 7 +test utf-4.4 {Tcl_NumUtfChars: #x00} testnumutfchars { + testnumutfchars \x00 +} 1 test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars { - testnumutfchars "" 1 -} {0} -test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} testnumutfchars { - testnumutfchars [bytestring "\xC2\xA2"] 1 -} {1} -test utf-4.7 {Tcl_NumUtfChars: long string, calc len} testnumutfchars { - testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1 -} {7} -test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} testnumutfchars { - testnumutfchars [bytestring "\xC0\x80"] 1 -} {1} - -test utf-5.1 {Tcl_UtfFindFirsts} { -} {} + testnumutfchars "" 0 +} 0 +test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} { + testnumutfchars \xA2 end +} 1 +test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} { + testnumutfchars abc\xA2[testbytestring \xE4\xB9\x8E\xA2\x4E] end +} 7 +test utf-4.8 {Tcl_NumUtfChars: #x00, calc len} testnumutfchars { + testnumutfchars \x00 end +} 1 +# Bug [2738427]: Tcl_NumUtfChars(...) no overflow check +test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring \xE2\x82\xAC] end-1 +} 2 +test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring \x00] end+1 +} 2 +test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1 +} 3 +test utf-4.12.0 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs2} { + testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end +} 2 +test utf-4.12.1 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs4} { + testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end +} 1 +test utf-4.13 {Tcl_NumUtfChars: end of string} {testnumutfchars testbytestring} { + testnumutfchars foobar[testbytestring \xF2\xC2\xA0] end +} 8 +test utf-4.14 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring \xF4\x90\x80\x80] end-1 +} 3 -test utf-6.1 {Tcl_UtfNext} { -} {} +test utf-5.1 {Tcl_UtfFindFirst} {testfindfirst testbytestring} { + testfindfirst [testbytestring abcbc] 98 +} bcbc +test utf-5.2 {Tcl_UtfFindLast} {testfindlast testbytestring} { + testfindlast [testbytestring abcbc] 98 +} bc -test utf-7.1 {Tcl_UtfPrev} { -} {} +test utf-6.1 {Tcl_UtfNext} {testutfnext testbytestring} { + # This takes the pointer one past the terminating NUL. + # This is really an invalid call. + testutfnext [testbytestring \x00] +} 1 +test utf-6.2 {Tcl_UtfNext} testutfnext { + testutfnext A +} 1 +test utf-6.3 {Tcl_UtfNext} testutfnext { + testutfnext AA +} 1 +test utf-6.4 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xA0] +} 1 +test utf-6.5 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xD0] +} 1 +test utf-6.6 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xE8] +} 1 +test utf-6.7 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xF2] +} 1 +test utf-6.8 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xF8] +} 1 +test utf-6.9 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\x00] +} 1 +test utf-6.10 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0]G +} 1 +test utf-6.11 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\x00] +} 2 +test utf-6.12 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xD0] +} 1 +test utf-6.13 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xE8] +} 1 +test utf-6.14 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xF2] +} 1 +test utf-6.15 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xF8] +} 1 +test utf-6.16 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\x00] +} 1 +test utf-6.17 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0]G +} 1 +test utf-6.18 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0] +} 2 +test utf-6.19 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xD0] +} 1 +test utf-6.20 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xE8] +} 1 +test utf-6.21 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xF2] +} 1 +test utf-6.22 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xF8] +} 1 +test utf-6.23 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\x00] +} 1 +test utf-6.24 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8]G +} 1 +test utf-6.25 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\x00] +} 1 +test utf-6.26 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xD0] +} 1 +test utf-6.27 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xE8] +} 1 +test utf-6.28 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xF2] +} 1 +test utf-6.29 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xF8] +} 1 +test utf-6.30.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { + testutfnext [testbytestring \xF2] +} 1 +test utf-6.30.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { + testutfnext [testbytestring \xF2\x00] +} 1 +test utf-6.31 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2]G +} 1 +test utf-6.32.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { + testutfnext [testbytestring \xF2\xA0] +} 1 +test utf-6.32.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { + testutfnext [testbytestring \xF2\xA0\x00] +} 1 +test utf-6.33 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xD0] +} 1 +test utf-6.34 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xE8] +} 1 +test utf-6.35 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xF2] +} 1 +test utf-6.36 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xF8] +} 1 +test utf-6.37 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8] +} 1 +test utf-6.38 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8]G +} 1 +test utf-6.39 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xA0] +} 1 +test utf-6.40 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xD0] +} 1 +test utf-6.41 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xE8] +} 1 +test utf-6.42 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xF2] +} 1 +test utf-6.43 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xF8] +} 1 +test utf-6.44 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0]G +} 2 +test utf-6.45 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xA0] +} 2 +test utf-6.46 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xD0] +} 2 +test utf-6.47 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xE8] +} 2 +test utf-6.48 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xF2] +} 2 +test utf-6.49 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xF8] +} 2 +test utf-6.50 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0]G +} 1 +test utf-6.51 {Tcl_UtfNext} testutfnext { + testutfnext \u8820 +} 3 +test utf-6.52 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\xD0] +} 1 +test utf-6.53 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\xE8] +} 1 +test utf-6.54 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\xF2] +} 1 +test utf-6.55 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\xF8] +} 1 +test utf-6.56 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0]G +} 1 +test utf-6.57 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\x00] +} 1 +test utf-6.58 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xD0] +} 1 +test utf-6.59 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xE8] +} 1 +test utf-6.60 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xF2] +} 1 +test utf-6.61 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xF8] +} 1 +test utf-6.62 {Tcl_UtfNext} testutfnext { + testutfnext \u8820G +} 3 +test utf-6.63 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xA0] +} 3 +test utf-6.64 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xD0] +} 3 +test utf-6.65 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xE8] +} 3 +test utf-6.66 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xF2] +} 3 +test utf-6.67 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext \u8820[testbytestring \xF8] +} 3 +test utf-6.68 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0]G +} 1 +test utf-6.69.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0] +} 1 +test utf-6.69.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0] +} 4 +test utf-6.70 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xD0] +} 1 +test utf-6.71 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xE8] +} 1 +test utf-6.72 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xF2] +} 1 +test utf-6.73 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xF8] +} 1 +test utf-6.74.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0]G +} 1 +test utf-6.74.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0]G +} 4 +test utf-6.75.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] +} 1 +test utf-6.75.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] +} 4 +test utf-6.76.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0] +} 1 +test utf-6.76.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0] +} 4 +test utf-6.77.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8] +} 1 +test utf-6.77.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8] +} 4 +test utf-6.78.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2] +} 1 +test utf-6.78.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2] +} 4 +test utf-6.79.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8] +} 1 +test utf-6.79.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8] +} 4 +test utf-6.80 {Tcl_UtfNext - overlong sequences} testutfnext { + testutfnext \x00 +} 2 +test utf-6.81 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xC0\x81] +} 1 +test utf-6.82 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xC1\x80] +} 1 +test utf-6.83 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xC2\x80] +} 2 +test utf-6.84 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xE0\x80\x80] +} 1 +test utf-6.85 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xE0\xA0\x80] +} 3 +test utf-6.86 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xF0\x80\x80\x80] +} 1 +test utf-6.87.0 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs2_utf16} { + testutfnext [testbytestring \xF0\x90\x80\x80] +} 1 +test utf-6.87.1 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs4} { + testutfnext [testbytestring \xF0\x90\x80\x80] +} 4 +test utf-6.88 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\x00] +} 2 +test utf-6.89 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring} { + testutfnext [testbytestring \x80\x80\x00] +} 2 +test utf-6.90.0 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs2_utf16} { + testutfnext [testbytestring \xF4\x8F\xBF\xBF] +} 1 +test utf-6.90.1 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs4} { + testutfnext [testbytestring \xF4\x8F\xBF\xBF] +} 4 +test utf-6.91 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring} { + testutfnext [testbytestring \xF4\x90\x80\x80] +} 1 +test utf-6.92 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\xA0] +} 3 +test utf-6.93 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring} { + testutfnext [testbytestring \x80\x80\x80] +} 3 +test utf-6.94 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xA0\xA0\xA0] +} 3 +test utf-6.95 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} { + testutfnext [testbytestring \x80\x80\x80\x80] +} 3 + +test utf-7.1 {Tcl_UtfPrev} testutfprev { + testutfprev {} +} 0 +test utf-7.2 {Tcl_UtfPrev} testutfprev { + testutfprev A +} 0 +test utf-7.3 {Tcl_UtfPrev} testutfprev { + testutfprev AA +} 1 +test utf-7.4 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8] +} 1 +test utf-7.4.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 2 +} 1 +test utf-7.4.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xF8\xA0\xA0] 2 +} 1 +test utf-7.5 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF2] +} 1 +test utf-7.5.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 2 +} 1 +test utf-7.5.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF2\xF8\xA0\xA0] 2 +} 1 +test utf-7.6 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8] +} 1 +test utf-7.6.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A\u8820[testbytestring \xA0] 2 +} 1 +test utf-7.6.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xF8\xA0\xA0] 2 +} 1 +test utf-7.7 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0] +} 1 +test utf-7.7.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 2 +} 1 +test utf-7.7.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xF8\xA0\xA0] 2 +} 1 +test utf-7.8 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0] +} 1 +test utf-7.8.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 2 +} 1 +test utf-7.8.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xF8\xA0\xA0] 2 +} 1 +test utf-7.9 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0] +} 2 +test utf-7.9.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 3 +} 2 +test utf-7.9.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xF8\xA0] 3 +} 2 +test utf-7.10.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0] +} 2 +test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0] +} 1 +test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3 +} 2 +test utf-7.10.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3 +} 1 +test utf-7.10.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3 +} 2 +test utf-7.10.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3 +} 1 +test utf-7.11 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xA0] +} 1 +test utf-7.11.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A\u8820[testbytestring \xA0] 3 +} 1 +test utf-7.11.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xA0\xF8\xA0] 3 +} 1 +test utf-7.11.3 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xA0\xF8] 3 +} 1 +test utf-7.12 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0] +} 1 +test utf-7.12.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 3 +} 1 +test utf-7.12.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xF8\xA0] 3 +} 1 +test utf-7.13 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0] +} 2 +test utf-7.13.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 3 +} 2 +test utf-7.13.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xF8\xA0] 3 +} 2 +test utf-7.14 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0] +} 3 +test utf-7.14.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 4 +} 3 +test utf-7.14.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xF8] 4 +} 3 +test utf-7.15.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0] +} 3 +test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0] +} 1 +test utf-7.15.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4 +} 3 +test utf-7.15.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4 +} 1 +test utf-7.15.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4 +} 3 +test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4 +} 1 +test utf-7.16 {Tcl_UtfPrev} testutfprev { + testutfprev A\u8820 +} 1 +test utf-7.16.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A\u8820[testbytestring \xA0] 4 +} 1 +test utf-7.16.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A\u8820[testbytestring \xF8] 4 +} 1 +test utf-7.17 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0] +} 3 +test utf-7.17.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 4 +} 3 +test utf-7.17.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xF8] 4 +} 3 +test utf-7.18.0 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { + testutfprev A[testbytestring \xA0\xA0\xA0] +} 1 +test utf-7.18.1 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { + testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 4 +} 1 +test utf-7.18.2 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { + testutfprev A[testbytestring \xA0\xA0\xA0\xF8] 4 +} 1 +test utf-7.19 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { + testutfprev A[testbytestring \xF8\xA0\xA0\xA0] +} 2 +test utf-7.20 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] +} 2 +test utf-7.21 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { + testutfprev A\u8820[testbytestring \xA0] +} 2 +test utf-7.22 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { + testutfprev A[testbytestring \xD0\xA0\xA0\xA0] +} 2 +test utf-7.23 {Tcl_UtfPrev} {testutfprev testbytestring utf16} { + testutfprev A[testbytestring \xA0\xA0\xA0\xA0] +} 2 +test utf-7.24 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xC0\x81] +} 2 +test utf-7.25 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xC0\x81] 2 +} 1 +test utf-7.26 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\x80\x80] +} 3 +test utf-7.27 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\x80] +} 2 +test utf-7.27.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\x80\x80] 3 +} 2 +test utf-7.28 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0] +} 1 +test utf-7.28.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\x80\x80] 2 +} 1 +test utf-7.29 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring utf16} { + testutfprev A[testbytestring \xF0\x80\x80\x80] +} 2 +test utf-7.30 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x80\x80\x80] 4 +} 3 +test utf-7.31 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x80\x80\x80] 3 +} 2 +test utf-7.32 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x80\x80\x80] 2 +} 1 +test utf-7.33 {Tcl_UtfPrev -- overlong sequence} testutfprev { + testutfprev A\x00 +} 1 +test utf-7.34 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xC1\x80] +} 2 +test utf-7.35 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xC2\x80] +} 1 +test utf-7.36 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\xA0\x80] +} 1 +test utf-7.37 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\xA0\x80] 3 +} 1 +test utf-7.38 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\xA0\x80] 2 +} 1 +test utf-7.39 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring utf16} { + testutfprev A[testbytestring \xF0\x90\x80\x80] +} 2 +test utf-7.40.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 4 +} 3 +test utf-7.40.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 4 +} 1 +test utf-7.41.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 3 +} 2 +test utf-7.41.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 3 +} 1 +test utf-7.42 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 2 +} 1 +test utf-7.43 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { + testutfprev [testbytestring \xA0] +} 0 +test utf-7.44 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { + testutfprev [testbytestring \xA0\xA0] +} 1 +test utf-7.45 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { + testutfprev [testbytestring \xA0\xA0\xA0] +} 2 +test utf-7.46 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring utf16} { + testutfprev [testbytestring \xA0\xA0\xA0\xA0] +} 1 +test utf-7.47 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} {testutfprev testbytestring} { + testutfprev [testbytestring \xE8\xA0] +} 0 +test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} testutfprev { + testutfprev \u8820 2 +} 0 +test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} { + testutfprev [testbytestring \xE8\xA0\x00] 2 +} 0 +test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring utf16} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] +} 2 +test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4 +} 3 +test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4 +} 1 +test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3 +} 2 +test utf-7.48.4 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3 +} 1 +test utf-7.48.5 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 2 +} 1 +test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring utf16} { + testutfprev A[testbytestring \xF4\x90\x80\x80] +} 2 +test utf-7.49.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x90\x80\x80] 4 +} 3 +test utf-7.49.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x90\x80\x80] 3 +} 2 +test utf-7.49.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x90\x80\x80] 2 +} 1 test utf-8.1 {Tcl_UniCharAtIndex: index = 0} { string index abcd 0 -} {a} +} a test utf-8.2 {Tcl_UniCharAtIndex: index = 0} { - string index \u4e4e\u25a 0 -} "\u4e4e" + string index \u4E4E\u25A 0 +} \u4E4E test utf-8.3 {Tcl_UniCharAtIndex: index > 0} { string index abcd 2 -} {c} +} c test utf-8.4 {Tcl_UniCharAtIndex: index > 0} { - string index \u4e4e\u25a\xff\u543 2 -} "\uff" + string index \u4E4E\u25A\xFF\u543 2 +} \xFF +test utf-8.5.0 {Tcl_UniCharAtIndex: high surrogate} ucs2 { + string index \uD842 0 +} \uD842 +test utf-8.5.1 {Tcl_UniCharAtIndex: high surrogate} ucs4 { + string index \uD842 0 +} \uD842 +test utf-8.5.2 {Tcl_UniCharAtIndex: high surrogate} utf16 { + string index \uD842 0 +} \uD842 +test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} { + string index \uDC42 0 +} \uDC42 +test utf-8.7.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index \uD83D\uDE00G 0 +} \uD83D +test utf-8.7.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index \uD83D\uDE00G 0 +} \U1F600 +test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index \uD83D\uDE00G 0 +} \U1F600 +test utf-8.8.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index \uD83D\uDE00G 1 +} \uDE00 +test utf-8.8.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index \uD83D\uDE00G 1 +} G +test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index \uD83D\uDE00G 1 +} {} +test utf-8.9.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index \uD83D\uDE00G 2 +} G +test utf-8.9.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index \uD83D\uDE00G 2 +} {} +test utf-8.9.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index \uD83D\uDE00G 2 +} G +test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} { + string index \U1F600G 0 +} \uFFFD +test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} { + string index \U1F600G 0 +} \U1F600 +test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} { + string index \U1F600G 0 +} \U1F600 +test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} { + string index \U1F600G 1 +} G +test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} { + string index \U1F600G 1 +} G +test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} { + string index \U1F600G 1 +} {} +test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} { + string index \U1F600G 2 +} {} +test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} { + string index \U1F600G 2 +} {} +test utf-8.12.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} { + string index \U1F600G 2 +} G test utf-9.1 {Tcl_UtfAtIndex: index = 0} { string range abcd 0 2 -} {abc} +} abc test utf-9.2 {Tcl_UtfAtIndex: index > 0} { - string range \u4e4e\u25a\xff\u543klmnop 1 5 -} "\u25a\xff\u543kl" - + string range \u4E4E\u25A\xFF\u543klmnop 1 5 +} \u25A\xFF\u543kl +test utf-9.3.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 { + string range \uD83D\uDE00G 0 0 +} \uD83D +test utf-9.3.1 {Tcl_UtfAtIndex: index = 0, Emoji} ucs4 { + string range \uD83D\uDE00G 0 0 +} \U1F600 +test utf-9.3.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 { + string range \uD83D\uDE00G 0 0 +} \U1F600 +test utf-9.4.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { + string range \uD83D\uDE00G 1 1 +} \uDE00 +test utf-9.4.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { + string range \uD83D\uDE00G 1 1 +} G +test utf-9.4.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { + string range \uD83D\uDE00G 1 1 +} {} +test utf-9.5.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { + string range \uD83D\uDE00G 2 2 +} G +test utf-9.5.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { + string range \uD83D\uDE00G 2 2 +} {} +test utf-9.5.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { + string range \uD83D\uDE00G 2 2 +} G +test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs2} { + string range \U1f600G 0 0 +} \uFFFD +test utf-9.6.1 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs4} { + string range \U1f600G 0 0 +} \U1F600 +test utf-9.6.2 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc utf16} { + string range \U1f600G 0 0 +} \U1F600 +test utf-9.7.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} { + string range \U1f600G 1 1 +} G +test utf-9.7.1 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs4} { + string range \U1f600G 1 1 +} G +test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc utf16} { + string range \U1f600G 1 1 +} {} +test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} { + string range \U1f600G 2 2 +} {} +test utf-9.8.1 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs4} { + string range \U1f600G 2 2 +} {} +test utf-9.8.2 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc utf16} { + string range \U1f600G 2 2 +} G test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { set x \n } { } -test utf-10.2 {Tcl_UtfBackslash: \u subst} { - set x \ua2 -} [bytestring "\xc2\xa2"] -test utf-10.3 {Tcl_UtfBackslash: longer \u subst} { - set x \u4e21 -} [bytestring "\xe4\xb8\xa1"] -test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} { - set x \u4e2k -} "[bytestring \xd3\xa2]k" -test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} { - set x \u4e216 -} "[bytestring \xe4\xb8\xa1]6" -proc bsCheck {char num} { +test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring { + expr {"\uA2" eq [testbytestring \xC2\xA2]} +} 1 +test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring { + expr {"\u4E21" eq [testbytestring \xE4\xB8\xA1]} +} 1 +test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring { + expr {"\u4E2k" eq "[testbytestring \xD3\xA2]k"} +} 1 +test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring { + expr {"\u4E216" eq "[testbytestring \xE4\xB8\xA1]6"} +} 1 +test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} {Uesc fullutf testbytestring} { + expr {"\U1E2165" eq "[testbytestring \xF0\x9E\x88\x96]5"} +} 1 +test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} {Uesc fullutf testbytestring} { + expr {"\U10E2165" eq "[testbytestring \xF4\x8E\x88\x96]5"} +} 1 + +proc bsCheck {char num {constraints {}}} { global errNum - test utf-10.$errNum {backslash substitution} { + test utf-10.$errNum {backslash substitution} $constraints { scan $char %c value set value } $num incr errNum } -set errNum 6 +set errNum 8 bsCheck \b 8 bsCheck \e 101 bsCheck \f 12 @@ -174,27 +1006,35 @@ bsCheck \x 120 bsCheck \xa 10 bsCheck \xA 10 bsCheck \x41 65 -bsCheck \x541 84 +bsCheck \x541 65 pre388 ;# == \x41 +bsCheck \x541 84 !pre388 ;# == \x54 1 bsCheck \u 117 bsCheck \uk 117 bsCheck \u41 65 bsCheck \ua 10 bsCheck \uA 10 bsCheck \340 224 -bsCheck \ua1 161 -bsCheck \u4e21 20001 -bsCheck \741 60 -bsCheck \U 85 -bsCheck \Uk 85 -bsCheck \U41 65 -bsCheck \Ua 10 -bsCheck \UA 10 -bsCheck \Ua1 161 -bsCheck \U4e21 20001 -bsCheck \U004e21 20001 -bsCheck \U00004e21 20001 -bsCheck \U00110000 65533 -bsCheck \Uffffffff 65533 +bsCheck \uA1 161 +bsCheck \u4E21 20001 +bsCheck \741 225 pre388 ;# == \341 +bsCheck \741 60 !pre388 ;# == \74 1 +bsCheck \U 85 +bsCheck \Uk 85 +bsCheck \U41 65 Uesc +bsCheck \Ua 10 Uesc +bsCheck \UA 10 Uesc +bsCheck \UA1 161 Uesc +bsCheck \U4E21 20001 Uesc +bsCheck \U004E21 20001 Uesc +bsCheck \U00004E21 20001 Uesc +bsCheck \U0000004E21 78 Uesc +bsCheck \U00110000 69632 {Uesc fullutf} +bsCheck \U01100000 69632 {Uesc fullutf} +bsCheck \U11000000 69632 {Uesc fullutf} +bsCheck \U0010FFFF 1114111 {Uesc fullutf} +bsCheck \U010FFFF0 1114111 {Uesc fullutf} +bsCheck \U10FFFF00 1114111 {Uesc fullutf} +bsCheck \UFFFFFFFF 1048575 {Uesc fullutf} test utf-11.1 {Tcl_UtfToUpper} { string toupper {} @@ -203,11 +1043,23 @@ test utf-11.2 {Tcl_UtfToUpper} { string toupper abc } ABC test utf-11.3 {Tcl_UtfToUpper} { - string toupper \u00e3ab -} \u00c3AB + string toupper \xE3gh +} \xC3GH test utf-11.4 {Tcl_UtfToUpper} { - string toupper \u01e3ab -} \u01e2AB + string toupper \u01E3gh +} \u01E2GH +test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} { + string toupper \u10D0\u1C90 +} \u1C90\u1C90 +test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} {Uesc fullutf} { + string toupper \U10428 +} \U10400 +test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} fullutf { + string toupper \uD801\uDC28 +} \uD801\uDC00 +test utf-11.8 {Tcl_UtfToUpper low/high surrogate)} { + string toupper \uDC24\uD824 +} \uDC24\uD824 test utf-12.1 {Tcl_UtfToLower} { string tolower {} @@ -216,11 +1068,23 @@ test utf-12.2 {Tcl_UtfToLower} { string tolower ABC } abc test utf-12.3 {Tcl_UtfToLower} { - string tolower \u00c3AB -} \u00e3ab + string tolower \xC3GH +} \xE3gh test utf-12.4 {Tcl_UtfToLower} { - string tolower \u01e2AB -} \u01e3ab + string tolower \u01E2GH +} \u01E3gh +test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} { + string tolower \u10D0\u1C90 +} \u10D0\u10D0 +test utf-12.6 {Tcl_UtfToLower low/high surrogate)} { + string tolower \uDC24\uD824 +} \uDC24\uD824 +test utf-12.7 {Tcl_UtfToLower beyond U+FFFF} {Uesc fullutf} { + string tolower \U10400 +} \U10428 +test utf-12.8 {Tcl_UtfToLower beyond U+FFFF} fullutf { + string tolower \uD801\uDC00 +} \uD801\uDC28 test utf-13.1 {Tcl_UtfToTitle} { string totitle {} @@ -229,11 +1093,26 @@ test utf-13.2 {Tcl_UtfToTitle} { string totitle abc } Abc test utf-13.3 {Tcl_UtfToTitle} { - string totitle \u00e3ab -} \u00c3ab + string totitle \xE3GH +} \xC3gh test utf-13.4 {Tcl_UtfToTitle} { - string totitle \u01f3ab -} \u01f2ab + string totitle \u01F3AB +} \u01F2ab +test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { + string totitle \u10D0\u1C90 +} \u10D0\u1C90 +test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { + string totitle \u1C90\u10D0 +} \u1C90\u10D0 +test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} { + string totitle \uDC24\uD824 +} \uDC24\uD824 +test utf-13.8 {Tcl_UtfToTitle beyond U+FFFF} {Uesc fullutf} { + string totitle \U10428\U10400 +} \U10400\U10428 +test utf-13.9 {Tcl_UtfToTitle beyond U+FFFF} fullutf { + string totitle \uD801\uDC28\uD801\uDC00 +} \uD801\uDC00\uD801\uDC28 test utf-14.1 {Tcl_UtfNcasecmp} { string compare -nocase a b @@ -252,7 +1131,7 @@ test utf-15.1 {Tcl_UniCharToUpper, negative delta} { string toupper aA } AA test utf-15.2 {Tcl_UniCharToUpper, positive delta} { - string toupper \u0178\u00ff + string toupper \u0178\xFF } \u0178\u0178 test utf-15.3 {Tcl_UniCharToUpper, no delta} { string toupper ! @@ -262,182 +1141,203 @@ test utf-16.1 {Tcl_UniCharToLower, negative delta} { string tolower aA } aa test utf-16.2 {Tcl_UniCharToLower, positive delta} { - string tolower \u0178\u00ff\uA78D\u01c5 -} \u00ff\u00ff\u0265\u01c6 + string tolower \u0178\xFF\uA78D\u01C5 +} \xFF\xFF\u0265\u01C6 test utf-17.1 {Tcl_UniCharToLower, no delta} { string tolower ! } ! test utf-18.1 {Tcl_UniCharToTitle, add one for title} { - string totitle \u01c4 -} \u01c5 + string totitle \u01C4 +} \u01C5 test utf-18.2 {Tcl_UniCharToTitle, subtract one for title} { - string totitle \u01c6 -} \u01c5 + string totitle \u01C6 +} \u01C5 test utf-18.3 {Tcl_UniCharToTitle, subtract delta for title (positive)} { - string totitle \u017f -} \u0053 + string totitle \u017F +} \x53 test utf-18.4 {Tcl_UniCharToTitle, subtract delta for title (negative)} { - string totitle \u00ff + string totitle \xFF } \u0178 test utf-18.5 {Tcl_UniCharToTitle, no delta} { string totitle ! } ! -test utf-19.1 {TclUniCharLen} { +test utf-19.1 {TclUniCharLen} -body { list [regexp \\d abc456def foo] $foo -} {1 4} +} -cleanup { + unset -nocomplain foo +} -result {1 4} -test utf-20.1 {TclUniCharNcmp} { -} {} +test utf-20.1 {TclUniCharNcmp} ucs4 { + string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0] +} -1 +test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} ucs2 { + set one [format %c 0xFFFF] + set two [format %c 0x10000] + set first [string compare $one $two] + string range $one 0 0 + string range $two 0 0 + set second [string compare $one $two] + expr {($first == $second) ? "agree" : "disagree"} +} agree +test utf-20.2.1 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} {utf16 knownBug} { + set one [format %c 0xFFFF] + set two [format %c 0x10000] + set first [string compare $one $two] + string range $one 0 0 + string range $two 0 0 + set second [string compare $one $two] + expr {($first == $second) ? "agree" : "disagree"} +} agree +test utf-20.2.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} ucs4 { + set one [format %c 0xFFFF] + set two [format %c 0x10000] + set first [string compare $one $two] + string range $one 0 0 + string range $two 0 0 + set second [string compare $one $two] + expr {($first == $second) ? "agree" : "disagree"} +} agree test utf-21.1 {TclUniCharIsAlnum} { - # this returns 1 with Unicode 6 compliance - string is alnum \u1040\u021f\u0220 -} {1} + # 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 - list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220] + # this returns 1 with Unicode 7 compliance + list [regexp {^[[:alnum:]]+$} \u1040\u021F\u0220] [regexp {^\w+$} \u1040\u021F\u0220_\u203F\u2040\u2054\uFE33\uFE34\uFE4D\uFE4E\uFE4F\uFF3F] } {1 1} test utf-21.3 {unicode print char in regc_locale.c} { - # this returns 1 with Unicode 6 compliance - regexp {^[[:print:]]+$} \ufbc1 + # this returns 1 with Unicode 7 compliance + regexp {^[[:print:]]+$} \uFBC1 } 1 test utf-21.4 {TclUniCharIsGraph} { # [Bug 3464428] string is graph \u0120 -} {1} +} 1 test utf-21.5 {unicode graph char in regc_locale.c} { # [Bug 3464428] regexp {^[[:graph:]]+$} \u0120 -} {1} +} 1 test utf-21.6 {TclUniCharIsGraph} { # [Bug 3464428] - string is graph \u00a0 -} {0} + string is graph \xA0 +} 0 test utf-21.7 {unicode graph char in regc_locale.c} { # [Bug 3464428] - regexp {[[:graph:]]} \u0020\u00a0\u2028\u2029 -} {0} + regexp {[[:graph:]]} \x20\xA0\u2028\u2029 +} 0 test utf-21.8 {TclUniCharIsPrint} { # [Bug 3464428] - string is print \u0009 -} {0} + string is print \x09 +} 0 test utf-21.9 {unicode print char in regc_locale.c} { # [Bug 3464428] - regexp {[[:print:]]} \u0009 -} {0} + regexp {[[:print:]]} \x09 +} 0 test utf-21.10 {unicode print char in regc_locale.c} { # [Bug 3464428] - regexp {[[:print:]]} \u0009 -} {0} + regexp {[[:print:]]} \x09 +} 0 test utf-21.11 {TclUniCharIsControl} { # [Bug 3464428] - string is control \u00ad -} {1} + string is control \x00\x1F\xAD\u0605\u061C\u180E\u2066\uFEFF +} 1 test utf-21.12 {unicode control char in regc_locale.c} { - # [Bug 3464428] - regexp {^[[:cntrl:]]$} \u00ad -} {1} + # [Bug 3464428], [Bug a876646efe] + regexp {^[[:cntrl:]]*$} \x00\x1F\xAD\u0605\u061C\u180E\u2066\uFEFF +} 1 test utf-22.1 {TclUniCharIsWordChar} { string wordend "xyz123_bar fg" 0 } 10 test utf-22.2 {TclUniCharIsWordChar} { - string wordend "x\u5080z123_bar\u203c fg" 0 + string wordend "x\u5080z123_bar\u203C fg" 0 } 10 test utf-23.1 {TclUniCharIsAlpha} { - # this returns 1 with Unicode 6 compliance - string is alpha \u021f\u0220 -} {1} + # 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 -} {1} + # 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 - string is digit \u1040\uabf0 -} {1} + # 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 - list [regexp {^[[:digit:]]+$} \u1040\uabf0] [regexp {^\d+$} \u1040\uabf0] + # 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 -} {1} + # 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} +test utf-24.5 {TclUniCharIsSpace} tip413 { + # this returns 1 with Unicode 7/TIP 413 compliance + string is space \x85\u1680\u180E\u200B\u202F\u2060 +} 1 +test utf-24.6 {unicode space char in regc_locale.c} tip413 { + # this returns 1 with Unicode 7/TIP 413 compliance + list [regexp {^[[:space:]]+$} \x85\u1680\u180E\u200B\u202F\u2060] [regexp {^\s+$} \x85\u1680\u180E\u200B\u202F\u2060] } {1 1} -testConstraint teststringobj [llength [info commands teststringobj]] - -test utf-25.1 {Tcl_UniCharNcasecmp} -constraints teststringobj \ - -setup { - testobj freeallvars - } \ - -body { - teststringobj set 1 a - teststringobj set 2 b - teststringobj getunicode 1 - teststringobj getunicode 2 - string compare -nocase [teststringobj get 1] [teststringobj get 2] - } \ - -cleanup { - testobj freeallvars - } \ - -result -1 -test utf-25.2 {Tcl_UniCharNcasecmp} -constraints teststringobj \ - -setup { - testobj freeallvars - } \ - -body { - teststringobj set 1 b - teststringobj set 2 a - teststringobj getunicode 1 - teststringobj getunicode 2 - string compare -nocase [teststringobj get 1] [teststringobj get 2] - } \ - -cleanup { - testobj freeallvars - } \ - -result 1 -test utf-25.3 {Tcl_UniCharNcasecmp} -constraints teststringobj \ - -setup { +proc UniCharCaseCmpTest {order one two {constraints {}}} { + variable count + test utf-25.$count {Tcl_UniCharNcasecmp} -setup { testobj freeallvars - } \ - -body { - teststringobj set 1 B - teststringobj set 2 a - teststringobj getunicode 1 - teststringobj getunicode 2 - string compare -nocase [teststringobj get 1] [teststringobj get 2] - } \ - -cleanup { + } -constraints [linsert $constraints 0 teststringobj] -cleanup { testobj freeallvars - } \ - -result 1 + } -body { + teststringobj set 1 $one + teststringobj set 2 $two + teststringobj maxchars 1 + teststringobj maxchars 2 + set result [string compare -nocase [teststringobj get 1] [teststringobj get 2]] + if {$result eq [string map {< -1 = 0 > 1} $order]} { + set result ok + } else { + set result "'$one' should be $order '$two' (no case)" + } + set result + } -result ok + incr count +} +variable count 1 +UniCharCaseCmpTest < a b +UniCharCaseCmpTest > b a +UniCharCaseCmpTest > B a +UniCharCaseCmpTest > aBcB abca +UniCharCaseCmpTest < \uFFFF [format %c 0x10000] ucs4 +UniCharCaseCmpTest < \uFFFF \U10000 {Uesc ucs4} +UniCharCaseCmpTest > [format %c 0x10000] \uFFFF ucs4 +UniCharCaseCmpTest > \U10000 \uFFFF {Uesc ucs4} -test utf-25.4 {Tcl_UniCharNcasecmp} -constraints teststringobj \ - -setup { - testobj freeallvars - } \ - -body { - teststringobj set 1 aBcB - teststringobj set 2 abca - teststringobj getunicode 1 - teststringobj getunicode 2 - string compare -nocase [teststringobj get 1] [teststringobj get 2] - } \ - -cleanup { - testobj freeallvars - } \ - -result 1 + +test utf-26.1 {Tcl_UniCharDString} -setup { + testobj freeallvars +} -constraints {teststringobj testbytestring} -cleanup { + testobj freeallvars +} -body { + teststringobj set 1 foo + teststringobj maxchars 1 + teststringobj append 1 [testbytestring barsoom\xF2\xC2\x80] 10 + scan [string index [teststringobj get 1] 11] %c +} -result 128 + + +unset count +rename UniCharCaseCmpTest {} # cleanup ::tcltest::cleanupTests diff --git a/tests/util.test b/tests/util.test index 0e50483..aa51004 100644 --- a/tests/util.test +++ b/tests/util.test @@ -1,24 +1,29 @@ # This file is a Tcl script to test the code in the file tclUtil.c. # This file is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1995-1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint controversialNaN 1 +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] testConstraint testconcatobj [llength [info commands testconcatobj]] testConstraint testdoubledigits [llength [info commands testdoubledigits]] +testConstraint testprint [llength [info commands testprint]] + +testConstraint precision [expr {![catch {set saved_precision $::tcl_precision}]}] + # Big test for correct ordering of data in [expr] @@ -207,7 +212,7 @@ test util-4.6 {Tcl_ConcatObj - utf-8 sequence with "whitespace" char} { } \xe0 test util-4.7 {Tcl_ConcatObj - refCount safety} testconcatobj { # Check for Bug #1447328 (actually, bugs in its original "fix"). One of the - # symptoms was Bug #2055782. + # symptoms was Bug #2055782. testconcatobj } {} @@ -274,10 +279,10 @@ test util-5.17 {Tcl_StringMatch: UTF-8} { # get 1 UTF-8 character Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc" } 1 -test util-5.18 {Tcl_StringMatch: UTF-8} { +test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # proper advance: wrong answer would match on UTF trail byte of \u4e4f - Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [bytestring a\u008fc] + Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\x8fc] } 0 test util-5.19 {Tcl_StringMatch: UTF-8} { # pattern += Tcl_UtfToUniChar(pattern, &endChar); @@ -382,8 +387,12 @@ test util-5.50 {Tcl_StringMatch} { test util-5.51 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch "" "" } 1 +test util-5.52 {Tcl_StringMatch} { + Wrapper_Tcl_StringMatch \[a\u0000 a\x80 +} 0 + -test util-6.1 {Tcl_PrintDouble - using tcl_precision} -setup { +test util-6.1 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { set old_precision $::tcl_precision set ::tcl_precision 12 } -body { @@ -391,7 +400,7 @@ test util-6.1 {Tcl_PrintDouble - using tcl_precision} -setup { } -cleanup { set ::tcl_precision $old_precision } -result {x1.4} -test util-6.2 {Tcl_PrintDouble - using tcl_precision} -setup { +test util-6.2 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { set old_precision $::tcl_precision set ::tcl_precision 12 } -body { @@ -399,7 +408,7 @@ test util-6.2 {Tcl_PrintDouble - using tcl_precision} -setup { } -cleanup { set ::tcl_precision $old_precision } -result {x1.39999999999} -test util-6.3 {Tcl_PrintDouble - using tcl_precision} -setup { +test util-6.3 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { set old_precision $::tcl_precision set ::tcl_precision 12 } -body { @@ -407,7 +416,7 @@ test util-6.3 {Tcl_PrintDouble - using tcl_precision} -setup { } -cleanup { set ::tcl_precision $old_precision } -result {x1.4} -test util-6.4 {Tcl_PrintDouble - using tcl_precision} -setup { +test util-6.4 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { set old_precision $::tcl_precision set ::tcl_precision 5 } -body { @@ -422,7 +431,7 @@ test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr 3.0e98] } {x3e+98} -test util-7.1 {TclPrecTraceProc - unset callbacks} -setup { +test util-7.1 {TclPrecTraceProc - unset callbacks} -constraints precision -setup { set old_precision $::tcl_precision } -body { set tcl_precision 7 @@ -432,7 +441,7 @@ test util-7.1 {TclPrecTraceProc - unset callbacks} -setup { } -cleanup { set ::tcl_precision $old_precision } -result {7 7} -test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -setup { +test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -constraints precision -setup { set old_precision $::tcl_precision } -body { set tcl_precision 12 @@ -444,7 +453,7 @@ test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -set } -cleanup { set ::tcl_precision $old_precision } -result {12 6} -test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -setup { +test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -constraints precision -setup { set old_precision $::tcl_precision } -body { set tcl_precision 12 @@ -457,7 +466,7 @@ test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -setup { } -cleanup { set ::tcl_precision $old_precision } -result {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12} -test util-7.4 {TclPrecTraceProc - write traces, bogus values} -setup { +test util-7.4 {TclPrecTraceProc - write traces, bogus values} -constraints precision -setup { set old_precision $::tcl_precision } -body { set tcl_precision 12 @@ -467,7 +476,7 @@ test util-7.4 {TclPrecTraceProc - write traces, bogus values} -setup { } -result {1 {can't set "tcl_precision": improper value for precision} 12} # This test always succeeded in the C locale anyway... -test util-8.1 {TclNeedSpace - correct UTF8 handling} { +test util-8.1 {TclNeedSpace - correct utf-8 handling} { # Bug 411825 # Note that this test relies on the fact that # [interp target] calls on Tcl_AppendElement() @@ -481,7 +490,7 @@ test util-8.1 {TclNeedSpace - correct UTF8 handling} { interp delete \u5420 set result } "\u5420 foo" -test util-8.2 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.2 {TclNeedSpace - correct utf-8 handling} testdstring { # Bug 411825 # This tests the same bug as the previous test, but # should be more future-proof, as the DString @@ -491,14 +500,14 @@ test util-8.2 {TclNeedSpace - correct UTF8 handling} testdstring { testdstring element foo llength [testdstring get] } 2 -test util-8.3 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.3 {TclNeedSpace - correct utf-8 handling} testdstring { # Bug 411825 - new variant reported by Dossy Shiobara testdstring free testdstring append \u00A0 -1 testdstring element foo llength [testdstring get] } 2 -test util-8.4 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.4 {TclNeedSpace - correct utf-8 handling} testdstring { # Another bug uncovered while fixing 411825 testdstring free testdstring append {\ } -1 @@ -506,209 +515,312 @@ test util-8.4 {TclNeedSpace - correct UTF8 handling} testdstring { testdstring element foo llength [testdstring get] } 2 -test util-8.5 {TclNeedSpace - correct UTF8 handling} testdstring { - # Note that in this test TclNeedSpace actually gets it wrong, - # claiming we need a space when we really do not. Extra space - # between list elements is harmless though, and better to have - # extra space in really weird string reps of lists, than to - # invest the effort required to make TclNeedSpace foolproof. +test util-8.5 {TclNeedSpace - correct utf-8 handling} testdstring { testdstring free testdstring append {\\ } -1 testdstring element foo list [llength [testdstring get]] [string length [testdstring get]] -} {2 7} -test util-8.6 {TclNeedSpace - correct UTF8 handling} testdstring { - # Another example of TclNeedSpace harmlessly getting it wrong. +} {2 6} +test util-8.6 {TclNeedSpace - correct utf-8 handling} testdstring { testdstring free testdstring append {\\ } -1 testdstring append \{ -1 testdstring element foo testdstring append \} -1 list [llength [testdstring get]] [string length [testdstring get]] -} {2 9} +} {2 8} +test util-8.7 {TclNeedSpace - watch out for escaped space} testdstring { + testdstring free + testdstring append {\ } -1 + testdstring start + testdstring end + + # Should make {\ {}} + list [llength [testdstring get]] [string index [testdstring get] 3] +} {2 \{} +test util-8.8 {TclNeedSpace - watch out for escaped space} testdstring { + testdstring free + testdstring append {\\ } -1 + testdstring start + testdstring end + + # Should make {\\ {}} + list [llength [testdstring get]] [string index [testdstring get] 3] +} {2 \{} +test util-8.9 {TclNeedSpace - watch out for escaped space} testdstring { + testdstring free + testdstring append {\\\ } -1 + testdstring start + testdstring end + + # Should make {\\\ {}} + list [llength [testdstring get]] [string index [testdstring get] 5] +} {2 \{} +test util-8.10 {TclNeedSpace - watch out for escaped space} testdstring { + testdstring free + testdstring append {\\\\\\\ } -1 + testdstring start + testdstring end -test util-9.0.0 {TclGetIntForIndex} { + # Should make {\\\\\\\ {}} + list [llength [testdstring get]] [string index [testdstring get] 9] +} {2 \{} +test util-8.11 {TclNeedSpace - watch out for escaped space} testdstring { + testdstring free + testdstring append {\\\\\\\\ } -1 + testdstring start + testdstring end + + # Should make {\\\\\\\\ {}} + list [llength [testdstring get]] [string index [testdstring get] 9] +} {2 \{} + +test util-9.0.0 {Tcl_GetIntForIndex} { string index abcd 0 } a -test util-9.0.1 {TclGetIntForIndex} { +test util-9.0.1 {Tcl_GetIntForIndex} { string index abcd 0x0 } a -test util-9.0.2 {TclGetIntForIndex} { +test util-9.0.2 {Tcl_GetIntForIndex} { string index abcd -0x0 } a -test util-9.0.3 {TclGetIntForIndex} { +test util-9.0.3 {Tcl_GetIntForIndex} { string index abcd { 0 } } a -test util-9.0.4 {TclGetIntForIndex} { +test util-9.0.4 {Tcl_GetIntForIndex} { string index abcd { 0x0 } } a -test util-9.0.5 {TclGetIntForIndex} { +test util-9.0.5 {Tcl_GetIntForIndex} { string index abcd { -0x0 } } a -test util-9.0.6 {TclGetIntForIndex} { +test util-9.0.6 {Tcl_GetIntForIndex} { string index abcd 01 } b -test util-9.0.7 {TclGetIntForIndex} { +test util-9.0.7 {Tcl_GetIntForIndex} { string index abcd { 01 } } b -test util-9.1.0 {TclGetIntForIndex} { +test util-9.0.8 {Tcl_GetIntForIndex} { + string index abcd { 0d0 } +} a +test util-9.0.9 {Tcl_GetIntForIndex} { + string index abcd { -0d0 } +} a +test util-9.1.0 {Tcl_GetIntForIndex} { string index abcd 3 } d -test util-9.1.1 {TclGetIntForIndex} { +test util-9.1.1 {Tcl_GetIntForIndex} { string index abcd { 3 } } d -test util-9.1.2 {TclGetIntForIndex} { +test util-9.1.2 {Tcl_GetIntForIndex} { string index abcdefghijk 0xa } k -test util-9.1.3 {TclGetIntForIndex} { +test util-9.1.3 {Tcl_GetIntForIndex} { string index abcdefghijk { 0xa } } k -test util-9.2.0 {TclGetIntForIndex} { +test util-9.1.4 {Tcl_GetIntForIndex} { + string index abcdefghijk 0d10 +} k +test util-9.1.5 {Tcl_GetIntForIndex} { + string index abcdefghijk { 0d10 } +} k +test util-9.2.0 {Tcl_GetIntForIndex} { string index abcd end -} d -test util-9.2.1 {TclGetIntForIndex} -body { +} d +test util-9.2.1 {Tcl_GetIntForIndex} -body { string index abcd { end} } -returnCodes error -match glob -result * -test util-9.2.2 {TclGetIntForIndex} -body { +test util-9.2.2 {Tcl_GetIntForIndex} -body { string index abcd {end } } -returnCodes error -match glob -result * -test util-9.3 {TclGetIntForIndex} { +test util-9.3 {Tcl_GetIntForIndex} -body { # Deprecated string index abcd en -} d -test util-9.4 {TclGetIntForIndex} { +} -returnCodes error -match glob -result * +test util-9.4 {Tcl_GetIntForIndex} -body { # Deprecated string index abcd e -} d -test util-9.5.0 {TclGetIntForIndex} { +} -returnCodes error -match glob -result * +test util-9.5.0 {Tcl_GetIntForIndex} { string index abcd end-1 } c -test util-9.5.1 {TclGetIntForIndex} { +test util-9.5.1 {Tcl_GetIntForIndex} { string index abcd {end-1 } } c -test util-9.5.2 {TclGetIntForIndex} -body { +test util-9.5.2 {Tcl_GetIntForIndex} -body { string index abcd { end-1} } -returnCodes error -match glob -result * -test util-9.6 {TclGetIntForIndex} { +test util-9.6 {Tcl_GetIntForIndex} { string index abcd end+-1 } c -test util-9.7 {TclGetIntForIndex} { +test util-9.7 {Tcl_GetIntForIndex} { string index abcd end+1 } {} -test util-9.8 {TclGetIntForIndex} { +test util-9.8 {Tcl_GetIntForIndex} { string index abcd end--1 } {} -test util-9.9.0 {TclGetIntForIndex} { +test util-9.9.0 {Tcl_GetIntForIndex} { string index abcd 0+0 } a -test util-9.9.1 {TclGetIntForIndex} { +test util-9.9.1 {Tcl_GetIntForIndex} { string index abcd { 0+0 } } a -test util-9.10 {TclGetIntForIndex} { +test util-9.10 {Tcl_GetIntForIndex} { string index abcd 0-0 } a -test util-9.11 {TclGetIntForIndex} { +test util-9.11 {Tcl_GetIntForIndex} { string index abcd 1+0 } b -test util-9.12 {TclGetIntForIndex} { +test util-9.12 {Tcl_GetIntForIndex} { string index abcd 1-0 } b -test util-9.13 {TclGetIntForIndex} { +test util-9.13 {Tcl_GetIntForIndex} { string index abcd 1+1 } c -test util-9.14 {TclGetIntForIndex} { +test util-9.14 {Tcl_GetIntForIndex} { string index abcd 1-1 } a -test util-9.15 {TclGetIntForIndex} { +test util-9.15 {Tcl_GetIntForIndex} { string index abcd -1+2 } b -test util-9.16 {TclGetIntForIndex} { +test util-9.16 {Tcl_GetIntForIndex} { string index abcd -1--2 } b -test util-9.17 {TclGetIntForIndex} { +test util-9.17 {Tcl_GetIntForIndex} { string index abcd { -1+2 } } b -test util-9.18 {TclGetIntForIndex} { +test util-9.18 {Tcl_GetIntForIndex} { string index abcd { -1--2 } } b -test util-9.19 {TclGetIntForIndex} -body { +test util-9.19 {Tcl_GetIntForIndex} -body { string index a {} } -returnCodes error -match glob -result * -test util-9.20 {TclGetIntForIndex} -body { +test util-9.20 {Tcl_GetIntForIndex} -body { string index a { } } -returnCodes error -match glob -result * -test util-9.21 {TclGetIntForIndex} -body { +test util-9.21 {Tcl_GetIntForIndex} -body { string index a " \r\t\n" } -returnCodes error -match glob -result * -test util-9.22 {TclGetIntForIndex} -body { +test util-9.22 {Tcl_GetIntForIndex} -body { string index a + } -returnCodes error -match glob -result * -test util-9.23 {TclGetIntForIndex} -body { +test util-9.23 {Tcl_GetIntForIndex} -body { string index a - } -returnCodes error -match glob -result * -test util-9.24 {TclGetIntForIndex} -body { +test util-9.24 {Tcl_GetIntForIndex} -body { string index a x } -returnCodes error -match glob -result * -test util-9.25 {TclGetIntForIndex} -body { +test util-9.25 {Tcl_GetIntForIndex} -body { string index a +x } -returnCodes error -match glob -result * -test util-9.26 {TclGetIntForIndex} -body { +test util-9.26 {Tcl_GetIntForIndex} -body { string index a -x } -returnCodes error -match glob -result * -test util-9.27 {TclGetIntForIndex} -body { +test util-9.27 {Tcl_GetIntForIndex} -body { string index a 0y } -returnCodes error -match glob -result * -test util-9.28 {TclGetIntForIndex} -body { +test util-9.28 {Tcl_GetIntForIndex} -body { string index a 1* } -returnCodes error -match glob -result * -test util-9.29 {TclGetIntForIndex} -body { +test util-9.29 {Tcl_GetIntForIndex} -body { string index a 0+ } -returnCodes error -match glob -result * -test util-9.30 {TclGetIntForIndex} -body { +test util-9.30 {Tcl_GetIntForIndex} -body { string index a {0+ } } -returnCodes error -match glob -result * -test util-9.31 {TclGetIntForIndex} -body { +test util-9.31 {Tcl_GetIntForIndex} -body { string index a 0x } -returnCodes error -match glob -result * -test util-9.32 {TclGetIntForIndex} -body { - string index a 0x1FFFFFFFF+0 +test util-9.31.1 {Tcl_GetIntForIndex} -body { + string index a 0d } -returnCodes error -match glob -result * -test util-9.33 {TclGetIntForIndex} -body { +test util-9.32 {Tcl_GetIntForIndex} -body { + string index a 0x1FFFFFFFF+0 +} -result {} +test util-9.33 {Tcl_GetIntForIndex} -body { string index a 100000000000+0 -} -returnCodes error -match glob -result * -test util-9.34 {TclGetIntForIndex} -body { +} -result {} +test util-9.33.1 {Tcl_GetIntForIndex} -body { + string index a 0d100000000000+0 +} -result {} +test util-9.34 {Tcl_GetIntForIndex} -body { string index a 1.0 } -returnCodes error -match glob -result * -test util-9.35 {TclGetIntForIndex} -body { +test util-9.35 {Tcl_GetIntForIndex} -body { string index a 1e23 } -returnCodes error -match glob -result * -test util-9.36 {TclGetIntForIndex} -body { +test util-9.36 {Tcl_GetIntForIndex} -body { string index a 1.5e2 } -returnCodes error -match glob -result * -test util-9.37 {TclGetIntForIndex} -body { +test util-9.37 {Tcl_GetIntForIndex} -body { string index a 0+x } -returnCodes error -match glob -result * -test util-9.38 {TclGetIntForIndex} -body { +test util-9.38 {Tcl_GetIntForIndex} -body { string index a 0+0x } -returnCodes error -match glob -result * -test util-9.39 {TclGetIntForIndex} -body { +test util-9.39 {Tcl_GetIntForIndex} -body { string index a 0+0xg } -returnCodes error -match glob -result * -test util-9.40 {TclGetIntForIndex} -body { +test util-9.40 {Tcl_GetIntForIndex} -body { string index a 0+0xg } -returnCodes error -match glob -result * -test util-9.41 {TclGetIntForIndex} -body { +test util-9.41 {Tcl_GetIntForIndex} -body { string index a 0+1.0 } -returnCodes error -match glob -result * -test util-9.42 {TclGetIntForIndex} -body { +test util-9.42 {Tcl_GetIntForIndex} -body { string index a 0+1e2 } -returnCodes error -match glob -result * -test util-9.43 {TclGetIntForIndex} -body { +test util-9.43 {Tcl_GetIntForIndex} -body { string index a 0+1.5e1 } -returnCodes error -match glob -result * -test util-9.44 {TclGetIntForIndex} -body { +test util-9.44 {Tcl_GetIntForIndex} -body { string index a 0+1000000000000 +} -result {} +test util-9.45 {Tcl_GetIntForIndex} -body { + string index abcd end+2305843009213693950 +} -result {} +test util-9.46 {Tcl_GetIntForIndex} -body { + string index abcd end+4294967294 +} -result {} +# TIP 502 +test util-9.47 {Tcl_GetIntForIndex} -body { + string index abcd 0x10000000000000000 +} -result {} +test util-9.48 {Tcl_GetIntForIndex} { + string index abcd -0x10000000000000000 +} {} +test util-9.49 {Tcl_GetIntForIndex} -body { + string index abcd end*1 +} -returnCodes error -match glob -result * +test util-9.50 {Tcl_GetIntForIndex} -body { + string index abcd {end- 1} +} -returnCodes error -match glob -result * +test util-9.51 {Tcl_GetIntForIndex} -body { + string index abcd end-end +} -returnCodes error -match glob -result * +test util-9.52 {Tcl_GetIntForIndex} -body { + string index abcd end-x } -returnCodes error -match glob -result * +test util-9.53 {Tcl_GetIntForIndex} -body { + string index abcd end-0.1 +} -returnCodes error -match glob -result * +test util-9.54 {Tcl_GetIntForIndex} { + string index abcd end-0x10000000000000000 +} {} +test util-9.55 {Tcl_GetIntForIndex} -body { + string index abcd end+0x10000000000000000 +} -result {} +test util-9.56 {Tcl_GetIntForIndex} -body { + string index abcd end--0x10000000000000000 +} -result {} +test util-9.57 {Tcl_GetIntForIndex} { + string index abcd end+-0x10000000000000000 +} {} +test util-9.58 {Tcl_GetIntForIndex} -body { + string index abcd end--0x8000000000000000 +} -result {} +test util-9.59 {Tcl_GetIntForIndex} { + string index abcd 0-0x10000000000000000 +} {} test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x0000000000000000 @@ -2118,7 +2230,6 @@ test util-15.8 {smallest normal} {*}{ } } -set saved_precision $::tcl_precision foreach ::tcl_precision {0 12} { for {set e -312} {$e < -9} {incr e} { test util-16.1.$::tcl_precision.$e {shortening of numbers} \ @@ -2132,7 +2243,7 @@ for {set e -9} {$e < -4} {incr e} { } set tcl_precision 12 for {set e -9} {$e < -4} {incr e} { - test util-16.1.$::tcl_precision.$e {8.4 compatible formatting of doubles} \ + test util-16.1.$::tcl_precision.$e {8.4 compatible formatting of doubles} precision \ "expr 1.1e$e" 1.1e[format %+03d $e] } foreach ::tcl_precision {0 12} { @@ -2162,1828 +2273,1828 @@ foreach ::tcl_precision {0 12} { } } set tcl_precision 17 -test util-16.1.17.-300 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-300 {8.4 compatible formatting of doubles} precision \ {expr 1e-300} \ 1e-300 -test util-16.1.17.-299 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-299 {8.4 compatible formatting of doubles} precision \ {expr 1e-299} \ 9.9999999999999999e-300 -test util-16.1.17.-298 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-298 {8.4 compatible formatting of doubles} precision \ {expr 1e-298} \ 9.9999999999999991e-299 -test util-16.1.17.-297 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-297 {8.4 compatible formatting of doubles} precision \ {expr 1e-297} \ 1e-297 -test util-16.1.17.-296 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-296 {8.4 compatible formatting of doubles} precision \ {expr 1e-296} \ 1e-296 -test util-16.1.17.-295 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-295 {8.4 compatible formatting of doubles} precision \ {expr 1e-295} \ 1.0000000000000001e-295 -test util-16.1.17.-294 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-294 {8.4 compatible formatting of doubles} precision \ {expr 1e-294} \ 1e-294 -test util-16.1.17.-293 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-293 {8.4 compatible formatting of doubles} precision \ {expr 1e-293} \ 1.0000000000000001e-293 -test util-16.1.17.-292 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-292 {8.4 compatible formatting of doubles} precision \ {expr 1e-292} \ 1.0000000000000001e-292 -test util-16.1.17.-291 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-291 {8.4 compatible formatting of doubles} precision \ {expr 1e-291} \ 9.9999999999999996e-292 -test util-16.1.17.-290 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-290 {8.4 compatible formatting of doubles} precision \ {expr 1e-290} \ 1.0000000000000001e-290 -test util-16.1.17.-289 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-289 {8.4 compatible formatting of doubles} precision \ {expr 1e-289} \ 1e-289 -test util-16.1.17.-288 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-288 {8.4 compatible formatting of doubles} precision \ {expr 1e-288} \ 1.0000000000000001e-288 -test util-16.1.17.-287 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-287 {8.4 compatible formatting of doubles} precision \ {expr 1e-287} \ 1e-287 -test util-16.1.17.-286 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-286 {8.4 compatible formatting of doubles} precision \ {expr 1e-286} \ 1.0000000000000001e-286 -test util-16.1.17.-285 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-285 {8.4 compatible formatting of doubles} precision \ {expr 1e-285} \ 1.0000000000000001e-285 -test util-16.1.17.-284 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-284 {8.4 compatible formatting of doubles} precision \ {expr 1e-284} \ 1e-284 -test util-16.1.17.-283 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-283 {8.4 compatible formatting of doubles} precision \ {expr 1e-283} \ 9.9999999999999995e-284 -test util-16.1.17.-282 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-282 {8.4 compatible formatting of doubles} precision \ {expr 1e-282} \ 1e-282 -test util-16.1.17.-281 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-281 {8.4 compatible formatting of doubles} precision \ {expr 1e-281} \ 1e-281 -test util-16.1.17.-280 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-280 {8.4 compatible formatting of doubles} precision \ {expr 1e-280} \ 9.9999999999999996e-281 -test util-16.1.17.-279 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-279 {8.4 compatible formatting of doubles} precision \ {expr 1e-279} \ 1.0000000000000001e-279 -test util-16.1.17.-278 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-278 {8.4 compatible formatting of doubles} precision \ {expr 1e-278} \ 9.9999999999999994e-279 -test util-16.1.17.-277 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-277 {8.4 compatible formatting of doubles} precision \ {expr 1e-277} \ 9.9999999999999997e-278 -test util-16.1.17.-276 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-276 {8.4 compatible formatting of doubles} precision \ {expr 1e-276} \ 1.0000000000000001e-276 -test util-16.1.17.-275 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-275 {8.4 compatible formatting of doubles} precision \ {expr 1e-275} \ 9.9999999999999993e-276 -test util-16.1.17.-274 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-274 {8.4 compatible formatting of doubles} precision \ {expr 1e-274} \ 9.9999999999999997e-275 -test util-16.1.17.-273 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-273 {8.4 compatible formatting of doubles} precision \ {expr 1e-273} \ 1.0000000000000001e-273 -test util-16.1.17.-272 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-272 {8.4 compatible formatting of doubles} precision \ {expr 1e-272} \ 9.9999999999999993e-273 -test util-16.1.17.-271 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-271 {8.4 compatible formatting of doubles} precision \ {expr 1e-271} \ 9.9999999999999996e-272 -test util-16.1.17.-270 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-270 {8.4 compatible formatting of doubles} precision \ {expr 1e-270} \ 1e-270 -test util-16.1.17.-269 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-269 {8.4 compatible formatting of doubles} precision \ {expr 1e-269} \ 9.9999999999999996e-270 -test util-16.1.17.-268 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-268 {8.4 compatible formatting of doubles} precision \ {expr 1e-268} \ 9.9999999999999996e-269 -test util-16.1.17.-267 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-267 {8.4 compatible formatting of doubles} precision \ {expr 1e-267} \ 9.9999999999999998e-268 -test util-16.1.17.-266 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-266 {8.4 compatible formatting of doubles} precision \ {expr 1e-266} \ 9.9999999999999998e-267 -test util-16.1.17.-265 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-265 {8.4 compatible formatting of doubles} precision \ {expr 1e-265} \ 9.9999999999999998e-266 -test util-16.1.17.-264 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-264 {8.4 compatible formatting of doubles} precision \ {expr 1e-264} \ 1e-264 -test util-16.1.17.-263 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-263 {8.4 compatible formatting of doubles} precision \ {expr 1e-263} \ 1e-263 -test util-16.1.17.-262 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-262 {8.4 compatible formatting of doubles} precision \ {expr 1e-262} \ 1e-262 -test util-16.1.17.-261 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-261 {8.4 compatible formatting of doubles} precision \ {expr 1e-261} \ 9.9999999999999998e-262 -test util-16.1.17.-260 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-260 {8.4 compatible formatting of doubles} precision \ {expr 1e-260} \ 9.9999999999999996e-261 -test util-16.1.17.-259 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-259 {8.4 compatible formatting of doubles} precision \ {expr 1e-259} \ 1.0000000000000001e-259 -test util-16.1.17.-258 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-258 {8.4 compatible formatting of doubles} precision \ {expr 1e-258} \ 9.9999999999999995e-259 -test util-16.1.17.-257 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-257 {8.4 compatible formatting of doubles} precision \ {expr 1e-257} \ 9.9999999999999998e-258 -test util-16.1.17.-256 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-256 {8.4 compatible formatting of doubles} precision \ {expr 1e-256} \ 9.9999999999999998e-257 -test util-16.1.17.-255 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-255 {8.4 compatible formatting of doubles} precision \ {expr 1e-255} \ 1e-255 -test util-16.1.17.-254 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-254 {8.4 compatible formatting of doubles} precision \ {expr 1e-254} \ 9.9999999999999991e-255 -test util-16.1.17.-253 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-253 {8.4 compatible formatting of doubles} precision \ {expr 1e-253} \ 1.0000000000000001e-253 -test util-16.1.17.-252 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-252 {8.4 compatible formatting of doubles} precision \ {expr 1e-252} \ 9.9999999999999994e-253 -test util-16.1.17.-251 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-251 {8.4 compatible formatting of doubles} precision \ {expr 1e-251} \ 1e-251 -test util-16.1.17.-250 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-250 {8.4 compatible formatting of doubles} precision \ {expr 1e-250} \ 1.0000000000000001e-250 -test util-16.1.17.-249 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-249 {8.4 compatible formatting of doubles} precision \ {expr 1e-249} \ 1.0000000000000001e-249 -test util-16.1.17.-248 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-248 {8.4 compatible formatting of doubles} precision \ {expr 1e-248} \ 9.9999999999999998e-249 -test util-16.1.17.-247 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-247 {8.4 compatible formatting of doubles} precision \ {expr 1e-247} \ 1e-247 -test util-16.1.17.-246 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-246 {8.4 compatible formatting of doubles} precision \ {expr 1e-246} \ 9.9999999999999996e-247 -test util-16.1.17.-245 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-245 {8.4 compatible formatting of doubles} precision \ {expr 1e-245} \ 9.9999999999999993e-246 -test util-16.1.17.-244 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-244 {8.4 compatible formatting of doubles} precision \ {expr 1e-244} \ 9.9999999999999993e-245 -test util-16.1.17.-243 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-243 {8.4 compatible formatting of doubles} precision \ {expr 1e-243} \ 1e-243 -test util-16.1.17.-242 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-242 {8.4 compatible formatting of doubles} precision \ {expr 1e-242} \ 9.9999999999999997e-243 -test util-16.1.17.-241 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-241 {8.4 compatible formatting of doubles} precision \ {expr 1e-241} \ 9.9999999999999997e-242 -test util-16.1.17.-240 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-240 {8.4 compatible formatting of doubles} precision \ {expr 1e-240} \ 9.9999999999999997e-241 -test util-16.1.17.-239 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-239 {8.4 compatible formatting of doubles} precision \ {expr 1e-239} \ 1.0000000000000001e-239 -test util-16.1.17.-238 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-238 {8.4 compatible formatting of doubles} precision \ {expr 1e-238} \ 9.9999999999999999e-239 -test util-16.1.17.-237 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-237 {8.4 compatible formatting of doubles} precision \ {expr 1e-237} \ 9.9999999999999999e-238 -test util-16.1.17.-236 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-236 {8.4 compatible formatting of doubles} precision \ {expr 1e-236} \ 1e-236 -test util-16.1.17.-235 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-235 {8.4 compatible formatting of doubles} precision \ {expr 1e-235} \ 9.9999999999999996e-236 -test util-16.1.17.-234 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-234 {8.4 compatible formatting of doubles} precision \ {expr 1e-234} \ 9.9999999999999996e-235 -test util-16.1.17.-233 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-233 {8.4 compatible formatting of doubles} precision \ {expr 1e-233} \ 9.9999999999999996e-234 -test util-16.1.17.-232 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-232 {8.4 compatible formatting of doubles} precision \ {expr 1e-232} \ 1e-232 -test util-16.1.17.-231 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-231 {8.4 compatible formatting of doubles} precision \ {expr 1e-231} \ 9.9999999999999999e-232 -test util-16.1.17.-230 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-230 {8.4 compatible formatting of doubles} precision \ {expr 1e-230} \ 1e-230 -test util-16.1.17.-229 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-229 {8.4 compatible formatting of doubles} precision \ {expr 1e-229} \ 1.0000000000000001e-229 -test util-16.1.17.-228 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-228 {8.4 compatible formatting of doubles} precision \ {expr 1e-228} \ 1e-228 -test util-16.1.17.-227 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-227 {8.4 compatible formatting of doubles} precision \ {expr 1e-227} \ 9.9999999999999994e-228 -test util-16.1.17.-226 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-226 {8.4 compatible formatting of doubles} precision \ {expr 1e-226} \ 9.9999999999999992e-227 -test util-16.1.17.-225 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-225 {8.4 compatible formatting of doubles} precision \ {expr 1e-225} \ 9.9999999999999996e-226 -test util-16.1.17.-224 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-224 {8.4 compatible formatting of doubles} precision \ {expr 1e-224} \ 1e-224 -test util-16.1.17.-223 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-223 {8.4 compatible formatting of doubles} precision \ {expr 1e-223} \ 9.9999999999999997e-224 -test util-16.1.17.-222 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-222 {8.4 compatible formatting of doubles} precision \ {expr 1e-222} \ 1e-222 -test util-16.1.17.-221 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-221 {8.4 compatible formatting of doubles} precision \ {expr 1e-221} \ 1e-221 -test util-16.1.17.-220 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-220 {8.4 compatible formatting of doubles} precision \ {expr 1e-220} \ 9.9999999999999999e-221 -test util-16.1.17.-219 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-219 {8.4 compatible formatting of doubles} precision \ {expr 1e-219} \ 1e-219 -test util-16.1.17.-218 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-218 {8.4 compatible formatting of doubles} precision \ {expr 1e-218} \ 1e-218 -test util-16.1.17.-217 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-217 {8.4 compatible formatting of doubles} precision \ {expr 1e-217} \ 1.0000000000000001e-217 -test util-16.1.17.-216 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-216 {8.4 compatible formatting of doubles} precision \ {expr 1e-216} \ 1e-216 -test util-16.1.17.-215 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-215 {8.4 compatible formatting of doubles} precision \ {expr 1e-215} \ 1e-215 -test util-16.1.17.-214 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-214 {8.4 compatible formatting of doubles} precision \ {expr 1e-214} \ 9.9999999999999991e-215 -test util-16.1.17.-213 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-213 {8.4 compatible formatting of doubles} precision \ {expr 1e-213} \ 9.9999999999999995e-214 -test util-16.1.17.-212 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-212 {8.4 compatible formatting of doubles} precision \ {expr 1e-212} \ 9.9999999999999995e-213 -test util-16.1.17.-211 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-211 {8.4 compatible formatting of doubles} precision \ {expr 1e-211} \ 1.0000000000000001e-211 -test util-16.1.17.-210 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-210 {8.4 compatible formatting of doubles} precision \ {expr 1e-210} \ 1e-210 -test util-16.1.17.-209 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-209 {8.4 compatible formatting of doubles} precision \ {expr 1e-209} \ 1e-209 -test util-16.1.17.-208 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-208 {8.4 compatible formatting of doubles} precision \ {expr 1e-208} \ 1.0000000000000001e-208 -test util-16.1.17.-207 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-207 {8.4 compatible formatting of doubles} precision \ {expr 1e-207} \ 9.9999999999999993e-208 -test util-16.1.17.-206 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-206 {8.4 compatible formatting of doubles} precision \ {expr 1e-206} \ 1e-206 -test util-16.1.17.-205 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-205 {8.4 compatible formatting of doubles} precision \ {expr 1e-205} \ 1e-205 -test util-16.1.17.-204 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-204 {8.4 compatible formatting of doubles} precision \ {expr 1e-204} \ 1e-204 -test util-16.1.17.-203 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-203 {8.4 compatible formatting of doubles} precision \ {expr 1e-203} \ 1e-203 -test util-16.1.17.-202 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-202 {8.4 compatible formatting of doubles} precision \ {expr 1e-202} \ 1e-202 -test util-16.1.17.-201 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-201 {8.4 compatible formatting of doubles} precision \ {expr 1e-201} \ 9.9999999999999995e-202 -test util-16.1.17.-200 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-200 {8.4 compatible formatting of doubles} precision \ {expr 1e-200} \ 9.9999999999999998e-201 -test util-16.1.17.-199 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-199 {8.4 compatible formatting of doubles} precision \ {expr 1e-199} \ 9.9999999999999998e-200 -test util-16.1.17.-198 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-198 {8.4 compatible formatting of doubles} precision \ {expr 1e-198} \ 9.9999999999999991e-199 -test util-16.1.17.-197 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-197 {8.4 compatible formatting of doubles} precision \ {expr 1e-197} \ 9.9999999999999999e-198 -test util-16.1.17.-196 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-196 {8.4 compatible formatting of doubles} precision \ {expr 1e-196} \ 1e-196 -test util-16.1.17.-195 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-195 {8.4 compatible formatting of doubles} precision \ {expr 1e-195} \ 1.0000000000000001e-195 -test util-16.1.17.-194 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-194 {8.4 compatible formatting of doubles} precision \ {expr 1e-194} \ 1e-194 -test util-16.1.17.-193 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-193 {8.4 compatible formatting of doubles} precision \ {expr 1e-193} \ 1e-193 -test util-16.1.17.-192 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-192 {8.4 compatible formatting of doubles} precision \ {expr 1e-192} \ 1.0000000000000001e-192 -test util-16.1.17.-191 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-191 {8.4 compatible formatting of doubles} precision \ {expr 1e-191} \ 1e-191 -test util-16.1.17.-190 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-190 {8.4 compatible formatting of doubles} precision \ {expr 1e-190} \ 1e-190 -test util-16.1.17.-189 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-189 {8.4 compatible formatting of doubles} precision \ {expr 1e-189} \ 1.0000000000000001e-189 -test util-16.1.17.-188 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-188 {8.4 compatible formatting of doubles} precision \ {expr 1e-188} \ 9.9999999999999995e-189 -test util-16.1.17.-187 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-187 {8.4 compatible formatting of doubles} precision \ {expr 1e-187} \ 1e-187 -test util-16.1.17.-186 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-186 {8.4 compatible formatting of doubles} precision \ {expr 1e-186} \ 9.9999999999999991e-187 -test util-16.1.17.-185 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-185 {8.4 compatible formatting of doubles} precision \ {expr 1e-185} \ 9.9999999999999999e-186 -test util-16.1.17.-184 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-184 {8.4 compatible formatting of doubles} precision \ {expr 1e-184} \ 1.0000000000000001e-184 -test util-16.1.17.-183 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-183 {8.4 compatible formatting of doubles} precision \ {expr 1e-183} \ 1e-183 -test util-16.1.17.-182 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-182 {8.4 compatible formatting of doubles} precision \ {expr 1e-182} \ 1e-182 -test util-16.1.17.-181 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-181 {8.4 compatible formatting of doubles} precision \ {expr 1e-181} \ 1e-181 -test util-16.1.17.-180 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-180 {8.4 compatible formatting of doubles} precision \ {expr 1e-180} \ 1e-180 -test util-16.1.17.-179 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-179 {8.4 compatible formatting of doubles} precision \ {expr 1e-179} \ 1e-179 -test util-16.1.17.-178 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-178 {8.4 compatible formatting of doubles} precision \ {expr 1e-178} \ 9.9999999999999995e-179 -test util-16.1.17.-177 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-177 {8.4 compatible formatting of doubles} precision \ {expr 1e-177} \ 9.9999999999999995e-178 -test util-16.1.17.-176 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-176 {8.4 compatible formatting of doubles} precision \ {expr 1e-176} \ 1e-176 -test util-16.1.17.-175 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-175 {8.4 compatible formatting of doubles} precision \ {expr 1e-175} \ 1e-175 -test util-16.1.17.-174 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-174 {8.4 compatible formatting of doubles} precision \ {expr 1e-174} \ 1e-174 -test util-16.1.17.-173 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-173 {8.4 compatible formatting of doubles} precision \ {expr 1e-173} \ 1e-173 -test util-16.1.17.-172 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-172 {8.4 compatible formatting of doubles} precision \ {expr 1e-172} \ 1e-172 -test util-16.1.17.-171 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-171 {8.4 compatible formatting of doubles} precision \ {expr 1e-171} \ 9.9999999999999998e-172 -test util-16.1.17.-170 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-170 {8.4 compatible formatting of doubles} precision \ {expr 1e-170} \ 9.9999999999999998e-171 -test util-16.1.17.-169 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-169 {8.4 compatible formatting of doubles} precision \ {expr 1e-169} \ 1e-169 -test util-16.1.17.-168 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-168 {8.4 compatible formatting of doubles} precision \ {expr 1e-168} \ 1e-168 -test util-16.1.17.-167 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-167 {8.4 compatible formatting of doubles} precision \ {expr 1e-167} \ 1e-167 -test util-16.1.17.-166 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-166 {8.4 compatible formatting of doubles} precision \ {expr 1e-166} \ 1e-166 -test util-16.1.17.-165 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-165 {8.4 compatible formatting of doubles} precision \ {expr 1e-165} \ 1e-165 -test util-16.1.17.-164 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-164 {8.4 compatible formatting of doubles} precision \ {expr 1e-164} \ 9.9999999999999996e-165 -test util-16.1.17.-163 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-163 {8.4 compatible formatting of doubles} precision \ {expr 1e-163} \ 9.9999999999999992e-164 -test util-16.1.17.-162 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-162 {8.4 compatible formatting of doubles} precision \ {expr 1e-162} \ 9.9999999999999995e-163 -test util-16.1.17.-161 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-161 {8.4 compatible formatting of doubles} precision \ {expr 1e-161} \ 1e-161 -test util-16.1.17.-160 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-160 {8.4 compatible formatting of doubles} precision \ {expr 1e-160} \ 9.9999999999999999e-161 -test util-16.1.17.-159 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-159 {8.4 compatible formatting of doubles} precision \ {expr 1e-159} \ 9.9999999999999999e-160 -test util-16.1.17.-158 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-158 {8.4 compatible formatting of doubles} precision \ {expr 1e-158} \ 1.0000000000000001e-158 -test util-16.1.17.-157 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-157 {8.4 compatible formatting of doubles} precision \ {expr 1e-157} \ 9.9999999999999994e-158 -test util-16.1.17.-156 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-156 {8.4 compatible formatting of doubles} precision \ {expr 1e-156} \ 1e-156 -test util-16.1.17.-155 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-155 {8.4 compatible formatting of doubles} precision \ {expr 1e-155} \ 1e-155 -test util-16.1.17.-154 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-154 {8.4 compatible formatting of doubles} precision \ {expr 1e-154} \ 9.9999999999999997e-155 -test util-16.1.17.-153 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-153 {8.4 compatible formatting of doubles} precision \ {expr 1e-153} \ 1e-153 -test util-16.1.17.-152 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-152 {8.4 compatible formatting of doubles} precision \ {expr 1e-152} \ 1.0000000000000001e-152 -test util-16.1.17.-151 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-151 {8.4 compatible formatting of doubles} precision \ {expr 1e-151} \ 9.9999999999999994e-152 -test util-16.1.17.-150 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-150 {8.4 compatible formatting of doubles} precision \ {expr 1e-150} \ 1e-150 -test util-16.1.17.-149 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-149 {8.4 compatible formatting of doubles} precision \ {expr 1e-149} \ 9.9999999999999998e-150 -test util-16.1.17.-148 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-148 {8.4 compatible formatting of doubles} precision \ {expr 1e-148} \ 9.9999999999999994e-149 -test util-16.1.17.-147 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-147 {8.4 compatible formatting of doubles} precision \ {expr 1e-147} \ 9.9999999999999997e-148 -test util-16.1.17.-146 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-146 {8.4 compatible formatting of doubles} precision \ {expr 1e-146} \ 1e-146 -test util-16.1.17.-145 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-145 {8.4 compatible formatting of doubles} precision \ {expr 1e-145} \ 9.9999999999999991e-146 -test util-16.1.17.-144 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-144 {8.4 compatible formatting of doubles} precision \ {expr 1e-144} \ 9.9999999999999995e-145 -test util-16.1.17.-143 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-143 {8.4 compatible formatting of doubles} precision \ {expr 1e-143} \ 9.9999999999999995e-144 -test util-16.1.17.-142 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-142 {8.4 compatible formatting of doubles} precision \ {expr 1e-142} \ 1e-142 -test util-16.1.17.-141 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-141 {8.4 compatible formatting of doubles} precision \ {expr 1e-141} \ 1e-141 -test util-16.1.17.-140 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-140 {8.4 compatible formatting of doubles} precision \ {expr 1e-140} \ 9.9999999999999998e-141 -test util-16.1.17.-139 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-139 {8.4 compatible formatting of doubles} precision \ {expr 1e-139} \ 1e-139 -test util-16.1.17.-138 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-138 {8.4 compatible formatting of doubles} precision \ {expr 1e-138} \ 1.0000000000000001e-138 -test util-16.1.17.-137 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-137 {8.4 compatible formatting of doubles} precision \ {expr 1e-137} \ 9.9999999999999998e-138 -test util-16.1.17.-136 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-136 {8.4 compatible formatting of doubles} precision \ {expr 1e-136} \ 1e-136 -test util-16.1.17.-135 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-135 {8.4 compatible formatting of doubles} precision \ {expr 1e-135} \ 1e-135 -test util-16.1.17.-134 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-134 {8.4 compatible formatting of doubles} precision \ {expr 1e-134} \ 1e-134 -test util-16.1.17.-133 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-133 {8.4 compatible formatting of doubles} precision \ {expr 1e-133} \ 1.0000000000000001e-133 -test util-16.1.17.-132 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-132 {8.4 compatible formatting of doubles} precision \ {expr 1e-132} \ 9.9999999999999999e-133 -test util-16.1.17.-131 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-131 {8.4 compatible formatting of doubles} precision \ {expr 1e-131} \ 9.9999999999999999e-132 -test util-16.1.17.-130 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-130 {8.4 compatible formatting of doubles} precision \ {expr 1e-130} \ 1.0000000000000001e-130 -test util-16.1.17.-129 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-129 {8.4 compatible formatting of doubles} precision \ {expr 1e-129} \ 9.9999999999999993e-130 -test util-16.1.17.-128 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-128 {8.4 compatible formatting of doubles} precision \ {expr 1e-128} \ 1.0000000000000001e-128 -test util-16.1.17.-127 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-127 {8.4 compatible formatting of doubles} precision \ {expr 1e-127} \ 1e-127 -test util-16.1.17.-126 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-126 {8.4 compatible formatting of doubles} precision \ {expr 1e-126} \ 9.9999999999999995e-127 -test util-16.1.17.-125 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-125 {8.4 compatible formatting of doubles} precision \ {expr 1e-125} \ 1e-125 -test util-16.1.17.-124 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-124 {8.4 compatible formatting of doubles} precision \ {expr 1e-124} \ 9.9999999999999993e-125 -test util-16.1.17.-123 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-123 {8.4 compatible formatting of doubles} precision \ {expr 1e-123} \ 1.0000000000000001e-123 -test util-16.1.17.-122 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-122 {8.4 compatible formatting of doubles} precision \ {expr 1e-122} \ 1.0000000000000001e-122 -test util-16.1.17.-121 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-121 {8.4 compatible formatting of doubles} precision \ {expr 1e-121} \ 9.9999999999999998e-122 -test util-16.1.17.-120 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-120 {8.4 compatible formatting of doubles} precision \ {expr 1e-120} \ 9.9999999999999998e-121 -test util-16.1.17.-119 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-119 {8.4 compatible formatting of doubles} precision \ {expr 1e-119} \ 1e-119 -test util-16.1.17.-118 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-118 {8.4 compatible formatting of doubles} precision \ {expr 1e-118} \ 9.9999999999999999e-119 -test util-16.1.17.-117 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-117 {8.4 compatible formatting of doubles} precision \ {expr 1e-117} \ 1e-117 -test util-16.1.17.-116 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-116 {8.4 compatible formatting of doubles} precision \ {expr 1e-116} \ 9.9999999999999999e-117 -test util-16.1.17.-115 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-115 {8.4 compatible formatting of doubles} precision \ {expr 1e-115} \ 1.0000000000000001e-115 -test util-16.1.17.-114 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-114 {8.4 compatible formatting of doubles} precision \ {expr 1e-114} \ 1.0000000000000001e-114 -test util-16.1.17.-113 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-113 {8.4 compatible formatting of doubles} precision \ {expr 1e-113} \ 9.9999999999999998e-114 -test util-16.1.17.-112 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-112 {8.4 compatible formatting of doubles} precision \ {expr 1e-112} \ 9.9999999999999995e-113 -test util-16.1.17.-111 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-111 {8.4 compatible formatting of doubles} precision \ {expr 1e-111} \ 1.0000000000000001e-111 -test util-16.1.17.-110 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-110 {8.4 compatible formatting of doubles} precision \ {expr 1e-110} \ 1.0000000000000001e-110 -test util-16.1.17.-109 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-109 {8.4 compatible formatting of doubles} precision \ {expr 1e-109} \ 9.9999999999999999e-110 -test util-16.1.17.-108 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-108 {8.4 compatible formatting of doubles} precision \ {expr 1e-108} \ 1e-108 -test util-16.1.17.-107 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-107 {8.4 compatible formatting of doubles} precision \ {expr 1e-107} \ 1e-107 -test util-16.1.17.-106 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-106 {8.4 compatible formatting of doubles} precision \ {expr 1e-106} \ 9.9999999999999994e-107 -test util-16.1.17.-105 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-105 {8.4 compatible formatting of doubles} precision \ {expr 1e-105} \ 9.9999999999999997e-106 -test util-16.1.17.-104 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-104 {8.4 compatible formatting of doubles} precision \ {expr 1e-104} \ 9.9999999999999993e-105 -test util-16.1.17.-103 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-103 {8.4 compatible formatting of doubles} precision \ {expr 1e-103} \ 9.9999999999999996e-104 -test util-16.1.17.-102 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-102 {8.4 compatible formatting of doubles} precision \ {expr 1e-102} \ 9.9999999999999993e-103 -test util-16.1.17.-101 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-101 {8.4 compatible formatting of doubles} precision \ {expr 1e-101} \ 1.0000000000000001e-101 -test util-16.1.17.-100 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-100 {8.4 compatible formatting of doubles} precision \ {expr 1e-100} \ 1e-100 -test util-16.1.17.-99 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-99 {8.4 compatible formatting of doubles} precision \ {expr 1e-99} \ 1e-99 -test util-16.1.17.-98 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-98 {8.4 compatible formatting of doubles} precision \ {expr 1e-98} \ 9.9999999999999994e-99 -test util-16.1.17.-97 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-97 {8.4 compatible formatting of doubles} precision \ {expr 1e-97} \ 1e-97 -test util-16.1.17.-96 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-96 {8.4 compatible formatting of doubles} precision \ {expr 1e-96} \ 9.9999999999999991e-97 -test util-16.1.17.-95 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-95 {8.4 compatible formatting of doubles} precision \ {expr 1e-95} \ 9.9999999999999999e-96 -test util-16.1.17.-94 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-94 {8.4 compatible formatting of doubles} precision \ {expr 1e-94} \ 9.9999999999999996e-95 -test util-16.1.17.-93 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-93 {8.4 compatible formatting of doubles} precision \ {expr 1e-93} \ 9.999999999999999e-94 -test util-16.1.17.-92 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-92 {8.4 compatible formatting of doubles} precision \ {expr 1e-92} \ 9.9999999999999999e-93 -test util-16.1.17.-91 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-91 {8.4 compatible formatting of doubles} precision \ {expr 1e-91} \ 1e-91 -test util-16.1.17.-90 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-90 {8.4 compatible formatting of doubles} precision \ {expr 1e-90} \ 9.9999999999999999e-91 -test util-16.1.17.-89 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-89 {8.4 compatible formatting of doubles} precision \ {expr 1e-89} \ 1e-89 -test util-16.1.17.-88 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-88 {8.4 compatible formatting of doubles} precision \ {expr 1e-88} \ 9.9999999999999993e-89 -test util-16.1.17.-87 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-87 {8.4 compatible formatting of doubles} precision \ {expr 1e-87} \ 1e-87 -test util-16.1.17.-86 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-86 {8.4 compatible formatting of doubles} precision \ {expr 1e-86} \ 1.0000000000000001e-86 -test util-16.1.17.-85 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-85 {8.4 compatible formatting of doubles} precision \ {expr 1e-85} \ 9.9999999999999998e-86 -test util-16.1.17.-84 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-84 {8.4 compatible formatting of doubles} precision \ {expr 1e-84} \ 1e-84 -test util-16.1.17.-83 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-83 {8.4 compatible formatting of doubles} precision \ {expr 1e-83} \ 1e-83 -test util-16.1.17.-82 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-82 {8.4 compatible formatting of doubles} precision \ {expr 1e-82} \ 9.9999999999999996e-83 -test util-16.1.17.-81 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-81 {8.4 compatible formatting of doubles} precision \ {expr 1e-81} \ 9.9999999999999996e-82 -test util-16.1.17.-80 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-80 {8.4 compatible formatting of doubles} precision \ {expr 1e-80} \ 9.9999999999999996e-81 -test util-16.1.17.-79 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-79 {8.4 compatible formatting of doubles} precision \ {expr 1e-79} \ 1e-79 -test util-16.1.17.-78 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-78 {8.4 compatible formatting of doubles} precision \ {expr 1e-78} \ 1e-78 -test util-16.1.17.-77 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-77 {8.4 compatible formatting of doubles} precision \ {expr 1e-77} \ 9.9999999999999993e-78 -test util-16.1.17.-76 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-76 {8.4 compatible formatting of doubles} precision \ {expr 1e-76} \ 9.9999999999999993e-77 -test util-16.1.17.-75 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-75 {8.4 compatible formatting of doubles} precision \ {expr 1e-75} \ 9.9999999999999996e-76 -test util-16.1.17.-74 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-74 {8.4 compatible formatting of doubles} precision \ {expr 1e-74} \ 9.9999999999999996e-75 -test util-16.1.17.-73 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-73 {8.4 compatible formatting of doubles} precision \ {expr 1e-73} \ 1e-73 -test util-16.1.17.-72 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-72 {8.4 compatible formatting of doubles} precision \ {expr 1e-72} \ 9.9999999999999997e-73 -test util-16.1.17.-71 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-71 {8.4 compatible formatting of doubles} precision \ {expr 1e-71} \ 9.9999999999999992e-72 -test util-16.1.17.-70 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-70 {8.4 compatible formatting of doubles} precision \ {expr 1e-70} \ 1e-70 -test util-16.1.17.-69 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-69 {8.4 compatible formatting of doubles} precision \ {expr 1e-69} \ 9.9999999999999996e-70 -test util-16.1.17.-68 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-68 {8.4 compatible formatting of doubles} precision \ {expr 1e-68} \ 1.0000000000000001e-68 -test util-16.1.17.-67 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-67 {8.4 compatible formatting of doubles} precision \ {expr 1e-67} \ 9.9999999999999994e-68 -test util-16.1.17.-66 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-66 {8.4 compatible formatting of doubles} precision \ {expr 1e-66} \ 9.9999999999999998e-67 -test util-16.1.17.-65 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-65 {8.4 compatible formatting of doubles} precision \ {expr 1e-65} \ 9.9999999999999992e-66 -test util-16.1.17.-64 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-64 {8.4 compatible formatting of doubles} precision \ {expr 1e-64} \ 9.9999999999999997e-65 -test util-16.1.17.-63 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-63 {8.4 compatible formatting of doubles} precision \ {expr 1e-63} \ 1.0000000000000001e-63 -test util-16.1.17.-62 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-62 {8.4 compatible formatting of doubles} precision \ {expr 1e-62} \ 1e-62 -test util-16.1.17.-61 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-61 {8.4 compatible formatting of doubles} precision \ {expr 1e-61} \ 1e-61 -test util-16.1.17.-60 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-60 {8.4 compatible formatting of doubles} precision \ {expr 1e-60} \ 9.9999999999999997e-61 -test util-16.1.17.-59 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-59 {8.4 compatible formatting of doubles} precision \ {expr 1e-59} \ 1e-59 -test util-16.1.17.-58 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-58 {8.4 compatible formatting of doubles} precision \ {expr 1e-58} \ 1e-58 -test util-16.1.17.-57 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-57 {8.4 compatible formatting of doubles} precision \ {expr 1e-57} \ 9.9999999999999995e-58 -test util-16.1.17.-56 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-56 {8.4 compatible formatting of doubles} precision \ {expr 1e-56} \ 1e-56 -test util-16.1.17.-55 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-55 {8.4 compatible formatting of doubles} precision \ {expr 1e-55} \ 9.9999999999999999e-56 -test util-16.1.17.-54 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-54 {8.4 compatible formatting of doubles} precision \ {expr 1e-54} \ 1e-54 -test util-16.1.17.-53 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-53 {8.4 compatible formatting of doubles} precision \ {expr 1e-53} \ 1e-53 -test util-16.1.17.-52 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-52 {8.4 compatible formatting of doubles} precision \ {expr 1e-52} \ 1e-52 -test util-16.1.17.-51 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-51 {8.4 compatible formatting of doubles} precision \ {expr 1e-51} \ 1e-51 -test util-16.1.17.-50 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-50 {8.4 compatible formatting of doubles} precision \ {expr 1e-50} \ 1e-50 -test util-16.1.17.-49 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-49 {8.4 compatible formatting of doubles} precision \ {expr 1e-49} \ 9.9999999999999994e-50 -test util-16.1.17.-48 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-48 {8.4 compatible formatting of doubles} precision \ {expr 1e-48} \ 9.9999999999999997e-49 -test util-16.1.17.-47 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-47 {8.4 compatible formatting of doubles} precision \ {expr 1e-47} \ 9.9999999999999997e-48 -test util-16.1.17.-46 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-46 {8.4 compatible formatting of doubles} precision \ {expr 1e-46} \ 1e-46 -test util-16.1.17.-45 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-45 {8.4 compatible formatting of doubles} precision \ {expr 1e-45} \ 9.9999999999999998e-46 -test util-16.1.17.-44 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-44 {8.4 compatible formatting of doubles} precision \ {expr 1e-44} \ 9.9999999999999995e-45 -test util-16.1.17.-43 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-43 {8.4 compatible formatting of doubles} precision \ {expr 1e-43} \ 1.0000000000000001e-43 -test util-16.1.17.-42 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-42 {8.4 compatible formatting of doubles} precision \ {expr 1e-42} \ 1e-42 -test util-16.1.17.-41 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-41 {8.4 compatible formatting of doubles} precision \ {expr 1e-41} \ 1e-41 -test util-16.1.17.-40 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-40 {8.4 compatible formatting of doubles} precision \ {expr 1e-40} \ 9.9999999999999993e-41 -test util-16.1.17.-39 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-39 {8.4 compatible formatting of doubles} precision \ {expr 1e-39} \ 9.9999999999999993e-40 -test util-16.1.17.-38 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-38 {8.4 compatible formatting of doubles} precision \ {expr 1e-38} \ 9.9999999999999996e-39 -test util-16.1.17.-37 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-37 {8.4 compatible formatting of doubles} precision \ {expr 1e-37} \ 1.0000000000000001e-37 -test util-16.1.17.-36 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-36 {8.4 compatible formatting of doubles} precision \ {expr 1e-36} \ 9.9999999999999994e-37 -test util-16.1.17.-35 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-35 {8.4 compatible formatting of doubles} precision \ {expr 1e-35} \ 1e-35 -test util-16.1.17.-34 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-34 {8.4 compatible formatting of doubles} precision \ {expr 1e-34} \ 9.9999999999999993e-35 -test util-16.1.17.-33 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-33 {8.4 compatible formatting of doubles} precision \ {expr 1e-33} \ 1.0000000000000001e-33 -test util-16.1.17.-32 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-32 {8.4 compatible formatting of doubles} precision \ {expr 1e-32} \ 1.0000000000000001e-32 -test util-16.1.17.-31 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-31 {8.4 compatible formatting of doubles} precision \ {expr 1e-31} \ 1.0000000000000001e-31 -test util-16.1.17.-30 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-30 {8.4 compatible formatting of doubles} precision \ {expr 1e-30} \ 1.0000000000000001e-30 -test util-16.1.17.-29 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-29 {8.4 compatible formatting of doubles} precision \ {expr 1e-29} \ 9.9999999999999994e-30 -test util-16.1.17.-28 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-28 {8.4 compatible formatting of doubles} precision \ {expr 1e-28} \ 9.9999999999999997e-29 -test util-16.1.17.-27 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-27 {8.4 compatible formatting of doubles} precision \ {expr 1e-27} \ 1e-27 -test util-16.1.17.-26 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-26 {8.4 compatible formatting of doubles} precision \ {expr 1e-26} \ 1e-26 -test util-16.1.17.-25 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-25 {8.4 compatible formatting of doubles} precision \ {expr 1e-25} \ 1e-25 -test util-16.1.17.-24 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-24 {8.4 compatible formatting of doubles} precision \ {expr 1e-24} \ 9.9999999999999992e-25 -test util-16.1.17.-23 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-23 {8.4 compatible formatting of doubles} precision \ {expr 1e-23} \ 9.9999999999999996e-24 -test util-16.1.17.-22 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-22 {8.4 compatible formatting of doubles} precision \ {expr 1e-22} \ 1e-22 -test util-16.1.17.-21 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-21 {8.4 compatible formatting of doubles} precision \ {expr 1e-21} \ 9.9999999999999991e-22 -test util-16.1.17.-20 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-20 {8.4 compatible formatting of doubles} precision \ {expr 1e-20} \ 9.9999999999999995e-21 -test util-16.1.17.-19 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-19 {8.4 compatible formatting of doubles} precision \ {expr 1e-19} \ 9.9999999999999998e-20 -test util-16.1.17.-18 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-18 {8.4 compatible formatting of doubles} precision \ {expr 1e-18} \ 1.0000000000000001e-18 -test util-16.1.17.-17 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-17 {8.4 compatible formatting of doubles} precision \ {expr 1e-17} \ 1.0000000000000001e-17 -test util-16.1.17.-16 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-16 {8.4 compatible formatting of doubles} precision \ {expr 1e-16} \ 9.9999999999999998e-17 -test util-16.1.17.-15 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-15 {8.4 compatible formatting of doubles} precision \ {expr 1e-15} \ 1.0000000000000001e-15 -test util-16.1.17.-14 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-14 {8.4 compatible formatting of doubles} precision \ {expr 1e-14} \ 1e-14 -test util-16.1.17.-13 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-13 {8.4 compatible formatting of doubles} precision \ {expr 1e-13} \ 1e-13 -test util-16.1.17.-12 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-12 {8.4 compatible formatting of doubles} precision \ {expr 1e-12} \ 9.9999999999999998e-13 -test util-16.1.17.-11 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-11 {8.4 compatible formatting of doubles} precision \ {expr 1e-11} \ 9.9999999999999994e-12 -test util-16.1.17.-10 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-10 {8.4 compatible formatting of doubles} precision \ {expr 1e-10} \ 1e-10 -test util-16.1.17.-9 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-9 {8.4 compatible formatting of doubles} precision \ {expr 1e-9} \ 1.0000000000000001e-09 -test util-16.1.17.-8 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-8 {8.4 compatible formatting of doubles} precision \ {expr 1e-8} \ 1e-08 -test util-16.1.17.-7 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-7 {8.4 compatible formatting of doubles} precision \ {expr 1e-7} \ 9.9999999999999995e-08 -test util-16.1.17.-6 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-6 {8.4 compatible formatting of doubles} precision \ {expr 1e-6} \ 9.9999999999999995e-07 -test util-16.1.17.-5 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-5 {8.4 compatible formatting of doubles} precision \ {expr 1e-5} \ 1.0000000000000001e-05 -test util-16.1.17.-4 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-4 {8.4 compatible formatting of doubles} precision \ {expr 1e-4} \ 0.0001 -test util-16.1.17.-3 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-3 {8.4 compatible formatting of doubles} precision \ {expr 1e-3} \ 0.001 -test util-16.1.17.-2 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-2 {8.4 compatible formatting of doubles} precision \ {expr 1e-2} \ 0.01 -test util-16.1.17.-1 {8.4 compatible formatting of doubles} \ +test util-16.1.17.-1 {8.4 compatible formatting of doubles} precision \ {expr 1e-1} \ 0.10000000000000001 -test util-16.1.17.0 {8.4 compatible formatting of doubles} \ +test util-16.1.17.0 {8.4 compatible formatting of doubles} precision \ {expr 1e0} \ 1.0 -test util-16.1.17.1 {8.4 compatible formatting of doubles} \ +test util-16.1.17.1 {8.4 compatible formatting of doubles} precision \ {expr 1e1} \ 10.0 -test util-16.1.17.2 {8.4 compatible formatting of doubles} \ +test util-16.1.17.2 {8.4 compatible formatting of doubles} precision \ {expr 1e2} \ 100.0 -test util-16.1.17.3 {8.4 compatible formatting of doubles} \ +test util-16.1.17.3 {8.4 compatible formatting of doubles} precision \ {expr 1e3} \ 1000.0 -test util-16.1.17.4 {8.4 compatible formatting of doubles} \ +test util-16.1.17.4 {8.4 compatible formatting of doubles} precision \ {expr 1e4} \ 10000.0 -test util-16.1.17.5 {8.4 compatible formatting of doubles} \ +test util-16.1.17.5 {8.4 compatible formatting of doubles} precision \ {expr 1e5} \ 100000.0 -test util-16.1.17.6 {8.4 compatible formatting of doubles} \ +test util-16.1.17.6 {8.4 compatible formatting of doubles} precision \ {expr 1e6} \ 1000000.0 -test util-16.1.17.7 {8.4 compatible formatting of doubles} \ +test util-16.1.17.7 {8.4 compatible formatting of doubles} precision \ {expr 1e7} \ 10000000.0 -test util-16.1.17.8 {8.4 compatible formatting of doubles} \ +test util-16.1.17.8 {8.4 compatible formatting of doubles} precision \ {expr 1e8} \ 100000000.0 -test util-16.1.17.9 {8.4 compatible formatting of doubles} \ +test util-16.1.17.9 {8.4 compatible formatting of doubles} precision \ {expr 1e9} \ 1000000000.0 -test util-16.1.17.10 {8.4 compatible formatting of doubles} \ +test util-16.1.17.10 {8.4 compatible formatting of doubles} precision \ {expr 1e10} \ 10000000000.0 -test util-16.1.17.11 {8.4 compatible formatting of doubles} \ +test util-16.1.17.11 {8.4 compatible formatting of doubles} precision \ {expr 1e11} \ 100000000000.0 -test util-16.1.17.12 {8.4 compatible formatting of doubles} \ +test util-16.1.17.12 {8.4 compatible formatting of doubles} precision \ {expr 1e12} \ 1000000000000.0 -test util-16.1.17.13 {8.4 compatible formatting of doubles} \ +test util-16.1.17.13 {8.4 compatible formatting of doubles} precision \ {expr 1e13} \ 10000000000000.0 -test util-16.1.17.14 {8.4 compatible formatting of doubles} \ +test util-16.1.17.14 {8.4 compatible formatting of doubles} precision \ {expr 1e14} \ 100000000000000.0 -test util-16.1.17.15 {8.4 compatible formatting of doubles} \ +test util-16.1.17.15 {8.4 compatible formatting of doubles} precision \ {expr 1e15} \ 1000000000000000.0 -test util-16.1.17.16 {8.4 compatible formatting of doubles} \ +test util-16.1.17.16 {8.4 compatible formatting of doubles} precision \ {expr 1e16} \ 10000000000000000.0 -test util-16.1.17.17 {8.4 compatible formatting of doubles} \ +test util-16.1.17.17 {8.4 compatible formatting of doubles} precision \ {expr 1e17} \ 1e+17 -test util-16.1.17.18 {8.4 compatible formatting of doubles} \ +test util-16.1.17.18 {8.4 compatible formatting of doubles} precision \ {expr 1e18} \ 1e+18 -test util-16.1.17.19 {8.4 compatible formatting of doubles} \ +test util-16.1.17.19 {8.4 compatible formatting of doubles} precision \ {expr 1e19} \ 1e+19 -test util-16.1.17.20 {8.4 compatible formatting of doubles} \ +test util-16.1.17.20 {8.4 compatible formatting of doubles} precision \ {expr 1e20} \ 1e+20 -test util-16.1.17.21 {8.4 compatible formatting of doubles} \ +test util-16.1.17.21 {8.4 compatible formatting of doubles} precision \ {expr 1e21} \ 1e+21 -test util-16.1.17.22 {8.4 compatible formatting of doubles} \ +test util-16.1.17.22 {8.4 compatible formatting of doubles} precision \ {expr 1e22} \ 1e+22 -test util-16.1.17.23 {8.4 compatible formatting of doubles} \ +test util-16.1.17.23 {8.4 compatible formatting of doubles} precision \ {expr 1e23} \ 9.9999999999999992e+22 -test util-16.1.17.24 {8.4 compatible formatting of doubles} \ +test util-16.1.17.24 {8.4 compatible formatting of doubles} precision \ {expr 1e24} \ 9.9999999999999998e+23 -test util-16.1.17.25 {8.4 compatible formatting of doubles} \ +test util-16.1.17.25 {8.4 compatible formatting of doubles} precision \ {expr 1e25} \ 1.0000000000000001e+25 -test util-16.1.17.26 {8.4 compatible formatting of doubles} \ +test util-16.1.17.26 {8.4 compatible formatting of doubles} precision \ {expr 1e26} \ 1e+26 -test util-16.1.17.27 {8.4 compatible formatting of doubles} \ +test util-16.1.17.27 {8.4 compatible formatting of doubles} precision \ {expr 1e27} \ 1e+27 -test util-16.1.17.28 {8.4 compatible formatting of doubles} \ +test util-16.1.17.28 {8.4 compatible formatting of doubles} precision \ {expr 1e28} \ 9.9999999999999996e+27 -test util-16.1.17.29 {8.4 compatible formatting of doubles} \ +test util-16.1.17.29 {8.4 compatible formatting of doubles} precision \ {expr 1e29} \ 9.9999999999999991e+28 -test util-16.1.17.30 {8.4 compatible formatting of doubles} \ +test util-16.1.17.30 {8.4 compatible formatting of doubles} precision \ {expr 1e30} \ 1e+30 -test util-16.1.17.31 {8.4 compatible formatting of doubles} \ +test util-16.1.17.31 {8.4 compatible formatting of doubles} precision \ {expr 1e31} \ 9.9999999999999996e+30 -test util-16.1.17.32 {8.4 compatible formatting of doubles} \ +test util-16.1.17.32 {8.4 compatible formatting of doubles} precision \ {expr 1e32} \ 1.0000000000000001e+32 -test util-16.1.17.33 {8.4 compatible formatting of doubles} \ +test util-16.1.17.33 {8.4 compatible formatting of doubles} precision \ {expr 1e33} \ 9.9999999999999995e+32 -test util-16.1.17.34 {8.4 compatible formatting of doubles} \ +test util-16.1.17.34 {8.4 compatible formatting of doubles} precision \ {expr 1e34} \ 9.9999999999999995e+33 -test util-16.1.17.35 {8.4 compatible formatting of doubles} \ +test util-16.1.17.35 {8.4 compatible formatting of doubles} precision \ {expr 1e35} \ 9.9999999999999997e+34 -test util-16.1.17.36 {8.4 compatible formatting of doubles} \ +test util-16.1.17.36 {8.4 compatible formatting of doubles} precision \ {expr 1e36} \ 1e+36 -test util-16.1.17.37 {8.4 compatible formatting of doubles} \ +test util-16.1.17.37 {8.4 compatible formatting of doubles} precision \ {expr 1e37} \ 9.9999999999999995e+36 -test util-16.1.17.38 {8.4 compatible formatting of doubles} \ +test util-16.1.17.38 {8.4 compatible formatting of doubles} precision \ {expr 1e38} \ 9.9999999999999998e+37 -test util-16.1.17.39 {8.4 compatible formatting of doubles} \ +test util-16.1.17.39 {8.4 compatible formatting of doubles} precision \ {expr 1e39} \ 9.9999999999999994e+38 -test util-16.1.17.40 {8.4 compatible formatting of doubles} \ +test util-16.1.17.40 {8.4 compatible formatting of doubles} precision \ {expr 1e40} \ 1e+40 -test util-16.1.17.41 {8.4 compatible formatting of doubles} \ +test util-16.1.17.41 {8.4 compatible formatting of doubles} precision \ {expr 1e41} \ 1e+41 -test util-16.1.17.42 {8.4 compatible formatting of doubles} \ +test util-16.1.17.42 {8.4 compatible formatting of doubles} precision \ {expr 1e42} \ 1e+42 -test util-16.1.17.43 {8.4 compatible formatting of doubles} \ +test util-16.1.17.43 {8.4 compatible formatting of doubles} precision \ {expr 1e43} \ 1e+43 -test util-16.1.17.44 {8.4 compatible formatting of doubles} \ +test util-16.1.17.44 {8.4 compatible formatting of doubles} precision \ {expr 1e44} \ 1.0000000000000001e+44 -test util-16.1.17.45 {8.4 compatible formatting of doubles} \ +test util-16.1.17.45 {8.4 compatible formatting of doubles} precision \ {expr 1e45} \ 9.9999999999999993e+44 -test util-16.1.17.46 {8.4 compatible formatting of doubles} \ +test util-16.1.17.46 {8.4 compatible formatting of doubles} precision \ {expr 1e46} \ 9.9999999999999999e+45 -test util-16.1.17.47 {8.4 compatible formatting of doubles} \ +test util-16.1.17.47 {8.4 compatible formatting of doubles} precision \ {expr 1e47} \ 1e+47 -test util-16.1.17.48 {8.4 compatible formatting of doubles} \ +test util-16.1.17.48 {8.4 compatible formatting of doubles} precision \ {expr 1e48} \ 1e+48 -test util-16.1.17.49 {8.4 compatible formatting of doubles} \ +test util-16.1.17.49 {8.4 compatible formatting of doubles} precision \ {expr 1e49} \ 9.9999999999999995e+48 -test util-16.1.17.50 {8.4 compatible formatting of doubles} \ +test util-16.1.17.50 {8.4 compatible formatting of doubles} precision \ {expr 1e50} \ 1.0000000000000001e+50 -test util-16.1.17.51 {8.4 compatible formatting of doubles} \ +test util-16.1.17.51 {8.4 compatible formatting of doubles} precision \ {expr 1e51} \ 9.9999999999999999e+50 -test util-16.1.17.52 {8.4 compatible formatting of doubles} \ +test util-16.1.17.52 {8.4 compatible formatting of doubles} precision \ {expr 1e52} \ 9.9999999999999999e+51 -test util-16.1.17.53 {8.4 compatible formatting of doubles} \ +test util-16.1.17.53 {8.4 compatible formatting of doubles} precision \ {expr 1e53} \ 9.9999999999999999e+52 -test util-16.1.17.54 {8.4 compatible formatting of doubles} \ +test util-16.1.17.54 {8.4 compatible formatting of doubles} precision \ {expr 1e54} \ 1.0000000000000001e+54 -test util-16.1.17.55 {8.4 compatible formatting of doubles} \ +test util-16.1.17.55 {8.4 compatible formatting of doubles} precision \ {expr 1e55} \ 1e+55 -test util-16.1.17.56 {8.4 compatible formatting of doubles} \ +test util-16.1.17.56 {8.4 compatible formatting of doubles} precision \ {expr 1e56} \ 1.0000000000000001e+56 -test util-16.1.17.57 {8.4 compatible formatting of doubles} \ +test util-16.1.17.57 {8.4 compatible formatting of doubles} precision \ {expr 1e57} \ 1e+57 -test util-16.1.17.58 {8.4 compatible formatting of doubles} \ +test util-16.1.17.58 {8.4 compatible formatting of doubles} precision \ {expr 1e58} \ 9.9999999999999994e+57 -test util-16.1.17.59 {8.4 compatible formatting of doubles} \ +test util-16.1.17.59 {8.4 compatible formatting of doubles} precision \ {expr 1e59} \ 9.9999999999999997e+58 -test util-16.1.17.60 {8.4 compatible formatting of doubles} \ +test util-16.1.17.60 {8.4 compatible formatting of doubles} precision \ {expr 1e60} \ 9.9999999999999995e+59 -test util-16.1.17.61 {8.4 compatible formatting of doubles} \ +test util-16.1.17.61 {8.4 compatible formatting of doubles} precision \ {expr 1e61} \ 9.9999999999999995e+60 -test util-16.1.17.62 {8.4 compatible formatting of doubles} \ +test util-16.1.17.62 {8.4 compatible formatting of doubles} precision \ {expr 1e62} \ 1e+62 -test util-16.1.17.63 {8.4 compatible formatting of doubles} \ +test util-16.1.17.63 {8.4 compatible formatting of doubles} precision \ {expr 1e63} \ 1.0000000000000001e+63 -test util-16.1.17.64 {8.4 compatible formatting of doubles} \ +test util-16.1.17.64 {8.4 compatible formatting of doubles} precision \ {expr 1e64} \ 1e+64 -test util-16.1.17.65 {8.4 compatible formatting of doubles} \ +test util-16.1.17.65 {8.4 compatible formatting of doubles} precision \ {expr 1e65} \ 9.9999999999999999e+64 -test util-16.1.17.66 {8.4 compatible formatting of doubles} \ +test util-16.1.17.66 {8.4 compatible formatting of doubles} precision \ {expr 1e66} \ 9.9999999999999995e+65 -test util-16.1.17.67 {8.4 compatible formatting of doubles} \ +test util-16.1.17.67 {8.4 compatible formatting of doubles} precision \ {expr 1e67} \ 9.9999999999999998e+66 -test util-16.1.17.68 {8.4 compatible formatting of doubles} \ +test util-16.1.17.68 {8.4 compatible formatting of doubles} precision \ {expr 1e68} \ 9.9999999999999995e+67 -test util-16.1.17.69 {8.4 compatible formatting of doubles} \ +test util-16.1.17.69 {8.4 compatible formatting of doubles} precision \ {expr 1e69} \ 1.0000000000000001e+69 -test util-16.1.17.70 {8.4 compatible formatting of doubles} \ +test util-16.1.17.70 {8.4 compatible formatting of doubles} precision \ {expr 1e70} \ 1.0000000000000001e+70 -test util-16.1.17.71 {8.4 compatible formatting of doubles} \ +test util-16.1.17.71 {8.4 compatible formatting of doubles} precision \ {expr 1e71} \ 1e+71 -test util-16.1.17.72 {8.4 compatible formatting of doubles} \ +test util-16.1.17.72 {8.4 compatible formatting of doubles} precision \ {expr 1e72} \ 9.9999999999999994e+71 -test util-16.1.17.73 {8.4 compatible formatting of doubles} \ +test util-16.1.17.73 {8.4 compatible formatting of doubles} precision \ {expr 1e73} \ 9.9999999999999998e+72 -test util-16.1.17.74 {8.4 compatible formatting of doubles} \ +test util-16.1.17.74 {8.4 compatible formatting of doubles} precision \ {expr 1e74} \ 9.9999999999999995e+73 -test util-16.1.17.75 {8.4 compatible formatting of doubles} \ +test util-16.1.17.75 {8.4 compatible formatting of doubles} precision \ {expr 1e75} \ 9.9999999999999993e+74 -test util-16.1.17.76 {8.4 compatible formatting of doubles} \ +test util-16.1.17.76 {8.4 compatible formatting of doubles} precision \ {expr 1e76} \ 1e+76 -test util-16.1.17.77 {8.4 compatible formatting of doubles} \ +test util-16.1.17.77 {8.4 compatible formatting of doubles} precision \ {expr 1e77} \ 9.9999999999999998e+76 -test util-16.1.17.78 {8.4 compatible formatting of doubles} \ +test util-16.1.17.78 {8.4 compatible formatting of doubles} precision \ {expr 1e78} \ 1e+78 -test util-16.1.17.79 {8.4 compatible formatting of doubles} \ +test util-16.1.17.79 {8.4 compatible formatting of doubles} precision \ {expr 1e79} \ 9.9999999999999997e+78 -test util-16.1.17.80 {8.4 compatible formatting of doubles} \ +test util-16.1.17.80 {8.4 compatible formatting of doubles} precision \ {expr 1e80} \ 1e+80 -test util-16.1.17.81 {8.4 compatible formatting of doubles} \ +test util-16.1.17.81 {8.4 compatible formatting of doubles} precision \ {expr 1e81} \ 9.9999999999999992e+80 -test util-16.1.17.82 {8.4 compatible formatting of doubles} \ +test util-16.1.17.82 {8.4 compatible formatting of doubles} precision \ {expr 1e82} \ 9.9999999999999996e+81 -test util-16.1.17.83 {8.4 compatible formatting of doubles} \ +test util-16.1.17.83 {8.4 compatible formatting of doubles} precision \ {expr 1e83} \ 1e+83 -test util-16.1.17.84 {8.4 compatible formatting of doubles} \ +test util-16.1.17.84 {8.4 compatible formatting of doubles} precision \ {expr 1e84} \ 1.0000000000000001e+84 -test util-16.1.17.85 {8.4 compatible formatting of doubles} \ +test util-16.1.17.85 {8.4 compatible formatting of doubles} precision \ {expr 1e85} \ 1e+85 -test util-16.1.17.86 {8.4 compatible formatting of doubles} \ +test util-16.1.17.86 {8.4 compatible formatting of doubles} precision \ {expr 1e86} \ 1e+86 -test util-16.1.17.87 {8.4 compatible formatting of doubles} \ +test util-16.1.17.87 {8.4 compatible formatting of doubles} precision \ {expr 1e87} \ 9.9999999999999996e+86 -test util-16.1.17.88 {8.4 compatible formatting of doubles} \ +test util-16.1.17.88 {8.4 compatible formatting of doubles} precision \ {expr 1e88} \ 9.9999999999999996e+87 -test util-16.1.17.89 {8.4 compatible formatting of doubles} \ +test util-16.1.17.89 {8.4 compatible formatting of doubles} precision \ {expr 1e89} \ 9.9999999999999999e+88 -test util-16.1.17.90 {8.4 compatible formatting of doubles} \ +test util-16.1.17.90 {8.4 compatible formatting of doubles} precision \ {expr 1e90} \ 9.9999999999999997e+89 -test util-16.1.17.91 {8.4 compatible formatting of doubles} \ +test util-16.1.17.91 {8.4 compatible formatting of doubles} precision \ {expr 1e91} \ 1.0000000000000001e+91 -test util-16.1.17.92 {8.4 compatible formatting of doubles} \ +test util-16.1.17.92 {8.4 compatible formatting of doubles} precision \ {expr 1e92} \ 1e+92 -test util-16.1.17.93 {8.4 compatible formatting of doubles} \ +test util-16.1.17.93 {8.4 compatible formatting of doubles} precision \ {expr 1e93} \ 1e+93 -test util-16.1.17.94 {8.4 compatible formatting of doubles} \ +test util-16.1.17.94 {8.4 compatible formatting of doubles} precision \ {expr 1e94} \ 1e+94 -test util-16.1.17.95 {8.4 compatible formatting of doubles} \ +test util-16.1.17.95 {8.4 compatible formatting of doubles} precision \ {expr 1e95} \ 1e+95 -test util-16.1.17.96 {8.4 compatible formatting of doubles} \ +test util-16.1.17.96 {8.4 compatible formatting of doubles} precision \ {expr 1e96} \ 1e+96 -test util-16.1.17.97 {8.4 compatible formatting of doubles} \ +test util-16.1.17.97 {8.4 compatible formatting of doubles} precision \ {expr 1e97} \ 1.0000000000000001e+97 -test util-16.1.17.98 {8.4 compatible formatting of doubles} \ +test util-16.1.17.98 {8.4 compatible formatting of doubles} precision \ {expr 1e98} \ 1e+98 -test util-16.1.17.99 {8.4 compatible formatting of doubles} \ +test util-16.1.17.99 {8.4 compatible formatting of doubles} precision \ {expr 1e99} \ 9.9999999999999997e+98 -test util-16.1.17.100 {8.4 compatible formatting of doubles} \ +test util-16.1.17.100 {8.4 compatible formatting of doubles} precision \ {expr 1e100} \ 1e+100 -test util-16.1.17.101 {8.4 compatible formatting of doubles} \ +test util-16.1.17.101 {8.4 compatible formatting of doubles} precision \ {expr 1e101} \ 9.9999999999999998e+100 -test util-16.1.17.102 {8.4 compatible formatting of doubles} \ +test util-16.1.17.102 {8.4 compatible formatting of doubles} precision \ {expr 1e102} \ 9.9999999999999998e+101 -test util-16.1.17.103 {8.4 compatible formatting of doubles} \ +test util-16.1.17.103 {8.4 compatible formatting of doubles} precision \ {expr 1e103} \ 1e+103 -test util-16.1.17.104 {8.4 compatible formatting of doubles} \ +test util-16.1.17.104 {8.4 compatible formatting of doubles} precision \ {expr 1e104} \ 1e+104 -test util-16.1.17.105 {8.4 compatible formatting of doubles} \ +test util-16.1.17.105 {8.4 compatible formatting of doubles} precision \ {expr 1e105} \ 9.9999999999999994e+104 -test util-16.1.17.106 {8.4 compatible formatting of doubles} \ +test util-16.1.17.106 {8.4 compatible formatting of doubles} precision \ {expr 1e106} \ 1.0000000000000001e+106 -test util-16.1.17.107 {8.4 compatible formatting of doubles} \ +test util-16.1.17.107 {8.4 compatible formatting of doubles} precision \ {expr 1e107} \ 9.9999999999999997e+106 -test util-16.1.17.108 {8.4 compatible formatting of doubles} \ +test util-16.1.17.108 {8.4 compatible formatting of doubles} precision \ {expr 1e108} \ 1e+108 -test util-16.1.17.109 {8.4 compatible formatting of doubles} \ +test util-16.1.17.109 {8.4 compatible formatting of doubles} precision \ {expr 1e109} \ 9.9999999999999998e+108 -test util-16.1.17.110 {8.4 compatible formatting of doubles} \ +test util-16.1.17.110 {8.4 compatible formatting of doubles} precision \ {expr 1e110} \ 1e+110 -test util-16.1.17.111 {8.4 compatible formatting of doubles} \ +test util-16.1.17.111 {8.4 compatible formatting of doubles} precision \ {expr 1e111} \ 9.9999999999999996e+110 -test util-16.1.17.112 {8.4 compatible formatting of doubles} \ +test util-16.1.17.112 {8.4 compatible formatting of doubles} precision \ {expr 1e112} \ 9.9999999999999993e+111 -test util-16.1.17.113 {8.4 compatible formatting of doubles} \ +test util-16.1.17.113 {8.4 compatible formatting of doubles} precision \ {expr 1e113} \ 1e+113 -test util-16.1.17.114 {8.4 compatible formatting of doubles} \ +test util-16.1.17.114 {8.4 compatible formatting of doubles} precision \ {expr 1e114} \ 1e+114 -test util-16.1.17.115 {8.4 compatible formatting of doubles} \ +test util-16.1.17.115 {8.4 compatible formatting of doubles} precision \ {expr 1e115} \ 1e+115 -test util-16.1.17.116 {8.4 compatible formatting of doubles} \ +test util-16.1.17.116 {8.4 compatible formatting of doubles} precision \ {expr 1e116} \ 1e+116 -test util-16.1.17.117 {8.4 compatible formatting of doubles} \ +test util-16.1.17.117 {8.4 compatible formatting of doubles} precision \ {expr 1e117} \ 1.0000000000000001e+117 -test util-16.1.17.118 {8.4 compatible formatting of doubles} \ +test util-16.1.17.118 {8.4 compatible formatting of doubles} precision \ {expr 1e118} \ 9.9999999999999997e+117 -test util-16.1.17.119 {8.4 compatible formatting of doubles} \ +test util-16.1.17.119 {8.4 compatible formatting of doubles} precision \ {expr 1e119} \ 9.9999999999999994e+118 -test util-16.1.17.120 {8.4 compatible formatting of doubles} \ +test util-16.1.17.120 {8.4 compatible formatting of doubles} precision \ {expr 1e120} \ 9.9999999999999998e+119 -test util-16.1.17.121 {8.4 compatible formatting of doubles} \ +test util-16.1.17.121 {8.4 compatible formatting of doubles} precision \ {expr 1e121} \ 1e+121 -test util-16.1.17.122 {8.4 compatible formatting of doubles} \ +test util-16.1.17.122 {8.4 compatible formatting of doubles} precision \ {expr 1e122} \ 1e+122 -test util-16.1.17.123 {8.4 compatible formatting of doubles} \ +test util-16.1.17.123 {8.4 compatible formatting of doubles} precision \ {expr 1e123} \ 9.9999999999999998e+122 -test util-16.1.17.124 {8.4 compatible formatting of doubles} \ +test util-16.1.17.124 {8.4 compatible formatting of doubles} precision \ {expr 1e124} \ 9.9999999999999995e+123 -test util-16.1.17.125 {8.4 compatible formatting of doubles} \ +test util-16.1.17.125 {8.4 compatible formatting of doubles} precision \ {expr 1e125} \ 9.9999999999999992e+124 -test util-16.1.17.126 {8.4 compatible formatting of doubles} \ +test util-16.1.17.126 {8.4 compatible formatting of doubles} precision \ {expr 1e126} \ 9.9999999999999992e+125 -test util-16.1.17.127 {8.4 compatible formatting of doubles} \ +test util-16.1.17.127 {8.4 compatible formatting of doubles} precision \ {expr 1e127} \ 9.9999999999999995e+126 -test util-16.1.17.128 {8.4 compatible formatting of doubles} \ +test util-16.1.17.128 {8.4 compatible formatting of doubles} precision \ {expr 1e128} \ 1.0000000000000001e+128 -test util-16.1.17.129 {8.4 compatible formatting of doubles} \ +test util-16.1.17.129 {8.4 compatible formatting of doubles} precision \ {expr 1e129} \ 1e+129 -test util-16.1.17.130 {8.4 compatible formatting of doubles} \ +test util-16.1.17.130 {8.4 compatible formatting of doubles} precision \ {expr 1e130} \ 1.0000000000000001e+130 -test util-16.1.17.131 {8.4 compatible formatting of doubles} \ +test util-16.1.17.131 {8.4 compatible formatting of doubles} precision \ {expr 1e131} \ 9.9999999999999991e+130 -test util-16.1.17.132 {8.4 compatible formatting of doubles} \ +test util-16.1.17.132 {8.4 compatible formatting of doubles} precision \ {expr 1e132} \ 9.9999999999999999e+131 -test util-16.1.17.133 {8.4 compatible formatting of doubles} \ +test util-16.1.17.133 {8.4 compatible formatting of doubles} precision \ {expr 1e133} \ 1e+133 -test util-16.1.17.134 {8.4 compatible formatting of doubles} \ +test util-16.1.17.134 {8.4 compatible formatting of doubles} precision \ {expr 1e134} \ 9.9999999999999992e+133 -test util-16.1.17.135 {8.4 compatible formatting of doubles} \ +test util-16.1.17.135 {8.4 compatible formatting of doubles} precision \ {expr 1e135} \ 9.9999999999999996e+134 -test util-16.1.17.136 {8.4 compatible formatting of doubles} \ +test util-16.1.17.136 {8.4 compatible formatting of doubles} precision \ {expr 1e136} \ 1.0000000000000001e+136 -test util-16.1.17.137 {8.4 compatible formatting of doubles} \ +test util-16.1.17.137 {8.4 compatible formatting of doubles} precision \ {expr 1e137} \ 1e+137 -test util-16.1.17.138 {8.4 compatible formatting of doubles} \ +test util-16.1.17.138 {8.4 compatible formatting of doubles} precision \ {expr 1e138} \ 1e+138 -test util-16.1.17.139 {8.4 compatible formatting of doubles} \ +test util-16.1.17.139 {8.4 compatible formatting of doubles} precision \ {expr 1e139} \ 1e+139 -test util-16.1.17.140 {8.4 compatible formatting of doubles} \ +test util-16.1.17.140 {8.4 compatible formatting of doubles} precision \ {expr 1e140} \ 1.0000000000000001e+140 -test util-16.1.17.141 {8.4 compatible formatting of doubles} \ +test util-16.1.17.141 {8.4 compatible formatting of doubles} precision \ {expr 1e141} \ 1e+141 -test util-16.1.17.142 {8.4 compatible formatting of doubles} \ +test util-16.1.17.142 {8.4 compatible formatting of doubles} precision \ {expr 1e142} \ 1.0000000000000001e+142 -test util-16.1.17.143 {8.4 compatible formatting of doubles} \ +test util-16.1.17.143 {8.4 compatible formatting of doubles} precision \ {expr 1e143} \ 1e+143 -test util-16.1.17.144 {8.4 compatible formatting of doubles} \ +test util-16.1.17.144 {8.4 compatible formatting of doubles} precision \ {expr 1e144} \ 1e+144 -test util-16.1.17.145 {8.4 compatible formatting of doubles} \ +test util-16.1.17.145 {8.4 compatible formatting of doubles} precision \ {expr 1e145} \ 9.9999999999999999e+144 -test util-16.1.17.146 {8.4 compatible formatting of doubles} \ +test util-16.1.17.146 {8.4 compatible formatting of doubles} precision \ {expr 1e146} \ 9.9999999999999993e+145 -test util-16.1.17.147 {8.4 compatible formatting of doubles} \ +test util-16.1.17.147 {8.4 compatible formatting of doubles} precision \ {expr 1e147} \ 9.9999999999999998e+146 -test util-16.1.17.148 {8.4 compatible formatting of doubles} \ +test util-16.1.17.148 {8.4 compatible formatting of doubles} precision \ {expr 1e148} \ 1e+148 -test util-16.1.17.149 {8.4 compatible formatting of doubles} \ +test util-16.1.17.149 {8.4 compatible formatting of doubles} precision \ {expr 1e149} \ 1e+149 -test util-16.1.17.150 {8.4 compatible formatting of doubles} \ +test util-16.1.17.150 {8.4 compatible formatting of doubles} precision \ {expr 1e150} \ 9.9999999999999998e+149 -test util-16.1.17.151 {8.4 compatible formatting of doubles} \ +test util-16.1.17.151 {8.4 compatible formatting of doubles} precision \ {expr 1e151} \ 1e+151 -test util-16.1.17.152 {8.4 compatible formatting of doubles} \ +test util-16.1.17.152 {8.4 compatible formatting of doubles} precision \ {expr 1e152} \ 1e+152 -test util-16.1.17.153 {8.4 compatible formatting of doubles} \ +test util-16.1.17.153 {8.4 compatible formatting of doubles} precision \ {expr 1e153} \ 1e+153 -test util-16.1.17.154 {8.4 compatible formatting of doubles} \ +test util-16.1.17.154 {8.4 compatible formatting of doubles} precision \ {expr 1e154} \ 1e+154 -test util-16.1.17.155 {8.4 compatible formatting of doubles} \ +test util-16.1.17.155 {8.4 compatible formatting of doubles} precision \ {expr 1e155} \ 1e+155 -test util-16.1.17.156 {8.4 compatible formatting of doubles} \ +test util-16.1.17.156 {8.4 compatible formatting of doubles} precision \ {expr 1e156} \ 9.9999999999999998e+155 -test util-16.1.17.157 {8.4 compatible formatting of doubles} \ +test util-16.1.17.157 {8.4 compatible formatting of doubles} precision \ {expr 1e157} \ 9.9999999999999998e+156 -test util-16.1.17.158 {8.4 compatible formatting of doubles} \ +test util-16.1.17.158 {8.4 compatible formatting of doubles} precision \ {expr 1e158} \ 9.9999999999999995e+157 -test util-16.1.17.159 {8.4 compatible formatting of doubles} \ +test util-16.1.17.159 {8.4 compatible formatting of doubles} precision \ {expr 1e159} \ 9.9999999999999993e+158 -test util-16.1.17.160 {8.4 compatible formatting of doubles} \ +test util-16.1.17.160 {8.4 compatible formatting of doubles} precision \ {expr 1e160} \ 1e+160 -test util-16.1.17.161 {8.4 compatible formatting of doubles} \ +test util-16.1.17.161 {8.4 compatible formatting of doubles} precision \ {expr 1e161} \ 1e+161 -test util-16.1.17.162 {8.4 compatible formatting of doubles} \ +test util-16.1.17.162 {8.4 compatible formatting of doubles} precision \ {expr 1e162} \ 9.9999999999999994e+161 -test util-16.1.17.163 {8.4 compatible formatting of doubles} \ +test util-16.1.17.163 {8.4 compatible formatting of doubles} precision \ {expr 1e163} \ 9.9999999999999994e+162 -test util-16.1.17.164 {8.4 compatible formatting of doubles} \ +test util-16.1.17.164 {8.4 compatible formatting of doubles} precision \ {expr 1e164} \ 1e+164 -test util-16.1.17.165 {8.4 compatible formatting of doubles} \ +test util-16.1.17.165 {8.4 compatible formatting of doubles} precision \ {expr 1e165} \ 9.999999999999999e+164 -test util-16.1.17.166 {8.4 compatible formatting of doubles} \ +test util-16.1.17.166 {8.4 compatible formatting of doubles} precision \ {expr 1e166} \ 9.9999999999999994e+165 -test util-16.1.17.167 {8.4 compatible formatting of doubles} \ +test util-16.1.17.167 {8.4 compatible formatting of doubles} precision \ {expr 1e167} \ 1e+167 -test util-16.1.17.168 {8.4 compatible formatting of doubles} \ +test util-16.1.17.168 {8.4 compatible formatting of doubles} precision \ {expr 1e168} \ 9.9999999999999993e+167 -test util-16.1.17.169 {8.4 compatible formatting of doubles} \ +test util-16.1.17.169 {8.4 compatible formatting of doubles} precision \ {expr 1e169} \ 9.9999999999999993e+168 -test util-16.1.17.170 {8.4 compatible formatting of doubles} \ +test util-16.1.17.170 {8.4 compatible formatting of doubles} precision \ {expr 1e170} \ 1e+170 -test util-16.1.17.171 {8.4 compatible formatting of doubles} \ +test util-16.1.17.171 {8.4 compatible formatting of doubles} precision \ {expr 1e171} \ 9.9999999999999995e+170 -test util-16.1.17.172 {8.4 compatible formatting of doubles} \ +test util-16.1.17.172 {8.4 compatible formatting of doubles} precision \ {expr 1e172} \ 1.0000000000000001e+172 -test util-16.1.17.173 {8.4 compatible formatting of doubles} \ +test util-16.1.17.173 {8.4 compatible formatting of doubles} precision \ {expr 1e173} \ 1e+173 -test util-16.1.17.174 {8.4 compatible formatting of doubles} \ +test util-16.1.17.174 {8.4 compatible formatting of doubles} precision \ {expr 1e174} \ 1.0000000000000001e+174 -test util-16.1.17.175 {8.4 compatible formatting of doubles} \ +test util-16.1.17.175 {8.4 compatible formatting of doubles} precision \ {expr 1e175} \ 9.9999999999999994e+174 -test util-16.1.17.176 {8.4 compatible formatting of doubles} \ +test util-16.1.17.176 {8.4 compatible formatting of doubles} precision \ {expr 1e176} \ 1e+176 -test util-16.1.17.177 {8.4 compatible formatting of doubles} \ +test util-16.1.17.177 {8.4 compatible formatting of doubles} precision \ {expr 1e177} \ 1e+177 -test util-16.1.17.178 {8.4 compatible formatting of doubles} \ +test util-16.1.17.178 {8.4 compatible formatting of doubles} precision \ {expr 1e178} \ 1.0000000000000001e+178 -test util-16.1.17.179 {8.4 compatible formatting of doubles} \ +test util-16.1.17.179 {8.4 compatible formatting of doubles} precision \ {expr 1e179} \ 9.9999999999999998e+178 -test util-16.1.17.180 {8.4 compatible formatting of doubles} \ +test util-16.1.17.180 {8.4 compatible formatting of doubles} precision \ {expr 1e180} \ 1e+180 -test util-16.1.17.181 {8.4 compatible formatting of doubles} \ +test util-16.1.17.181 {8.4 compatible formatting of doubles} precision \ {expr 1e181} \ 9.9999999999999992e+180 -test util-16.1.17.182 {8.4 compatible formatting of doubles} \ +test util-16.1.17.182 {8.4 compatible formatting of doubles} precision \ {expr 1e182} \ 1.0000000000000001e+182 -test util-16.1.17.183 {8.4 compatible formatting of doubles} \ +test util-16.1.17.183 {8.4 compatible formatting of doubles} precision \ {expr 1e183} \ 9.9999999999999995e+182 -test util-16.1.17.184 {8.4 compatible formatting of doubles} \ +test util-16.1.17.184 {8.4 compatible formatting of doubles} precision \ {expr 1e184} \ 1e+184 -test util-16.1.17.185 {8.4 compatible formatting of doubles} \ +test util-16.1.17.185 {8.4 compatible formatting of doubles} precision \ {expr 1e185} \ 9.9999999999999998e+184 -test util-16.1.17.186 {8.4 compatible formatting of doubles} \ +test util-16.1.17.186 {8.4 compatible formatting of doubles} precision \ {expr 1e186} \ 9.9999999999999998e+185 -test util-16.1.17.187 {8.4 compatible formatting of doubles} \ +test util-16.1.17.187 {8.4 compatible formatting of doubles} precision \ {expr 1e187} \ 9.9999999999999991e+186 -test util-16.1.17.188 {8.4 compatible formatting of doubles} \ +test util-16.1.17.188 {8.4 compatible formatting of doubles} precision \ {expr 1e188} \ 1e+188 -test util-16.1.17.189 {8.4 compatible formatting of doubles} \ +test util-16.1.17.189 {8.4 compatible formatting of doubles} precision \ {expr 1e189} \ 1e+189 -test util-16.1.17.190 {8.4 compatible formatting of doubles} \ +test util-16.1.17.190 {8.4 compatible formatting of doubles} precision \ {expr 1e190} \ 1.0000000000000001e+190 -test util-16.1.17.191 {8.4 compatible formatting of doubles} \ +test util-16.1.17.191 {8.4 compatible formatting of doubles} precision \ {expr 1e191} \ 1.0000000000000001e+191 -test util-16.1.17.192 {8.4 compatible formatting of doubles} \ +test util-16.1.17.192 {8.4 compatible formatting of doubles} precision \ {expr 1e192} \ 1e+192 -test util-16.1.17.193 {8.4 compatible formatting of doubles} \ +test util-16.1.17.193 {8.4 compatible formatting of doubles} precision \ {expr 1e193} \ 1.0000000000000001e+193 -test util-16.1.17.194 {8.4 compatible formatting of doubles} \ +test util-16.1.17.194 {8.4 compatible formatting of doubles} precision \ {expr 1e194} \ 9.9999999999999994e+193 -test util-16.1.17.195 {8.4 compatible formatting of doubles} \ +test util-16.1.17.195 {8.4 compatible formatting of doubles} precision \ {expr 1e195} \ 9.9999999999999998e+194 -test util-16.1.17.196 {8.4 compatible formatting of doubles} \ +test util-16.1.17.196 {8.4 compatible formatting of doubles} precision \ {expr 1e196} \ 9.9999999999999995e+195 -test util-16.1.17.197 {8.4 compatible formatting of doubles} \ +test util-16.1.17.197 {8.4 compatible formatting of doubles} precision \ {expr 1e197} \ 9.9999999999999995e+196 -test util-16.1.17.198 {8.4 compatible formatting of doubles} \ +test util-16.1.17.198 {8.4 compatible formatting of doubles} precision \ {expr 1e198} \ 1e+198 -test util-16.1.17.199 {8.4 compatible formatting of doubles} \ +test util-16.1.17.199 {8.4 compatible formatting of doubles} precision \ {expr 1e199} \ 1.0000000000000001e+199 -test util-16.1.17.200 {8.4 compatible formatting of doubles} \ +test util-16.1.17.200 {8.4 compatible formatting of doubles} precision \ {expr 1e200} \ 9.9999999999999997e+199 -test util-16.1.17.201 {8.4 compatible formatting of doubles} \ +test util-16.1.17.201 {8.4 compatible formatting of doubles} precision \ {expr 1e201} \ 1e+201 -test util-16.1.17.202 {8.4 compatible formatting of doubles} \ +test util-16.1.17.202 {8.4 compatible formatting of doubles} precision \ {expr 1e202} \ 9.999999999999999e+201 -test util-16.1.17.203 {8.4 compatible formatting of doubles} \ +test util-16.1.17.203 {8.4 compatible formatting of doubles} precision \ {expr 1e203} \ 9.9999999999999999e+202 -test util-16.1.17.204 {8.4 compatible formatting of doubles} \ +test util-16.1.17.204 {8.4 compatible formatting of doubles} precision \ {expr 1e204} \ 9.9999999999999999e+203 -test util-16.1.17.205 {8.4 compatible formatting of doubles} \ +test util-16.1.17.205 {8.4 compatible formatting of doubles} precision \ {expr 1e205} \ 1e+205 -test util-16.1.17.206 {8.4 compatible formatting of doubles} \ +test util-16.1.17.206 {8.4 compatible formatting of doubles} precision \ {expr 1e206} \ 1e+206 -test util-16.1.17.207 {8.4 compatible formatting of doubles} \ +test util-16.1.17.207 {8.4 compatible formatting of doubles} precision \ {expr 1e207} \ 1e+207 -test util-16.1.17.208 {8.4 compatible formatting of doubles} \ +test util-16.1.17.208 {8.4 compatible formatting of doubles} precision \ {expr 1e208} \ 9.9999999999999998e+207 -test util-16.1.17.209 {8.4 compatible formatting of doubles} \ +test util-16.1.17.209 {8.4 compatible formatting of doubles} precision \ {expr 1e209} \ 1.0000000000000001e+209 -test util-16.1.17.210 {8.4 compatible formatting of doubles} \ +test util-16.1.17.210 {8.4 compatible formatting of doubles} precision \ {expr 1e210} \ 9.9999999999999993e+209 -test util-16.1.17.211 {8.4 compatible formatting of doubles} \ +test util-16.1.17.211 {8.4 compatible formatting of doubles} precision \ {expr 1e211} \ 9.9999999999999996e+210 -test util-16.1.17.212 {8.4 compatible formatting of doubles} \ +test util-16.1.17.212 {8.4 compatible formatting of doubles} precision \ {expr 1e212} \ 9.9999999999999991e+211 -test util-16.1.17.213 {8.4 compatible formatting of doubles} \ +test util-16.1.17.213 {8.4 compatible formatting of doubles} precision \ {expr 1e213} \ 9.9999999999999998e+212 -test util-16.1.17.214 {8.4 compatible formatting of doubles} \ +test util-16.1.17.214 {8.4 compatible formatting of doubles} precision \ {expr 1e214} \ 9.9999999999999995e+213 -test util-16.1.17.215 {8.4 compatible formatting of doubles} \ +test util-16.1.17.215 {8.4 compatible formatting of doubles} precision \ {expr 1e215} \ 9.9999999999999991e+214 -test util-16.1.17.216 {8.4 compatible formatting of doubles} \ +test util-16.1.17.216 {8.4 compatible formatting of doubles} precision \ {expr 1e216} \ 1e+216 -test util-16.1.17.217 {8.4 compatible formatting of doubles} \ +test util-16.1.17.217 {8.4 compatible formatting of doubles} precision \ {expr 1e217} \ 9.9999999999999996e+216 -test util-16.1.17.218 {8.4 compatible formatting of doubles} \ +test util-16.1.17.218 {8.4 compatible formatting of doubles} precision \ {expr 1e218} \ 1.0000000000000001e+218 -test util-16.1.17.219 {8.4 compatible formatting of doubles} \ +test util-16.1.17.219 {8.4 compatible formatting of doubles} precision \ {expr 1e219} \ 9.9999999999999997e+218 -test util-16.1.17.220 {8.4 compatible formatting of doubles} \ +test util-16.1.17.220 {8.4 compatible formatting of doubles} precision \ {expr 1e220} \ 1e+220 -test util-16.1.17.221 {8.4 compatible formatting of doubles} \ +test util-16.1.17.221 {8.4 compatible formatting of doubles} precision \ {expr 1e221} \ 1e+221 -test util-16.1.17.222 {8.4 compatible formatting of doubles} \ +test util-16.1.17.222 {8.4 compatible formatting of doubles} precision \ {expr 1e222} \ 1e+222 -test util-16.1.17.223 {8.4 compatible formatting of doubles} \ +test util-16.1.17.223 {8.4 compatible formatting of doubles} precision \ {expr 1e223} \ 1e+223 -test util-16.1.17.224 {8.4 compatible formatting of doubles} \ +test util-16.1.17.224 {8.4 compatible formatting of doubles} precision \ {expr 1e224} \ 9.9999999999999997e+223 -test util-16.1.17.225 {8.4 compatible formatting of doubles} \ +test util-16.1.17.225 {8.4 compatible formatting of doubles} precision \ {expr 1e225} \ 9.9999999999999993e+224 -test util-16.1.17.226 {8.4 compatible formatting of doubles} \ +test util-16.1.17.226 {8.4 compatible formatting of doubles} precision \ {expr 1e226} \ 9.9999999999999996e+225 -test util-16.1.17.227 {8.4 compatible formatting of doubles} \ +test util-16.1.17.227 {8.4 compatible formatting of doubles} precision \ {expr 1e227} \ 1.0000000000000001e+227 -test util-16.1.17.228 {8.4 compatible formatting of doubles} \ +test util-16.1.17.228 {8.4 compatible formatting of doubles} precision \ {expr 1e228} \ 9.9999999999999992e+227 -test util-16.1.17.229 {8.4 compatible formatting of doubles} \ +test util-16.1.17.229 {8.4 compatible formatting of doubles} precision \ {expr 1e229} \ 9.9999999999999999e+228 -test util-16.1.17.230 {8.4 compatible formatting of doubles} \ +test util-16.1.17.230 {8.4 compatible formatting of doubles} precision \ {expr 1e230} \ 1.0000000000000001e+230 -test util-16.1.17.231 {8.4 compatible formatting of doubles} \ +test util-16.1.17.231 {8.4 compatible formatting of doubles} precision \ {expr 1e231} \ 1.0000000000000001e+231 -test util-16.1.17.232 {8.4 compatible formatting of doubles} \ +test util-16.1.17.232 {8.4 compatible formatting of doubles} precision \ {expr 1e232} \ 1.0000000000000001e+232 -test util-16.1.17.233 {8.4 compatible formatting of doubles} \ +test util-16.1.17.233 {8.4 compatible formatting of doubles} precision \ {expr 1e233} \ 9.9999999999999997e+232 -test util-16.1.17.234 {8.4 compatible formatting of doubles} \ +test util-16.1.17.234 {8.4 compatible formatting of doubles} precision \ {expr 1e234} \ 1e+234 -test util-16.1.17.235 {8.4 compatible formatting of doubles} \ +test util-16.1.17.235 {8.4 compatible formatting of doubles} precision \ {expr 1e235} \ 1.0000000000000001e+235 -test util-16.1.17.236 {8.4 compatible formatting of doubles} \ +test util-16.1.17.236 {8.4 compatible formatting of doubles} precision \ {expr 1e236} \ 1.0000000000000001e+236 -test util-16.1.17.237 {8.4 compatible formatting of doubles} \ +test util-16.1.17.237 {8.4 compatible formatting of doubles} precision \ {expr 1e237} \ 9.9999999999999994e+236 -test util-16.1.17.238 {8.4 compatible formatting of doubles} \ +test util-16.1.17.238 {8.4 compatible formatting of doubles} precision \ {expr 1e238} \ 1e+238 -test util-16.1.17.239 {8.4 compatible formatting of doubles} \ +test util-16.1.17.239 {8.4 compatible formatting of doubles} precision \ {expr 1e239} \ 9.9999999999999999e+238 -test util-16.1.17.240 {8.4 compatible formatting of doubles} \ +test util-16.1.17.240 {8.4 compatible formatting of doubles} precision \ {expr 1e240} \ 1e+240 -test util-16.1.17.241 {8.4 compatible formatting of doubles} \ +test util-16.1.17.241 {8.4 compatible formatting of doubles} precision \ {expr 1e241} \ 1.0000000000000001e+241 -test util-16.1.17.242 {8.4 compatible formatting of doubles} \ +test util-16.1.17.242 {8.4 compatible formatting of doubles} precision \ {expr 1e242} \ 1.0000000000000001e+242 -test util-16.1.17.243 {8.4 compatible formatting of doubles} \ +test util-16.1.17.243 {8.4 compatible formatting of doubles} precision \ {expr 1e243} \ 1.0000000000000001e+243 -test util-16.1.17.244 {8.4 compatible formatting of doubles} \ +test util-16.1.17.244 {8.4 compatible formatting of doubles} precision \ {expr 1e244} \ 1.0000000000000001e+244 -test util-16.1.17.245 {8.4 compatible formatting of doubles} \ +test util-16.1.17.245 {8.4 compatible formatting of doubles} precision \ {expr 1e245} \ 1e+245 -test util-16.1.17.246 {8.4 compatible formatting of doubles} \ +test util-16.1.17.246 {8.4 compatible formatting of doubles} precision \ {expr 1e246} \ 1.0000000000000001e+246 -test util-16.1.17.247 {8.4 compatible formatting of doubles} \ +test util-16.1.17.247 {8.4 compatible formatting of doubles} precision \ {expr 1e247} \ 9.9999999999999995e+246 -test util-16.1.17.248 {8.4 compatible formatting of doubles} \ +test util-16.1.17.248 {8.4 compatible formatting of doubles} precision \ {expr 1e248} \ 1e+248 -test util-16.1.17.249 {8.4 compatible formatting of doubles} \ +test util-16.1.17.249 {8.4 compatible formatting of doubles} precision \ {expr 1e249} \ 9.9999999999999992e+248 -test util-16.1.17.250 {8.4 compatible formatting of doubles} \ +test util-16.1.17.250 {8.4 compatible formatting of doubles} precision \ {expr 1e250} \ 9.9999999999999992e+249 -test util-16.1.17.251 {8.4 compatible formatting of doubles} \ +test util-16.1.17.251 {8.4 compatible formatting of doubles} precision \ {expr 1e251} \ 1e+251 -test util-16.1.17.252 {8.4 compatible formatting of doubles} \ +test util-16.1.17.252 {8.4 compatible formatting of doubles} precision \ {expr 1e252} \ 1.0000000000000001e+252 -test util-16.1.17.253 {8.4 compatible formatting of doubles} \ +test util-16.1.17.253 {8.4 compatible formatting of doubles} precision \ {expr 1e253} \ 9.9999999999999994e+252 -test util-16.1.17.254 {8.4 compatible formatting of doubles} \ +test util-16.1.17.254 {8.4 compatible formatting of doubles} precision \ {expr 1e254} \ 9.9999999999999994e+253 -test util-16.1.17.255 {8.4 compatible formatting of doubles} \ +test util-16.1.17.255 {8.4 compatible formatting of doubles} precision \ {expr 1e255} \ 9.9999999999999999e+254 -test util-16.1.17.256 {8.4 compatible formatting of doubles} \ +test util-16.1.17.256 {8.4 compatible formatting of doubles} precision \ {expr 1e256} \ 1e+256 -test util-16.1.17.257 {8.4 compatible formatting of doubles} \ +test util-16.1.17.257 {8.4 compatible formatting of doubles} precision \ {expr 1e257} \ 1e+257 -test util-16.1.17.258 {8.4 compatible formatting of doubles} \ +test util-16.1.17.258 {8.4 compatible formatting of doubles} precision \ {expr 1e258} \ 1.0000000000000001e+258 -test util-16.1.17.259 {8.4 compatible formatting of doubles} \ +test util-16.1.17.259 {8.4 compatible formatting of doubles} precision \ {expr 1e259} \ 9.9999999999999993e+258 -test util-16.1.17.260 {8.4 compatible formatting of doubles} \ +test util-16.1.17.260 {8.4 compatible formatting of doubles} precision \ {expr 1e260} \ 1.0000000000000001e+260 -test util-16.1.17.261 {8.4 compatible formatting of doubles} \ +test util-16.1.17.261 {8.4 compatible formatting of doubles} precision \ {expr 1e261} \ 9.9999999999999993e+260 -test util-16.1.17.262 {8.4 compatible formatting of doubles} \ +test util-16.1.17.262 {8.4 compatible formatting of doubles} precision \ {expr 1e262} \ 1e+262 -test util-16.1.17.263 {8.4 compatible formatting of doubles} \ +test util-16.1.17.263 {8.4 compatible formatting of doubles} precision \ {expr 1e263} \ 1e+263 -test util-16.1.17.264 {8.4 compatible formatting of doubles} \ +test util-16.1.17.264 {8.4 compatible formatting of doubles} precision \ {expr 1e264} \ 1e+264 -test util-16.1.17.265 {8.4 compatible formatting of doubles} \ +test util-16.1.17.265 {8.4 compatible formatting of doubles} precision \ {expr 1e265} \ 1.0000000000000001e+265 -test util-16.1.17.266 {8.4 compatible formatting of doubles} \ +test util-16.1.17.266 {8.4 compatible formatting of doubles} precision \ {expr 1e266} \ 1e+266 -test util-16.1.17.267 {8.4 compatible formatting of doubles} \ +test util-16.1.17.267 {8.4 compatible formatting of doubles} precision \ {expr 1e267} \ 9.9999999999999997e+266 -test util-16.1.17.268 {8.4 compatible formatting of doubles} \ +test util-16.1.17.268 {8.4 compatible formatting of doubles} precision \ {expr 1e268} \ 9.9999999999999997e+267 -test util-16.1.17.269 {8.4 compatible formatting of doubles} \ +test util-16.1.17.269 {8.4 compatible formatting of doubles} precision \ {expr 1e269} \ 1e+269 -test util-16.1.17.270 {8.4 compatible formatting of doubles} \ +test util-16.1.17.270 {8.4 compatible formatting of doubles} precision \ {expr 1e270} \ 1e+270 -test util-16.1.17.271 {8.4 compatible formatting of doubles} \ +test util-16.1.17.271 {8.4 compatible formatting of doubles} precision \ {expr 1e271} \ 9.9999999999999995e+270 -test util-16.1.17.272 {8.4 compatible formatting of doubles} \ +test util-16.1.17.272 {8.4 compatible formatting of doubles} precision \ {expr 1e272} \ 1.0000000000000001e+272 -test util-16.1.17.273 {8.4 compatible formatting of doubles} \ +test util-16.1.17.273 {8.4 compatible formatting of doubles} precision \ {expr 1e273} \ 9.9999999999999995e+272 -test util-16.1.17.274 {8.4 compatible formatting of doubles} \ +test util-16.1.17.274 {8.4 compatible formatting of doubles} precision \ {expr 1e274} \ 9.9999999999999992e+273 -test util-16.1.17.275 {8.4 compatible formatting of doubles} \ +test util-16.1.17.275 {8.4 compatible formatting of doubles} precision \ {expr 1e275} \ 9.9999999999999996e+274 -test util-16.1.17.276 {8.4 compatible formatting of doubles} \ +test util-16.1.17.276 {8.4 compatible formatting of doubles} precision \ {expr 1e276} \ 1.0000000000000001e+276 -test util-16.1.17.277 {8.4 compatible formatting of doubles} \ +test util-16.1.17.277 {8.4 compatible formatting of doubles} precision \ {expr 1e277} \ 1e+277 -test util-16.1.17.278 {8.4 compatible formatting of doubles} \ +test util-16.1.17.278 {8.4 compatible formatting of doubles} precision \ {expr 1e278} \ 9.9999999999999996e+277 -test util-16.1.17.279 {8.4 compatible formatting of doubles} \ +test util-16.1.17.279 {8.4 compatible formatting of doubles} precision \ {expr 1e279} \ 1.0000000000000001e+279 -test util-16.1.17.280 {8.4 compatible formatting of doubles} \ +test util-16.1.17.280 {8.4 compatible formatting of doubles} precision \ {expr 1e280} \ 1e+280 -test util-16.1.17.281 {8.4 compatible formatting of doubles} \ +test util-16.1.17.281 {8.4 compatible formatting of doubles} precision \ {expr 1e281} \ 1e+281 -test util-16.1.17.282 {8.4 compatible formatting of doubles} \ +test util-16.1.17.282 {8.4 compatible formatting of doubles} precision \ {expr 1e282} \ 1e+282 -test util-16.1.17.283 {8.4 compatible formatting of doubles} \ +test util-16.1.17.283 {8.4 compatible formatting of doubles} precision \ {expr 1e283} \ 9.9999999999999996e+282 -test util-16.1.17.284 {8.4 compatible formatting of doubles} \ +test util-16.1.17.284 {8.4 compatible formatting of doubles} precision \ {expr 1e284} \ 1.0000000000000001e+284 -test util-16.1.17.285 {8.4 compatible formatting of doubles} \ +test util-16.1.17.285 {8.4 compatible formatting of doubles} precision \ {expr 1e285} \ 9.9999999999999998e+284 -test util-16.1.17.286 {8.4 compatible formatting of doubles} \ +test util-16.1.17.286 {8.4 compatible formatting of doubles} precision \ {expr 1e286} \ 1e+286 -test util-16.1.17.287 {8.4 compatible formatting of doubles} \ +test util-16.1.17.287 {8.4 compatible formatting of doubles} precision \ {expr 1e287} \ 1.0000000000000001e+287 -test util-16.1.17.288 {8.4 compatible formatting of doubles} \ +test util-16.1.17.288 {8.4 compatible formatting of doubles} precision \ {expr 1e288} \ 1e+288 -test util-16.1.17.289 {8.4 compatible formatting of doubles} \ +test util-16.1.17.289 {8.4 compatible formatting of doubles} precision \ {expr 1e289} \ 1.0000000000000001e+289 -test util-16.1.17.290 {8.4 compatible formatting of doubles} \ +test util-16.1.17.290 {8.4 compatible formatting of doubles} precision \ {expr 1e290} \ 1.0000000000000001e+290 -test util-16.1.17.291 {8.4 compatible formatting of doubles} \ +test util-16.1.17.291 {8.4 compatible formatting of doubles} precision \ {expr 1e291} \ 9.9999999999999996e+290 -test util-16.1.17.292 {8.4 compatible formatting of doubles} \ +test util-16.1.17.292 {8.4 compatible formatting of doubles} precision \ {expr 1e292} \ 1e+292 -test util-16.1.17.293 {8.4 compatible formatting of doubles} \ +test util-16.1.17.293 {8.4 compatible formatting of doubles} precision \ {expr 1e293} \ 9.9999999999999992e+292 -test util-16.1.17.294 {8.4 compatible formatting of doubles} \ +test util-16.1.17.294 {8.4 compatible formatting of doubles} precision \ {expr 1e294} \ 1.0000000000000001e+294 -test util-16.1.17.295 {8.4 compatible formatting of doubles} \ +test util-16.1.17.295 {8.4 compatible formatting of doubles} precision \ {expr 1e295} \ 9.9999999999999998e+294 -test util-16.1.17.296 {8.4 compatible formatting of doubles} \ +test util-16.1.17.296 {8.4 compatible formatting of doubles} precision \ {expr 1e296} \ 9.9999999999999998e+295 -test util-16.1.17.297 {8.4 compatible formatting of doubles} \ +test util-16.1.17.297 {8.4 compatible formatting of doubles} precision \ {expr 1e297} \ 1e+297 -test util-16.1.17.298 {8.4 compatible formatting of doubles} \ +test util-16.1.17.298 {8.4 compatible formatting of doubles} precision \ {expr 1e298} \ 9.9999999999999996e+297 -test util-16.1.17.299 {8.4 compatible formatting of doubles} \ +test util-16.1.17.299 {8.4 compatible formatting of doubles} precision \ {expr 1e299} \ 1.0000000000000001e+299 -test util-16.1.17.300 {8.4 compatible formatting of doubles} \ +test util-16.1.17.300 {8.4 compatible formatting of doubles} precision \ {expr 1e300} \ 1.0000000000000001e+300 -test util-16.1.17.301 {8.4 compatible formatting of doubles} \ +test util-16.1.17.301 {8.4 compatible formatting of doubles} precision \ {expr 1e301} \ 1.0000000000000001e+301 -test util-16.1.17.302 {8.4 compatible formatting of doubles} \ +test util-16.1.17.302 {8.4 compatible formatting of doubles} precision \ {expr 1e302} \ 1.0000000000000001e+302 -test util-16.1.17.303 {8.4 compatible formatting of doubles} \ +test util-16.1.17.303 {8.4 compatible formatting of doubles} precision \ {expr 1e303} \ 1e+303 -test util-16.1.17.304 {8.4 compatible formatting of doubles} \ +test util-16.1.17.304 {8.4 compatible formatting of doubles} precision \ {expr 1e304} \ 9.9999999999999994e+303 -test util-16.1.17.305 {8.4 compatible formatting of doubles} \ +test util-16.1.17.305 {8.4 compatible formatting of doubles} precision \ {expr 1e305} \ 9.9999999999999994e+304 -test util-16.1.17.306 {8.4 compatible formatting of doubles} \ +test util-16.1.17.306 {8.4 compatible formatting of doubles} precision \ {expr 1e306} \ 1e+306 -test util-16.1.17.307 {8.4 compatible formatting of doubles} \ +test util-16.1.17.307 {8.4 compatible formatting of doubles} precision \ {expr 1e307} \ 9.9999999999999999e+306 @@ -4006,7 +4117,7 @@ test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { } set r } [list {*}{ - 0x43fffffffffffffc 0xc3fffffffffffffc + 0x43fffffffffffffc 0xc3fffffffffffffc 0x43fffffffffffffc 0xc3fffffffffffffc 0x43fffffffffffffd 0xc3fffffffffffffd 0x43fffffffffffffe 0xc3fffffffffffffe @@ -4016,7 +4127,57 @@ test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { 0x4400000000000000 0xc400000000000000 }] -set ::tcl_precision $saved_precision +test util-18.1 {Tcl_ObjPrintf} {testprint} { + testprint %lld [expr 2**63-1] +} {9223372036854775807} + +test util-18.2 {Tcl_ObjPrintf} {testprint} { + testprint %I64d [expr 2**63-1] +} {9223372036854775807} + +test util-18.3 {Tcl_ObjPrintf} {testprint} { + testprint %qd [expr 2**63-1] +} {9223372036854775807} + +test util-18.4 {Tcl_ObjPrintf} {testprint} { + testprint %jd [expr 2**63-1] +} {9223372036854775807} + +test util-18.5 {Tcl_ObjPrintf} {testprint} { + testprint %lld [expr -2**63] +} {-9223372036854775808} + +test util-18.6 {Tcl_ObjPrintf} {testprint} { + testprint %I64d [expr -2**63] +} {-9223372036854775808} + +test util-18.7 {Tcl_ObjPrintf} {testprint} { + testprint %qd [expr -2**63] +} {-9223372036854775808} + +test util-18.8 {Tcl_ObjPrintf} {testprint} { + testprint %jd [expr -2**63] +} {-9223372036854775808} + +test util-18.9 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %I32d" [expr -2**63+2] +} {-9223372036854775806 2} + +test util-18.10 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %p" 65535 +} {65535 0xffff} + +test util-18.11 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %td" 65536 +} {65536 65536} + +test util-18.12 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %Id" 65537 +} {65537 65537} + +if {[catch {set ::tcl_precision $saved_precision}]} { + unset ::tcl_precision +} # cleanup ::tcltest::cleanupTests diff --git a/tests/var.test b/tests/var.test index ed7e930..a8d4b84 100644 --- a/tests/var.test +++ b/tests/var.test @@ -8,23 +8,39 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testupvar [llength [info commands testupvar]] testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] testConstraint testsetnoerr [llength [info commands testsetnoerr]] +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + return [lindex [split [memory info] \n] 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} + catch {rename p ""} catch {namespace delete test_ns_var} @@ -38,15 +54,17 @@ catch {unset arr} test var-1.1 {TclLookupVar, Array handling} -setup { catch {unset a} } -body { - set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd + set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd set i 10 set arr(foo) 37 list [$x i] $i [$x arr(foo)] $arr(foo) } -result {11 11 38 38} +set ::x "global value" +namespace eval test_ns_var { + variable x "namespace value" +} test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} { - set x "global value" namespace eval test_ns_var { - variable x "namespace value" proc p {} { global x ;# specifies TCL_GLOBAL_ONLY to get global x return $x @@ -166,7 +184,9 @@ test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: set result } } {0 2 1 {can't set "foo": upvar refers to element in deleted array}} -test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} { +test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} -setup { + unset -nocomplain test_ns_var::x +} -body { namespace eval test_ns_var { variable result {} variable x @@ -178,10 +198,32 @@ test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: namespace delete [namespace current] set result } -} {0 2 1 {can't set "foo": upvar refers to element in deleted array}} +} -result {0 2 1 {can't set "foo": upvar refers to element in deleted array}} test var-1.19 {TclLookupVar, right error message when parsing variable name} -body { [format set] thisvar(doesntexist) } -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable} +test var-1.20 {TclLookupVar, regression on utf-8 variable names} -setup { + proc p [list \u20ac \xe4] {info vars} +} -body { + # test variable with non-ascii name is available (euro and a-uml chars here): + list \ + [p 1 2] \ + [apply [list [list \u20ac \xe4] {info vars}] 1 2] \ + [apply [list [list [list \u20ac \u20ac] [list \xe4 \xe4]] {info vars}]] \ +} -cleanup { + rename p {} +} -result [lrepeat 3 [list \u20ac \xe4]] +test var-1.21 {TclLookupVar, regression on utf-8 variable names} -setup { + proc p [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]} +} -body { + # test variable with non-ascii name (and default) is resolvable (euro and a-uml chars here): + list \ + [p] \ + [apply [list [list \u20ac \xe4] {list [set \u20ac] [set \xe4]}] v\u20ac v\xe4] \ + [apply [list [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}]] \ +} -cleanup { + rename p {} +} -result [lrepeat 3 [list v\u20ac v\xe4]] test var-2.1 {Tcl_LappendObjCmd, create var if new} { catch {unset x} @@ -215,7 +257,7 @@ test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup { set a 123321 proc p {} { # create global xx linked to global a - testupvar 1 a {} xx global + testupvar 1 a {} xx global } list [p] $xx [set xx 789] $a } -result {{} 123321 789 789} @@ -227,7 +269,7 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { catch {unset ::test_ns_var::vv} proc p {} { # create namespace var vv linked to global a - testupvar 1 a {} vv namespace + testupvar 1 a {} vv namespace } p } @@ -260,6 +302,7 @@ test var-3.7 {MakeUpvar, my var has ::s} -setup { } } -result {789789} test var-3.8 {MakeUpvar, my var already exists in global ns} -setup { + upvar #0 aaaaa xxxxx catch {unset aaaaa} catch {unset xxxxx} } -body { @@ -273,6 +316,8 @@ test var-3.9 {MakeUpvar, my var has invalid ns name} -setup { } -returnCodes error -body { set aaaaa 789789 upvar #0 aaaaa test_ns_fred::lnk +} -cleanup { + unset ::aaaaa } -result {can't create "test_ns_fred::lnk": parent namespace doesn't exist} test var-3.10 {MakeUpvar, between namespaces} -body { namespace eval {} { @@ -281,15 +326,13 @@ test var-3.10 {MakeUpvar, between namespaces} -body { set foo::bar 1 list $bar $foo::bar } -} -cleanup { - unset ::aaaaa } -result {1 1} test var-3.11 {MakeUpvar, my var looks like array elem} -setup { catch {unset aaaaa} } -returnCodes error -body { set aaaaa 789789 upvar #0 aaaaa foo(bar) -} -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} +} -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} @@ -321,9 +364,11 @@ test var-5.2 {Tcl_GetVariableFullName, namespace variable} { namespace which -variable martha } } {::test_ns_var::martha} -test var-5.3 {Tcl_GetVariableFullName, namespace variable} { +test var-5.3 {Tcl_GetVariableFullName, namespace variable} -setup { + namespace eval test_ns_var {variable martha} +} -body { namespace which -variable test_ns_var::martha -} {::test_ns_var::martha} +} -result {::test_ns_var::martha} test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { namespace eval test_ns_var { @@ -347,6 +392,7 @@ test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { test_ns_var::p } {java} test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} { + namespace eval ::test_ns_var::test_ns_nested {} set ::test_ns_var::test_ns_nested:: 24 apply {{} { global ::test_ns_var::test_ns_nested:: @@ -388,20 +434,26 @@ test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} { } list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg } {0 1 {can't read "test_ns_var::two": no such variable}} -test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} { +test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} -setup { + catch {namespace delete test_ns_var} + namespace eval test_ns_var {variable one 1} +} -body { namespace eval test_ns_var { variable two 2 } list [lsort [info vars test_ns_var::*]] \ [namespace eval test_ns_var {set two}] -} [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2] -test var-7.4 {Tcl_VariableObjCmd, list of vars} { +} -result [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2] +test var-7.4 {Tcl_VariableObjCmd, list of vars} -setup { + catch {namespace delete test_ns_var} + namespace eval test_ns_var {variable one 1; variable two 2} +} -body { namespace eval test_ns_var { variable three 3 four 4 } list [lsort [info vars test_ns_var::*]] \ - [namespace eval test_ns_var {expr $three+$four}] -} [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] + [namespace eval test_ns_var {expr {$three+$four}}] +} -result [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { catch {unset a} catch {unset five} @@ -475,7 +527,9 @@ test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until na [lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\ {1 {can't unset "test_ns_var2::z": no such variable}}\ {}] -test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { +test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup { + namespace eval test_ns_var { variable eight 8 } +} -body { namespace eval test_ns_var { proc p {} { variable eight @@ -483,14 +537,16 @@ test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link v } p } -} {8 eight} -test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { +} -result {8 eight} +test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup { + namespace eval test_ns_var { variable eight 8 } +} -body { proc p {} { ;# note this proc is at global :: scope variable test_ns_var::eight list [set eight] [info vars] } p -} {8 eight} +} -result {8 eight} test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { namespace eval test_ns_var { variable {} {My name is empty} @@ -515,11 +571,11 @@ test var-7.14 {Tcl_VariableObjCmd, array element parameter} -body { namespace eval test_ns_var { variable arrayvar(1) } } -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" test var-7.15 {Tcl_VariableObjCmd, array element parameter} -body { - namespace eval test_ns_var { + namespace eval test_ns_var { variable arrayvar set arrayvar(1) x variable arrayvar(1) y - } + } } -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" test var-7.16 {Tcl_VariableObjCmd, no args (TIP 323)} { variable @@ -560,6 +616,22 @@ test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called wit list [namespace delete test_ns_var] $::info } -result {{} {::test_ns_var::v {} u}} +test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup { + proc ::t {a i o} { + set $a 321 + } +} -body { + leaktest { + namespace eval n { + variable v 123 + trace variable v u ::t + } + namespace delete n + } +} -cleanup { + rename ::t {} +} -result 0 + test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup { catch {unset u} catch {unset v} @@ -727,6 +799,22 @@ test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup { } set x "If you see this, it worked" } -result "If you see this, it worked" +test var-13.2 {unset array with search, bug 46a2410650} -body { + apply {{} { + array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66} + set s [array startsearch a] + unset a([array nextelement a $s]) + array nextelement a $s + }} +} -returnCodes error -result {couldn't find search "s-1-a"} +test var-13.3 {unset array with search, SIGSEGV, bug 46a2410650} -body { + apply {{} { + array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66} + set s [array startsearch a] + unset a(ff) + array nextelement a $s + }} +} -returnCodes error -result {couldn't find search "s-1-a"} test var-14.1 {array names syntax} -body { array names foo bar baz snafu @@ -741,13 +829,16 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { set var $name } # - # Note that the variable name has to be + # Note that the variable name has to be # unused previously for the segfault to # be triggered. # namespace eval test A useSomeUnlikelyNameHere namespace eval test unset useSomeUnlikelyNameHere } {} +test var-15.2 {compiled unset evaluation order, Bug 3970f54c4e} { + apply {{} {unset foo [return ok]}} +} ok test var-16.1 {CallVarTraces: save/restore interp error state} { trace add variable ::errorCode write " ;#" @@ -767,10 +858,22 @@ test var-17.1 {TclArraySet [Bug 1669489]} -setup { } -cleanup { unset -nocomplain ::a ::elements } -result {} +test var-17.2 {TclArraySet Dict shortcut only on pure value} -setup { + unset -nocomplain a d + set d {p 1 p 2} + dict get $d p + set foo 0 +} -body { + trace add variable a write "[list incr [namespace which -variable foo]];#" + array set a $d + set foo +} -cleanup { + unset -nocomplain a d foo +} -result 2 test var-18.1 {array unset and unset traces: Bug 2939073} -setup { set already 0 - unset x + unset -nocomplain x } -body { array set x {e 1 i 1} trace add variable x unset {apply {args { @@ -793,11 +896,595 @@ test var-19.1 {crash when freeing locals hashtable: Bug 3037525} { foo ; # This crashes without the fix for the bug rename foo {} } {} + +test var-20.1 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + global x + array set x {a 1} + }} + array size x +} -result 1 +test var-20.2 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + global x + array set x {} + }} + array size x +} -result 0 +test var-20.3 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + array set ::x {a 1} + }} + array size x +} -result 1 +test var-20.4 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + array set ::x {} + }} + array size x +} -result 0 +test var-20.5 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + global x + eval {array set x {a 1}} + }} + array size x +} -result 1 +test var-20.6 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + global x + eval {array set x {}} + }} + array size x +} -result 0 +test var-20.7 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + eval {array set ::x {a 1}} + }} + array size x +} -result 1 +test var-20.8 {array set compilation correctness: Bug 3603163} -setup { + unset -nocomplain x +} -body { + apply {{} { + eval {array set ::x {}} + }} + array size x +} -result 0 +test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup { + variable foo + variable lambda + unset -nocomplain lambda foo + array set foo {} + lappend lambda {} + lappend lambda [list array set [namespace which -variable foo] {a 1}] +} -body { + after 0 [list apply $lambda] + vwait [namespace which -variable foo] +} -cleanup { + unset -nocomplain lambda foo +} -result {} +test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body { + apply {{} {set name foo(bar); array set $name {a 1}}} +} -returnCodes error -match glob -result * +test var-20.11 {array set don't compile bad initializer} -setup { + unset -nocomplain foo + trace add variable foo array {set foo(bar) baz;#} +} -body { + catch {array set foo bad} + set foo(bar) +} -cleanup { + unset -nocomplain foo +} -result baz +test var-20.12 {array set don't compile bad initializer} -setup { + unset -nocomplain ::foo + trace add variable ::foo array {set ::foo(bar) baz;#} +} -body { + catch {apply {{} { + set value bad + array set ::foo $value + + }}} + set ::foo(bar) +} -cleanup { + unset -nocomplain ::foo +} -result baz + +test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + set foo bar + unset foo {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + +test var-22.0 {leak in array element unset: Bug a3309d01db} -setup { + proc doit k { + variable A + set A($k) {} + foreach n [array names A] { + if {$n <= $k-1} { + unset A($n) + } + } + } +} -constraints memory -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + doit $i + set tmp $end + set end [getbytes] + } + set leakedBytes [expr {$end - $tmp}] +} -cleanup { + array unset A + rename doit {} +} -result 0 +test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup { + proc doit {} { + interp create child + child eval { + proc doit script { + eval $script + set foo bar + } + doit {foreach foo baz {}} + } + interp delete child + } +} -constraints memory -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + doit + set tmp $end + set end [getbytes] + } + set leakedBytes [expr {$end - $tmp}] +} -cleanup { + array unset A + rename doit {} +} -result 0 +test var-22.2 {leak in parsedVarName} -constraints memory -body { + set i 0 + leaktest {lappend x($i)} +} -cleanup { + unset -nocomplain i x +} -result 0 + +unset -nocomplain a k v +test var-23.1 {array command, for loop, too many args} -returnCodes error -body { + array for {k v} c d e {} +} -result {wrong # args: should be "array for {key value} arrayName script"} +test var-23.2 {array command, for loop, not enough args} -returnCodes error -body { + array for {k v} {} +} -result {wrong # args: should be "array for {key value} arrayName script"} +test var-23.3 {array command, for loop, too many list args} -setup { + unset -nocomplain a +} -returnCodes error -body { + array for {k v w} a {} +} -result {must have two variable names} +test var-23.4 {array command, for loop, not enough list args} -setup { + unset -nocomplain a +} -returnCodes error -body { + array for {k} a {} +} -result {must have two variable names} +test var-23.5 {array command, for loop, no array} -setup { + unset -nocomplain a +} -returnCodes error -body { + array for {k v} a {} +} -result {"a" isn't an array} +test var-23.6 {array command, for loop, array doesn't exist yet but has compiler-allocated procedure slot} -setup { + catch {rename p ""} +} -returnCodes error -body { + apply {{x} { + if {$x==1} { + return [array for {k v} a {}] + } + set a(x) 123 + }} 1 +} -result {"a" isn't an array} +test var-23.7 {array enumeration} -setup { + unset -nocomplain a + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k v} a { + lappend reslist $k $v + } + lsort -stride 2 -index 0 $reslist +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {a 1 b 2 c 3} +test var-23.9 {array enumeration, nested} -setup { + unset -nocomplain a + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k1 v1} a { + lappend reslist $k1 $v1 + set r2 {} + array for {k2 v2} a { + lappend r2 $k2 $v2 + } + lappend reslist [lsort -stride 2 -index 0 $r2] + } + # there is no guarantee in which order the array contents will be + # returned. + lsort -stride 3 -index 0 $reslist +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {a 1 {a 1 b 2 c 3} b 2 {a 1 b 2 c 3} c 3 {a 1 b 2 c 3}} +test var-23.10 {array enumeration, delete key} -match glob -setup { + unset -nocomplain a + set reslist [list] +} -body { + set retval {} + try { + array set a {a 1 b 2 c 3 d 4} + array for {k v} a { + lappend reslist $k $v + if { $k eq "a" } { + unset a(c) + } + } + lsort -stride 2 -index 0 $reslist + } on error {err res} { + set retval [dict get $res -errorinfo] + } + set retval +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist + unset -nocomplain retval +} -result {array changed during iteration*} +test var-23.11 {array enumeration, insert key} -match glob -setup { + unset -nocomplain a + set reslist [list] +} -body { + set retval {} + try { + array set a {a 1 b 2 c 3 d 4} + array for {k v} a { + lappend reslist $k $v + if { $k eq "a" } { + set a(e) 5 + } + } + lsort -stride 2 -index 0 $reslist + } on error {err res} { + set retval [dict get $res -errorinfo] + } +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {array changed during iteration*} +test var-23.12 {array enumeration, change value} -setup { + unset -nocomplain a + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k v} a { + lappend reslist $k $v + if { $k eq "a" } { + set a(c) 9 + } + } + lsort -stride 2 -index 0 $reslist +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {a 1 b 2 c 9} +test var-23.13 {array enumeration, number of traces} -setup { + set ::countarrayfor 0 + proc ::tracearrayfor { args } { + incr ::countarrayfor + } + unset -nocomplain ::a + set reslist [list] +} -body { + array set ::a {a 1 b 2 c 3} + foreach {k} [array names a] { + trace add variable ::a($k) read ::tracearrayfor + } + array for {k v} ::a { + lappend reslist $k $v + } + set ::countarrayfor +} -cleanup { + unset -nocomplain ::countarrayfor + unset -nocomplain ::a + unset -nocomplain reslist +} -result 3 +test var-23.14 {array for, shared arguments} -setup { + set vn {k v} + unset -nocomplain $vn +} -body { + array set $vn {a 1 b 2 c 3} + array for $vn $vn {} +} -cleanup { + unset -nocomplain $vn vn +} -result {} + +test var-24.1 {array default set and get: interpreted} -setup { + unset -nocomplain ary +} -body { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ + [array default get ary] +} -cleanup { + unset -nocomplain ary +} -result {3 7 1 0 7} +test var-24.2 {array default set and get: compiled} { + apply {{} { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ + [array default get ary] + }} +} {3 7 1 0 7} +test var-24.3 {array default unset: interpreted} -setup { + unset -nocomplain ary +} -body { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [array default unset ary] $ary(a) [catch {set ary(b)}] +} -cleanup { + unset -nocomplain ary +} -result {3 7 {} 3 1} +test var-24.4 {array default unset: compiled} { + apply {{} { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [array default unset ary] $ary(a) \ + [catch {set ary(b)}] + }} +} {3 7 {} 3 1} +test var-24.5 {array default exists: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array set ary {a 3} + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 7 + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 11 + lappend result [info exists ary],[array exists ary],[array default exists ary] +} -cleanup { + unset -nocomplain ary result +} -result {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} +test var-24.6 {array default exists: compiled} { + apply {{} { + array set ary {a 3} + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 7 + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 11 + lappend result [info exists ary],[array exists ary],[array default exists ary] + }} +} {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} +test var-24.7 {array default and append: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + append ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + append ary(x) def + append ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 grillabc 2 grillabcdef ghi} +test var-24.8 {array default and append: compiled} { + apply {{} { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + append ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + append ary(x) def + append ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 grillabc 2 grillabcdef ghi} +test var-24.9 {array default and lappend: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + lappend ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + lappend ary(x) def + lappend ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 {grill abc} 2 {grill abc def} ghi} +test var-24.10 {array default and lappend: compiled} { + apply {{} { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + lappend ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + lappend ary(x) def + lappend ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 {grill abc} 2 {grill abc def} ghi} +test var-24.11 {array default and incr: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary 7 + lappend result [array size ary] [info exist ary(x)] + incr ary(x) 11 + lappend result [array size ary] $ary(x) + array default unset ary + incr ary(x) + incr ary(y) + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 18 2 19 1} +test var-24.12 {array default and incr: compiled} { + apply {{} { + array default set ary 7 + lappend result [array size ary] [info exist ary(x)] + incr ary(x) 11 + lappend result [array size ary] $ary(x) + array default unset ary + incr ary(x) + incr ary(y) + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 18 2 19 1} +test var-24.13 {array default and dict: interpreted} -setup { + unset -nocomplain ary x y z +} -body { + array default set ary {x y} + dict lappend ary(p) x z + dict update ary(q) x y { + set y z + } + dict with ary(r) { + set x 123 + } + lsort -stride 2 -index 0 [array get ary] +} -cleanup { + unset -nocomplain ary x y z +} -result {p {x {y z}} q {x z} r {x 123}} +test var-24.14 {array default and dict: compiled} { + lsort -stride 2 -index 0 [apply {{} { + array default set ary {x y} + dict lappend ary(p) x z + dict update ary(q) x y { + set y z + } + dict with ary(r) { + set x 123 + } + array get ary + }}] +} {p {x {y z}} q {x z} r {x 123}} +test var-24.15 {array default set and get: two-level} { + apply {{} { + array set ary {a 3} + array default set ary 7 + apply {{} { + upvar 1 ary ary ary(c) c + lappend result $ary(a) $ary(b) $c + lappend result [info exist ary(a)] [info exist ary(b)] [info exist c] + lappend result [array default get ary] + }} + }} +} {3 7 7 1 0 0 7} +test var-24.16 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default set ary 7 +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {can't array default set "ary": variable isn't array} +test var-24.17 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + array default set ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.18 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + array default set ary x y +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.19 {array default get: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default get ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.20 {array default get: errors} -setup { + unset -nocomplain ary +} -body { + array default get ary x y +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.21 {array default exists: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default exists ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.22 {array default exists: errors} -setup { + unset -nocomplain ary +} -body { + array default exists ary x +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.23 {array default unset: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default unset ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.24 {array default unset: errors} -setup { + unset -nocomplain ary +} -body { + array default unset ary x +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob catch {namespace delete ns} catch {unset arr} catch {unset v} +catch {rename getbytes ""} catch {rename p ""} catch {namespace delete test_ns_var} catch {namespace delete test_ns_var2} diff --git a/tests/while-old.test b/tests/while-old.test index ee17d0b..9c8cacc 100644 --- a/tests/while-old.test +++ b/tests/while-old.test @@ -6,21 +6,21 @@ # into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test while-old-1.1 {basic while loops} { set count 0 - while {$count < 10} {set count [expr $count+1]} + while {$count < 10} {set count [expr {$count + 1}]} set count } 10 test while-old-1.2 {basic while loops} { @@ -58,9 +58,9 @@ test while-old-2.1 {continue in while loop} { set index 0 set result {} while {$index < 5} { - if {$index == 2} {set index [expr $index+1]; continue} + if {$index == 2} {set index [expr {$index + 1}]; continue} set result [concat $result [lindex $list $index]] - set index [expr $index+1] + set index [expr {$index + 1}] } set result } {1 2 4 5} @@ -72,7 +72,7 @@ test while-old-3.1 {break in while loop} { while {$index < 5} { if {$index == 3} break set result [concat $result [lindex $list $index]] - set index [expr $index+1] + set index [expr {$index + 1}] } set result } {1 2 3} diff --git a/tests/while.test b/tests/while.test index 642ec93..6ea8548 100644 --- a/tests/while.test +++ b/tests/while.test @@ -4,14 +4,14 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -77,7 +77,7 @@ test while-1.9 {TclCompileWhileCmd: simple command body} -body { set a {} set i 1 while {$i<6} { - if $i==4 break + if {$i==4} break set a [concat $a $i] incr i } @@ -112,8 +112,8 @@ test while-1.12 {TclCompileWhileCmd: long command body} -body { set a {} set i 1 while {$i<6} { - if $i==4 break - if $i>5 continue + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -155,7 +155,7 @@ test while-1.13 {TclCompileWhileCmd: while command result} -body { } -result {} test while-1.14 {TclCompileWhileCmd: while command result} -body { set i 0 - set a [while {$i < 5} {if $i==3 break; incr i}] + set a [while {$i < 5} {if {$i==3} break; incr i}] return $a } -cleanup { unset a i @@ -207,9 +207,9 @@ test while-2.4 {continue tests, long command body} -body { set a {} set i 1 while {$i<6} { - if $i==2 {incr i; continue} - if $i==4 break - if $i>5 continue + if {$i==2} {incr i; continue} + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -277,9 +277,9 @@ test while-3.3 {break tests, long command body} -body { set a {} set i 1 while {$i<6} { - if $i==2 {incr i; continue} - if $i==5 break - if $i>5 continue + if {$i==2} {incr i; continue} + if {$i==5} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -295,7 +295,7 @@ test while-3.3 {break tests, long command body} -body { catch {incr i 5} msg catch {incr i -5} msg } - if $i==4 break + if {$i==4} break if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -401,7 +401,7 @@ test while-4.10 {while (not compiled): simple command body} -body { set i 1 set z while $z {$i<6} { - if $i==4 break + if {$i==4} break set a [concat $a $i] incr i } @@ -439,8 +439,8 @@ test while-4.13 {while (not compiled): long command body} -body { set z while set i 1 $z {$i<6} { - if $i==4 break - if $i>5 continue + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -484,7 +484,7 @@ test while-4.14 {while (not compiled): while command result} -body { test while-4.15 {while (not compiled): while command result} -body { set i 0 set z while - set a [$z {$i < 5} {if $i==3 break; incr i}] + set a [$z {$i < 5} {if {$i==3} break; incr i}] return $a } -cleanup { unset a i z @@ -538,9 +538,9 @@ test while-5.4 {break tests, long command body with computed command names} -bod set i 1 set z break while {$i<6} { - if $i==2 {incr i; continue} - if $i==5 $z - if $i>5 continue + if {$i==2} {incr i; continue} + if {$i==5} $z + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -556,7 +556,7 @@ test while-5.4 {break tests, long command body with computed command names} -bod catch {incr i 5} msg catch {incr i -5} msg } - if $i==4 $z + if {$i==4} $z if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -637,9 +637,9 @@ test while-6.5 {continue tests, long command body with computed command names} - set i 1 set z continue while {$i<6} { - if $i==2 {incr i; continue} - if $i==4 break - if $i>5 $z + if {$i==2} {incr i; continue} + if {$i==4} break + if {$i>5} $z if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg diff --git a/tests/winConsole.test b/tests/winConsole.test index fdde41c..8ca1457 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -4,13 +4,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1999 by Scriptics Corporation. +# Copyright © 1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/winDde.test b/tests/winDde.test index 01fb54c..f57a226 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -4,26 +4,27 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1999 by Scriptics Corporation. +# Copyright © 1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 - #tcltest::configure -verbose {pass start} + package require tcltest 2.5 namespace import -force ::tcltest::* } +testConstraint debug [::tcl::pkgconfig get debug] testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::ddever [package require dde 1.4.0b1] - set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} { + set ::ddever [package require dde 1.4.4] + set ::ddelib [info loaded {} Dde]}]} { testConstraint dde 1 } } +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] # ------------------------------------------------------------------------- @@ -37,12 +38,12 @@ proc createChildProcess {ddeServerName args} { set f [open $::scriptName w+] puts $f [list set ddeServerName $ddeServerName] - puts $f [list load $::ddelib dde] + puts $f [list load $::ddelib Dde] puts $f { # DDE child server - # if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -103,14 +104,14 @@ proc createChildProcess {ddeServerName args} { # ------------------------------------------------------------------------- test winDde-1.0 {check if we are testing the right dll} {win dde} { set ::ddever -} {1.4.0b1} +} {1.4.4} test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] } -result {foobar foobar self} test winDde-2.1 {Checking for other services} -constraints dde -body { - expr [llength [dde services {} {}]] >= 0 + expr {[llength [dde services {} {}]] >= 0} } -result 1 test winDde-2.2 {Checking for existence, with service and topic specified} \ -constraints dde -body { @@ -118,11 +119,11 @@ test winDde-2.2 {Checking for existence, with service and topic specified} \ } -result 1 test winDde-2.3 {Checking for existence, with only the service specified} \ -constraints dde -body { - expr [llength [dde services TclEval {}]] >= 1 + expr {[llength [dde services TclEval {}]] >= 1} } -result 1 test winDde-2.4 {Checking for existence, with only the topic specified} \ -constraints dde -body { - expr [llength [dde services {} self]] >= 1 + expr {[llength [dde services {} self]] >= 1} } -result 1 # ------------------------------------------------------------------------- @@ -153,19 +154,29 @@ test winDde-3.5 {DDE request locally} -constraints dde -body { dde request -binary TclEval self \xe1 } -result "foo\x00" # Set variable a to A with diaeresis (unicode C4) by relying on the fact -# that utf8 is sent (e.g. "c3 84" on the wire) -test winDde-3.6 {DDE request utf8} -constraints dde -body { +# that utf-8 is sent (e.g. "c3 84" on the wire) +test winDde-3.6 {DDE request utf-8} -constraints dde -body { set \xe1 "not set" dde execute TclEval self "set \xe1 \xc4" scan [set \xe1] %c } -result 196 # Set variable a to A with diaeresis (unicode C4) using binary execute # and compose utf-8 (e.g. "c3 84" ) manualy -test winDde-3.7 {DDE request binary} -constraints dde -body { - set a "not set" - dde execute -binary TclEval self [list set a \xc3\x84\x00] - scan $a %c +test winDde-3.7 {DDE request binary} -constraints {dde notWine} -body { + set \xe1 "not set" + dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00] + scan [set \xe1] %c } -result 196 +test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body { + set \xe1 "" + dde poke TclEval self \xe1 \xc4 + dde request TclEval self \xe1 +} -result \xc4 +test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body { + set \xe1 "" + dde poke -binary TclEval self \xe1 \xc3\x84\x00 + dde request TclEval self \xe1 +} -result \xc4 # ------------------------------------------------------------------------- @@ -192,8 +203,8 @@ test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body { set \xe1 "" set name ch\xEDld-4.3 set child [createChildProcess $name] - dde execute TclEval $name [list set a foo] - set \xe1 [dde request TclEval $name a] + dde execute TclEval $name [list set \xe1 foo] + set \xe1 [dde request TclEval $name \xe1] dde execute TclEval $name {set done 1} update set \xe1 @@ -202,11 +213,21 @@ test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body { set \xe1 "" set name ch\xEDld-4.4 set child [createChildProcess $name] - set \xe1 [dde eval $name set a foo] + set \xe1 [dde eval $name set \xe1 foo] dde execute TclEval $name {set done 1} update set \xe1 } -result foo +test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body { + set \xe1 "" + set name ch\xEDld-4.5 + set child [createChildProcess $name] + dde poke TclEval $name \xe1 foo + set \xe1 [dde request TclEval $name \xe1] + dde execute TclEval $name {set done 1} + update + set \xe1 +} -result foo # ------------------------------------------------------------------------- @@ -258,19 +279,19 @@ test winDde-6.6 {DDE remote servername collision force} -constraints {dde stdio} # ------------------------------------------------------------------------- -test winDde-7.1 {Load DDE in slave interpreter} -constraints dde -setup { - interp create slave +test winDde-7.1 {Load DDE in child interpreter} -constraints dde -setup { + interp create child } -body { - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.1] + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.1] } -cleanup { - interp delete slave + interp delete child } -result {dde-interp-7.1} -test winDde-7.2 {DDE slave cleanup} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.5] - interp delete slave +test winDde-7.2 {DDE child cleanup} -constraints dde -setup { + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.5] + interp delete child } -body { dde services TclEval {} set s [dde services TclEval {}] @@ -279,128 +300,128 @@ test winDde-7.2 {DDE slave cleanup} -constraints dde -setup { set s } } -result {} -test winDde-7.3 {DDE present in slave interp} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.3] +test winDde-7.3 {DDE present in child interp} -constraints dde -setup { + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.3] } -body { dde services TclEval dde-interp-7.3 } -cleanup { - interp delete slave + interp delete child } -result {{TclEval dde-interp-7.3}} test winDde-7.4 {interp name collision with -force} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.4] + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.4] } -body { dde servername -force -- dde-interp-7.4 } -cleanup { - interp delete slave + interp delete child } -result {dde-interp-7.4} test winDde-7.5 {interp name collision without -force} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.5] + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.5] } -body { dde servername -- dde-interp-7.5 } -cleanup { - interp delete slave + interp delete child } -result "dde-interp-7.5 #2" # ------------------------------------------------------------------------- test winDde-8.1 {Safe DDE load} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde + interp create -safe child + child invokehidden load $::ddelib Dde } -body { - slave eval dde servername slave + child eval dde servername child } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {invalid command name "dde"} test winDde-8.2 {Safe DDE set servername} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde + interp create -safe child + child invokehidden load $::ddelib Dde } -body { - slave invokehidden dde servername slave -} -cleanup {interp delete slave} -result {slave} + child invokehidden dde servername child +} -cleanup {interp delete child} -result {child} test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - catch {dde eval slave set a 1} msg -} -cleanup {interp delete slave} -result {1} + catch {dde eval child set a 1} msg +} -cleanup {interp delete child} -result {1} test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - slave eval set a 1 - dde execute TclEval slave {set a 2} - slave eval set a -} -cleanup {interp delete slave} -result 1 + child eval set a 1 + dde execute TclEval child {set a 2} + child eval set a +} -cleanup {interp delete child} -result 1 test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - slave eval set a 1 - dde request TclEval slave a + child eval set a 1 + dde request TclEval child a } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {remote server cannot handle this command} test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} } -body { - slave invokehidden dde servername -handler DDEACCEPT slave -} -cleanup {interp delete slave} -result slave + child invokehidden dde servername -handler DDEACCEPT child +} -cleanup {interp delete child} -result child test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave set x 1 -} -cleanup {interp delete slave} -result {set x 1} + dde eval child set x 1 +} -cleanup {interp delete child} -result {set x 1} test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + child invokehidden dde servername -handler DDEACCEPT child } -body { set s "c:\\Program Files\\Microsoft Visual Studio\\" - dde eval slave $s - string equal [slave eval set DDECMD] $s -} -cleanup {interp delete slave} -result 1 + dde eval child $s + string equal [child eval set DDECMD] $s +} -cleanup {interp delete child} -result 1 test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave set \xe1 1 - slave eval set \xe1 -} -cleanup {interp delete slave} -result 1 + dde eval child set \xe1 1 + child eval set \xe1 +} -cleanup {interp delete child} -result 1 test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave [list set x 1] - slave eval set x -} -cleanup {interp delete slave} -result 1 + dde eval child [list set x 1] + child eval set x +} -cleanup {interp delete child} -result 1 test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave [list [list set x 1]] - slave eval set x -} -cleanup {interp delete slave} -returnCodes error -result {invalid command name "set x 1"} + dde eval child [list [list set x 1]] + child eval set x +} -cleanup {interp delete child} -returnCodes error -result {invalid command name "set x 1"} # ------------------------------------------------------------------------- @@ -460,7 +481,7 @@ test winDde-9.4 {External safe DDE check null data passing} -constraints {dde st # ------------------------------------------------------------------------- #cleanup -#catch {interp delete $slave}; # ensure we clean up the slave. +#catch {interp delete $child}; # ensure we clean up the child. file delete -force $::scriptName ::tcltest::cleanupTests return diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 28a0e9f..d118725 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -4,31 +4,32 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Initialise the test constraints -testConstraint winVista 0 -testConstraint win2000orXP 0 -testConstraint winOlderThan2000 0 testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint testfile [llength [info commands testfile]] testConstraint testchmod [llength [info commands testchmod]] testConstraint cdrom 0 testConstraint exdev 0 testConstraint longFileNames 0 +# Some things fail under all Continuous Integration systems for subtle reasons +# such as CI often running with elevated privileges in a container. +testConstraint notInCIenv [expr {![info exists ::env(CI)]}] +testConstraint knownMsvcBug [expr {![info exists ::env(CI_BUILD_WITH_MSVC)]}] proc createfile {file {string a}} { set f [open $file w] @@ -56,19 +57,6 @@ proc cleanup {args} { } } -if {[testConstraint winOnly]} { - set major [string index $tcl_platform(osVersion) 0] - if {[testConstraint nt] && $major > 4} { - if {$major > 5} { - testConstraint winVista 1 - } elseif {$major == 5} { - testConstraint win2000orXP 1 - } - } else { - testConstraint winOlderThan2000 1 - } -} - # find a CD-ROM so we can test read-only filesystems. proc findfile {dir} { @@ -98,8 +86,13 @@ if {[testConstraint testvolumetype]} { # NB: filename is chosen to be short but unlikely to clash with other apps if {[file exists c:/] && [file exists d:/]} { catch {file delete d:/TclTmpF.1} - if {[catch {createfile d:/TclTmpF.1 {}}] == 0} { - file delete d:/TclTmpF.1 + catch {file delete d:/TclTmpD.1} + catch {file delete c:/TclTmpC.1} + if {![catch {createfile d:/TclTmpF.1 {}}] && [file isfile d:/TclTmpF.1] + && ![catch {file mkdir d:/TclTmpD.1}] && [file isdirectory d:/TclTmpD.1] + && ![catch {file mkdir c:/TclTmpC.1}] && [file isdirectory c:/TclTmpC.1] + } { + file delete d:/TclTmpF.1 d:/TclTmpD.1 c:/TclTmpC.1 testConstraint exdev 1 } } @@ -132,25 +125,25 @@ test winFCmd-1.1 {TclpRenameFile: errno: EACCES} -body { } -constraints {win cdrom testfile} -returnCodes error -result EACCES test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1/td2/td3 file mkdir td2 testfile mv td2 td1/td2 } -returnCodes error -result EEXIST test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { testfile mv / td1 } -returnCodes error -result EINVAL test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1 testfile mv td1 td1/td2 } -returnCodes error -result EINVAL test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1 createfile tf1 testfile mv tf1 td1 @@ -179,12 +172,12 @@ test winFCmd-1.9 {TclpRenameFile: errno: ENOTDIR} -setup { testfile mv td1 tf1 } -returnCodes error -result ENOTDIR test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} -setup { - file delete -force d:/tf1 + file delete -force d:/TclTmpD.1 } -constraints {win exdev testfile} -body { - file mkdir c:/tf1 - testfile mv c:/tf1 d:/tf1 + file mkdir c:/TclTmpC.1 + testfile mv c:/TclTmpC.1 d:/TclTmpD.1 } -cleanup { - file delete -force c:/tf1 + file delete -force c:/TclTmpC.1 } -returnCodes error -result EXDEV test winFCmd-1.11 {TclpRenameFile: errno: EACCES} -setup { cleanup @@ -203,30 +196,9 @@ test winFCmd-1.12 {TclpRenameFile: errno: EACCES} -setup { } -cleanup { catch {close $fd} } -returnCodes error -result EACCES -test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup { - cleanup -} -constraints {win win2000orXP testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EINVAL -test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} -setup { - cleanup -} -constraints {win nt winOlderThan2000 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EACCES -test winFCmd-1.13.2 {TclpRenameFile: errno: ENOENT} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result ENOENT -test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup { - cleanup -} -constraints {win 95 testfile} -body { - createfile tf1 - testfile mv tf1 nul -} -returnCodes error -result EACCES test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup { cleanup -} -constraints {win nt testfile} -body { +} -constraints {win testfile} -body { createfile tf1 testfile mv tf1 nul } -returnCodes error -result EEXIST @@ -247,26 +219,9 @@ test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} -setup { } -constraints {win testfile} -body { testfile mv tf1 tf2 } -returnCodes error -result ENOENT -test winFCmd-1.19 {TclpRenameFile: errno == EACCES} -setup { - cleanup -} -constraints {win win2000orXP testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EINVAL -test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup { - cleanup -} -constraints {win nt winOlderThan2000 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EACCES -test winFCmd-1.19.2 {TclpRenameFile: errno == ENOENT} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result ENOENT test winFCmd-1.20 {TclpRenameFile: src is dir} -setup { cleanup -} -constraints {win nt testfile} -body { - # under 95, this would actually succeed and move the current dir out from - # under the current process! +} -constraints {win testfile} -body { file delete /tf1 testfile mv [pwd] /tf1 } -returnCodes error -result EACCES @@ -283,7 +238,7 @@ test winFCmd-1.22 {TclpRenameFile: long dst} -setup { } -returnCodes error -result ENAMETOOLONG test winFCmd-1.23 {TclpRenameFile: move dir into self} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1 testfile mv [pwd]/td1 td1/td2 } -returnCodes error -result EINVAL @@ -328,21 +283,21 @@ test winFCmd-1.29 {TclpRenameFile: src is dir} -setup { } -returnCodes error -result ENOTDIR test winFCmd-1.30 {TclpRenameFile: dst is dir} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1 file mkdir td2/td2 testfile mv td1 td2 } -returnCodes error -result EEXIST test winFCmd-1.31 {TclpRenameFile: TclpRemoveDirectory fails} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1 file mkdir td2/td2 testfile mv td1 td2 } -returnCodes error -result EEXIST test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1/td2 file mkdir td2 testfile mv td1 td2 @@ -350,15 +305,15 @@ test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} -setup { } -result {0 1 1} test winFCmd-1.33 {TclpRenameFile: After removing dst dir, MoveFile fails} \ -constraints {win exdev testfile testchmod} -body { - file mkdir d:/td1 - testchmod 000 d:/td1 - file mkdir c:/tf1 - catch {testfile mv c:/tf1 d:/td1} msg - list $msg [file writable d:/td1] -} -cleanup { - catch {testchmod 666 d:/td1} - file delete d:/td1 - file delete -force c:/tf1 + file mkdir d:/TclTmpD.1 + testchmod 0 d:/TclTmpD.1 + file mkdir c:/TclTmpC.1 + catch {testfile mv c:/TclTmpC.1 d:/TclTmpD.1} msg + list $msg [file writable d:/TclTmpD.1] +} -cleanup { + catch {testchmod 0o666 d:/TclTmpD.1} + file delete d:/TclTmpD.1 + file delete -force c:/TclTmpC.1 } -result {EXDEV 0} test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} -setup { cleanup @@ -371,7 +326,7 @@ test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} -setup { } -returnCodes error -result ENOTDIR test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1 createfile tf1 testfile mv tf1 td1 @@ -412,7 +367,7 @@ proc MakeFiles {dirname} { set f [open $filename w] close $f file stat $filename stat - if {[set n [lsearch -exact -integer $inodes $stat(ino)]] != -1} { + if {[set n [lsearch -exact -integer $inodes $stat(ino)]] >= 0} { return [list [file join $dirname Test$n] $filename] } lappend inodes $stat(ino) @@ -422,7 +377,7 @@ proc MakeFiles {dirname} { test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup { cleanup -} -constraints {win winNonZeroInodes} -body { +} -constraints {win winNonZeroInodes knownMsvcBug notInCIenv} -body { file mkdir td1 foreach {a b} [MakeFiles td1] break file rename -force $a $b @@ -472,31 +427,6 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} -setup { } -cleanup { cleanup } -returnCodes error -result ENOENT -test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup { - cleanup -} -constraints {win 95 testfile} -body { - createfile tf1 - set fd [open tf2 w] - testfile cp tf1 tf2 -} -cleanup { - close $fd - cleanup -} -returnCodes error -result EACCES -test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup { - cleanup -} -constraints {win win2000orXP testfile} -body { - testfile cp nul tf1 -} -returnCodes error -result EINVAL -test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} -setup { - cleanup -} -constraints {win nt winOlderThan2000 testfile} -body { - testfile cp nul tf1 -} -returnCodes error -result EACCES -test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile cp nul tf1 -} -returnCodes error -result ENOENT test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup { cleanup } -constraints {win testfile} -body { @@ -520,11 +450,11 @@ test winFCmd-2.12 {TclpCopyFile: CopyFile succeeds} -setup { cleanup } -constraints {win testfile} -body { createfile tf1 tf1 - testchmod 000 tf1 + testchmod 0 tf1 testfile cp tf1 tf2 list [contents tf2] [file writable tf2] } -cleanup { - catch {testchmod 666 tf1} + catch {testchmod 0o666 tf1} cleanup } -result {tf1 0} test winFCmd-2.13 {TclpCopyFile: CopyFile fails} -setup { @@ -566,24 +496,13 @@ test winFCmd-2.17 {TclpCopyFile: dst is readonly} -setup { } -constraints {win testfile testchmod} -body { createfile tf1 tf1 createfile tf2 tf2 - testchmod 000 tf2 + testchmod 0 tf2 testfile cp tf1 tf2 list [file writable tf2] [contents tf2] } -cleanup { - catch {testchmod 666 tf2} + catch {testchmod 0o666 tf2} cleanup } -result {1 tf1} -test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} -setup { - cleanup -} -constraints {win 95 testfile testchmod} -body { - createfile tf1 - createfile tf2 - testchmod 000 tf2 - set fd [open tf2] - set msg [list [catch {testfile cp tf1 tf2} msg] $msg] - close $fd - lappend msg [file writable tf2] -} -result {1 EACCES 0} test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} -body { testfile rm $cdfile $cdrom/dummy~~.fil @@ -647,7 +566,7 @@ test winFCmd-3.10 {TclpDeleteFile: path is readonly} -setup { cleanup } -constraints {win testfile testchmod} -body { createfile tf1 - testchmod 000 tf1 + testchmod 0 tf1 testfile rm tf1 file exists tf1 } -result {0} @@ -655,20 +574,17 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup { cleanup } -constraints {win testfile testchmod} -body { set fd [open tf1 w] - testchmod 000 tf1 + testchmod 0 tf1 testfile rm tf1 } -cleanup { close $fd - catch {testchmod 666 tf1} + catch {testchmod 0o666 tf1} cleanup } -returnCodes error -result EACCES test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body { testfile mkdir $cdrom/dummy~~.dir -} -constraints {win nt cdrom testfile} -returnCodes error -result EACCES -test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} -body { - testfile mkdir $cdrom/dummy~~.dir -} -constraints {win 95 cdrom testfile} -returnCodes error -result ENOSPC +} -constraints {win cdrom testfile} -returnCodes error -result EACCES test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup { cleanup } -constraints {win testfile} -body { @@ -701,13 +617,13 @@ test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} -setup { test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup { cleanup -} -constraints {winVista testfile testchmod} -body { +} -constraints {win testfile testchmod knownMsvcBug notInCIenv} -body { file mkdir td1 - testchmod 000 td1 + testchmod 0 td1 testfile rmdir td1 file exists td1 } -returnCodes error -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -result {td1 EACCES} # This next test has a very hokey way of matching... @@ -755,59 +671,34 @@ test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} -setup { } -result {1 {tf1 ENOTDIR}} test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { cleanup -} -constraints {winVista testfile testchmod} -body { +} -constraints {win testfile testchmod knownMsvcBug notInCIenv} -body { file mkdir td1 - testchmod 000 td1 + testchmod 0 td1 testfile rmdir td1 file exists td1 } -returnCodes error -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -result {td1 EACCES} -test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile rmdir nul -} -returnCodes error -result {nul EACCES} test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { cleanup -} -constraints {win nt testfile} -body { +} -constraints {win testfile notInCIenv} -body { testfile rmdir / # WinXP returns EEXIST, WinNT seems to return EACCES. No policy # decision has been made as to which is correct. } -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$} -# This next test has a very hokey way of matching... -test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} -setup { - cleanup -} -constraints {win 95 testfile} -body { - createfile tf1 - set res [catch {testfile rmdir tf1} msg] - # get rid of path - set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]] - list $res $msg -} -result {1 {tf1 ENOTDIR}} test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { cleanup -} -constraints {winVista testfile testchmod} -body { +} -constraints {win testfile testchmod knownMsvcBug notInCIenv} -body { file mkdir td1 - testchmod 000 td1 + testchmod 0 td1 testfile rmdir td1 file exists td1 } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -returnCodes error -result {td1 EACCES} # This next test has a very hokey way of matching... -test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} -setup { - cleanup -} -constraints {win 95 testfile} -body { - file mkdir td1/td2 - set res [catch {testfile rmdir td1} msg] - # get rid of path - set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]] - list $res $msg -} -result {1 {td1 EEXIST}} -# This next test has a very hokey way of matching... test winFCmd-6.15 {TclpRemoveDirectory: !recursive} -setup { cleanup } -constraints {win testfile} -body { @@ -887,14 +778,9 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} -setup { } -cleanup { cleanup } -result {tf1} -test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} -body { - # cdrom can return either d:\ or D:/, but we only care about the errcode - testfile rmdir $cdrom/ -} -constraints {win 95 cdrom testfile} -returnCodes error -match glob \ - -result {* EACCES} ; # was EEXIST, but changed for win98. test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body { testfile rmdir $cdrom/ -} -constraints {win nt cdrom testfile} -returnCodes error -match glob \ +} -constraints {win cdrom testfile} -returnCodes error -match glob \ -result {* EACCES} test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \ {win emptyTest} { @@ -905,11 +791,11 @@ test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} -setup { } -constraints {win testfile testchmod} -body { file mkdir td1 createfile td1/tf1 tf1 - testchmod 000 td1 + testchmod 0 td1 testfile cpdir td1 td2 list [file exists td2] [file writable td2] } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -result {1 1} test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} -setup { @@ -930,17 +816,9 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} -setup { } -cleanup { cleanup } -result {tf1} -test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} -setup { - cleanup -} -constraints {win 95 testfile} -body { - file mkdir td1 - testfile cpdir td1 / -} -cleanup { - cleanup -} -returnCodes error -result {/ EEXIST} test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup { cleanup -} -constraints {win nt testfile} -body { +} -constraints {win testfile} -body { file mkdir td1 testfile cpdir td1 / } -cleanup { @@ -984,11 +862,11 @@ test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} -setup { } -constraints {win testfile testchmod} -body { file mkdir td1 createfile td1/tf1 tf1 - testchmod 000 td1 + testchmod 0 td1 testfile cpdir td1 td2 list [file exists td2] [file writable td2] } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -result {1 1} test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} -setup { @@ -1015,11 +893,11 @@ test winFCmd-8.2 {TraversalCopy: DOTREE_PRED} -setup { cleanup } -constraints {win testfile testchmod} -body { file mkdir td1/td2 - testchmod 000 td1 + testchmod 0 td1 testfile cpdir td1 td2 list [file writable td1] [file writable td1/td2] } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -result {0 1} test winFCmd-8.3 {TraversalCopy: DOTREE_POSTD} -setup { @@ -1038,24 +916,15 @@ test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup { createfile td1/tf1 testfile rmdir -force td1 } -result {} -test winFCmd-9.2 {TraversalDelete: DOTREE_F} -setup { - cleanup -} -constraints {win 95 testfile} -body { - file mkdir td1 - set fd [open td1/tf1 w] - testfile rmdir -force td1 -} -cleanup { - close $fd -} -returnCodes error -result {td1\tf1 EACCES} test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup { cleanup -} -constraints {winVista testfile testchmod} -body { +} -constraints {win testfile testchmod knownMsvcBug notInCIenv} -body { file mkdir td1/td2 - testchmod 000 td1 + testchmod 0 td1 testfile rmdir -force td1 file exists td1 } -cleanup { - catch {testchmod 666 td1} + catch {testchmod 0o666 td1} cleanup } -returnCodes error -result {td1 EACCES} test winFCmd-9.4 {TraversalDelete: DOTREE_POSTD} -setup { @@ -1162,14 +1031,15 @@ test winFCmd-12.4 {ConvertFileNameFormat} -constraints {win} -setup { test winFCmd-12.5 {ConvertFileNameFormat: absolute path} -body { list [file attributes / -longname] [file attributes \\ -longname] } -constraints {win} -result {/ /} -test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup { - catch {file delete -force -- c:/td1} -} -constraints {win win2000orXP} -body { - createfile c:/td1 {} - string tolower [file attributes c:/td1 -longname] -} -cleanup { - file delete -force -- c:/td1 -} -result {c:/td1} +test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive (in temp folder)} -setup { + catch {file delete -force -- $::env(TEMP)/td1} +} -constraints {win} -body { + createfile $::env(TEMP)/td1 {} + string equal [string tolower [file attributes $::env(TEMP)/td1 -longname]] \ + [string tolower [file normalize $::env(TEMP)]/td1] +} -cleanup { + file delete -force -- $::env(TEMP)/td1 +} -result 1 test winFCmd-12.7 {ConvertFileNameFormat} -body { string tolower [file attributes //bisque/tcl/ws -longname] } -constraints {nonPortable win} -result {//bisque/tcl/ws} @@ -1229,7 +1099,7 @@ test winFCmd-15.2 {SetWinFileAttributes - archive} -constraints {win} -setup { } -cleanup { cleanup } -result {{} 1} -test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win} -setup { +test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win notInCIenv} -setup { cleanup } -body { createfile td1 {} @@ -1237,7 +1107,7 @@ test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win} -setup { } -cleanup { cleanup } -result {{} 0} -test winFCmd-15.4 {SetWinFileAttributes - hidden} -constraints {win} -setup { +test winFCmd-15.4 {SetWinFileAttributes - hidden} -constraints {win notInCIenv} -setup { cleanup } -body { createfile td1 {} @@ -1270,7 +1140,7 @@ test winFCmd-15.7 {SetWinFileAttributes - readonly} -setup { } -cleanup { cleanup } -result {{} 0} -test winFCmd-15.8 {SetWinFileAttributes - system} -constraints {win} -setup { +test winFCmd-15.8 {SetWinFileAttributes - system} -constraints {win notInCIenv} -setup { cleanup } -body { createfile td1 {} @@ -1406,14 +1276,14 @@ test winFCmd-18.1.2 {Windows reserved path names} -constraints win -body { file pathtype com4 } -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 } -result "absolute" @@ -1442,13 +1312,13 @@ test winFCmd-18.8 {Windows reserved path names} -constraints win -body { file normalize cOm1: } -result COM1 -test winFCmd-19.1 {Windows extended path names} -constraints nt -body { +test winFCmd-19.1 {Windows extended path names} -constraints win -body { file normalize //?/c:/windows/win.ini } -result //?/c:/windows/win.ini -test winFCmd-19.2 {Windows extended path names} -constraints nt -body { +test winFCmd-19.2 {Windows extended path names} -constraints win -body { file normalize //?/c:/windows/../windows/win.ini } -result //?/c:/windows/win.ini -test winFCmd-19.3 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.3 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp] set tmpfile [file normalize $tmpfile] } -body { @@ -1459,7 +1329,7 @@ test winFCmd-19.3 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.4 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.4 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp] set tmpfile //?/[file normalize $tmpfile] } -body { @@ -1470,18 +1340,18 @@ test winFCmd-19.4 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.5 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.5 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp] set tmpfile [file normalize $tmpfile] } -body { list [catch { set f [open $tmpfile [list WRONLY CREAT]] close $f - } res] errormsg ;#$res + } res] $res } -cleanup { catch {file delete $tmpfile} -} -result [list 1 errormsg] -test winFCmd-19.6 {Windows extended path names} -constraints nt -setup { +} -result [list 0 {}] +test winFCmd-19.6 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp] set tmpfile //?/[file normalize $tmpfile] } -body { @@ -1492,7 +1362,7 @@ test winFCmd-19.6 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.7 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.7 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "] set tmpfile [file normalize $tmpfile] } -body { @@ -1503,7 +1373,7 @@ test winFCmd-19.7 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {} [list tcl[pid].tmp]] -test winFCmd-19.8 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.8 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "] set tmpfile //?/[file normalize $tmpfile] } -body { @@ -1515,6 +1385,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 win -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} { diff --git a/tests/winFile.test b/tests/winFile.test index fba9bcb..0c13a0e 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -4,70 +4,49 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } -namespace import -force ::tcltest::* ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint notNTFS 0 -testConstraint win2000 0 if {[testConstraint testvolumetype]} { testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}] } -if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} { - testConstraint win2000 1 -} +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] test winFile-1.1 {TclpGetUserHome} -constraints {win} -body { glob ~nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} -test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body { +test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body { # The administrator account should always exist. glob ~administrator } -match glob -result * -test winFile-1.3 {TclpGetUserHome} -constraints {win 95} -body { - # Find some user in system.ini and then see if they have a home. - - set f [open $::env(windir)/system.ini] - while {[gets $f line] >= 0} { - if {$line ne {[Password Lists]}} { - continue - } - gets $f - set name [lindex [split [gets $f] =] 0] - if {$name ne ""} { - return [catch {glob ~$name}] - } - } - return 0 ;# didn't find anything... -} -cleanup { - catch {close $f} -} -result {0} -test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} { +test winFile-1.4 {TclpGetUserHome} {win nonPortable} { catch {glob ~stanton@workgroup} } {0} test winFile-2.1 {TclpMatchFiles: case sensitivity} -constraints {win} -body { makeFile {} GlobCapS - list [glob -nocomplain GlobC*] [glob -nocomplain globc*] -} -cleanup { + set args [list -nocomplain -tails -directory [temporaryDirectory]] + list [glob {*}$args GlobC*] [glob {*}$args globc*]} -cleanup { removeFile GlobCapS } -result {GlobCapS GlobCapS} test winFile-2.2 {TclpMatchFiles: case sensitivity} -constraints {win} -body { makeFile {} globlower - list [glob -nocomplain globl*] [glob -nocomplain gLOBl*] + set args [list -nocomplain -tails -directory [temporaryDirectory]] + list [glob {*}$args globl*] [glob {*}$args gLOBl*] } -cleanup { removeFile globlower } -result {globlower globlower} @@ -172,7 +151,7 @@ if {[testConstraint win]} { test winFile-4.0 { Enhanced NTFS user/group permissions: test no acccess } -constraints { - win nt notNTFS win2000 + win notNTFS notWine } -setup { set owner [getuser $fname] set user $::env(USERDOMAIN)\\$::env(USERNAME) @@ -187,7 +166,7 @@ test winFile-4.0 { test winFile-4.1 { Enhanced NTFS user/group permissions: test readable only } -constraints { - win nt notNTFS + win notNTFS notWine } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -198,7 +177,7 @@ test winFile-4.1 { test winFile-4.2 { Enhanced NTFS user/group permissions: test writable only } -constraints { - win nt notNTFS + win notNTFS notWine } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -210,7 +189,7 @@ test winFile-4.2 { test winFile-4.3 { Enhanced NTFS user/group permissions: test read+write } -constraints { - win nt notNTFS + win notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -223,7 +202,7 @@ test winFile-4.3 { test winFile-4.4 { Enhanced NTFS user/group permissions: test full access } -constraints { - win nt notNTFS + win notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { diff --git a/tests/winNotify.test b/tests/winNotify.test index 3e9aa29..52502a2 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.test @@ -4,19 +4,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testeventloop [expr {[info commands testeventloop] != {}}] diff --git a/tests/winPipe.test b/tests/winPipe.test index d2e804d..6252f96 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -6,42 +6,52 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output (except for one message) means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} unset -nocomplain path catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] - set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [info loaded {} Tcltest] } -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] +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] + + +# 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 append big $big -append big $big +append big $big append big $big append big $big 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 @@ -74,18 +84,14 @@ test winpipe-1.2 {32 bit comprehensive tests: from big file} {win exec cat32} { exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" -test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win nt exec cat32} { +test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win exec cat32} { exec [interpreter] $path(more) < $path(little) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } {little stderr32} -test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat32} { +test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win exec cat32} { exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" -test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {win 95 exec cat32} { - exec command /c type $path(big) |& $cat32 > $path(stdout) 2> $path(stderr) - list [contents $path(stdout)] [contents $path(stderr)] -} "{$big} stderr32" test winpipe-1.6 {32 bit comprehensive tests: from console} \ {win cat32 AllocConsole} { # would block waiting for human input @@ -174,12 +180,8 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \ catch {close $f} set r } "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" -test winpipe-1.22 {Checking command.com for Win95/98 hanging} {win 95 exec} { - exec command.com /c dir /b - set result 1 -} 1 -test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { +test winpipe-4.1 {Tcl_WaitPid} {win exec cat32} { proc readResults {f} { global x result if { [eof $f] } { @@ -198,7 +200,7 @@ test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { vwait x list $result $x [contents $path(stderr)] } "{$big} 1 stderr32" -test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} { +test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -206,7 +208,7 @@ test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec test set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] } {1 1 SIGFPE} -test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept} { +test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -214,7 +216,7 @@ test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec tes set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] } {1 1 SIGSEGV} -test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept} { +test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -222,7 +224,7 @@ test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec test set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] } {1 1 SIGILL} -test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept} { +test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -316,9 +318,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(). ### @@ -377,65 +424,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 notWine} -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 notWine} -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 notWine} -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) @@ -453,8 +613,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: diff --git a/tests/winTime.test b/tests/winTime.test index add8f98..ae1797d 100644 --- a/tests/winTime.test +++ b/tests/winTime.test @@ -4,21 +4,24 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testwinclock [llength [info commands testwinclock]] +# Some things fail under all Continuous Integration systems for subtle reasons +# such as CI often running with elevated privileges in a container. +testConstraint notInCIenv [expr {![info exists ::env(CI)]}] # The next two tests will crash on Windows if the check for negative # clock values is not done properly. @@ -40,7 +43,7 @@ test winTime-1.2 {TclpGetDate} {win} { # with the Windows clock. 30 sec really isn't enough, # but how much time does a tester have patience for? -test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock} { +test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock notInCIenv} { # May fail due to OS/hardware discrepancies. See: # http://support.microsoft.com/default.aspx?scid=kb;en-us;274323 set failed {} @@ -50,7 +53,7 @@ test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock} { foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] break set diff [expr { $tcl_sec - $sys_sec + 1.0e-6 * ( $tcl_usec - $sys_usec ) }] - if { abs($diff) > 0.06 } { + if { abs($diff) > 0.1 } { set failed "Tcl clock differs from system clock by $diff sec" break } else { diff --git a/tests/zipfs.test b/tests/zipfs.test new file mode 100644 index 0000000..cdddc71 --- /dev/null +++ b/tests/zipfs.test @@ -0,0 +1,284 @@ +# The file tests the tclZlib.c file. +# +# 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 generates output +# for errors. No output means no errors were found. +# +# Copyright © 1996-1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +testConstraint zipfs [expr { + [llength [info commands zlib]] && [regexp tcltest [info nameofexecutable]] +}] +testConstraint zipfslib 1 + +# Removed in tip430 - zipfs is no longer a static package +#test zipfs-0.0 {zipfs basics} -constraints zipfs -body { +# load {} zipfs +#} -result {} + +set ziproot [zipfs root] +set CWD [pwd] +set tmpdir [file join $CWD tmp] +file mkdir $tmpdir + +test zipfs-0.0 {zipfs basics} -constraints zipfs -body { + package require tcl::zipfs +} -result {2.0} +test zipfs-0.1 {zipfs basics} -constraints zipfs -body { + expr {${ziproot} in [file volumes]} +} -result 1 + +if {![string match ${ziproot}* $tcl_library]} { + ### + # "make test" does not map tcl_library from the dynamic library on Unix + # + # Hack the environment to pretend we did pull tcl_library from a zip + # archive + ### + set tclzip [file join $CWD [::tcl::pkgconfig get zipfile,runtime]] + testConstraint zipfslib [file isfile $tclzip] + if {[testConstraint zipfslib]} { + zipfs mount /lib/tcl $tclzip + set ::tcl_library ${ziproot}lib/tcl/tcl_library + } +} + +test zipfs-0.2 {zipfs basics} -constraints zipfslib -body { + string match ${ziproot}* $tcl_library +} -result 1 +test zipfs-0.3 {zipfs basics: glob} -constraints zipfslib -setup { + set pwd [pwd] +} -body { + cd $tcl_library + expr { [file join . http] in [glob -dir . http*] } +} -cleanup { + cd $pwd +} -result 1 +test zipfs-0.4 {zipfs basics: glob} -constraints zipfslib -setup { + set pwd [pwd] +} -body { + cd $tcl_library + expr { [file join $tcl_library http] in [glob -dir [pwd] http*] } +} -cleanup { + cd $pwd +} -result 1 +test zipfs-0.5 {zipfs basics: glob} -constraints zipfslib -body { + expr { [file join $tcl_library http] in [glob -dir $tcl_library http*] } +} -result 1 +test zipfs-0.6 {zipfs basics: glob} -constraints zipfslib -body { + expr { [file join $tcl_library http] in [glob [file join $tcl_library http*]] } +} -result 1 +test zipfs-0.7 {zipfs basics: glob} -constraints zipfslib -body { + expr { "http" in [glob -tails -dir $tcl_library http*] } +} -result 1 +test zipfs-0.8 {zipfs basics: glob} -constraints zipfslib -body { + expr { "http" in [glob -nocomplain -tails -types d -dir $tcl_library http*] } +} -result 1 +test zipfs-0.9 {zipfs basics: glob} -constraints zipfslib -body { + glob -nocomplain -tails -types f -dir $tcl_library http* +} -result {} +test zipfs-0.10 {zipfs basics: join} -constraints {zipfs zipfslib} -body { + file join [zipfs root] bar baz +} -result "[zipfs root]bar/baz" +test zipfs-0.11 {zipfs basics: join} -constraints {zipfs zipfslib} -body { + file normalize [zipfs root] +} -result "[zipfs root]" +test zipfs-0.12 {zipfs basics: join} -constraints {zipfs zipfslib} -body { + file normalize [zipfs root]//bar/baz//qux/../ +} -result "[zipfs root]bar/baz" + +test zipfs-1.3 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mount a b c d e f +} -result {wrong # args: should be "zipfs mount ?mountpoint? ?zipfile? ?password?"} +test zipfs-1.4 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs unmount a b c d e f +} -result {wrong # args: should be "zipfs unmount zipfile"} +test zipfs-1.5 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mkkey a b c d e f +} -result {wrong # args: should be "zipfs mkkey password"} +test zipfs-1.6 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mkimg a b c d e f +} -result {wrong # args: should be "zipfs mkimg outfile indir ?strip? ?password? ?infile?"} +test zipfs-1.7 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mkzip a b c d e f +} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"} +test zipfs-1.8 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs exists a b c d e f +} -result {wrong # args: should be "zipfs exists filename"} +test zipfs-1.9 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs info a b c d e f +} -result {wrong # args: should be "zipfs info filename"} +test zipfs-1.10 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs list a b c d e f +} -result {wrong # args: should be "zipfs list ?(-glob|-regexp)? ?pattern?"} + +file mkdir tmp +test zipfs-2.1 {zipfs mkzip empty archive} -constraints zipfs -returnCodes error -body { + zipfs mkzip [file join $tmpdir empty.zip] $tcl_library/xxxx +} -result {empty archive} +### +# The next series of tests operate within a zipfile created a temporary +# directory. +### +set zipfile [file join $tmpdir abc.zip] +if {[file exists $zipfile]} { + file delete $zipfile +} +test zipfs-2.2 {zipfs mkzip} -constraints zipfs -body { + cd $tcl_library/encoding + zipfs mkzip $zipfile . + zipfs mount ${ziproot}abc $zipfile + zipfs list -glob ${ziproot}abc/cp850.* +} -cleanup { + cd $CWD +} -result "[zipfs root]abc/cp850.enc" +testConstraint zipfsenc [zipfs exists /abc/cp850.enc] +test zipfs-2.3 {zipfs info} -constraints {zipfs zipfsenc} -body { + set r [zipfs info ${ziproot}abc/cp850.enc] + lrange $r 0 2 +} -result [list $zipfile 1090 527] ;# NOTE: Only the first 3 results are stable +test zipfs-2.4 {zipfs data} -constraints {zipfs zipfsenc} -body { + set zipfd [open ${ziproot}/abc/cp850.enc] ;# FIXME: leave open - see later test + read $zipfd +} -result {# Encoding file: cp850, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5 +00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192 +00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB +2591259225932502252400C100C200C000A9256325512557255D00A200A52510 +25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4 +00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580 +00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4 +00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0 +} ;# FIXME: result depends on content of encodings dir +test zipfs-2.5 {zipfs exists} -constraints {zipfs zipfsenc} -body { + zipfs exists /abc/cp850.enc +} -result 1 +test zipfs-2.6 {zipfs unmount while busy} -constraints {zipfs zipfsenc} -body { + zipfs unmount /abc +} -returnCodes error -result {filesystem is busy} +test zipfs-2.7 {zipfs unmount} -constraints {zipfs zipfsenc} -body { + close $zipfd + zipfs unmount /abc + zipfs exists /abc/cp850.enc +} -result 0 +### +# Repeat the tests for a buffer mounted archive +### +test zipfs-2.8 {zipfs mkzip} -constraints zipfs -body { + cd $tcl_library/encoding + zipfs mkzip $zipfile . + set fin [open $zipfile r] + fconfigure $fin -translation binary + set dat [read $fin] + close $fin + zipfs mount_data def $dat + zipfs list -glob ${ziproot}def/cp850.* +} -cleanup { + cd $CWD +} -result "[zipfs root]def/cp850.enc" +testConstraint zipfsencbuf [zipfs exists /def/cp850.enc] +test zipfs-2.9 {zipfs info} -constraints {zipfs zipfsencbuf} -body { + set r [zipfs info ${ziproot}def/cp850.enc] + lrange $r 0 2 +} -result [list {Memory Buffer} 1090 527] ;# NOTE: Only the first 3 results are stable +test zipfs-2.10 {zipfs data} -constraints {zipfs zipfsencbuf} -body { + set zipfd [open ${ziproot}/def/cp850.enc] ;# FIXME: leave open - see later test + read $zipfd +} -result {# Encoding file: cp850, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5 +00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192 +00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB +2591259225932502252400C100C200C000A9256325512557255D00A200A52510 +25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4 +00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580 +00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4 +00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0 +} ;# FIXME: result depends on content of encodings dir +test zipfs-2.11 {zipfs exists} -constraints {zipfs zipfsencbuf} -body { + zipfs exists /def/cp850.enc +} -result 1 +test zipfs-2.12 {zipfs unmount while busy} -constraints {zipfs zipfsencbuf} -body { + zipfs unmount /def +} -returnCodes error -result {filesystem is busy} +test zipfs-2.13 {zipfs unmount} -constraints {zipfs zipfsencbuf} -body { + close $zipfd + zipfs unmount /def + zipfs exists /def/cp850.enc +} -result 0 + +catch {file delete -force $tmpdir} + +test zipfs-3.1 {zipfs in child interpreters} -constraints zipfs -setup { + set interp [interp create] +} -body { + interp eval $interp { + zipfs ? + } +} -returnCodes error -cleanup { + interp delete $interp +} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount} +test zipfs-3.2 {zipfs in child interpreters} -constraints zipfs -setup { + set interp [interp create] +} -body { + interp eval $interp { + zipfs mkzip + } +} -returnCodes error -cleanup { + interp delete $interp +} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"} +test zipfs-3.3 {zipfs in child interpreters} -constraints zipfs -setup { + set safe [interp create -safe] +} -body { + interp eval $safe { + zipfs ? + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount} +test zipfs-3.4 {zipfs in child interpreters} -constraints zipfs -setup { + set safe [interp create -safe] +} -body { + interp eval $safe { + zipfs mkzip + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {not allowed to invoke subcommand mkzip of zipfs} + +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/zlib.test b/tests/zlib.test index 8212082..7de6d64 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -4,18 +4,25 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1996-1998 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.1 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint zlib [llength [info commands zlib]] +testConstraint recentZlib 0 +catch { + # Work around a bug in some versions of zlib; known to manifest on at + # least Mac OS X Mountain Lion... + testConstraint recentZlib \ + [package vsatisfies [zlib::pkgconfig get zlibVersion] 1.2.6] +} test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body { zlib @@ -23,6 +30,12 @@ test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body { test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body { zlib ? {} } -result {bad command "?": must be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream} +test zlib-1.3 {zlib basics} -constraints zlib -body { + zlib::pkgconfig list +} -result zlibVersion +test zlib-1.4 {zlib basics} -constraints zlib -body { + package present tcl::zlib +} -result 2.0.1 test zlib-2.1 {zlib compress/decompress} zlib { zlib decompress [zlib compress abcdefghijklm] @@ -70,7 +83,7 @@ test zlib-7.0 {zlib stream} -constraints zlib -returnCodes error -setup { $s ? } -cleanup { $s close -} -result {bad option "?": must be add, checksum, close, eof, finalize, flush, fullflush, get, put, or reset} +} -result {bad option "?": must be add, checksum, close, eof, finalize, flush, fullflush, get, header, put, or reset} test zlib-7.1 {zlib stream} zlib { set s [zlib stream compress] $s put -finalize abcdeEDCBA @@ -119,6 +132,73 @@ test zlib-7.6 {zlib stream} zlib { $s close lappend result $data } {{} 69f34b6a abcdeEDCBA..} +test zlib-7.7 {zlib stream: Bug 25842c161} -constraints zlib -body { + set s [zlib stream deflate] + $s put {} +} -cleanup { + catch {$s close} +} -result "" +# Also causes Tk Bug 10f2e7872b +test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup { + expr {srand(12345)} + set randdata {} + for {set i 0} {$i<6001} {incr i} { + append randdata [binary format c [expr {int(256*rand())}]] + } +} -body { + set strm [zlib stream compress] + for {set i 1} {$i<3000} {incr i} { + $strm put $randdata + } + $strm put -finalize $randdata + set data [$strm get] + list [string length $data] [string length [zlib decompress $data]] +} -cleanup { + catch {$strm close} + unset -nocomplain randdata data +} -result {120185 18003000} +test zlib-7.9 {zlib stream finalize (bug 25842c161)} -constraints zlib -setup { + set z1 [zlib stream gzip] + set z2 [zlib stream gzip] +} -body { + $z1 put ABCDEedbca.. + $z1 finalize + zlib gunzip [$z1 get] +} -cleanup { + $z1 close +} -result ABCDEedbca.. +test zlib-7.10 {zlib stream finalize (bug 25842c161)} -constraints zlib -setup { + set z2 [zlib stream gzip] +} -body { + $z2 put -finalize ABCDEedbca.. + zlib gunzip [$z2 get] +} -cleanup { + $z2 close +} -result ABCDEedbca.. +test zlib-7.11 {zlib stream put -finalize (bug 25842c161)} -constraints zlib -setup { + set c [zlib stream gzip] + set d [zlib stream gunzip] +} -body { + $c put abcdeEDCBA.. + $c finalize + $d put [$c get] + $d finalize + $d get +} -cleanup { + $c close + $d close +} -result abcdeEDCBA.. +test zlib-7.12 {zlib stream put; zlib stream finalize (bug 25842c161)} -constraints zlib -setup { + set c [zlib stream gzip] + set d [zlib stream gunzip] +} -body { + $c put -finalize abcdeEDCBA.. + $d put -finalize [$c get] + $d get +} -cleanup { + $c close + $d close +} -result abcdeEDCBA.. test zlib-8.1 {zlib transformation} -constraints zlib -setup { set file [makeFile {} test.gz] @@ -202,7 +282,210 @@ test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup { set ::res } -cleanup { catch {close $r} -} -result {qwertyuiop MIDDLE asdfghjkl} +} -result {qwertyuiop MIDDLE asdfghjkl {}} +test zlib-8.6 {transformation and fconfigure} -setup { + set file [makeFile {} test.z] + set fd [open $file wb] +} -constraints zlib -body { + list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \ + [chan pop $fd; fconfigure $fd] +} -cleanup { + catch {close $fd} + removeFile $file +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +test zlib-8.7 {transformation and fconfigure} -setup { + set file [makeFile {} test.gz] + set fd [open $file wb] +} -constraints zlib -body { + list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \ + [chan pop $fd; fconfigure $fd] +} -cleanup { + catch {close $fd} + removeFile $file +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +# Input is headers from fetching SPDY draft +# Dictionary is that which is proposed _in_ SPDY draft +set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" +set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" +test zlib-8.8 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push compress $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 1 -translation binary -buffering none + fconfigure $inSide -blocking 1 -translation binary + puts -nonewline $outSide $spdyHeaders + chan pop $outSide + chan close $outSide + set compressed [read $inSide] + catch {zlib decompress $compressed} err opt + list [string length [zlib compress $spdyHeaders]] \ + [string length $compressed] \ + $err [dict get $opt -errorcode] [zlib adler32 $spdyDict] +} -cleanup { + catch {close $outSide} + catch {close $inSide} +} -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} +test zlib-8.9 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream decompress] +} -constraints zlib -body { + zlib push compress $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 1 -translation binary -buffering none + fconfigure $inSide -blocking 1 -translation binary + puts -nonewline $outSide $spdyHeaders + set result [fconfigure $outSide -checksum] + chan pop $outSide + chan close $outSide + $strm put -dictionary $spdyDict [read $inSide] + lappend result [string length $spdyHeaders] [string length [$strm get]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {3064818174 358 358} +test zlib-8.10 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints {zlib recentZlib} -body { + zlib push deflate $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 1 -translation binary -buffering none + fconfigure $inSide -blocking 1 -translation binary + puts -nonewline $outSide $spdyHeaders + chan pop $outSide + chan close $outSide + set compressed [read $inSide] + catch { + zlib inflate $compressed + throw UNREACHABLE "should be unreachable" + } err opt + list [string length [zlib deflate $spdyHeaders]] \ + [string length $compressed] \ + $err [dict get $opt -errorcode] +} -cleanup { + catch {close $outSide} + catch {close $inSide} +} -result {254 212 {data error} {TCL ZLIB DATA}} +test zlib-8.11 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream inflate] +} -constraints zlib -body { + zlib push deflate $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 1 -translation binary -buffering none + fconfigure $inSide -blocking 1 -translation binary + puts -nonewline $outSide $spdyHeaders + chan pop $outSide + chan close $outSide + $strm put -dictionary $spdyDict [read $inSide] + list [string length $spdyHeaders] [string length [$strm get]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358} +test zlib-8.12 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream compress] +} -constraints zlib -body { + $strm put -dictionary $spdyDict -finalize $spdyHeaders + zlib push decompress $inSide + fconfigure $outSide -blocking 1 -translation binary + fconfigure $inSide -translation binary -dictionary $spdyDict + puts -nonewline $outSide [$strm get] + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] \ + [fconfigure $inSide -checksum] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358 3064818174} +test zlib-8.13 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream compress] +} -constraints zlib -body { + $strm put -dictionary $spdyDict -finalize $spdyHeaders + zlib push decompress $inSide -dictionary $spdyDict + fconfigure $outSide -blocking 1 -translation binary + fconfigure $inSide -translation binary + puts -nonewline $outSide [$strm get] + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] \ + [fconfigure $inSide -checksum] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358 3064818174} +test zlib-8.14 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream deflate] +} -constraints zlib -body { + $strm put -finalize -dictionary $spdyDict $spdyHeaders + zlib push inflate $inSide + fconfigure $outSide -blocking 1 -buffering none -translation binary + fconfigure $inSide -translation binary -dictionary $spdyDict + puts -nonewline $outSide [$strm get] + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358} +test zlib-8.15 {transformation and fconfigure} -setup { + lassign [chan pipe] inSide outSide + set strm [zlib stream deflate] +} -constraints zlib -body { + $strm put -finalize -dictionary $spdyDict $spdyHeaders + zlib push inflate $inSide -dictionary $spdyDict + fconfigure $outSide -blocking 1 -buffering none -translation binary + fconfigure $inSide -translation binary + puts -nonewline $outSide [$strm get] + close $outSide + list [string length $spdyHeaders] [string length [read $inSide]] +} -cleanup { + catch {close $outSide} + catch {close $inSide} + catch {$strm close} +} -result {358 358} +test zlib-8.16 {Bug 3603553: buffer transfer with large writes} -setup { + # Actual data isn't very important; needs to be substantially larger than + # the internal buffer (32kB) and incompressible. + set largeData {} + for {set i 0;expr {srand(1)}} {$i < 100000} {incr i} { + append largeData [lindex "a b c d e f g h i j k l m n o p" \ + [expr {int(16*rand())}]] + } + set file [makeFile {} test.gz] +} -constraints zlib -body { + set f [open $file wb] + fconfigure $f -buffering none + zlib push gzip $f + puts -nonewline $f $largeData + close $f + file size $file +} -cleanup { + removeFile $file +} -result 57647 +test zlib-8.17 {Bug dd260aaf: fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push inflate $inSide + zlib push deflate $outSide + list [chan configure $inSide -dictionary] [chan configure $outSide -dictionary] +} -cleanup { + catch {close $inSide} + catch {close $outSide} +} -result {{} {}} +test zlib-8.18 {Bug dd260aaf: fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push inflate $inSide -dictionary "one two" + zlib push deflate $outSide -dictionary "one two" + list [chan configure $inSide -dictionary] [chan configure $outSide -dictionary] +} -cleanup { + catch {close $inSide} + catch {close $outSide} +} -result {{one two} {one two}} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] @@ -225,6 +508,7 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c + set ::total -1 }}} 0] set file [makeFile {} test.gz] } -body { @@ -232,7 +516,10 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { set sin [socket $addr $port] chan configure $sin -translation binary zlib push gunzip $sin - update + after 1000 {set ::total timeout} + vwait ::total + after cancel {set ::total timeout} + if {$::total != -1} {error "unexpected value $::total of ::total"} set total [fcopy $sin [set fout [open $file wb]]] close $sin close $fout @@ -633,7 +920,7 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints { rename zlibRead {} } -result {error {invalid block type}} -test zlib-11.1 "Bug #3390073: mis-appled gzip filtering" -setup { +test zlib-11.1 "Bug #3390073: mis-applied gzip filtering" -setup { set file [makeFile {} test.input] } -constraints zlib -body { set f [open $file wb] @@ -647,7 +934,7 @@ test zlib-11.1 "Bug #3390073: mis-appled gzip filtering" -setup { } -cleanup { removeFile $file } -result {1000 0} -test zlib-11.2 "Bug #3390073: mis-appled gzip filtering" -setup { +test zlib-11.2 "Bug #3390073: mis-applied gzip filtering" -setup { set file [makeFile {} test.input] } -constraints zlib -body { set f [open $file wb] @@ -663,6 +950,141 @@ test zlib-11.2 "Bug #3390073: mis-appled gzip filtering" -setup { } -cleanup { removeFile $file } -result {1000 /foo/bar 0} +test zlib-11.3 {Bug 3595576 variant} -setup { + set file [makeFile {} test.input] +} -constraints zlib -body { + set f [open $file wb] + puts -nonewline [zlib push gzip $f -header {filename /foo/bar}] \ + [string repeat "hello" 1000] + close $f + set f [open $file rb] + set d [read $f] + close $f + zlib gunzip $d -header noSuchNs::foo +} -cleanup { + removeFile $file +} -returnCodes error -result {can't set "noSuchNs::foo": parent namespace doesn't exist} + +test zlib-12.1 {Tk Bug 9eb55debc5} -constraints zlib -setup { + set stream [zlib stream compress] +} -body { + for {set opts {};set y 0} {$y < 60} {incr y} { + for {set line {};set x 0} {$x < 100} {incr x} { + append line [binary format ccc $x $y 128] + } + if {$y == 59} { + set opts -finalize + } + $stream put {*}$opts $line + } + set data [$stream get] + list [string length $data] [string length [zlib decompress $data]] +} -cleanup { + $stream close +} -result {12026 18000} +test zlib-12.2 {Patrick Dunnigan's issue} -constraints zlib -setup { + set filesrc [makeFile {} test.input] + set filedst [makeFile {} test.output] + set f [open $filesrc "wb"] + for {set i 0} {$i < 10000} {incr i} { + puts -nonewline $f "x" + } + close $f +} -body { + set fin [open $filesrc "rb"] + set fout [open $filedst "wb"] + set header [dict create filename "test.input" time 0] + try { + fcopy $fin [zlib push gzip $fout -header $header] + } finally { + close $fin + close $fout + } + file size $filedst +} -cleanup { + removeFile $filesrc + removeFile $filedst +} -result 56 + +set zlibbinf "" +proc _zlibbinf {} { + # inlined zlib.bin file creator: + variable zlibbinf + if {$zlibbinf eq ""} { + set zlibbinf [makeFile {} test-zlib-13.bin] + set f [open $zlibbinf wb] + puts -nonewline $f [zlib decompress [binary decode base64 { + eJx7e+6s1+EAgYaLjK3ratptGmOck0vT/y/ZujHAd0qJelDBXfUPJ3tfrtLbpX+wOOFHmtn03/tizm + /+tXROXU3d203b79p5X6/0cvUyFzTsqOj4sa9r8SrZI5zT7265e2Xzq595Fb9LbpgffVy7cZaJ/d15 + 4U9L7LLM2vdqut8+aSU/r6q9Ltv6+T9mBhTgIK97bH33m/O1C1eBwf9FDKNgaIDaj9wA+5hToA== + }]] + close $f + } + return $zlibbinf +} +test zlib-13.1 {Ticket [8af92dfb66] - zlib stream mis-expansion} -constraints zlib -setup { + set pathin [_zlibbinf] + set chanin [open $pathin rb] + set pathout [makeFile {} test-zlib-13.deflated] + set chanout [open $pathout wb] + zlib push inflate $chanin + fcopy $chanin $chanout + close $chanin + close $chanout +} -body { + file size $pathout +} -cleanup { + removeFile $pathout + unset chanin pathin chanout pathout +} -result 458752 + +test zlib-13.2 {Ticket [f70ce1fead] - zlib multi-stream expansion} -constraints zlib -setup { + # Start from the basic asset + set pathin [_zlibbinf] + set chanin [open $pathin rb] + # Create a multi-stream by copying the asset twice into it. + set pathout [makeFile {} test-zlib-13.multi] + set chanout [open $pathout wb] + fcopy $chanin $chanout + seek $chanin 0 start + fcopy $chanin $chanout + close $chanin + close $chanout + # The multi-stream file shall be our input + set pathin $pathout + set chanin [open $pathin rb] + # And our destinations + set pathout1 [makeFile {} test-zlib-13.multi-1] + set pathout2 [makeFile {} test-zlib-13.multi-2] +} -body { + # Decode first stream + set chanout [open $pathout1 wb] + zlib push inflate $chanin + fcopy $chanin $chanout + chan pop $chanin + close $chanout + # Decode second stream + set chanout [open $pathout2 wb] + zlib push inflate $chanin + fcopy $chanin $chanout + chan pop $chanin + close $chanout + # + list [file size $pathout1] [file size $pathout2] +} -cleanup { + close $chanin + removeFile $pathout + removeFile $pathout1 + removeFile $pathout2 + unset chanin pathin chanout pathout pathout1 pathout2 +} -result {458752 458752} + +if {$zlibbinf ne ""} { + removeFile $zlibbinf +} +unset zlibbinf +rename _zlibbinf {} + ::tcltest::cleanupTests return |