diff options
Diffstat (limited to 'tests')
152 files changed, 20058 insertions, 8757 deletions
diff --git a/tests/README b/tests/README index 75a08e7..ce2382e 100644 --- a/tests/README +++ b/tests/README @@ -1,7 +1,5 @@ README -- Tcl test suite design document. -RCS: @(#) $Id: README,v 1.12 2003/04/01 19:17:21 dgp Exp $ - Contents: --------- diff --git a/tests/all.tcl b/tests/all.tcl index 75650a1..05d3024 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -9,11 +9,11 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: all.tcl,v 1.19 2006/11/03 00:34:52 hobbs Exp $ +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 {} diff --git a/tests/append.test b/tests/append.test index 3c000df..69c6381 100644 --- a/tests/append.test +++ b/tests/append.test @@ -10,17 +10,15 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: append.test,v 1.12 2010/09/01 20:35:33 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } -catch {unset x} - +unset -nocomplain x + test append-1.1 {append command} { - catch {unset x} + unset -nocomplain x list [append x 1 2 abc "long string"] $x } {{12abclong string} {12abclong string}} test append-1.2 {append command} { @@ -52,12 +50,12 @@ test append-3.2 {append errors} -returnCodes error -body { append x(0) 44 } -result {can't set "x(0)": variable isn't array} test append-3.3 {append errors} -returnCodes error -body { - catch {unset x} + unset -nocomplain x append x } -result {can't read "x": no such variable} test append-4.1 {lappend command} { - catch {unset x} + unset -nocomplain x list [lappend x 1 2 abc "long string"] $x } {{1 2 abc {long string}} {1 2 abc {long string}}} test append-4.2 {lappend command} { @@ -128,19 +126,19 @@ test append-4.16 {lappend command} { lappend x abc } "x abc" test append-4.17 {lappend command} { - catch {unset x} + unset -nocomplain x lappend x } {} test append-4.18 {lappend command} { - catch {unset x} + unset -nocomplain x lappend x {} } {{}} test append-4.19 {lappend command} { - catch {unset x} + unset -nocomplain x lappend x(0) } {} test append-4.20 {lappend command} { - catch {unset x} + unset -nocomplain x lappend x(0) abc } {abc} unset -nocomplain x @@ -154,7 +152,7 @@ test append-4.22 {lappend command} -returnCodes error -body { } -result {unmatched open quote in list} test append-5.1 {long lappends} -setup { - catch {unset x} + unset -nocomplain x proc check {var size} { set l [llength $var] if {$l != $size} { @@ -188,7 +186,7 @@ test append-6.2 {lappend errors} -returnCodes error -body { test append-7.1 {lappend-created var and error in trace on that var} -setup { catch {rename foo ""} - catch {unset x} + unset -nocomplain x } -body { trace variable x w foo proc foo {} {global x; unset x} @@ -200,8 +198,8 @@ test append-7.1 {lappend-created var and error in trace on that var} -setup { list [info exists x] [catch {set x} msg] $msg } -result {0 1 {can't read "x": no such variable}} test append-7.2 {lappend var triggers read trace} -setup { - catch {unset myvar} - catch {unset ::result} + unset -nocomplain myvar + unset -nocomplain ::result } -body { trace variable myvar r foo proc foo {args} {append ::result $args} @@ -209,8 +207,8 @@ test append-7.2 {lappend var triggers read trace} -setup { return $::result } -result {myvar {} r} test append-7.3 {lappend var triggers read trace, array var} -setup { - catch {unset myvar} - catch {unset ::result} + unset -nocomplain myvar + unset -nocomplain ::result } -body { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them, and was changed back in 8.4. @@ -220,8 +218,8 @@ test append-7.3 {lappend var triggers read trace, array var} -setup { return $::result } -result {myvar b r} test append-7.4 {lappend var triggers read trace, array var exists} -setup { - catch {unset myvar} - catch {unset ::result} + unset -nocomplain myvar + unset -nocomplain ::result } -body { set myvar(0) 1 trace variable myvar r foo @@ -230,8 +228,8 @@ test append-7.4 {lappend var triggers read trace, array var exists} -setup { return $::result } -result {myvar b r} test append-7.5 {append var does not trigger read trace} -setup { - catch {unset myvar} - catch {unset ::result} + unset -nocomplain myvar + unset -nocomplain ::result } -body { trace variable myvar r foo proc foo {args} {append ::result $args} @@ -239,15 +237,16 @@ test append-7.5 {append var does not trigger read trace} -setup { info exists ::result } -result {0} +# THERE ARE NO append-8.* TESTS +# New tests for bug 3057639 to show off the more consistent behaviour of +# lappend in both direct-eval and bytecompiled code paths (see appendComp.test +# for the compiled variants). lappend now behaves like append. 9.0/1 lappend - +# 9.2/3 append -# New tests for bug 3057639 to show off the more consistent behaviour -# of lappend in both direct-eval and bytecompiled code paths (see -# appendComp.test for the compiled variants). lappend now behaves like -# append. 9.0/1 lappend - 9.2/3 append - -test append-9.0 {bug 3057639, lappend direct eval, read trace on non-existing array variable element} { - catch {unset myvar} +test append-9.0 {bug 3057639, lappend direct eval, read trace on non-existing array variable element} -setup { + unset -nocomplain myvar +} -body { array set myvar {} proc nonull {var key val} { upvar 1 $var lvar @@ -259,17 +258,19 @@ test append-9.0 {bug 3057639, lappend direct eval, read trace on non-existing ar list [catch { lappend myvar(key) "new value" } msg] $msg -} {0 {{new value}}} - -test append-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} { - catch {unset ::env(__DUMMY__)} +} -result {0 {{new value}}} +test append-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} -setup { + unset -nocomplain ::env(__DUMMY__) +} -body { list [catch { lappend ::env(__DUMMY__) "new value" } msg] $msg -} {0 {{new value}}} - -test append-9.2 {bug 3057639, append direct eval, read trace on non-existing array variable element} { - catch {unset myvar} +} -cleanup { + unset -nocomplain ::env(__DUMMY__) +} -result {0 {{new value}}} +test append-9.2 {bug 3057639, append direct eval, read trace on non-existing array variable element} -setup { + unset -nocomplain myvar +} -body { array set myvar {} proc nonull {var key val} { upvar 1 $var lvar @@ -281,19 +282,25 @@ test append-9.2 {bug 3057639, append direct eval, read trace on non-existing arr list [catch { append myvar(key) "new value" } msg] $msg -} {0 {new value}} - -test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} { - catch {unset ::env(__DUMMY__)} +} -result {0 {new value}} +test append-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} -setup { + unset -nocomplain ::env(__DUMMY__) +} -body { list [catch { append ::env(__DUMMY__) "new value" } msg] $msg -} {0 {new value}} - - -catch {unset i x result y} +} -cleanup { + unset -nocomplain ::env(__DUMMY__) +} -result {0 {new value}} + +unset -nocomplain i x result y catch {rename foo ""} # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/appendComp.test b/tests/appendComp.test index 9523d2d..f85c3ba 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -10,20 +10,19 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: appendComp.test,v 1.13 2010/09/01 20:35:33 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } catch {unset x} - -test appendComp-1.1 {append command} { - catch {unset x} + +test appendComp-1.1 {append command} -setup { + unset -nocomplain x +} -body { proc foo {} {append ::x 1 2 abc "long string"} list [foo] $x -} {{12abclong string} {12abclong string}} +} -result {{12abclong string} {12abclong string}} test appendComp-1.2 {append command} { proc foo {} { set x "" @@ -67,7 +66,7 @@ test appendComp-3.2 {append errors} -returnCodes error -body { } -result {can't set "x(0)": variable isn't array} test appendComp-3.3 {append errors} -returnCodes error -body { proc foo {} { - catch {unset x} + unset -nocomplain x append x } foo @@ -76,7 +75,7 @@ test appendComp-3.3 {append errors} -returnCodes error -body { test appendComp-4.1 {lappend command} { proc foo {} { global x - catch {unset x} + unset -nocomplain x lappend x 1 2 abc "long string" } list [foo] $x @@ -207,27 +206,31 @@ test appendComp-4.20 {lappend command} { foo } {abc} -proc check {var size} { - set l [llength $var] - if {$l != $size} { - return "length mismatch: should have been $size, was $l" - } - for {set i 0} {$i < $size} {set i [expr $i+1]} { - set j [lindex $var $i] - if {$j != "item $i"} { - return "element $i should have been \"item $i\", was \"$j\"" +test appendComp-5.1 {long lappends} -setup { + unset -nocomplain x + proc check {var size} { + set l [llength $var] + if {$l != $size} { + return "length mismatch: should have been $size, was $l" } + 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\"" + } + } + return ok } - return ok -} -test appendComp-5.1 {long lappends} { - catch {unset x} +} -body { set x "" for {set i 0} {$i < 300} {set i [expr $i+1]} { lappend x "item $i" } check $x 300 -} ok +} -cleanup { + unset -nocomplain x + catch {rename check ""} +} -result ok test appendComp-6.1 {lappend errors} -returnCodes error -body { proc foo {} {lappend} @@ -243,7 +246,7 @@ test appendComp-6.2 {lappend errors} -returnCodes error -body { test appendComp-7.1 {lappendComp-created var and error in trace on that var} -setup { catch {rename foo ""} - catch {unset x} + unset -nocomplain x } -body { proc bar {} { global x @@ -259,7 +262,7 @@ test appendComp-7.1 {lappendComp-created var and error in trace on that var} -se bar } -result {0 1 {can't read "x": no such variable}} test appendComp-7.2 {lappend var triggers read trace, index var} -setup { - catch {unset ::result} + unset -nocomplain ::result } -body { proc bar {} { trace variable myvar r foo @@ -282,7 +285,7 @@ test appendComp-7.3 {lappend var triggers read trace, stack var} -setup { bar } -result {::myvar {} r} -constraints {bug-3057639} test appendComp-7.4 {lappend var triggers read trace, array var} -setup { - catch {unset ::result} + unset -nocomplain ::result } -body { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them. Maybe not correct, but been there a while. @@ -295,7 +298,7 @@ test appendComp-7.4 {lappend var triggers read trace, array var} -setup { bar } -result {myvar b r} -constraints {bug-3057639} test appendComp-7.5 {lappend var triggers read trace, array var} -setup { - catch {unset ::result} + unset -nocomplain ::result } -body { # The behavior of read triggers on lappend changed in 8.0 to not trigger # them. Maybe not correct, but been there a while. @@ -308,7 +311,7 @@ test appendComp-7.5 {lappend var triggers read trace, array var} -setup { bar } -result {myvar b r} test appendComp-7.6 {lappend var triggers read trace, array var exists} -setup { - catch {unset ::result} + unset -nocomplain ::result } -body { proc bar {} { set myvar(0) 1 @@ -320,8 +323,8 @@ test appendComp-7.6 {lappend var triggers read trace, array var exists} -setup { bar } -result {myvar b r} -constraints {bug-3057639} test appendComp-7.7 {lappend var triggers read trace, array stack var} -setup { - catch {unset ::myvar} - catch {unset ::result} + unset -nocomplain ::myvar + unset -nocomplain ::result } -body { proc bar {} { trace variable ::myvar r foo @@ -332,8 +335,8 @@ test appendComp-7.7 {lappend var triggers read trace, array stack var} -setup { bar } -result {::myvar b r} -constraints {bug-3057639} test appendComp-7.8 {lappend var triggers read trace, array stack var} -setup { - catch {unset ::myvar} - catch {unset ::result} + unset -nocomplain ::myvar + unset -nocomplain ::result } -body { proc bar {} { trace variable ::myvar r foo @@ -344,7 +347,7 @@ test appendComp-7.8 {lappend var triggers read trace, array stack var} -setup { bar } -result {::myvar b r} test appendComp-7.9 {append var does not trigger read trace} -setup { - catch {unset ::result} + unset -nocomplain ::result } -body { proc bar {} { trace variable myvar r foo @@ -369,25 +372,24 @@ test appendComp-8.1 {defer error to runtime} -setup { interp delete slave } -result {} +# New tests for bug 3057639 to show off the more consistent behaviour of +# lappend in both direct-eval and bytecompiled code paths (see append.test for +# the direct-eval variants). lappend now behaves like append. 9.0/1 lappend - +# 9.2/3 append. -# New tests for bug 3057639 to show off the more consistent behaviour -# of lappend in both direct-eval and bytecompiled code paths (see -# append.test for the direct-eval variants). lappend now behaves like -# append. 9.0/1 lappend - 9.2/3 append. - -# Note also the tests above now constrained by bug-3057639, these -# changed behaviour with the triggering of read traces in bc mode -# gone. +# Note also the tests above now constrained by bug-3057639, these changed +# behaviour with the triggering of read traces in bc mode gone. -# Going back to the tests below. The direct-eval tests are ok before -# and after patch (no read traces run for lappend, append). The -# compiled tests are failing for lappend (9.0/1) before the patch, -# showing how it invokes read traces in the compiled path. The append -# tests are good (9.2/3). After the patch the failues are gone. +# Going back to the tests below. The direct-eval tests are ok before and after +# patch (no read traces run for lappend, append). The compiled tests are +# failing for lappend (9.0/1) before the patch, showing how it invokes read +# traces in the compiled path. The append tests are good (9.2/3). After the +# patch the failues are gone. -test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing array variable element} { - catch {unset myvar} +test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing array variable element} -setup { + unset -nocomplain myvar array set myvar {} +} -body { proc nonull {var key val} { upvar 1 $var lvar if {![info exists lvar($key)]} { @@ -399,22 +401,21 @@ test appendComp-9.0 {bug 3057639, lappend compiled, read trace on non-existing a lappend ::myvar(key) "new value" } list [catch { foo } msg] $msg -} {0 {{new value}}} - - -test appendComp-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} { - catch {unset ::env(__DUMMY__)} +} -result {0 {{new value}}} +test appendComp-9.1 {bug 3057639, lappend direct eval, read trace on non-existing env element} -setup { + unset -nocomplain ::env(__DUMMY__) +} -body { proc foo {} { lappend ::env(__DUMMY__) "new value" } list [catch { foo } msg] $msg -} {0 {{new value}}} - - - -test appendComp-9.2 {bug 3057639, append compiled, read trace on non-existing array variable element} { - catch {unset myvar} +} -cleanup { + unset -nocomplain ::env(__DUMMY__) +} -result {0 {{new value}}} +test appendComp-9.2 {bug 3057639, append compiled, read trace on non-existing array variable element} -setup { + unset -nocomplain myvar array set myvar {} +} -body { proc nonull {var key val} { upvar 1 $var lvar if {![info exists lvar($key)]} { @@ -426,18 +427,18 @@ test appendComp-9.2 {bug 3057639, append compiled, read trace on non-existing ar append ::myvar(key) "new value" } list [catch { foo } msg] $msg -} {0 {new value}} - - -test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} { - catch {unset ::env(__DUMMY__)} +} -result {0 {new value}} +test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing env element} -setup { + unset -nocomplain ::env(__DUMMY__) +} -body { proc foo {} { append ::env(__DUMMY__) "new value" } list [catch { foo } msg] $msg -} {0 {new value}} - - +} -cleanup { + unset -nocomplain ::env(__DUMMY__) +} -result {0 {new value}} + catch {unset i x result y} catch {rename foo ""} catch {rename bar ""} @@ -447,3 +448,8 @@ catch {rename bar {}} # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/apply.test b/tests/apply.test index 9bcb50d..ba19b81 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -11,8 +11,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: apply.test,v 1.15 2010/08/15 16:12:27 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.2 diff --git a/tests/assemble.test b/tests/assemble.test new file mode 100644 index 0000000..7d4e5d1 --- /dev/null +++ b/tests/assemble.test @@ -0,0 +1,3293 @@ +# assemble.test -- +# +# Test suite for the 'tcl::unsupported::assemble' command +# +# Copyright (c) 2010 by Ozgur Dogan Ugurlu. +# Copyright (c) 2010 by Kevin B. Kenny. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. +#----------------------------------------------------------------------------- + +# Commands covered: assemble + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.2 + namespace import -force ::tcltest::* +} +namespace eval tcl::unsupported {namespace export assemble} +namespace import tcl::unsupported::assemble + +# Procedure to make code that fills the literal and local variable tables, to +# force instructions to spill to four bytes. + +proc fillTables {} { + set s {} + set sep {} + for {set i 0} {$i < 256} {incr i} { + append s $sep [list set v$i literal$i] + set sep \n + } + return $s +} + +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}] + } +} + +# assemble-1 - TclNRAssembleObjCmd + +test assemble-1.1 {wrong # args, direct eval} { + -body { + eval [list assemble] + } + -returnCodes error + -result {wrong # args*} + -match glob +} +test assemble-1.2 {wrong # args, direct eval} { + -body { + eval [list assemble too many] + } + -returnCodes error + -result {wrong # args*} + -match glob +} +test assemble-1.3 {error reporting, direct eval} { + -body { + list [catch { + eval [list assemble { + # bad opcode + rubbish + }] + } result] $result $errorInfo + } + -match glob + -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":* + while executing +"rubbish" + ("assemble" body, line 3)*}} + -cleanup {unset result} +} +test assemble-1.4 {simple direct eval} { + -body { + eval [list assemble {push {this is a test}}] + } + -result {this is a test} +} + +# assemble-2 - CompileAssembleObj + +test assemble-2.1 {bytecode reuse, direct eval} { + -body { + set x {push "this is a test"} + list [eval [list assemble $x]] \ + [eval [list assemble $x]] + } + -result {{this is a test} {this is a test}} +} +test assemble-2.2 {bytecode discard, direct eval} { + -body { + set x {load value} + proc p1 {x} { + set value value1 + assemble $x + } + proc p2 {x} { + set a b + set value value2 + assemble $x + } + list [p1 $x] [p2 $x] + } + -result {value1 value2} + -cleanup { + unset x + rename p1 {} + rename p2 {} + } +} +test assemble-2.3 {null script, direct eval} { + -body { + set x {} + assemble $x + } + -result {} + -cleanup {unset x} +} + +# assemble-3 - TclCompileAssembleCmd + +test assemble-3.1 {wrong # args, compiled path} { + -body { + proc x {} { + assemble + } + x + } + -returnCodes error + -match glob + -result {wrong # args:*} +} +test assemble-3.2 {wrong # args, compiled path} { + -body { + proc x {} { + assemble too many + } + x + } + -returnCodes error + -match glob + -result {wrong # args:*} + -cleanup { + rename x {} + } +} + +# assemble-4 - TclAssembleCode mainline + +test assemble-4.1 {syntax error} { + -body { + proc x {} { + assemble { + {}extra + } + } + list [catch x result] $result $::errorInfo + } + -cleanup { + rename x {} + unset result + } + -match glob + -result {1 {extra characters after close-brace} {extra characters after close-brace + while executing +"{}extra + " + ("assemble" body, line 2)*}} +} +test assemble-4.2 {null command} { + -body { + proc x {} { + assemble { + push hello; pop;;push goodbye + } + } + x + } + -result goodbye + -cleanup { + rename x {} + } +} + +# assemble-5 - GetNextOperand off-nominal cases + +test assemble-5.1 {unsupported expansion} { + -body { + proc x {y} { + assemble { + {*}$y + } + } + list [catch {x {push hello}} result] $result $::errorCode + } + -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} + -cleanup { + rename x {} + unset result + } +} +test assemble-5.2 {unsupported substitution} { + -body { + proc x {y} { + assemble { + $y + } + } + list [catch {x {nop}} result] $result $::errorCode + } + -cleanup { + rename x {} + unset result + } + -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} +} +test assemble-5.3 {unsupported substitution} { + -body { + proc x {} { + assemble { + [x] + } + } + list [catch {x} result] $result $::errorCode + } + -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} +} +test assemble-5.4 {backslash substitution} { + -body { + proc x {} { + assemble { + p\x75sh\ + hello\ world + } + } + x + } + -cleanup { + rename x {} + } + -result {hello world} +} + +# assemble-6 - ASSEM_PUSH + +test assemble-6.1 {push, wrong # args} { + -body { + assemble push + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-6.2 {push, wrong # args} { + -body { + assemble {push too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-6.3 {push} { + -body { + eval [list assemble {push hello}] + } + -result hello +} +test assemble-6.4 {push4} { + -body { + proc x {} " + [fillTables] + assemble {push hello} + " + x + } + -cleanup { + rename x {} + } + -result hello +} + +# assemble-7 - ASSEM_1BYTE + +test assemble-7.1 {add, wrong # args} { + -body { + assemble {add excess} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-7.2 {add} { + -body { + assemble { + push 2 + push 2 + add + } + } + -result {4} +} +test assemble-7.3 {appendArrayStk} { + -body { + set a(b) {hello, } + assemble { + push a + push b + push world + appendArrayStk + } + set a(b) + } + -result {hello, world} + -cleanup {unset a} +} +test assemble-7.4 {appendStk} { + -body { + set a {hello, } + assemble { + push a + push world + appendStk + } + set a + } + -result {hello, world} + -cleanup {unset a} +} +test assemble-7.5 {bitwise ops} { + -body { + list \ + [assemble {push 0b1100; push 0b1010; bitand}] \ + [assemble {push 0b1100; bitnot}] \ + [assemble {push 0b1100; push 0b1010; bitor}] \ + [assemble {push 0b1100; push 0b1010; bitxor}] + } + -result {8 -13 14 6} +} +test assemble-7.6 {div} { + -body { + assemble {push 999999; push 7; div} + } + -result 142857 +} +test assemble-7.7 {dup} { + -body { + assemble { + push 1; dup; dup; add; dup; add; dup; add; add + } + } + -result 9 +} +test assemble-7.8 {eq} { + -body { + list \ + [assemble {push able; push baker; eq}] \ + [assemble {push able; push able; eq}] + } + -result {0 1} +} +test assemble-7.9 {evalStk} { + -body { + assemble { + push {concat test 7.3} + evalStk + } + } + -result {test 7.3} +} +test assemble-7.9a {evalStk, syntax} { + -body { + assemble { + push {{}bad} + evalStk + } + } + -returnCodes error + -result {extra characters after close-brace} +} +test assemble-7.9b {evalStk, backtrace} { + -body { + proc y {z} { + error testing + } + proc x {} { + assemble { + push { + # test error in evalStk + y asd + } + evalStk + } + } + list [catch x result] $result $errorInfo + } + -result {1 testing {testing + while executing +"error testing" + (procedure "y" line 2) + invoked from within +"y asd"*}} + -match glob + -cleanup { + rename y {} + rename x {} + } +} +test assemble-7.10 {existArrayStk} { + -body { + proc x {name key} { + set a(b) c + assemble { + load name; load key; existArrayStk + } + } + list [x a a] [x a b] [x b a] [x b b] + } + -result {0 1 0 0} + -cleanup {rename x {}} +} +test assemble-7.11 {existStk} { + -body { + proc x {name} { + set a b + assemble { + load name; existStk + } + } + list [x a] [x b] + } + -result {1 0} + -cleanup {rename x {}} +} +test assemble-7.12 {expon} { + -body { + assemble {push 3; push 4; expon} + } + -result 81 +} +test assemble-7.13 {exprStk} { + -body { + assemble { + push {acos(-1)} + exprStk + } + } + -result 3.141592653589793 +} +test assemble-7.13a {exprStk, syntax} { + -body { + assemble { + push {2+} + exprStk + } + } + -returnCodes error + -result {missing operand at _@_ +in expression "2+_@_"} +} +test assemble-7.13b {exprStk, backtrace} { + -body { + proc y {z} { + error testing + } + proc x {} { + assemble { + push {[y asd]} + exprStk + } + } + list [catch x result] $result $errorInfo + } + -result {1 testing {testing + while executing +"error testing" + (procedure "y" line 2) + invoked from within +"y asd"*}} + -match glob + -cleanup { + rename y {} + rename x {} + } +} +test assemble-7.14 {ge gt le lt} { + -body { + proc x {a b} { + list [assemble {load a; load b; ge}] \ + [assemble {load a; load b; gt}] \ + [assemble {load a; load b; le}] \ + [assemble {load a; load b; lt}] + } + list [x 0 0] [x 0 1] [x 1 0] + } + -result {{1 0 1 0} {0 0 1 1} {1 1 0 0}} + -cleanup {rename x {}} +} +test assemble-7.15 {incrArrayStk} { + -body { + proc x {} { + set a(b) 5 + assemble { + push a; push b; push 7; incrArrayStk + } + } + x + } + -result 12 + -cleanup {rename x {}} +} +test assemble-7.16 {incrStk} { + -body { + proc x {} { + set a 5 + assemble { + push a; push 7; incrStk + } + } + x + } + -result 12 + -cleanup {rename x {}} +} +test assemble-7.17 {land/lor} { + -body { + proc x {a b} { + list \ + [assemble {load a; load b; land}] \ + [assemble {load a; load b; lor}] + } + list [x 0 0] [x 0 23] [x 35 0] [x 47 59] + } + -result {{0 0} {0 1} {0 1} {1 1}} + -cleanup {rename x {}} +} +test assemble-7.18 {lappendArrayStk} { + -body { + proc x {} { + set able(baker) charlie + assemble { + push able + push baker + push dog + lappendArrayStk + } + } + x + } + -result {charlie dog} + -cleanup {rename x {}} +} +test assemble-7.19 {lappendStk} { + -body { + proc x {} { + set able baker + assemble { + push able + push charlie + lappendStk + } + } + x + } + -result {baker charlie} + -cleanup {rename x {}} +} +test assemble-7.20 {listIndex} { + -body { + assemble { + push {a b c d} + push 2 + listIndex + } + } + -result c +} +test assemble-7.21 {listLength} { + -body { + assemble { + push {a b c d} + listLength + } + } + -result 4 +} +test assemble-7.22 {loadArrayStk} { + -body { + proc x {} { + set able(baker) charlie + assemble { + push able + push baker + loadArrayStk + } + } + x + } + -result charlie + -cleanup {rename x {}} +} +test assemble-7.23 {loadStk} { + -body { + proc x {} { + set able baker + assemble { + push able + loadStk + } + } + x + } + -result baker + -cleanup {rename x {}} +} +test assemble-7.24 {lsetList} { + -body { + proc x {} { + set l {{a b} {c d} {e f} {g h}} + assemble { + push {2 1}; push i; load l; lsetList + } + } + x + } + -result {{a b} {c d} {e i} {g h}} +} +test assemble-7.25 {lshift} { + -body { + assemble {push 16; push 4; lshift} + } + -result 256 +} +test assemble-7.26 {mod} { + -body { + assemble {push 123456; push 1000; mod} + } + -result 456 +} +test assemble-7.27 {mult} { + -body { + assemble {push 12345679; push 9; mult} + } + -result 111111111 +} +test assemble-7.28 {neq} { + -body { + list \ + [assemble {push able; push baker; neq}] \ + [assemble {push able; push able; neq}] + } + -result {1 0} +} +test assemble-7.29 {not} { + -body { + list \ + [assemble {push 17; not}] \ + [assemble {push 0; not}] + } + -result {0 1} +} +test assemble-7.30 {pop} { + -body { + assemble {push this; pop; push that} + } + -result that +} +test assemble-7.31 {rshift} { + -body { + assemble {push 257; push 4; rshift} + } + -result 16 +} +test assemble-7.32 {storeArrayStk} { + -body { + proc x {} { + assemble { + push able; push baker; push charlie; storeArrayStk + } + array get able + } + x + } + -result {baker charlie} + -cleanup {rename x {}} +} +test assemble-7.33 {storeStk} { + -body { + proc x {} { + assemble { + push able; push baker; storeStk + } + set able + } + x + } + -result {baker} + -cleanup {rename x {}} +} +test assemble-7,34 {strcmp} { + -body { + proc x {a b} { + assemble { + load a; load b; strcmp + } + } + list [x able baker] [x baker able] [x baker baker] + } + -result {-1 1 0} + -cleanup {rename x {}} +} +test assemble-7.35 {streq/strneq} { + -body { + proc x {a b} { + list \ + [assemble {load a; load b; streq}] \ + [assemble {load a; load b; strneq}] + } + list [x able able] [x able baker] + } + -result {{1 0} {0 1}} + -cleanup {rename x {}} +} +test assemble-7.36 {strindex} { + -body { + assemble {push testing; push 4; strindex} + } + -result i +} +test assemble-7.37 {strlen} { + -body { + assemble {push testing; strlen} + } + -result 7 +} +test assemble-7.38 {sub} { + -body { + assemble {push 42; push 17; sub} + } + -result 25 +} +test assemble-7.39 {tryCvtToNumeric} { + -body { + assemble { + push 42; tryCvtToNumeric + } + } + -result 42 +} +# assemble-7.40 absent +test assemble-7.41 {uminus} { + -body { + assemble { + push 42; uminus + } + } + -result -42 +} +test assemble-7.42 {uplus} { + -body { + assemble { + push 42; uplus + } + } + -result 42 +} +test assemble-7.43 {uplus} { + -body { + assemble { + push NaN; uplus + } + } + -returnCodes error + -result {can't use non-numeric floating-point value as operand of "+"} +} +test assemble-7.43.1 {tryCvtToNumeric} { + -body { + assemble { + push NaN; tryCvtToNumeric + } + } + -returnCodes error + -result {domain error: argument not in valid range} +} +test assemble-7.44 {listIn} { + -body { + assemble { + push b; push {a b c}; listIn + } + } + -result 1 +} +test assemble-7.45 {listNotIn} { + -body { + assemble { + push d; push {a b c}; listNotIn + } + } + -result 1 +} +test assemble-7.46 {nop} { + -body { + assemble { push x; nop; nop; nop} + } + -result x +} + +# assemble-8 ASSEM_LVT and FindLocalVar + +test assemble-8.1 {load, wrong # args} { + -body { + assemble load + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-8.2 {load, wrong # args} { + -body { + assemble {load too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-8.3 {nonlocal var} { + -body { + list [catch {assemble {load ::env}} result] $result $errorCode + } + -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} + -cleanup {unset result} +} +test assemble-8.4 {bad context} { + -body { + set x 1 + list [catch {assemble {load x}} result] $result $errorCode + } + -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} + -cleanup {unset result} +} +test assemble-8.5 {bad context} { + -body { + namespace eval assem { + set x 1 + list [catch {assemble {load x}} result] $result $errorCode + } + } + -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} + -cleanup {namespace delete assem} +} +test assemble-8.6 {load1} { + -body { + proc x {a} { + assemble { + load a + } + } + x able + } + -result able + -cleanup {rename x {}} +} +test assemble-8.7 {load4} { + -body { + proc x {a} " + [fillTables] + set b \$a + assemble {load b} + " + x able + } + -result able + -cleanup {rename x {}} +} +test assemble-8.8 {loadArray1} { + -body { + proc x {} { + set able(baker) charlie + assemble { + push baker + loadArray able + } + } + x + } + -result charlie + -cleanup {rename x {}} +} +test assemble-8.9 {loadArray4} { + -body " + proc x {} { + [fillTables] + set able(baker) charlie + assemble { + push baker + loadArray able + } + } + x + " + -result charlie + -cleanup {rename x {}} +} +test assemble-8.10 {append1} { + -body { + proc x {} { + set y {hello, } + assemble { + push world; append y + } + } + x + } + -result {hello, world} + -cleanup {rename x {}} +} +test assemble-8.11 {append4} { + -body { + proc x {} " + [fillTables] + set y {hello, } + assemble { + push world; append y + } + " + x + } + -result {hello, world} + -cleanup {rename x {}} +} +test assemble-8.12 {appendArray1} { + -body { + proc x {} { + set y(z) {hello, } + assemble { + push z; push world; appendArray y + } + } + x + } + -result {hello, world} + -cleanup {rename x {}} +} +test assemble-8.13 {appendArray4} { + -body { + proc x {} " + [fillTables] + set y(z) {hello, } + assemble { + push z; push world; appendArray y + } + " + x + } + -result {hello, world} + -cleanup {rename x {}} +} +test assemble-8.14 {lappend1} { + -body { + proc x {} { + set y {hello,} + assemble { + push world; lappend y + } + } + x + } + -result {hello, world} + -cleanup {rename x {}} +} +test assemble-8.15 {lappend4} { + -body { + proc x {} " + [fillTables] + set y {hello,} + assemble { + push world; lappend y + } + " + x + } + -result {hello, world} + -cleanup {rename x {}} +} +test assemble-8.16 {lappendArray1} { + -body { + proc x {} { + set y(z) {hello,} + assemble { + push z; push world; lappendArray y + } + } + x + } + -result {hello, world} + -cleanup {rename x {}} +} +test assemble-8.17 {lappendArray4} { + -body { + proc x {} " + [fillTables] + set y(z) {hello,} + assemble { + push z; push world; lappendArray y + } + " + x + } + -result {hello, world} + -cleanup {rename x {}} +} +test assemble-8.18 {store1} { + -body { + proc x {} { + assemble { + push test; store y + } + set y + } + x + } + -result {test} + -cleanup {rename x {}} +} +test assemble-8.19 {store4} { + -body { + proc x {} " + [fillTables] + assemble { + push test; store y + } + set y + " + x + } + -result test + -cleanup {rename x {}} +} +test assemble-8.20 {storeArray1} { + -body { + proc x {} { + assemble { + push z; push test; storeArray y + } + set y(z) + } + x + } + -result test + -cleanup {rename x {}} +} +test assemble-8.21 {storeArray4} { + -body { + proc x {} " + [fillTables] + assemble { + push z; push test; storeArray y + } + " + x + } + -result test + -cleanup {rename x {}} +} + +# assemble-9 - ASSEM_CONCAT1, GetIntegerOperand, CheckOneByte + +test assemble-9.1 {wrong # args} { + -body {assemble concat} + -result {wrong # args*} + -match glob + -returnCodes error +} +test assemble-9.2 {wrong # args} { + -body {assemble {concat too many}} + -result {wrong # args*} + -match glob + -returnCodes error +} +test assemble-9.3 {not a number} { + -body {assemble {concat rubbish}} + -result {expected integer but got "rubbish"} + -returnCodes error +} +test assemble-9.4 {too small} { + -body {assemble {concat -1}} + -result {operand does not fit in one byte} + -returnCodes error +} +test assemble-9.5 {too small} { + -body {assemble {concat 256}} + -result {operand does not fit in one byte} + -returnCodes error +} +test assemble-9.6 {concat} { + -body { + assemble {push h; push e; push l; push l; push o; concat 5} + } + -result hello +} +test assemble-9.7 {concat} { + -body { + list [catch {assemble {concat 0}} result] $result $::errorCode + } + -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} + -cleanup {unset result} +} + +# assemble-10 -- eval and expr + +test assemble-10.1 {eval - wrong # args} { + -body { + assemble {eval} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-10.2 {eval - wrong # args} { + -body { + assemble {eval too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-10.3 {eval} { + -body { + proc x {} { + assemble { + push 3 + store n + pop + eval {expr {3*$n + 1}} + push 1 + add + } + } + x + } + -result 11 + -cleanup {rename x {}} +} +test assemble-10.4 {expr} { + -body { + proc x {} { + assemble { + push 3 + store n + pop + expr {3*$n + 1} + push 1 + add + } + } + x + } + -result 11 + -cleanup {rename x {}} +} +test assemble-10.5 {eval and expr - nonsimple} { + -body { + proc x {} { + assemble { + eval "s\x65t n 3" + pop + expr "\x33*\$n + 1" + push 1 + add + } + } + x + } + -result 11 + -cleanup { + rename x {} + } +} +test assemble-10.6 {eval - noncompilable} { + -body { + list [catch {assemble {eval $x}} result] $result $::errorCode + } + -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} +} +test assemble-10.7 {expr - noncompilable} { + -body { + list [catch {assemble {expr $x}} result] $result $::errorCode + } + -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} +} + +# assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend, +# nsupvar, variable, upvar) + +test assemble-11.1 {exist - wrong # args} { + -body { + assemble {exist} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-11.2 {exist - wrong # args} { + -body { + assemble {exist too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-11.3 {nonlocal var} { + -body { + list [catch {assemble {exist ::env}} result] $result $errorCode + } + -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} + -cleanup {unset result} +} +test assemble-11.4 {exist} { + -body { + proc x {} { + set y z + list [assemble {exist y}] \ + [assemble {exist z}] + } + x + } + -result {1 0} + -cleanup {rename x {}} +} +test assemble-11.5 {existArray} { + -body { + proc x {} { + set a(b) c + list [assemble {push b; existArray a}] \ + [assemble {push c; existArray a}] \ + [assemble {push a; existArray b}] + } + x + } + -result {1 0 0} + -cleanup {rename x {}} +} +test assemble-11.6 {dictAppend} { + -body { + proc x {} { + set dict {a 1 b 2 c 3} + assemble {push b; push 22; dictAppend dict} + } + x + } + -result {a 1 b 222 c 3} + -cleanup {rename x {}} +} +test assemble-11.7 {dictLappend} { + -body { + proc x {} { + set dict {a 1 b 2 c 3} + assemble {push b; push 2; dictLappend dict} + } + x + } + -result {a 1 b {2 2} c 3} + -cleanup {rename x {}} +} +test assemble-11.8 {upvar} { + -body { + proc x {v} { + assemble {push 1; load v; upvar w; pop; load w} + } + proc y {} { + set z 123 + x z + } + y + } + -result 123 + -cleanup {rename x {}; rename y {}} +} +test assemble-11.9 {nsupvar} { + -body { + namespace eval q { variable v 123 } + proc x {} { + assemble {push q; push v; nsupvar y; pop; load y} + } + x + } + -result 123 + -cleanup {namespace delete q; rename x {}} +} +test assemble-11.10 {variable} { + -body { + namespace eval q { namespace eval r {variable v 123}} + proc x {} { + assemble {push q::r::v; variable y; load y} + } + x + } + -result 123 + -cleanup {namespace delete q; rename x {}} +} + +# assemble-12 - ASSEM_LVT1 (incr and incrArray) + +test assemble-12.1 {incr - wrong # args} { + -body { + assemble {incr} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-12.2 {incr - wrong # args} { + -body { + assemble {incr too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-12.3 {incr nonlocal var} { + -body { + list [catch {assemble {incr ::env}} result] $result $errorCode + } + -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} + -cleanup {unset result} +} +test assemble-12.4 {incr} { + -body { + proc x {} { + set y 5 + assemble {push 3; incr y} + } + x + } + -result 8 + -cleanup {rename x {}} +} +test assemble-12.5 {incrArray} { + -body { + proc x {} { + set a(b) 5 + assemble {push b; push 3; incrArray a} + } + x + } + -result 8 + -cleanup {rename x {}} +} +test assemble-12.6 {incr, stupid stack restriction} { + -body { + proc x {} " + [fillTables] + set y 5 + assemble {push 3; incr y} + " + list [catch {x} result] $result $errorCode + } + -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} + -cleanup {unset result; rename x {}} +} + +# assemble-13 -- ASSEM_LVT1_SINT1 - incrImm and incrArrayImm + +test assemble-13.1 {incrImm - wrong # args} { + -body { + assemble {incrImm x} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-13.2 {incrImm - wrong # args} { + -body { + assemble {incrImm too many args} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-13.3 {incrImm nonlocal var} { + -body { + list [catch {assemble {incrImm ::env 2}} result] $result $errorCode + } + -result {1 {variable "::env" is not local} {TCL ASSEM NONLOCAL ::env}} + -cleanup {unset result} +} +test assemble-13.4 {incrImm not a number} { + -body { + proc x {} { + assemble {incrImm x rubbish} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-13.5 {incrImm too big} { + -body { + proc x {} { + assemble {incrImm x 0x80} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} + -cleanup {rename x {}; unset result} +} +test assemble-13.6 {incrImm too small} { + -body { + proc x {} { + assemble {incrImm x -0x81} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} + -cleanup {rename x {}; unset result} +} +test assemble-13.7 {incrImm} { + -body { + proc x {} { + set y 1 + list [assemble {incrImm y -0x80}] [assemble {incrImm y 0x7f}] + } + x + } + -result {-127 0} + -cleanup {rename x {}} +} +test assemble-13.8 {incrArrayImm} { + -body { + proc x {} { + set a(b) 5 + assemble {push b; incrArrayImm a 3} + } + x + } + -result 8 + -cleanup {rename x {}} +} +test assemble-13.9 {incrImm, stupid stack restriction} { + -body { + proc x {} " + [fillTables] + set y 5 + assemble {incrImm y 3} + " + list [catch {x} result] $result $errorCode + } + -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} + -cleanup {unset result; rename x {}} +} + +# assemble-14 -- ASSEM_SINT1 (incrArrayStkImm and incrStkImm) + +test assemble-14.1 {incrStkImm - wrong # args} { + -body { + assemble {incrStkImm} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-14.2 {incrStkImm - wrong # args} { + -body { + assemble {incrStkImm too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-14.3 {incrStkImm not a number} { + -body { + proc x {} { + assemble {incrStkImm rubbish} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-14.4 {incrStkImm too big} { + -body { + proc x {} { + assemble {incrStkImm 0x80} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} + -cleanup {rename x {}; unset result} +} +test assemble-14.5 {incrStkImm too small} { + -body { + proc x {} { + assemble {incrStkImm -0x81} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand does not fit in one byte} {TCL ASSEM 1BYTE}} + -cleanup {rename x {}; unset result} +} +test assemble-14.6 {incrStkImm} { + -body { + proc x {} { + set y 1 + list [assemble {push y; incrStkImm -0x80}] \ + [assemble {push y; incrStkImm 0x7f}] + } + x + } + -result {-127 0} + -cleanup {rename x {}} +} +test assemble-14.7 {incrArrayStkImm} { + -body { + proc x {} { + set a(b) 5 + assemble {push a; push b; incrArrayStkImm 3} + } + x + } + -result 8 + -cleanup {rename x {}} +} + +# 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 +} + +# assemble-16 - invokeStk + +test assemble-16.1 {invokeStk - wrong # args} { + -body { + assemble {invokeStk} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-16.2 {invokeStk - wrong # args} { + -body { + assemble {invokeStk too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-16.3 {invokeStk - not a number} { + -body { + proc x {} { + assemble {invokeStk rubbish} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-16.4 {invokeStk - no operands} { + -body { + proc x {} { + assemble {invokeStk 0} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} + -cleanup {rename x {}; unset result} +} +test assemble-16.5 {invokeStk1} { + -body { + tcl::unsupported::assemble {push concat; push 1; push 2; invokeStk 3} + } + -result {1 2} +} +test assemble-16.6 {invokeStk4} { + -body { + proc x {n} { + set code {push concat} + set shouldbe {} + for {set i 1} {$i < $n} {incr i} { + append code \n {push a} $i + lappend shouldbe a$i + } + append code \n {invokeStk} { } $n + set is [assemble $code] + expr {$is eq $shouldbe} + } + list [x 254] [x 255] [x 256] [x 257] + } + -result {1 1 1 1} + -cleanup {rename x {}} +} + +# assemble-17 -- jumps and labels + +test assemble-17.1 {label, wrong # args} { + -body { + assemble {label} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-17.2 {label, wrong # args} { + -body { + assemble {label too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-17.3 {label, bad subst} { + -body { + list [catch {assemble {label $foo}} result] $result $::errorCode + } + -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} + -cleanup {unset result} +} +test assemble-17.4 {duplicate label} { + -body { + list [catch {assemble {label foo; label foo}} result] \ + $result $::errorCode + } + -result {1 {duplicate definition of label "foo"} {TCL ASSEM DUPLABEL foo}} +} +test assemble-17.5 {jump, wrong # args} { + -body { + assemble {jump} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-17.6 {jump, wrong # args} { + -body { + assemble {jump too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-17.7 {jump, bad subst} { + -body { + list [catch {assemble {jump $foo}} result] $result $::errorCode + } + -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}} + -cleanup {unset result} +} +test assemble-17.8 {jump - ahead and back} { + -body { + assemble { + jump three + + label one + push a + jump four + + label two + push b + jump six + + label three + push c + jump five + + label four + push d + jump two + + label five + push e + jump one + + label six + push f + concat 6 + } + } + -result ceadbf +} +test assemble-17.9 {jump - resolve a label multiple times} { + -body { + proc x {} { + set case 0 + set result {} + assemble { + jump common + + label zero + pop + incrImm case 1 + pop + push a + append result + pop + jump common + + label one + pop + incrImm case 1 + pop + push b + append result + pop + jump common + + label common + load case + dup + push 0 + eq + jumpTrue zero + dup + push 1 + eq + jumpTrue one + dup + push 2 + eq + jumpTrue two + dup + push 3 + eq + jumpTrue three + + label two + pop + incrImm case 1 + pop + push c + append result + pop + jump common + + label three + pop + incrImm case 1 + pop + push d + append result + } + } + x + } + -result abcd + -cleanup {rename x {}} +} +test assemble-17.10 {jump4 needed} { + -body { + assemble "push x; jump one; label two; [string repeat {dup; pop;} 128] + jump three; label one; jump two; label three" + } + -result x +} +test assemble-17.11 {jumpTrue} { + -body { + proc x {y} { + assemble { + load y + jumpTrue then + push no + jump else + label then + push yes + label else + } + } + list [x 0] [x 1] + } + -result {no yes} + -cleanup {rename x {}} +} +test assemble-17.12 {jumpFalse} { + -body { + proc x {y} { + assemble { + load y + jumpFalse then + push no + jump else + label then + push yes + label else + } + } + list [x 0] [x 1] + } + -result {yes no} + -cleanup {rename x {}} +} +test assemble-17.13 {jump to undefined label} { + -body { + list [catch {assemble {jump nowhere}} result] $result $::errorCode + } + -result {1 {undefined label "nowhere"} {TCL ASSEM NOLABEL nowhere}} +} +test assemble-17.14 {jump to undefined label, line number correct?} { + -body { + catch {assemble {#1 + #2 + #3 + jump nowhere + #5 + #6 + }} + set ::errorInfo + } + -match glob + -result {*"assemble" body, line 4*} +} +test assemble-17.15 {multiple passes of code resizing} { + -setup { + set body { + push - + } + for {set i 0} {$i < 14} {incr i} { + append body "label a" $i \ + "; push a; concat 2; nop; nop; jump b" \ + $i \n + } + append body {label a14; push a; concat 2; push 1; jumpTrue b14} \n + append body {label a15; push a; concat 2; push 0; jumpFalse b15} \n + for {set i 0} {$i < 15} {incr i} { + append body "label b" $i \ + "; push b; concat 2; nop; nop; jump a" \ + [expr {$i+1}] \n + } + append body {label c; push -; concat 2; nop; nop; nop; jump d} \n + append body {label b15; push b; concat 2; nop; nop; jump c} \n + append body {label d} + proc x {} [list assemble $body] + } + -body { + x + } + -cleanup { + catch {unset body} + catch {rename x {}} + } + -result -abababababababababababababababab- +} + +# assemble-18 - lindexMulti + +test assemble-18.1 {lindexMulti - wrong # args} { + -body { + assemble {lindexMulti} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-18.2 {lindexMulti - wrong # args} { + -body { + assemble {lindexMulti too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-18.3 {lindexMulti - bad subst} { + -body { + assemble {lindexMulti $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} +test assemble-18.4 {lindexMulti - not a number} { + -body { + proc x {} { + assemble {lindexMulti rubbish} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-18.5 {lindexMulti - bad operand count} { + -body { + proc x {} { + assemble {lindexMulti 0} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} + -cleanup {rename x {}; unset result} +} +test assemble-18.6 {lindexMulti} { + -body { + assemble {push {{a b c} {d e f} {g h j}}; lindexMulti 1} + } + -result {{a b c} {d e f} {g h j}} +} +test assemble-18.7 {lindexMulti} { + -body { + assemble {push {{a b c} {d e f} {g h j}}; push 1; lindexMulti 2} + } + -result {d e f} +} +test assemble-18.8 {lindexMulti} { + -body { + assemble {push {{a b c} {d e f} {g h j}}; push 2; push 1; lindexMulti 3} + } + -result h +} + +# assemble-19 - list + +test assemble-19.1 {list - wrong # args} { + -body { + assemble {list} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-19.2 {list - wrong # args} { + -body { + assemble {list too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-19.3 {list - bad subst} { + -body { + assemble {list $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} +test assemble-19.4 {list - not a number} { + -body { + proc x {} { + assemble {list rubbish} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-19.5 {list - negative operand count} { + -body { + proc x {} { + assemble {list -1} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} + -cleanup {rename x {}; unset result} +} +test assemble-19.6 {list - no args} { + -body { + assemble {list 0} + } + -result {} +} +test assemble-19.7 {list - 1 arg} { + -body { + assemble {push hello; list 1} + } + -result hello +} +test assemble-19.8 {list - 2 args} { + -body { + assemble {push hello; push world; list 2} + } + -result {hello world} +} + +# assemble-20 - lsetFlat + +test assemble-20.1 {lsetFlat - wrong # args} { + -body { + assemble {lsetFlat} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-20.2 {lsetFlat - wrong # args} { + -body { + assemble {lsetFlat too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-20.3 {lsetFlat - bad subst} { + -body { + assemble {lsetFlat $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} +test assemble-20.4 {lsetFlat - not a number} { + -body { + proc x {} { + assemble {lsetFlat rubbish} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-20.5 {lsetFlat - negative operand count} { + -body { + proc x {} { + assemble {lsetFlat 1} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand must be >=2} {TCL ASSEM OPERAND>=2}} + -cleanup {rename x {}; unset result} +} +test assemble-20.6 {lsetFlat} { + -body { + assemble {push b; push a; lsetFlat 2} + } + -result b +} +test assemble-20.7 {lsetFlat} { + -body { + assemble {push 1; push d; push {a b c}; lsetFlat 3} + } + -result {a d c} +} + +# assemble-21 - over + +test assemble-21.1 {over - wrong # args} { + -body { + assemble {over} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-21.2 {over - wrong # args} { + -body { + assemble {over too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-21.3 {over - bad subst} { + -body { + assemble {over $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} +test assemble-21.4 {over - not a number} { + -body { + proc x {} { + assemble {over rubbish} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-21.5 {over - negative operand count} { + -body { + proc x {} { + assemble {over -1} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} + -cleanup {rename x {}; unset result} +} +test assemble-21.6 {over} { + -body { + proc x {} { + assemble { + push 1 + push 2 + push 3 + over 0 + store x + pop + pop + pop + pop + load x + } + } + x + } + -result 3 + -cleanup {rename x {}} +} +test assemble-21.7 {over} { + -body { + proc x {} { + assemble { + push 1 + push 2 + push 3 + over 2 + store x + pop + pop + pop + pop + load x + } + } + x + } + -result 1 + -cleanup {rename x {}} +} + +# assemble-22 - reverse + +test assemble-22.1 {reverse - wrong # args} { + -body { + assemble {reverse} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-22.2 {reverse - wrong # args} { + -body { + assemble {reverse too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} + +test assemble-22.3 {reverse - bad subst} { + -body { + assemble {reverse $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} + +test assemble-22.4 {reverse - not a number} { + -body { + proc x {} { + assemble {reverse rubbish} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-22.5 {reverse - negative operand count} { + -body { + proc x {} { + assemble {reverse -1} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand must be nonnegative} {TCL ASSEM NONNEGATIVE}} + -cleanup {rename x {}; unset result} +} +test assemble-22.6 {reverse - zero operand count} { + -body { + proc x {} { + assemble {push 1; reverse 0} + } + x + } + -result 1 + -cleanup {rename x {}} +} +test assemble-22.7 {reverse} { + -body { + proc x {} { + assemble { + push 1 + push 2 + push 3 + reverse 1 + store x + pop + pop + pop + load x + } + } + x + } + -result 3 + -cleanup {rename x {}} +} +test assemble-22.8 {reverse} { + -body { + proc x {} { + assemble { + push 1 + push 2 + push 3 + reverse 3 + store x + pop + pop + pop + load x + } + } + x + } + -result 1 + -cleanup {rename x {}} +} + +# assemble-23 - ASSEM_BOOL (strmatch, unsetStk, unsetArrayStk) + +test assemble-23.1 {strmatch - wrong # args} { + -body { + assemble {strmatch} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-23.2 {strmatch - wrong # args} { + -body { + assemble {strmatch too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-23.3 {strmatch - bad subst} { + -body { + assemble {strmatch $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} +test assemble-23.4 {strmatch - not a boolean} { + -body { + proc x {} { + assemble {strmatch rubbish} + } + x + } + -returnCodes error + -result {expected boolean value but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-23.5 {strmatch} { + -body { + proc x {a b} { + list [assemble {load a; load b; strmatch 0}] \ + [assemble {load a; load b; strmatch 1}] + } + list [x foo*.grill fengbar.grill] [x foo*.grill foobar.grill] [x foo*.grill FOOBAR.GRILL] + } + -result {{0 0} {1 1} {0 1}} + -cleanup {rename x {}} +} +test assemble-23.6 {unsetStk} { + -body { + proc x {} { + set a {} + assemble {push a; unsetStk false} + info exists a + } + x + } + -result 0 + -cleanup {rename x {}} +} +test assemble-23.7 {unsetStk} { + -body { + proc x {} { + assemble {push a; unsetStk false} + info exists a + } + x + } + -result 0 + -cleanup {rename x {}} +} +test assemble-23.8 {unsetStk} { + -body { + proc x {} { + assemble {push a; unsetStk true} + info exists a + } + x + } + -returnCodes error + -result {can't unset "a": no such variable} + -cleanup {rename x {}} +} +test assemble-23.9 {unsetArrayStk} { + -body { + proc x {} { + set a(b) {} + assemble {push a; push b; unsetArrayStk false} + info exists a(b) + } + x + } + -result 0 + -cleanup {rename x {}} +} +test assemble-23.10 {unsetArrayStk} { + -body { + proc x {} { + assemble {push a; push b; unsetArrayStk false} + info exists a(b) + } + x + } + -result 0 + -cleanup {rename x {}} +} +test assemble-23.11 {unsetArrayStk} { + -body { + proc x {} { + assemble {push a; push b; unsetArrayStk true} + info exists a(b) + } + x + } + -returnCodes error + -result {can't unset "a(b)": no such variable} + -cleanup {rename x {}} +} + +# assemble-24 -- ASSEM_BOOL_LVT4 (unset; unsetArray) + +test assemble-24.1 {unset - wrong # args} { + -body { + assemble {unset one} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-24.2 {unset - wrong # args} { + -body { + assemble {unset too many args} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-24.3 {unset - bad subst -arg 1} { + -body { + assemble {unset $foo bar} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} +test assemble-24.4 {unset - not a boolean} { + -body { + proc x {} { + assemble {unset rubbish trash} + } + x + } + -returnCodes error + -result {expected boolean value but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-24.5 {unset - bad subst - arg 2} { + -body { + assemble {unset true $bar} + } + -returnCodes error + -result {assembly code may not contain substitutions} +} +test assemble-24.6 {unset - nonlocal var} { + -body { + assemble {unset true ::foo::bar} + } + -returnCodes error + -result {variable "::foo::bar" is not local} +} +test assemble-24.7 {unset} { + -body { + proc x {} { + set a {} + assemble {unset false a} + info exists a + } + x + } + -result 0 + -cleanup {rename x {}} +} +test assemble-24.8 {unset} { + -body { + proc x {} { + assemble {unset false a} + info exists a + } + x + } + -result 0 + -cleanup {rename x {}} +} +test assemble-24.9 {unset} { + -body { + proc x {} { + assemble {unset true a} + info exists a + } + x + } + -returnCodes error + -result {can't unset "a": no such variable} + -cleanup {rename x {}} +} +test assemble-24.10 {unsetArray} { + -body { + proc x {} { + set a(b) {} + assemble {push b; unsetArray false a} + info exists a(b) + } + x + } + -result 0 + -cleanup {rename x {}} +} +test assemble-24.11 {unsetArray} { + -body { + proc x {} { + assemble {push b; unsetArray false a} + info exists a(b) + } + x + } + -result 0 + -cleanup {rename x {}} +} +test assemble-24.12 {unsetArray} { + -body { + proc x {} { + assemble {push b; unsetArray true a} + info exists a(b) + } + x + } + -returnCodes error + -result {can't unset "a(b)": no such variable} + -cleanup {rename x {}} +} + +# assemble-25 - dict get + +test assemble-25.1 {dict get - wrong # args} { + -body { + assemble {dictGet} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-25.2 {dict get - wrong # args} { + -body { + assemble {dictGet too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-25.3 {dictGet - bad subst} { + -body { + assemble {dictGet $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} +test assemble-25.4 {dict get - not a number} { + -body { + proc x {} { + assemble {dictGet rubbish} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-25.5 {dictGet - negative operand count} { + -body { + proc x {} { + assemble {dictGet 0} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} + -cleanup {rename x {}; unset result} +} +test assemble-25.6 {dictGet - 1 index} { + -body { + assemble {push {a 1 b 2}; push a; dictGet 1} + } + -result 1 +} + +# assemble-26 - dict set + +test assemble-26.1 {dict set - wrong # args} { + -body { + assemble {dictSet 1} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-26.2 {dict get - wrong # args} { + -body { + assemble {dictSet too many args} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-26.3 {dictSet - bad subst} { + -body { + assemble {dictSet 1 $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} +test assemble-26.4 {dictSet - not a number} { + -body { + proc x {} { + assemble {dictSet rubbish foo} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-26.5 {dictSet - zero operand count} { + -body { + proc x {} { + assemble {dictSet 0 foo} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} + -cleanup {rename x {}; unset result} +} +test assemble-26.6 {dictSet - bad local} { + -body { + proc x {} { + assemble {dictSet 1 ::foo::bar} + } + list [catch x result] $result $::errorCode + } + -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} + -cleanup {rename x {}; unset result} +} +test assemble-26.7 {dictSet} { + -body { + proc x {} { + set dict {a 1 b 2 c 3} + assemble {push b; push 4; dictSet 1 dict} + } + x + } + -result {a 1 b 4 c 3} + -cleanup {rename x {}} +} + +# assemble-27 - dictUnset + +test assemble-27.1 {dictUnset - wrong # args} { + -body { + assemble {dictUnset 1} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-27.2 {dictUnset - wrong # args} { + -body { + assemble {dictUnset too many args} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-27.3 {dictUnset - bad subst} { + -body { + assemble {dictUnset 1 $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} +test assemble-27.4 {dictUnset - not a number} { + -body { + proc x {} { + assemble {dictUnset rubbish foo} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-27.5 {dictUnset - zero operand count} { + -body { + proc x {} { + assemble {dictUnset 0 foo} + } + list [catch x result] $result $::errorCode + } + -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} + -cleanup {rename x {}; unset result} +} +test assemble-27.6 {dictUnset - bad local} { + -body { + proc x {} { + assemble {dictUnset 1 ::foo::bar} + } + list [catch x result] $result $::errorCode + } + -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} + -cleanup {rename x {}; unset result} +} +test assemble-27.7 {dictUnset} { + -body { + proc x {} { + set dict {a 1 b 2 c 3} + assemble {push b; dictUnset 1 dict} + } + x + } + -result {a 1 c 3} + -cleanup {rename x {}} +} + +# assemble-28 - dictIncrImm + +test assemble-28.1 {dictIncrImm - wrong # args} { + -body { + assemble {dictIncrImm 1} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-28.2 {dictIncrImm - wrong # args} { + -body { + assemble {dictIncrImm too many args} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-28.3 {dictIncrImm - bad subst} { + -body { + assemble {dictIncrImm 1 $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} +test assemble-28.4 {dictIncrImm - not a number} { + -body { + proc x {} { + assemble {dictIncrImm rubbish foo} + } + x + } + -returnCodes error + -result {expected integer but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-28.5 {dictIncrImm - bad local} { + -body { + proc x {} { + assemble {dictIncrImm 1 ::foo::bar} + } + list [catch x result] $result $::errorCode + } + -result {1 {variable "::foo::bar" is not local} {TCL ASSEM NONLOCAL ::foo::bar}} + -cleanup {rename x {}; unset result} +} +test assemble-28.6 {dictIncrImm} { + -body { + proc x {} { + set dict {a 1 b 2 c 3} + assemble {push b; dictIncrImm 42 dict} + } + x + } + -result {a 1 b 44 c 3} + -cleanup {rename x {}} +} + +# assemble-29 - ASSEM_REGEXP + +test assemble-29.1 {regexp - wrong # args} { + -body { + assemble {regexp} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-29.2 {regexp - wrong # args} { + -body { + assemble {regexp too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-29.3 {regexp - bad subst} { + -body { + assemble {regexp $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} +test assemble-29.4 {regexp - not a boolean} { + -body { + proc x {} { + assemble {regexp rubbish} + } + x + } + -returnCodes error + -result {expected boolean value but got "rubbish"} + -cleanup {rename x {}} +} +test assemble-29.5 {regexp} { + -body { + assemble {push br.*br; push abracadabra; regexp false} + } + -result 1 +} +test assemble-29.6 {regexp} { + -body { + assemble {push br.*br; push aBRacadabra; regexp false} + } + -result 0 +} +test assemble-29.7 {regexp} { + -body { + assemble {push br.*br; push aBRacadabra; regexp true} + } + -result 1 +} + +# assemble-30 - Catches + +test assemble-30.1 {simplest possible catch} { + -body { + proc x {} { + assemble { + beginCatch @bad + push error + push testing + invokeStk 2 + pop + push 0 + jump @ok + label @bad + push 1; # should be pushReturnCode + label @ok + endCatch + } + } + x + } + -result 1 + -cleanup {rename x {}} +} +test assemble-30.2 {catch in external catch conntext} { + -body { + proc x {} { + list [catch { + assemble { + beginCatch @bad + push error + push testing + invokeStk 2 + pop + push 0 + jump @ok + label @bad + pushReturnCode + label @ok + endCatch + } + } result] $result + } + x + } + -result {0 1} + -cleanup {rename x {}} +} +test assemble-30.3 {embedded catches} { + -body { + proc x {} { + list [catch { + assemble { + beginCatch @bad + push error + eval { list [catch {error whatever} result] $result } + invokeStk 2 + push 0 + reverse 2 + jump @done + label @bad + pushReturnCode + pushResult + label @done + endCatch + list 2 + } + } result2] $result2 + } + x + } + -result {0 {1 {1 whatever}}} + -cleanup {rename x {}} +} +test assemble-30.4 {throw in wrong context} { + -body { + proc x {} { + list [catch { + assemble { + beginCatch @bad + push error + eval { list [catch {error whatever} result] $result } + invokeStk 2 + push 0 + reverse 2 + jump @done + + label @bad + load x + pushResult + + label @done + endCatch + list 2 + } + } result] $result $::errorCode [split $::errorInfo \n] + } + x + } + -match glob + -result {1 {"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} {TCL ASSEM BADTHROW} {{"loadScalar1" instruction may not appear in a context where an exception has been caught and not disposed of.} { in assembly code between lines 10 and 15}*}} + -cleanup {rename x {}} +} +test assemble-30.5 {unclosed catch} { + -body { + proc x {} { + assemble { + beginCatch @error + push 0 + jump @done + label @error + push 1 + label @done + push "" + pop + } + } + list [catch {x} result] $result $::errorCode $::errorInfo + } + -match glob + -result {1 {catch still active on exit from assembly code} {TCL ASSEM UNCLOSEDCATCH} {catch still active on exit from assembly code + ("assemble" body, line 2)*}} + -cleanup {rename x {}} +} +test assemble-30.6 {inconsistent catch contexts} { + -body { + proc x {y} { + assemble { + load y + jumpTrue @inblock + beginCatch @error + label @inblock + push 0 + jump @done + label @error + push 1 + label @done + } + } + list [catch {x 2} result] $::errorCode $::errorInfo + } + -match glob + -result {1 {TCL ASSEM BADCATCH} {execution reaches an instruction in inconsistent exception contexts + ("assemble" body, line 5)*}} + -cleanup {rename x {}} +} + +# assemble-31 - Jump tables + +test assemble-31.1 {jumpTable, wrong # args} { + -body { + assemble {jumpTable} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-31.2 {jumpTable, wrong # args} { + -body { + assemble {jumpTable too many} + } + -returnCodes error + -match glob + -result {wrong # args*} +} +test assemble-31.3 {jumpTable - bad subst} { + -body { + assemble {jumpTable $foo} + } + -returnCodes error + -match glob + -result {assembly code may not contain substitutions} +} +test assemble-31.4 {jumptable - not a list} { + -body { + assemble {jumpTable \{rubbish} + } + -returnCodes error + -result {unmatched open brace in list} +} +test assemble-31.5 {jumpTable, badly structured} { + -body { + list [catch {assemble { + # line 2 + jumpTable {one two three};# line 3 + }} result] \ + $result $::errorCode $::errorInfo + } + -match glob + -result {1 {jump table must have an even number of list elements} {TCL ASSEM BADJUMPTABLE} {jump table must have an even number of list elements*("assemble" body, line 3)*}} +} +test assemble-31.6 {jumpTable, missing symbol} { + -body { + list [catch {assemble { + # line 2 + jumpTable {1 a};# line 3 + }} result] \ + $result $::errorCode $::errorInfo + } + -match glob + -result {1 {undefined label "a"} {TCL ASSEM NOLABEL a} {undefined label "a"*("assemble" body, line 3)*}} +} +test assemble-31.7 {jumptable, actual example} { + -setup { + proc x {} { + set result {} + for {set i 0} {$i < 5} {incr i} { + lappend result [assemble { + load i + jumpTable {1 @one 2 @two 3 @three} + push {none of the above} + jump @done + label @one + push one + jump @done + label @two + push two + jump @done + label @three + push three + label @done + }] + } + set tcl_traceCompile 2 + set result + } + } + -body x + -result {{none of the above} one two three {none of the above}} + -cleanup {set tcl_traceCompile 0; rename x {}} +} + +test assemble-40.1 {unbalanced stack} { + -body { + list \ + [catch { + assemble { + push 3 + dup + mult + push 4 + dup + mult + pop + expon + } + } result] $result $::errorInfo + } + -result {1 {stack underflow} {stack underflow + in assembly code between lines 1 and end of assembly code*}} + -match glob + -returnCodes ok +} +test assemble-40.2 {unbalanced stack} {*}{ + -body { + list \ + [catch { + assemble { + label a + push {} + label b + pop + label c + pop + label d + push {} + } + } result] $result $::errorInfo + } + -result {1 {stack underflow} {stack underflow + in assembly code between lines 7 and 9*}} + -match glob + -returnCodes ok +} + +test assemble-41.1 {Inconsistent stack usage} {*}{ + -body { + proc x {y} { + assemble { + load y + jumpFalse else + push 0 + jump then + label else + push 1 + push 2 + label then + pop + } + } + catch {x 1} + set errorInfo + } + -match glob + -result {inconsistent stack depths on two execution paths + ("assemble" body, line 10)*} +} +test assemble-41.2 {Inconsistent stack, jumptable and default} { + -body { + proc x {y} { + assemble { + load y + jumpTable {0 else} + push 0 + label else + pop + } + } + catch {x 1} + set errorInfo + } + -match glob + -result {inconsistent stack depths on two execution paths + ("assemble" body, line 6)*} +} +test assemble-41.3 {Inconsistent stack, two legs of jumptable} { + -body { + proc x {y} { + assemble { + load y + jumpTable {0 no 1 yes} + label no + push 0 + label yes + pop + } + } + catch {x 1} + set errorInfo + } + -match glob + -result {inconsistent stack depths on two execution paths + ("assemble" body, line 7)*} +} + +test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} { + -body { + proc ulam {n} { + assemble { + 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 + ge; # man n max>=n + jumpTrue skip; # max 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 + } + } + set result {} + for {set i 1} {$i < 30} {incr i} { + lappend result [ulam $i] + } + set result + } + -result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88} +} + +test assemble-51.1 {memory leak testing} memory { + leaktest { + apply {{} {assemble {push hello}}} + } +} 0 +test assemble-51.2 {memory leak testing} memory { + leaktest { + apply {{{x 0}} {assemble {incrImm x 1}}} + } +} 0 +test assemble-51.3 {memory leak testing} memory { + leaktest { + apply {{n} { + assemble { + 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 + ge; # man n max>=n + jumpTrue skip; # max 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 + } + }} 1 + } +} 0 +test assemble-51.4 {memory leak testing} memory { + leaktest { + catch { + apply {{} { + assemble {reverse polish notation} + }} + } + } +} 0 + +rename fillTables {} +rename assemble {} + +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/assemble1.bench b/tests/assemble1.bench new file mode 100644 index 0000000..18fd3a9 --- /dev/null +++ b/tests/assemble1.bench @@ -0,0 +1,85 @@ +proc ulam1 {n} { + set max $n + while {$n != 1} { + if {$n > $max} { + set max $n + } + if {$n % 2} { + set n [expr {3 * $n + 1}] + } else { + set n [expr {$n / 2}] + } + } + return $max +} + +set tcl_traceCompile 2; ulam1 1; set tcl_traceCompile 0 + +proc ulam2 {n} { + tcl::unsupported::assemble { + 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 + ge; # man n max>=n + jumpTrue skip; # max 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 + } +} +set tcl_traceCompile 2; ulam2 1; set tcl_traceCompile 0 + +proc test1 {n} { + for {set i 1} {$i <= $n} {incr i} { + ulam1 $i + } +} +proc test2 {n} { + for {set i 1} {$i <= $n} {incr i} { + ulam2 $i + } +} + +for {set j 0} {$j < 10} {incr j} { + test1 1 + set before [clock microseconds] + 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 a677090..d1489b3 100644 --- a/tests/assocd.test +++ b/tests/assocd.test @@ -10,14 +10,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: assocd.test,v 1.6 2004/05/19 10:42:00 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testgetassocdata [llength [info commands testgetassocdata]] testConstraint testsetassocdata [llength [info commands testsetassocdata]] testConstraint testdelassocdata [llength [info commands testdelassocdata]] diff --git a/tests/async.test b/tests/async.test index 654f995..cb67cc2 100644 --- a/tests/async.test +++ b/tests/async.test @@ -10,18 +10,17 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: async.test,v 1.10 2010/03/24 10:35:21 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testasync [llength [info commands testasync]] -testConstraint threaded [expr { - [info exists ::tcl_platform(threaded)] && $::tcl_platform(threaded) -}] +testConstraint threaded [::tcl::pkgconfig get threaded] proc async1 {result code} { global aresult acode @@ -198,7 +197,7 @@ test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { set aresult {Async event not delivered} testasync marklater $handle set i 0 - } [string repeat {;incr i;} 1500000] { + } "[string repeat {;incr i;} 1500000]after 10;" { return $aresult }]] $hm } -result {test pattern} -cleanup { diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test index 56e1ffb..8f29131 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -1,17 +1,15 @@ # Commands covered: auto_mkindex auto_import # -# This file contains tests related to autoloading and generating -# the autoloading index. +# 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. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: autoMkindex.test,v 1.15 2004/05/25 17:44:29 dgp Exp $ +# 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} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -19,10 +17,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { makeFile {# Test file for: # auto_mkindex # -# This file provides example cases for testing the Tcl autoloading -# facility. Things are much more complicated with namespaces and classes. -# The "auto_mkindex" facility can no longer be built on top of a simple -# regular expression parser. It must recognize constructs like this: +# This file provides example cases for testing the Tcl autoloading facility. +# Things are much more complicated with namespaces and classes. The +# "auto_mkindex" facility can no longer be built on top of a simple regular +# expression parser. It must recognize constructs like this: # # namespace eval foo { # proc test {x y} { ... } @@ -31,23 +29,23 @@ makeFile {# Test file for: # } # } # -# Note that procedures and itcl class definitions can be nested inside -# of namespaces. +# Note that procedures and itcl class definitions can be nested inside of +# namespaces. # # Copyright (c) 1993-1998 Lucent Technologies, Inc. # This shouldn't cause any problems namespace import -force blt::* -# Should be able to handle "proc" definitions, even if they are -# preceded by white space. +# 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]} # -# Should be able to handle proc declarations within namespaces, -# even if they have explicit namespace paths. +# Should be able to handle proc declarations within namespaces, even if they +# have explicit namespace paths. # namespace eval buried { proc inside {args} {return "inside: $args"} @@ -69,8 +67,8 @@ namespace eval buried { } } -# With proper hooks, we should be able to support other commands -# that create procedures +# With proper hooks, we should be able to support other commands that create +# procedures proc buried::myproc {name body args} { ::proc $name $body $args @@ -90,17 +88,15 @@ namespace eval ::buried { } {::buried::my proc} mycmd6 args {return "another"} -# A correctly functioning [auto_import] won't choke when a child -# namespace [namespace import]s from its parent. +# A correctly functioning [auto_import] won't choke when a child namespace +# [namespace import]s from its parent. # namespace eval ::parent::child { namespace import ::parent::* } proc ::parent::child::test {} {} - } autoMkindex.tcl - # Save initial state of auto_mkindex_parser auto_load auto_mkindex @@ -120,21 +116,19 @@ set result "" set origDir [pwd] cd $::tcltest::temporaryDirectory - + test autoMkindex-1.1 {remove any existing tclIndex file} { file delete tclIndex file exists tclIndex } {0} - test autoMkindex-1.2 {build tclIndex based on a test file} { auto_mkindex . autoMkindex.tcl file exists tclIndex } {1} - set element "{source [file join . autoMkindex.tcl]}" - -test autoMkindex-1.3 {examine tclIndex} { +test autoMkindex-1.3 {examine tclIndex} -setup { file delete tclIndex +} -body { auto_mkindex . autoMkindex.tcl namespace eval tcl_autoMkindex_tmp { set dir "." @@ -145,33 +139,35 @@ test autoMkindex-1.3 {examine tclIndex} { lappend ::result [list $elem $auto_index($elem)] } } + return $result +} -cleanup { namespace delete tcl_autoMkindex_tmp - set ::result -} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}" +} -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {normal $element} {top $element}" - -test autoMkindex-2.1 {commands on the autoload path can be imported} { +test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { file delete tclIndex + interp create slave +} -body { auto_mkindex . autoMkindex.tcl - set interp [interp create] - set final [$interp eval { + slave eval { namespace eval blt {} set auto_path [linsert $auto_path 0 .] set info [list [catch {namespace import buried::*} result] $result] foreach name [lsort [info commands pub_*]] { lappend info $name [namespace origin $name] } - set info - }] - interp delete $interp - set final -} "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two" + return $info + } +} -cleanup { + interp delete slave +} -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} { +test autoMkindex-3.1 {slaveHook} -setup { + file delete tclIndex +} -body { auto_mkindex_parser::slavehook { _%@namespace eval ::blt { proc foo {} {} @@ -179,26 +175,23 @@ test autoMkindex-3.1 {slaveHook} { } } auto_mkindex_parser::slavehook { _%@namespace import -force ::blt::* } - file delete tclIndex auto_mkindex . autoMkindex.tcl - + file exists tclIndex +} -cleanup { # Reset initCommands to avoid trashing other tests - AutoMkindexTestReset - file exists tclIndex -} 1 - -# The auto_mkindex_parser::command is used to register commands -# that create new commands. - -test autoMkindex-3.2 {auto_mkindex_parser::command} { +} -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 { + file delete tclIndex +} -body { auto_mkindex_parser::command buried::myproc {name args} { variable index variable scriptFile append index [list set auto_index([fullname $name])] \ " \[list source \[file join \$dir [list $scriptFile]\]\]\n" } - file delete tclIndex auto_mkindex . autoMkindex.tcl namespace eval tcl_autoMkindex_tmp { set dir "." @@ -208,17 +201,16 @@ test autoMkindex-3.2 {auto_mkindex_parser::command} { foreach elem [lsort [array names auto_index]] { lappend ::result [list $elem $auto_index($elem)] } + return $::result } +} -cleanup { namespace delete tcl_autoMkindex_tmp - # Reset initCommands to avoid trashing other tests - AutoMkindexTestReset - set ::result -} "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}" - - -test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} { +} -result "{::buried::explicit $element} {::buried::inside $element} {{::buried::my proc} $element} {::buried::mycmd1 $element} {::buried::mycmd2 $element} {::buried::mycmd4 $element} {::buried::myproc $element} {::buried::pub_one $element} {::buried::pub_two $element} {::buried::relative $element} {::buried::under::neath $element} {::buried::within $element} {::parent::child::test $element} {indented $element} {mycmd3 $element} {normal $element} {top $element}" +test autoMkindex-3.3 {auto_mkindex_parser::command} -setup { + file delete tclIndex +} -constraints {knownBug} -body { auto_mkindex_parser::command {buried::my proc} {name args} { variable index variable scriptFile @@ -226,7 +218,6 @@ test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} { append index [list set auto_index([fullname $name])] \ " \[list source \[file join \$dir [list $scriptFile]\]\]\n" } - file delete tclIndex auto_mkindex . autoMkindex.tcl namespace eval tcl_autoMkindex_tmp { set dir "." @@ -237,109 +228,93 @@ test autoMkindex-3.3 {auto_mkindex_parser::command} {knownBug} { lappend ::result [list $elem $auto_index($elem)] } } + list [lsearch -inline $::result *mycmd4*] \ + [lsearch -inline $::result *mycmd5*] \ + [lsearch -inline $::result *mycmd6*] +} -cleanup { namespace delete tcl_autoMkindex_tmp - # Reset initCommands to avoid trashing other tests - AutoMkindexTestReset - proc lvalue {list pattern} { - set ix [lsearch $list $pattern] - if {$ix >= 0} { - return [lindex $list $ix] - } else { - return {} - } - } - list [lvalue $::result *mycmd4*] [lvalue $::result *mycmd5*] [lvalue $::result *mycmd6*] -} "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}" - - -makeDirectory pkg -makeFile { -package provide football 1.0 - -namespace eval ::pro:: { - # - # export only public functions. - # - namespace export {[a-z]*} -} -namespace eval ::college:: { - # - # export only public functions. - # - namespace export {[a-z]*} -} - -proc ::pro::team {} { - puts "go packers!" - return true -} +} -result "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}" -proc ::college::team {} { - puts "go badgers!" - return true -} - -} [file join pkg samename.tcl] - - -test autoMkindex-4.1 {platform indenpendant source commands} { +test autoMkindex-4.1 {platform independent source commands} -setup { file delete tclIndex + makeDirectory pkg + makeFile { + package provide football 1.0 + namespace eval ::pro:: { + # + # export only public functions. + # + namespace export {[a-z]*} + } + namespace eval ::college:: { + # + # export only public functions. + # + namespace export {[a-z]*} + } + proc ::pro::team {} { + puts "go packers!" + return true + } + proc ::college::team {} { + puts "go badgers!" + return true + } + } [file join pkg samename.tcl] +} -body { auto_mkindex . pkg/samename.tcl set f [open tclIndex r] - set dat [split [string trim [read $f]] "\n"] - set len [llength $dat] - set result [lsort [lrange $dat [expr {$len-2}] [expr {$len-1}]]] - close $f - set result -} {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}} - -removeFile [file join pkg samename.tcl] - -makeFile { -set dollar1 "this string contains an unescaped dollar sign -> \\$foo" -set dollar2 "this string contains an escaped dollar sign -> \$foo \\\$foo" -set bracket1 "this contains an unescaped bracket [NoSuchProc]" -set bracket2 "this contains an escaped bracket \[NoSuchProc\]" -set bracket3 "this contains nested unescaped brackets [[NoSuchProc]]" -proc testProc {} {} -} [file join pkg magicchar.tcl] - -test autoMkindex-5.1 {escape magic tcl chars in general code} { + lsort [lrange [split [string trim [read $f]] "\n"] end-1 end] +} -cleanup { + catch {close $f} + removeFile [file join pkg samename.tcl] + removeDirectory pkg +} -result {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}} + +test autoMkindex-5.1 {escape magic tcl chars in general code} -setup { file delete tclIndex + makeDirectory pkg + makeFile { + set dollar1 "this string contains an unescaped dollar sign -> \\$foo" + set dollar2 \ + "this string contains an escaped dollar sign -> \$foo \\\$foo" + set bracket1 "this contains an unescaped bracket [NoSuchProc]" + set bracket2 "this contains an escaped bracket \[NoSuchProc\]" + set bracket3 \ + "this contains nested unescaped brackets [[NoSuchProc]]" + proc testProc {} {} + } [file join pkg magicchar.tcl] set result {} - if { ![catch {auto_mkindex . pkg/magicchar.tcl}] } { - set f [open tclIndex r] - set dat [split [string trim [read $f]] "\n"] - set result [lindex $dat end] - close $f - } - set result -} {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]} - -removeFile [file join pkg magicchar.tcl] - -makeFile { -proc {[magic mojo proc]} {} {} -} [file join pkg magicchar2.tcl] - -test autoMkindex-5.2 {correctly locate auto loaded procs with []} { +} -body { + auto_mkindex . pkg/magicchar.tcl + set f [open tclIndex r] + lindex [split [string trim [read $f]] "\n"] end +} -cleanup { + catch {close $f} + removeFile [file join pkg magicchar.tcl] + removeDirectory pkg +} -result {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]} +test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup { file delete tclIndex + makeDirectory pkg + makeFile { + proc {[magic mojo proc]} {} {} + } [file join pkg magicchar2.tcl] set result {} - if { ![catch {auto_mkindex . pkg/magicchar2.tcl}] } { - # Make a slave interp to test the autoloading - set c [interp create] - $c eval {lappend auto_path [pwd]} - set result [$c eval {catch {{[magic mojo proc]}}}] - interp delete $c - } - set result -} 0 - -removeFile [file join pkg magicchar2.tcl] -removeDirectory pkg - + interp create slave +} -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]}}} +} -cleanup { + interp delete slave + removeFile [file join pkg magicchar2.tcl] + removeDirectory pkg +} -result 0 + # Clean up. unset result @@ -357,3 +332,9 @@ if {[file exists tclIndex]} { cd $origDir ::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/basic.test b/tests/basic.test index c07d805..7435571 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -14,13 +14,13 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: basic.test,v 1.46 2009/09/17 17:58:10 dgp Exp $ -# package require tcltest 2 namespace import -force ::tcltest::* +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testevalex [llength [info commands testevalex]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] testConstraint testcreatecommand [llength [info commands testcreatecommand]] diff --git a/tests/binary.test b/tests/binary.test index 79fdb92..ccd0f29 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -9,8 +9,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: binary.test,v 1.41 2010/09/15 22:12:00 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -2383,6 +2381,23 @@ test binary-63.4 {NaN} ieeeFloatingPoint { format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] } 0x7ff3123456789abc +# Make sure TclParseNumber() rejects invalid nan-hex formats [Bug 3402540] +test binary-63.5 {NaN} -constraints ieeeFloatingPoint -body { + binary format q Nan( +} -returnCodes error -match glob -result {expected floating-point number*} +test binary-63.6 {NaN} -constraints ieeeFloatingPoint -body { + binary format q Nan() +} -returnCodes error -match glob -result {expected floating-point number*} +test binary-63.7 {NaN} -constraints ieeeFloatingPoint -body { + binary format q Nan(g) +} -returnCodes error -match glob -result {expected floating-point number*} +test binary-63.8 {NaN} -constraints ieeeFloatingPoint -body { + binary format q Nan(1,2) +} -returnCodes error -match glob -result {expected floating-point number*} +test binary-63.9 {NaN} -constraints ieeeFloatingPoint -body { + binary format q Nan(1234567890abcd) +} -returnCodes error -match glob -result {expected floating-point number*} + test binary-64.1 {NaN} -constraints ieeeFloatingPoint -body { binary scan [binary format w 0x7ff8000000000000] q d set d @@ -2627,6 +2642,27 @@ 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 WA==WFla]]] $r +} -returnCodes error -match glob -result {invalid base64 character *} test binary-74.1 {binary encode uuencode} -body { binary encode uuencode diff --git a/tests/case.test b/tests/case.test index a9bec93..6d63cea 100644 --- a/tests/case.test +++ b/tests/case.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: case.test,v 1.8 2008/07/21 22:22:28 nijtmans Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/chan.test b/tests/chan.test index 7dccda7..d8390e2 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -6,8 +6,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: chan.test,v 1.16 2008/12/18 01:14:17 ferrieux Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -63,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 diff --git a/tests/chanio.test b/tests/chanio.test index c1dba49..665df50 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -12,8 +12,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: chanio.test,v 1.23 2010/02/07 08:03:11 dkf Exp $ if {[catch {package require tcltest 2}]} { chan puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -31,6 +29,9 @@ namespace eval ::tcl::test::io { variable msg variable expected + ::tcltest::loadTestedCommands + catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testchannel [llength [info commands testchannel]] testConstraint exec [llength [info commands exec]] testConstraint openpipe 1 @@ -39,14 +40,14 @@ namespace eval ::tcl::test::io { testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] - testConstraint testthread [llength [info commands testthread]] + testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] - # You need a *very* special environment to do some tests. In - # particular, many file systems do not support large-files... + # You need a *very* special environment to do some tests. In particular, + # many file systems do not support large-files... testConstraint largefileSupport 0 - # some tests can only be run is umask is 2 - # if "umask" cannot be run, the tests will be skipped. + # some tests can only be run is umask is 2 if "umask" cannot be run, the + # tests will be skipped. set umaskValue 0 testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}] @@ -92,6 +93,11 @@ namespace eval ::tcl::test::io { chan close $f return $a } + + # Wrapper round butt-ugly pipe syntax + proc openpipe {{mode r+} args} { + open "|[list [interpreter] {*}$args]" $mode + } test chan-io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} { # no test, need to cause an async error. @@ -183,17 +189,17 @@ test chan-io-2.2 {WriteBytes: savedLF > 0} { chan close $f lappend x [contents $path(test1)] } [list "123456789012345\r" "123456789012345\r\n12"] -test chan-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. +test chan-io-2.3 {WriteBytes: flush on line} -body { + # 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] chan configure $f -encoding binary -buffering line -translation crlf chan puts -nonewline $f "\n12" - set x [contents $path(test1)] + contents $path(test1) +} -cleanup { chan close $f - set x -} "\r\n12" +} -result "\r\n12" test chan-io-2.4 {WriteBytes: reset sawLF after each buffer} { set f [open $path(test1) w] chan configure $f -encoding binary -buffering line -translation lf \ @@ -222,17 +228,17 @@ test chan-io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} { chan close $f lappend x [contents $path(test1)] } [list "123456789012345\r" "123456789012345\r\n12"] -test chan-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. +test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -body { + # 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] chan configure $f -encoding ascii -buffering line -translation crlf chan puts -nonewline $f "\n12" - set x [contents $path(test1)] + contents $path(test1) +} -cleanup { chan close $f - set x -} "\r\n12" +} -result "\r\n12" 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] @@ -380,118 +386,118 @@ test chan-io-5.5 {CheckFlush: none} { lappend x [contents $path(test1)] } [list "1234567890" "1234567890"] -test chan-io-6.1 {Tcl_GetsObj: working} { +test chan-io-6.1 {Tcl_GetsObj: working} -body { set f [open $path(test1) w] chan puts $f "foo\nboo" chan close $f set f [open $path(test1)] - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} {foo} +} -result {foo} test chan-io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} emptyTest { # no test, need to cause an async error. } {} -test chan-io-6.3 {Tcl_GetsObj: how many have we used?} { +test chan-io-6.3 {Tcl_GetsObj: how many have we used?} -body { # if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved} set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f "abc\ndefg" chan close $f set f [open $path(test1)] - set x [list [chan tell $f] [chan gets $f line] [chan tell $f] [chan gets $f line] $line] + list [chan tell $f] [chan gets $f line] [chan tell $f] [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {0 3 5 4 defg} -test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} { +} -result {0 3 5 4 defg} +test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} -body { set f [open $path(test1) w] chan configure $f -translation binary chan puts $f "\x81\u1234\0" chan close $f set f [open $path(test1)] chan configure $f -translation binary - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 3 "\x81\x34\x00"] -test chan-io-6.5 {Tcl_GetsObj: encoding != NULL} { +} -result [list 3 "\x81\x34\x00"] +test chan-io-6.5 {Tcl_GetsObj: encoding != NULL} -body { set f [open $path(test1) w] chan configure $f -translation binary chan puts $f "\x88\xea\x92\x9a" chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 2 "\u4e00\u4e01"] +} -result [list 2 "\u4e00\u4e01"] set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a -test chan-io-6.6 {Tcl_GetsObj: loop test} { +test chan-io-6.6 {Tcl_GetsObj: loop test} -body { # if (dst >= dstEnd) set f [open $path(test1) w] chan puts $f $a chan puts $f hi chan close $f set f [open $path(test1)] - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 256 $a] -test chan-io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} { +} -result [list 256 $a] +test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints {stdio openpipe} -body { # if (FilterInputBytes(chanPtr, &gs) != 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan puts -nonewline $f "hi\nwould" chan flush $f chan gets $f chan configure $f -blocking 0 - set x [chan gets $f line] + chan gets $f line +} -cleanup { chan close $f - set x -} {-1} -test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} { +} -result {-1} +test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} -body { set f [open $path(test1) w] chan puts $f "abcdef\x1aghijk\nwombat" chan close $f set f [open $path(test1)] chan configure $f -eofchar \x1a - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {6 abcdef -1 {}} -test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} { +} -result {6 abcdef -1 {}} +test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} -body { set f [open $path(test1) w] chan puts $f "abcdefghijk\nwom\u001abat" chan close $f set f [open $path(test1)] chan configure $f -eofchar \x1a - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {11 abcdefghijk 3 wom} +} -result {11 abcdefghijk 3 wom} # Comprehensive tests -test chan-io-6.10 {Tcl_GetsObj: lf mode: no chars} { +test chan-io-6.10 {Tcl_GetsObj: lf mode: no chars} -body { set f [open $path(test1) w] chan close $f set f [open $path(test1)] chan configure $f -translation lf - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {-1 {}} -test chan-io-6.11 {Tcl_GetsObj: lf mode: lone \n} { +} -result {-1 {}} +test chan-io-6.11 {Tcl_GetsObj: lf mode: lone \n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\n" chan close $f set f [open $path(test1)] chan configure $f -translation lf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {0 {} -1 {}} -test chan-io-6.12 {Tcl_GetsObj: lf mode: lone \r} { +} -result {0 {} -1 {}} +test chan-io-6.12 {Tcl_GetsObj: lf mode: lone \r} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r" @@ -499,193 +505,194 @@ test chan-io-6.12 {Tcl_GetsObj: lf mode: lone \r} { set f [open $path(test1)] chan configure $f -translation lf set x [list [chan gets $f line] $line [chan gets $f line] $line] +} -cleanup { chan close $f - set x -} [list 1 "\r" -1 ""] -test chan-io-6.13 {Tcl_GetsObj: lf mode: 1 char} { +} -result [list 1 "\r" -1 ""] +test chan-io-6.13 {Tcl_GetsObj: lf mode: 1 char} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f a chan close $f set f [open $path(test1)] chan configure $f -translation lf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} { +} -result {1 a -1 {}} +test chan-io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\n" chan close $f set f [open $path(test1)] chan configure $f -translation lf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.15 {Tcl_GetsObj: lf mode: several chars} { +} -result {1 a -1 {}} +test chan-io-6.15 {Tcl_GetsObj: lf mode: several chars} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" chan close $f set f [open $path(test1)] chan configure $f -translation lf - set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line \ + [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""] -test chan-io-6.16 {Tcl_GetsObj: cr mode: no chars} { +} -result [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""] +test chan-io-6.16 {Tcl_GetsObj: cr mode: no chars} -body { set f [open $path(test1) w] chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {-1 {}} -test chan-io-6.17 {Tcl_GetsObj: cr mode: lone \n} { +} -result {-1 {}} +test chan-io-6.17 {Tcl_GetsObj: cr mode: lone \n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\n" chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 1 "\n" -1 ""] -test chan-io-6.18 {Tcl_GetsObj: cr mode: lone \r} { +} -result [list 1 "\n" -1 ""] +test chan-io-6.18 {Tcl_GetsObj: cr mode: lone \r} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r" chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {0 {} -1 {}} -test chan-io-6.19 {Tcl_GetsObj: cr mode: 1 char} { +} -result {0 {} -1 {}} +test chan-io-6.19 {Tcl_GetsObj: cr mode: 1 char} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f a chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} { +} -result {1 a -1 {}} +test chan-io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\r" chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.21 {Tcl_GetsObj: cr mode: several chars} { +} -result {1 a -1 {}} +test chan-io-6.21 {Tcl_GetsObj: cr mode: several chars} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""] -test chan-io-6.22 {Tcl_GetsObj: crlf mode: no chars} { +} -result [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""] +test chan-io-6.22 {Tcl_GetsObj: crlf mode: no chars} -body { set f [open $path(test1) w] chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {-1 {}} -test chan-io-6.23 {Tcl_GetsObj: crlf mode: lone \n} { +} -result {-1 {}} +test chan-io-6.23 {Tcl_GetsObj: crlf mode: lone \n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\n" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 1 "\n" -1 ""] -test chan-io-6.24 {Tcl_GetsObj: crlf mode: lone \r} { +} -result [list 1 "\n" -1 ""] +test chan-io-6.24 {Tcl_GetsObj: crlf mode: lone \r} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 1 "\r" -1 ""] -test chan-io-6.25 {Tcl_GetsObj: crlf mode: \r\r} { +} -result [list 1 "\r" -1 ""] +test chan-io-6.25 {Tcl_GetsObj: crlf mode: \r\r} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r\r" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 2 "\r\r" -1 ""] -test chan-io-6.26 {Tcl_GetsObj: crlf mode: \r\n} { +} -result [list 2 "\r\r" -1 ""] +test chan-io-6.26 {Tcl_GetsObj: crlf mode: \r\n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r\n" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 0 "" -1 ""] -test chan-io-6.27 {Tcl_GetsObj: crlf mode: 1 char} { +} -result {0 {} -1 {}} +test chan-io-6.27 {Tcl_GetsObj: crlf mode: 1 char} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f a chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} { +} -result {1 a -1 {}} +test chan-io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\r\n" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.29 {Tcl_GetsObj: crlf mode: several chars} { +} -result {1 a -1 {}} +test chan-io-6.29 {Tcl_GetsObj: crlf mode: several chars} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""] -test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} { +} -result [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""] +test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} -constraints {testchannel} -body { # if (eol >= dstEnd) set f [open $path(test1) w] chan configure $f -translation lf @@ -693,23 +700,26 @@ test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} { chan close $f set f [open $path(test1)] chan configure $f -translation crlf -buffersize 16 - set x [list [chan gets $f line] $line [testchannel inputbuffered $f]] + list [chan gets $f line] $line [testchannel inputbuffered $f] +} -cleanup { chan close $f - set x -} [list 15 "123456789012345" 15] -test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} { +} -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 { # (FilterInputBytes() != 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {crlf lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r" chan configure $f -buffersize 16 - set x [chan gets $f] + lappend x [chan gets $f] chan configure $f -blocking 0 - lappend x [chan gets $f line] $line [chan blocked $f] [testchannel inputbuffered $f] + lappend x [chan gets $f line] $line [chan blocked $f] \ + [testchannel inputbuffered $f] +} -cleanup { chan close $f - set x -} [list "bbbbbbbbbbbbbb" -1 "" 1 16] -test chan-io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} { +} -result {bbbbbbbbbbbbbb -1 {} 1 16} +test chan-io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} -constraints {testchannel} -body { # not (FilterInputBytes() != 0) set f [open $path(test1) w] chan configure $f -translation lf @@ -717,11 +727,11 @@ test chan-io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testcha chan close $f set f [open $path(test1)] chan configure $f -translation crlf -buffersize 16 - set x [list [chan gets $f line] $line [chan tell $f] [testchannel inputbuffered $f]] + list [chan gets $f line] $line [chan tell $f] [testchannel inputbuffered $f] +} -cleanup { chan close $f - set x -} [list 15 "123456789012345" 17 3] -test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { +} -result {15 123456789012345 17 3} +test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} -body { # eol still equals dstEnd set f [open $path(test1) w] chan configure $f -translation lf @@ -729,11 +739,11 @@ test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { chan close $f set f [open $path(test1)] chan configure $f -translation crlf -buffersize 16 - set x [list [chan gets $f line] $line [chan eof $f]] + list [chan gets $f line] $line [chan eof $f] +} -cleanup { chan close $f - set x -} [list 16 "123456789012345\r" 1] -test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} { +} -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') set f [open $path(test1) w] chan configure $f -translation lf @@ -741,161 +751,171 @@ test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} chan close $f set f [open $path(test1)] chan configure $f -translation crlf -buffersize 16 - set x [list [chan gets $f line] $line [chan tell $f]] + list [chan gets $f line] $line [chan tell $f] +} -cleanup { chan close $f - set x -} [list 20 "123456789012345\rabcd" 22] -test chan-io-6.35 {Tcl_GetsObj: auto mode: no chars} { +} -result [list 20 "123456789012345\rabcd" 22] +test chan-io-6.35 {Tcl_GetsObj: auto mode: no chars} -body { set f [open $path(test1) w] chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line] + list [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {-1 {}} -test chan-io-6.36 {Tcl_GetsObj: auto mode: lone \n} { +} -result {-1 {}} +test chan-io-6.36 {Tcl_GetsObj: auto mode: lone \n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\n" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 0 "" -1 ""] -test chan-io-6.37 {Tcl_GetsObj: auto mode: lone \r} { +} -result {0 {} -1 {}} +test chan-io-6.37 {Tcl_GetsObj: auto mode: lone \r} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 0 "" -1 ""] -test chan-io-6.38 {Tcl_GetsObj: auto mode: \r\r} { +} -result {0 {} -1 {}} +test chan-io-6.38 {Tcl_GetsObj: auto mode: \r\r} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r\r" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 0 "" 0 "" -1 ""] -test chan-io-6.39 {Tcl_GetsObj: auto mode: \r\n} { +} -result {0 {} 0 {} -1 {}} +test chan-io-6.39 {Tcl_GetsObj: auto mode: \r\n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r\n" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 0 "" -1 ""] -test chan-io-6.40 {Tcl_GetsObj: auto mode: 1 char} { +} -result {0 {} -1 {}} +test chan-io-6.40 {Tcl_GetsObj: auto mode: 1 char} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f a chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} { +} -result {1 a -1 {}} +test chan-io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\r\n" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {1 a -1 {}} -test chan-io-6.42 {Tcl_GetsObj: auto mode: several chars} { +} -result {1 a -1 {}} +test chan-io-6.42 {Tcl_GetsObj: auto mode: several chars} -setup { + set x "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan gets $f line] $line [chan gets $f line] $line] + lappend x [chan gets $f line] $line [chan gets $f line] $line lappend x [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] -test chan-io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} { +} -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 { # if (chanPtr->flags & INPUT_SAW_CR) - set f [open "|[list [interpreter] $path(cat)]" w+] + 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 - set x [list [chan gets $f]] + lappend x [chan gets $f] chan configure $f -blocking 0 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] lappend x [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} { +} -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') - set f [open "|[list [interpreter] $path(cat)]" w+] + 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 - set x [list [chan gets $f]] + lappend x [chan gets $f] chan configure $f -blocking 0 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] lappend x [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} { +} -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 { # Tcl_ExternalToUtf() - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan configure $f -encoding unicode chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 chan gets $f chan configure $f -blocking 0 - set x [list [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" lappend x [chan gets $f line] $line [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} [list 15 "123456789abcdef" 1 4 "abcd" 0] -test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} { +} -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 { # memmove() - set f [open "|[list [interpreter] $path(cat)]" w+] + 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 chan gets $f chan configure $f -blocking 0 - set x [list [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 "\n\x1a" lappend x [chan gets $f line] $line [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} [list 15 "123456789abcdef" 1 -1 "" 0] -test chan-io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testchannel} { +} -result {15 123456789abcdef 1 -1 {} 0} +test chan-io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} -constraints {testchannel} -body { # (eol == dstEnd) set f [open $path(test1) w] chan configure $f -translation lf @@ -903,11 +923,11 @@ test chan-io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {te chan close $f set f [open $path(test1)] chan configure $f -translation auto -buffersize 16 - set x [list [chan gets $f] [testchannel inputbuffered $f]] + list [chan gets $f] [testchannel inputbuffered $f] +} -cleanup { chan close $f - set x -} [list "123456789012345" 15] -test chan-io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} { +} -result {123456789012345 15} +test chan-io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} -constraints {testchannel} -body { # PeekAhead() did not get any, so (eol >= dstEnd) set f [open $path(test1) w] chan configure $f -translation lf @@ -915,44 +935,44 @@ test chan-io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} { chan close $f set f [open $path(test1)] chan configure $f -translation auto -buffersize 16 - set x [list [chan gets $f] [testchannel queuedcr $f]] + list [chan gets $f] [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} [list "123456789012345" 1] -test chan-io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { +} -result {123456789012345 1} +test chan-io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} -constraints {testchannel} -body { # if (*eol == '\n') {skip++} set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "123456\r\n78901" chan close $f set f [open $path(test1)] - set x [list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]] + list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] +} -cleanup { chan close $f - set x -} [list "123456" 0 8 "78901"] -test chan-io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { +} -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') set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "123456\r78901" chan close $f set f [open $path(test1)] - set x [list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]] + list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] +} -cleanup { chan close $f - set x -} [list "123456" 0 7 "78901"] -test chan-io-6.51 {Tcl_GetsObj: auto mode: \n} { +} -result {123456 0 7 78901} +test chan-io-6.51 {Tcl_GetsObj: auto mode: \n} -body { # else if (*eol == '\n') {goto gotoeol;} set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "123456\n78901" chan close $f set f [open $path(test1)] - set x [list [chan gets $f] [chan tell $f] [chan gets $f]] + list [chan gets $f] [chan tell $f] [chan gets $f] +} -cleanup { chan close $f - set x -} [list "123456" 7 "78901"] -test chan-io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { +} -result {123456 7 78901} +test chan-io-6.52 {Tcl_GetsObj: saw EOF character} -constraints {testchannel} -body { # if (eof != NULL) set f [open $path(test1) w] chan configure $f -translation lf @@ -960,30 +980,30 @@ test chan-io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { chan close $f set f [open $path(test1)] chan configure $f -eofchar \x1a - set x [list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f]] + list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] +} -cleanup { chan close $f - set x -} [list "123456" 0 6 ""] -test chan-io-6.53 {Tcl_GetsObj: device EOF} { +} -result {123456 0 6 {}} +test chan-io-6.53 {Tcl_GetsObj: device EOF} -body { # didn't produce any bytes set f [open $path(test1) w] chan close $f set f [open $path(test1)] - set x [list [chan gets $f line] $line [chan eof $f]] + list [chan gets $f line] $line [chan eof $f] +} -cleanup { chan close $f - set x -} {-1 {} 1} -test chan-io-6.54 {Tcl_GetsObj: device EOF} { +} -result {-1 {} 1} +test chan-io-6.54 {Tcl_GetsObj: device EOF} -body { # got some bytes before EOF. set f [open $path(test1) w] chan puts -nonewline $f abc chan close $f set f [open $path(test1)] - set x [list [chan gets $f line] $line [chan eof $f]] + list [chan gets $f line] $line [chan eof $f] +} -cleanup { chan close $f - set x -} {3 abc 1} -test chan-io-6.55 {Tcl_GetsObj: overconverted} { +} -result {3 abc 1} +test chan-io-6.55 {Tcl_GetsObj: overconverted} -body { # Tcl_ExternalToUtf(), make sure state updated set f [open $path(test1) w] chan configure $f -encoding iso2022-jp @@ -991,32 +1011,40 @@ test chan-io-6.55 {Tcl_GetsObj: overconverted} { chan close $f set f [open $path(test1)] chan configure $f -encoding iso2022-jp - set x [list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line] + list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] -test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} { +} -result [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] +test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup { update - set f [open "|[list [interpreter] $path(cat)]" w+] + variable x {} +} -constraints {stdio openpipe fileevent} -body { + set f [openpipe w+ $path(cat)] chan configure $f -buffering none chan puts -nonewline $f "foobar" chan configure $f -blocking 0 - variable x {} - after 500 [namespace code { lappend x timeout }] - chan event $f readable [namespace code { lappend x [chan gets $f] }] + after 500 [namespace code { + lappend x timeout + }] + chan event $f readable [namespace code { + lappend x [chan gets $f] + }] vwait [namespace which -variable x] vwait [namespace which -variable x] chan configure $f -blocking 1 chan puts -nonewline $f "baz\n" - after 500 [namespace code { lappend x timeout }] + after 500 [namespace code { + lappend x timeout + }] chan configure $f -blocking 0 vwait [namespace which -variable x] vwait [namespace which -variable x] + return $x +} -cleanup { chan close $f - set x -} {{} timeout foobarbaz timeout} +} -result {{} timeout foobarbaz timeout} -test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} { +test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} -body { # (result == TCL_CONVERT_MULTIBYTE) set f [open $path(test1) w] chan configure $f -encoding shiftjis @@ -1024,11 +1052,11 @@ test chan-io-7.1 {FilterInputBytes: split up character at end of buffer} { chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis -buffersize 16 - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} "1234567890123\uff10\uff11\uff12\uff13\uff14" -test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} { +} -result "1234567890123\uff10\uff11\uff12\uff13\uff14" +test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} -body { # (bufPtr->nextAdded < bufPtr->bufLength) set f [open $path(test1) w] chan configure $f -encoding binary @@ -1036,44 +1064,46 @@ test chan-io-7.2 {FilterInputBytes: split up character in middle of buffer} { chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis - set x [list [chan gets $f line] $line [chan eof $f]] + list [chan gets $f line] $line [chan eof $f] +} -cleanup { chan close $f - set x -} [list 10 "1234567890" 0] -test chan-io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { +} -result {10 1234567890 0} +test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup { + set x "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -encoding binary chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis - set x [list [chan gets $f line] $line] + lappend x [chan gets $f line] $line lappend x [chan tell $f] [testchannel inputbuffered $f] [chan eof $f] lappend x [chan gets $f line] $line +} -cleanup { chan close $f - set x -} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] -test chan-io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} { - set f [open "|[list [interpreter] $path(cat)]" w+] +} -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 { + set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" chan configure $f -encoding shiftjis -blocking 0 - chan event $f read [namespace code "ready $f"] - variable x {} - proc ready {f} { - variable x + chan event $f read [namespace code { lappend x [chan gets $f line] $line [chan blocked $f] - } + }] vwait [namespace which -variable x] chan configure $f -encoding binary -blocking 1 chan puts $f "\x51\x82\x52" chan configure $f -encoding shiftjis vwait [namespace which -variable x] + return $x +} -cleanup { chan close $f - set x -} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] +} -result [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] -test chan-io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} { +test chan-io-8.1 {PeekAhead: only go to device if no more cached data} -constraints {testchannel} -body { # (bufPtr->nextPtr == NULL) set f [open $path(test1) w] chan configure $f -encoding ascii -translation lf @@ -1083,43 +1113,43 @@ test chan-io-8.1 {PeekAhead: only go to device if no more cached data} {testchan chan configure $f -encoding ascii -translation auto -buffersize 16 # here chan gets $f - set x [testchannel inputbuffered $f] + testchannel inputbuffered $f +} -cleanup { chan close $f - set x -} "7" -test chan-io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} { +} -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 { # not (bufPtr->nextPtr == NULL) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation lf -encoding ascii -buffering none chan puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz" - variable x {} - chan event $f read [namespace code "ready $f"] - proc ready {f} { - variable x + 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 vwait [namespace which -variable x] chan configure $f -translation auto -encoding ascii -blocking 1 # here vwait [namespace which -variable x] + return $x +} -cleanup { chan close $f - set x -} [list -1 "" 42 15 "123456789012345" 25] -test chan-io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} { +} -result {-1 {} 42 15 123456789012345 25} +test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel openpipe fileevent} -body { # (bytesLeft == 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} chan puts -nonewline $f "abcdefghijklmno\r" chan flush $f - set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + list [chan gets $f line] $line [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} [list 15 "abcdefghijklmno" 1] +} -result {15 abcdefghijklmno 1} set a "123456789012345678901234567890" append a "123456789012345678901234567890" append a "1234567890123456789012345678901" -test chan-io-8.4 {PeekAhead: cached data available in this buffer} { +test chan-io-8.4 {PeekAhead: cached data available in this buffer} -body { # not (bytesLeft == 0) set f [open $path(test1) w+] chan configure $f -translation binary @@ -1130,45 +1160,47 @@ test chan-io-8.4 {PeekAhead: cached data available in this buffer} { # "${a}\r" was converted in one operation (because ENCODING_LINESIZE is # 30). To check if "\n" follows, calls PeekAhead and determines that # cached data is available in buffer w/o having to call driver. - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} $a +} -result $a unset a -test chan-io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} { +test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel openpipe fileevent} -body { # (bufPtr->nextAdded < bufPtr->length) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} chan puts -nonewline $f "abcdefghijklmno\r" chan flush $f # here - set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + list [chan gets $f line] $line [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} {15 abcdefghijklmno 1} -test chan-io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} { +} -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) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffersize 16 chan puts -nonewline $f "abcdefghijklmno\r" chan flush $f # here - set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + list [chan gets $f line] $line [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} {15 abcdefghijklmno 1} -test chan-io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} { +} -result {15 abcdefghijklmno 1} +test chan-io-8.7 {PeekAhead: cleanup} -setup { + set x "" +} -constraints {stdio testchannel openpipe fileevent} -body { # Make sure bytes are removed from buffer. - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffering none chan puts -nonewline $f "abcdefghijklmno\r" # here - set x [list [chan gets $f line] $line [testchannel queuedcr $f]] + lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan puts -nonewline $f "\x1a" lappend x [chan gets $f line] $line +} -cleanup { chan close $f - set x -} {15 abcdefghijklmno 1 -1 {}} +} -result {15 abcdefghijklmno 1 -1 {}} test chan-io-9.1 {CommonGetsCleanup} emptyTest { } {} @@ -1176,18 +1208,18 @@ test chan-io-9.1 {CommonGetsCleanup} emptyTest { test chan-io-10.1 {Tcl_ReadChars: CheckChannelErrors} emptyTest { # no test, need to cause an async error. } {} -test chan-io-10.2 {Tcl_ReadChars: loop until enough copied} { +test chan-io-10.2 {Tcl_ReadChars: loop until enough copied} -body { # one time # for (copied = 0; (unsigned) toRead > 0; ) set f [open $path(test1) w] chan puts $f abcdefghijklmnop chan close $f set f [open $path(test1)] - set x [chan read $f 5] + chan read $f 5 +} -cleanup { chan close $f - set x -} {abcde} -test chan-io-10.3 {Tcl_ReadChars: loop until enough copied} { +} -result {abcde} +test chan-io-10.3 {Tcl_ReadChars: loop until enough copied} -body { # multiple times # for (copied = 0; (unsigned) toRead > 0; ) set f [open $path(test1) w] @@ -1196,34 +1228,34 @@ test chan-io-10.3 {Tcl_ReadChars: loop until enough copied} { set f [open $path(test1)] chan configure $f -buffersize 16 # here - set x [chan read $f 19] + chan read $f 19 +} -cleanup { chan close $f - set x -} {abcdefghijklmnopqrs} -test chan-io-10.4 {Tcl_ReadChars: no more in channel buffer} { +} -result {abcdefghijklmnopqrs} +test chan-io-10.4 {Tcl_ReadChars: no more in channel buffer} -body { # (copiedNow < 0) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijkl chan close $f set f [open $path(test1)] # here - set x [chan read $f 1000] + chan read $f 1000 +} -cleanup { chan close $f - set x -} {abcdefghijkl} -test chan-io-10.5 {Tcl_ReadChars: stop on EOF} { +} -result {abcdefghijkl} +test chan-io-10.5 {Tcl_ReadChars: stop on EOF} -body { # (chanPtr->flags & CHANNEL_EOF) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijkl chan close $f set f [open $path(test1)] # here - set x [chan read $f 1000] + chan read $f 1000 +} -cleanup { chan close $f - set x -} {abcdefghijkl} +} -result {abcdefghijkl} -test chan-io-11.1 {ReadBytes: want to read a lot} { +test chan-io-11.1 {ReadBytes: want to read a lot} -body { # ((unsigned) toRead > (unsigned) srcLen) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijkl @@ -1231,11 +1263,11 @@ test chan-io-11.1 {ReadBytes: want to read a lot} { set f [open $path(test1)] chan configure $f -encoding binary # here - set x [chan read $f 1000] + chan read $f 1000 +} -cleanup { chan close $f - set x -} {abcdefghijkl} -test chan-io-11.2 {ReadBytes: want to read all} { +} -result {abcdefghijkl} +test chan-io-11.2 {ReadBytes: want to read all} -body { # ((unsigned) toRead > (unsigned) srcLen) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijkl @@ -1243,11 +1275,11 @@ test chan-io-11.2 {ReadBytes: want to read all} { set f [open $path(test1)] chan configure $f -encoding binary # here - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} {abcdefghijkl} -test chan-io-11.3 {ReadBytes: allocate more space} { +} -result {abcdefghijkl} +test chan-io-11.3 {ReadBytes: allocate more space} -body { # (toRead > length - offset - 1) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijklmnopqrstuvwxyz @@ -1255,11 +1287,11 @@ test chan-io-11.3 {ReadBytes: allocate more space} { set f [open $path(test1)] chan configure $f -buffersize 16 -encoding binary # here - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} {abcdefghijklmnopqrstuvwxyz} -test chan-io-11.4 {ReadBytes: EOF char found} { +} -result {abcdefghijklmnopqrstuvwxyz} +test chan-io-11.4 {ReadBytes: EOF char found} -body { # (TranslateInputEOL() != 0) set f [open $path(test1) w] chan puts $f abcdefghijklmnopqrstuvwxyz @@ -1267,34 +1299,34 @@ test chan-io-11.4 {ReadBytes: EOF char found} { set f [open $path(test1)] chan configure $f -eofchar m -encoding binary # here - set x [list [chan read $f] [chan eof $f] [chan read $f] [chan eof $f]] + list [chan read $f] [chan eof $f] [chan read $f] [chan eof $f] +} -cleanup { chan close $f - set x -} [list "abcdefghijkl" 1 "" 1] +} -result {abcdefghijkl 1 {} 1} -test chan-io-12.1 {ReadChars: want to read a lot} { +test chan-io-12.1 {ReadChars: want to read a lot} -body { # ((unsigned) toRead > (unsigned) srcLen) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijkl chan close $f set f [open $path(test1)] # here - set x [chan read $f 1000] + chan read $f 1000 +} -cleanup { chan close $f - set x -} {abcdefghijkl} -test chan-io-12.2 {ReadChars: want to read all} { +} -result {abcdefghijkl} +test chan-io-12.2 {ReadChars: want to read all} -body { # ((unsigned) toRead > (unsigned) srcLen) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijkl chan close $f set f [open $path(test1)] # here - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} {abcdefghijkl} -test chan-io-12.3 {ReadChars: allocate more space} { +} -result {abcdefghijkl} +test chan-io-12.3 {ReadChars: allocate more space} -body { # (toRead > length - offset - 1) set f [open $path(test1) w] chan puts -nonewline $f abcdefghijklmnopqrstuvwxyz @@ -1302,22 +1334,21 @@ test chan-io-12.3 {ReadChars: allocate more space} { set f [open $path(test1)] chan configure $f -buffersize 16 # here - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} {abcdefghijklmnopqrstuvwxyz} -test chan-io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} { +} -result {abcdefghijklmnopqrstuvwxyz} +test chan-io-12.4 {ReadChars: split-up char} -setup { + variable x {} +} -constraints {stdio testchannel openpipe fileevent} -body { # (srcRead == 0) - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none -buffersize 16 chan puts -nonewline $f "123456789012345\x96" chan configure $f -encoding shiftjis -blocking 0 - chan event $f read [namespace code "ready $f"] - proc ready {f} { - variable x + chan event $f read [namespace code { lappend x [chan read $f] [testchannel inputbuffered $f] - } - variable x {} + }] chan configure $f -encoding shiftjis vwait [namespace which -variable x] chan configure $f -encoding binary -blocking 1 @@ -1325,17 +1356,20 @@ test chan-io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileeve after 500 ;# Give the cat process time to catch up chan configure $f -encoding shiftjis -blocking 0 vwait [namespace which -variable x] + return $x +} -cleanup { chan close $f - set x -} [list "123456789012345" 1 "\u672c" 0] -test chan-io-12.5 {ReadChars: chan events on partial characters} {stdio openpipe fileevent} { +} -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 { set path(test1) [makeFile { chan configure stdout -encoding binary -buffering none chan gets stdin; chan puts -nonewline "\xe7" chan gets stdin; chan puts -nonewline "\x89" chan gets stdin; chan puts -nonewline "\xa6" } test1] - set f [open "|[list [interpreter] $path(test1)]" r+] + set f [openpipe r+ $path(test1)] chan event $f readable [namespace code { lappend x [chan read $f] if {[chan eof $f]} { @@ -1345,7 +1379,6 @@ test chan-io-12.5 {ReadChars: chan events on partial characters} {stdio openpipe chan puts $f "go1" chan flush $f chan configure $f -blocking 0 -encoding utf-8 - variable x {} vwait [namespace which -variable x] after 500 [namespace code { lappend x timeout }] vwait [namespace which -variable x] @@ -1359,32 +1392,31 @@ test chan-io-12.5 {ReadChars: chan events on partial characters} {stdio openpipe vwait [namespace which -variable x] vwait [namespace which -variable x] lappend x [catch {chan close $f} msg] $msg - set x -} "{} timeout {} timeout \u7266 {} eof 0 {}" +} -result "{} timeout {} timeout \u7266 {} eof 0 {}" -test chan-io-13.1 {TranslateInputEOL: cr mode} {} { +test chan-io-13.1 {TranslateInputEOL: cr mode} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\rdef\r" chan close $f set f [open $path(test1)] chan configure $f -translation cr - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef\n" -test chan-io-13.2 {TranslateInputEOL: crlf mode} { +} -result "abcd\ndef\n" +test chan-io-13.2 {TranslateInputEOL: crlf mode} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\r\ndef\r\n" chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef\n" -test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} { +} -result "abcd\ndef\n" +test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} -body { # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf @@ -1392,11 +1424,11 @@ test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} { chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef\r" -test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { +} -result "abcd\ndef\r" +test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} -body { # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf @@ -1404,11 +1436,11 @@ test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef\rfgh" -test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} { +} -result "abcd\ndef\rfgh" +test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} -body { # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf @@ -1416,32 +1448,32 @@ test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} { chan close $f set f [open $path(test1)] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef\nfgh" -test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} { +} -result "abcd\ndef\nfgh" +test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup { + variable x {} + variable y {} +} -constraints {stdio testchannel openpipe fileevent} -body { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. - set f [open "|[list [interpreter] $path(cat)]" w+] + set f [openpipe w+ $path(cat)] chan configure $f -blocking 0 -buffering none -translation {auto lf} - chan event $f read [namespace code "ready $f"] - proc ready {f} { - variable x + chan event $f read [namespace code { lappend x [chan read $f] [testchannel queuedcr $f] - } - variable x {} - variable y {} + }] chan puts -nonewline $f "abcdefghj\r" after 500 [namespace code {set y ok}] vwait [namespace which -variable y] chan puts -nonewline $f "\n01234" after 500 [namespace code {set y ok}] vwait [namespace which -variable y] + return $x +} -cleanup { chan close $f - set x -} [list "abcdefghj\n" 1 "01234" 0] -test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} { +} -result [list "abcdefghj\n" 1 "01234" 0] +test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints {testchannel openpipe} -body { # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf @@ -1449,11 +1481,11 @@ test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [list [chan read $f] [testchannel queuedcr $f]] + list [chan read $f] [testchannel queuedcr $f] +} -cleanup { chan close $f - set x -} [list "abcd\n" 1] -test chan-io-13.8 {TranslateInputEOL: auto mode: \r\n} { +} -result [list "abcd\n" 1] +test chan-io-13.8 {TranslateInputEOL: auto mode: \r\n} -body { # (*src == '\n') set f [open $path(test1) w] chan configure $f -translation lf @@ -1461,22 +1493,22 @@ test chan-io-13.8 {TranslateInputEOL: auto mode: \r\n} { chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef" -test chan-io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { +} -result "abcd\ndef" +test chan-io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\rdef" chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef" -test chan-io-13.10 {TranslateInputEOL: auto mode: \n} { +} -result "abcd\ndef" +test chan-io-13.10 {TranslateInputEOL: auto mode: \n} -body { # not (*src == '\r') set f [open $path(test1) w] chan configure $f -translation lf @@ -1484,11 +1516,11 @@ test chan-io-13.10 {TranslateInputEOL: auto mode: \n} { chan close $f set f [open $path(test1)] chan configure $f -translation auto - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\ndef" -test chan-io-13.11 {TranslateInputEOL: EOF char} { +} -result "abcd\ndef" +test chan-io-13.11 {TranslateInputEOL: EOF char} -body { # (*chanPtr->inEofChar != '\0') set f [open $path(test1) w] chan configure $f -translation lf @@ -1496,11 +1528,11 @@ test chan-io-13.11 {TranslateInputEOL: EOF char} { chan close $f set f [open $path(test1)] chan configure $f -translation auto -eofchar e - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "abcd\nd" -test chan-io-13.12 {TranslateInputEOL: find EOF char in src} { +} -result "abcd\nd" +test chan-io-13.12 {TranslateInputEOL: find EOF char in src} -body { # (*chanPtr->inEofChar != '\0') set f [open $path(test1) w] chan configure $f -translation lf @@ -1508,16 +1540,16 @@ test chan-io-13.12 {TranslateInputEOL: find EOF char in src} { chan close $f set f [open $path(test1)] chan configure $f -translation auto -eofchar e - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "\n\n\nab\n\nd" +} -result "\n\n\nab\n\nd" # Test standard handle management. The functions tested are Tcl_SetStdChannel # and Tcl_GetStdChannel. Incidentally we are also testing channel table # management. -if {[info commands testchannel] ne ""} { +if {[testConstraint testchannel]} { set consoleFileNames [lsort [testchannel open]] } else { # just to avoid an error @@ -1525,24 +1557,24 @@ if {[info commands testchannel] ne ""} { } test chan-io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} { - set l "" - lappend l [chan configure stdin -buffering] - lappend l [chan configure stdout -buffering] - lappend l [chan configure stderr -buffering] - lappend l [lsort [testchannel open]] - set l + set result "" + lappend result [chan configure stdin -buffering] + lappend result [chan configure stdout -buffering] + lappend result [chan configure stderr -buffering] + lappend result [lsort [testchannel open]] } [list line line none $consoleFileNames] -test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { +test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} -setup { interp create x - set l "" - lappend l [x eval {chan configure stdin -buffering}] - lappend l [x eval {chan configure stdout -buffering}] - lappend l [x eval {chan configure stderr -buffering}] + set result "" +} -body { + lappend result [x eval {chan configure stdin -buffering}] + lappend result [x eval {chan configure stdout -buffering}] + lappend result [x eval {chan configure stderr -buffering}] +} -cleanup { interp delete x - set l -} {line line none} +} -result {line line none} set path(test3) [makeFile {} test3] -test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} { +test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec openpipe} -body { set f [open $path(test1) w] chan puts -nonewline $f { chan close stdin @@ -1564,15 +1596,15 @@ test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} { set f [open $path(test2) r] set f2 [open $path(test3) r] lappend result [chan read $f] [chan read $f2] +} -cleanup { chan close $f chan close $f2 - set result -} {{ +} -result {{ out } {err }} # This test relies on the fact that stdout is used before stderr. -test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} { +test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec} -body { set f [open $path(test1) w] chan puts -nonewline $f { chan close stdin chan close stdout @@ -1581,7 +1613,8 @@ test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} { chan puts $f [list open $path(test1) r]] chan puts $f "set f2 \[[list open $path(test2) w]]" chan puts $f "set f3 \[[list open $path(test3) w]]" - chan puts $f { chan puts stdout [chan gets stdin] + chan puts $f { + chan puts stdout [chan gets stdin] chan puts stdout $f2 chan puts stderr $f3 chan close $f @@ -1593,10 +1626,10 @@ test chan-io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec} { set f [open $path(test2) r] set f2 [open $path(test3) r] lappend result [chan read $f] [chan read $f2] +} -cleanup { chan close $f chan close $f2 - set result -} {{ chan close stdin +} -result {{ chan close stdin stdout } {stderr }} @@ -1653,10 +1686,10 @@ test chan-io-14.8 {reuse of stdio special channels} -setup { chan puts [chan gets $f] } chan close $f - set f [open "|[list [interpreter] $path(script)]" r] - set c [chan gets $f] + set f [openpipe r $path(script)] + chan gets $f +} -cleanup { chan close $f - set c } -result hello test chan-io-14.9 {reuse of stdio special channels} -setup { file delete $path(script) @@ -1673,15 +1706,14 @@ test chan-io-14.9 {reuse of stdio special channels} -setup { chan puts [chan gets $f] } chan close $f - set f [open "|[list [interpreter] $path(script) [array get path]]" r] - set c [chan gets $f] - chan close $f - set c + set f [openpipe r $path(script) [array get path]] + chan gets $f } -cleanup { + chan close $f # Added delay to give Windows time to stop the spawned process and clean # up its grip on the file test1. Added delete as proper test cleanup. # The failing tests were 18.1 and 18.2 as first re-users of file "test1". - after 10000 + after [expr {[testConstraint win] ? 10000 : 500}] file delete $path(script) file delete $path(test1) } -result hello @@ -1699,39 +1731,42 @@ test chan-io-16.1 {Tcl_DeleteChan CloseHandler} emptyTest { # These functions use "eof stdin" to ensure that the standard channels are # added to the channel table of the interpreter. -test chan-io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { +test chan-io-17.1 {GetChannelTable, DeleteChannelTable on std handles} -setup { + set l "" +} -constraints {testchannel} -body { set l1 [testchannel refcount stdin] chan eof stdin interp create x - set l "" - lappend l [expr [testchannel refcount stdin] - $l1] + lappend l [expr {[testchannel refcount stdin] - $l1}] x eval {chan eof stdin} - lappend l [expr [testchannel refcount stdin] - $l1] + lappend l [expr {[testchannel refcount stdin] - $l1}] interp delete x - lappend l [expr [testchannel refcount stdin] - $l1] -} {0 1 0} -test chan-io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { + lappend l [expr {[testchannel refcount stdin] - $l1}] +} -result {0 1 0} +test chan-io-17.2 {GetChannelTable, DeleteChannelTable on std handles} -setup { + set l "" +} -constraints {testchannel} -body { set l1 [testchannel refcount stdout] chan eof stdin interp create x - set l "" - lappend l [expr [testchannel refcount stdout] - $l1] + lappend l [expr {[testchannel refcount stdout] - $l1}] x eval {chan eof stdout} - lappend l [expr [testchannel refcount stdout] - $l1] + lappend l [expr {[testchannel refcount stdout] - $l1}] interp delete x - lappend l [expr [testchannel refcount stdout] - $l1] -} {0 1 0} -test chan-io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { + lappend l [expr {[testchannel refcount stdout] - $l1}] +} -result {0 1 0} +test chan-io-17.3 {GetChannelTable, DeleteChannelTable on std handles} -setup { + set l "" +} -constraints {testchannel} -body { set l1 [testchannel refcount stderr] chan eof stdin interp create x - set l "" - lappend l [expr [testchannel refcount stderr] - $l1] + lappend l [expr {[testchannel refcount stderr] - $l1}] x eval {chan eof stderr} - lappend l [expr [testchannel refcount stderr] - $l1] + lappend l [expr {[testchannel refcount stderr] - $l1}] interp delete x - lappend l [expr [testchannel refcount stderr] - $l1] -} {0 1 0} + lappend l [expr {[testchannel refcount stderr] - $l1}] +} -result {0 1 0} test chan-io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { file delete -force $path(test1) @@ -1745,8 +1780,7 @@ test chan-io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { } else { lappend l "very broken: $f found after being chan closed" } - string equal [string tolower $l] \ - [list 1 "can not find channel named \"$f\""] + string equal $l [list 1 "can not find channel named \"$f\""] } -result 1 test chan-io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { file delete -force $path(test1) @@ -1767,8 +1801,7 @@ test chan-io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { } else { lappend l "very broken: $f found after being chan closed" } - string equal [string tolower $l] \ - [list 1 2 1 1 "can not find channel named \"$f\""] + string equal $l [list 1 2 1 1 "can not find channel named \"$f\""] } -result 1 test chan-io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { file delete $path(test1) @@ -1787,20 +1820,20 @@ test chan-io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { } else { lappend l "very broken: $f found after being chan closed" } - string equal [string tolower $l] \ - [list 1 2 1 "can not find channel named \"$f\""] + string equal $l [list 1 2 1 "can not find channel named \"$f\""] } -result 1 test chan-io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { chan eof stdin } 0 -test chan-io-19.2 {testing Tcl_GetChannel, user opened handle} { +test chan-io-19.2 {testing Tcl_GetChannel, user opened handle} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] - set x [chan eof $f] + chan eof $f +} -cleanup { chan close $f - set x -} 0 +} -result 0 test chan-io-19.3 {Tcl_GetChannel, channel not found} -body { chan eof file34 } -returnCodes error -result {can not find channel named "file34"} @@ -1816,35 +1849,36 @@ test chan-io-19.4 {Tcl_CreateChannel, insertion into channel table} -setup { } else { lappend l "very broken: $f found after being chan closed" } - string equal [string tolower $l] \ - [list 0 "can not find channel named \"$f\""] + string equal $l [list 0 "can not find channel named \"$f\""] } -result 1 -test chan-io-20.1 {Tcl_CreateChannel: initial settings} { - set a [open $path(test2) w] +test chan-io-20.1 {Tcl_CreateChannel: initial settings} -setup { set old [encoding system] +} -body { + set a [open $path(test2) w] encoding system ascii set f [open $path(test1) w] - set x [chan configure $f -encoding] - chan close $f + chan configure $f -encoding +} -cleanup { encoding system $old + chan close $f chan close $a - set x -} {ascii} -test chan-io-20.2 {Tcl_CreateChannel: initial settings} {win} { +} -result {ascii} +test chan-io-20.2 {Tcl_CreateChannel: initial settings} -constraints {win} -body { set f [open $path(test1) w+] - set x [list [chan configure $f -eofchar] [chan configure $f -translation]] + list [chan configure $f -eofchar] [chan configure $f -translation] +} -cleanup { chan close $f - set x -} [list [list \x1a ""] {auto crlf}] -test chan-io-20.3 {Tcl_CreateChannel: initial settings} {unix} { +} -result [list [list \x1a ""] {auto crlf}] +test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -body { set f [open $path(test1) w+] - set x [list [chan configure $f -eofchar] [chan configure $f -translation]] + list [chan configure $f -eofchar] [chan configure $f -translation] +} -cleanup { chan close $f - set x -} {{{} {}} {auto lf}} -set path(stdout) [makeFile {} stdout] -test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} { +} -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 { set f [open $path(script) w] chan puts -nonewline $f { chan close stdout @@ -1855,10 +1889,11 @@ test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio open chan puts stderr [chan configure stdout -buffersize] } chan close $f - set f [open "|[list [interpreter] $path(script)]"] - catch {chan close $f} msg - set msg -} {777} + set f [openpipe r $path(script)] + chan close $f +} -cleanup { + removeFile $path(stdout) +} -returnCodes error -result {777} test chan-io-21.1 {Chan CloseChannelsOnExit} emptyTest { } {} @@ -1873,99 +1908,107 @@ test chan-io-22.1 {Tcl_GetChannelMode} emptyTest { # Not used anywhere in Tcl. } {} -test chan-io-23.1 {Tcl_GetChannelName} {testchannel} { +test chan-io-23.1 {Tcl_GetChannelName} -constraints {testchannel} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] set n [testchannel name $f] + expr {$n eq $f ? "ok" : "$n != $f"} +} -cleanup { chan close $f - string compare $n $f -} 0 +} -result ok -test chan-io-24.1 {Tcl_GetChannelType} {testchannel} { +test chan-io-24.1 {Tcl_GetChannelType} -constraints {testchannel} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] - set t [testchannel type $f] + testchannel type $f +} -cleanup { chan close $f - string compare $t file -} 0 +} -result "file" -test chan-io-25.1 {Tcl_GetChannelHandle, input} {testchannel} { +test chan-io-25.1 {Tcl_GetChannelHandle, input} -setup { + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} chan puts $f "1234567890\n098765432" chan close $f set f [open $path(test1) r] chan gets $f - set l "" lappend l [testchannel inputbuffered $f] lappend l [chan tell $f] +} -cleanup { chan close $f - set l -} {10 11} -test chan-io-25.2 {Tcl_GetChannelHandle, output} {testchannel} { +} -result {10 11} +test chan-io-25.2 {Tcl_GetChannelHandle, output} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello - set l "" lappend l [testchannel outputbuffered $f] lappend l [chan tell $f] chan flush $f lappend l [testchannel outputbuffered $f] lappend l [chan tell $f] +} -cleanup { chan close $f file delete $path(test1) - set l -} {6 6 0 6} +} -result {6 6 0 6} -test chan-io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} { +test chan-io-26.1 {Tcl_GetChannelInstanceData} -body { # "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] + set f [openpipe r << exit] + pid $f +} -constraints {stdio openpipe} -cleanup { chan close $f -} {} +} -match regexp -result {^\d+$} # Test flushing. The functions tested here are FlushChannel. -test chan-io-27.1 {FlushChannel, no output buffered} { +test chan-io-27.1 {FlushChannel, no output buffered} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan flush $f - set s [file size $path(test1)] + file size $path(test1) +} -cleanup { chan close $f - set s -} 0 -test chan-io-27.2 {FlushChannel, some output buffered} { +} -result 0 +test chan-io-27.2 {FlushChannel, some output buffered} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set l "" chan puts $f hello lappend l [file size $path(test1)] chan flush $f lappend l [file size $path(test1)] chan close $f lappend l [file size $path(test1)] - set l -} {0 6 6} -test chan-io-27.3 {FlushChannel, implicit flush on chan close} { +} -result {0 6 6} +test chan-io-27.3 {FlushChannel, implicit flush on chan close} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set l "" chan puts $f hello lappend l [file size $path(test1)] chan close $f lappend l [file size $path(test1)] - set l -} {0 6} -test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} { +} -result {0 6} +test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} chan configure $f -buffersize 60 - set l "" lappend l [file size $path(test1)] for {set i 0} {$i < 12} {incr i} { chan puts $f hello @@ -1973,15 +2016,15 @@ test chan-io-27.4 {FlushChannel, implicit flush when buffer fills} { lappend l [file size $path(test1)] chan flush $f lappend l [file size $path(test1)] +} -cleanup { chan close $f - set l -} {0 60 72} -test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} \ - {unixOrPc} { +} -result {0 60 72} +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 { set f [open $path(test1) w] chan configure $f -translation lf -buffersize 60 -eofchar {} - set l "" lappend l [file size $path(test1)] for {set i 0} {$i < 12} {incr i} { chan puts $f hello @@ -1989,14 +2032,13 @@ test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan cl lappend l [file size $path(test1)] chan close $f lappend l [file size $path(test1)] - set l -} {0 60 72} +} -result {0 60 72} set path(pipe) [makeFile {} pipe] set path(output) [makeFile {} output] -test chan-io-27.6 {FlushChannel, async flushing, async chan close} \ - {stdio asyncPipeChan Close openpipe} { +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 { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f { @@ -2014,7 +2056,7 @@ test chan-io-27.6 {FlushChannel, async flushing, async chan close} \ } set f [open $path(output) w] chan close $f - set f [open "|[list [interpreter] $path(pipe)]" w] + set f [openpipe w $path(pipe)] chan configure $f -blocking off chan puts -nonewline $f $x chan close $f @@ -2028,26 +2070,28 @@ test chan-io-27.6 {FlushChannel, async flushing, async chan close} \ } else { set result ok } -} ok +} -result ok # Tests closing a channel. The functions tested are Chan CloseChannel and # Tcl_Chan Close. -test chan-io-28.1 {Chan CloseChannel called when all references are dropped} {testchannel} { +test chan-io-28.1 {Chan CloseChannel called when all references are dropped} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] interp create x interp share "" $f x - set l "" lappend l [testchannel refcount $f] x eval chan close $f interp delete x lappend l [testchannel refcount $f] +} -cleanup { chan close $f - set l -} {2 1} -test chan-io-28.2 {Chan CloseChannel called when all references are dropped} { +} -result {2 1} +test chan-io-28.2 {Chan CloseChannel called when all references are dropped} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] interp create x interp share "" $f x @@ -2057,14 +2101,14 @@ test chan-io-28.2 {Chan CloseChannel called when all references are dropped} { x eval chan close $f interp delete x set f [open $path(test1) r] - set l [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set l -} abcdef -test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} \ - {stdio asyncPipeChan Close nonPortable openpipe} { +} -result abcdef +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 { set f [open $path(pipe) w] chan puts $f { # Need to not have eof char appended on chan close, because the other @@ -2087,7 +2131,7 @@ test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} \ } set f [open $path(output) w] chan close $f - set f [open "|[list [interpreter] pipe]" r+] + set f [openpipe r+ $path(pipe)] chan configure $f -blocking off -eofchar {} chan puts -nonewline $f $x chan close $f @@ -2101,10 +2145,11 @@ test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} \ } else { set result ok } -} ok -test chan-io-28.4 {Tcl_Chan Close} {testchannel} { +} -result ok +test chan-io-28.4 {Tcl_Chan Close} -constraints {testchannel} -setup { file delete $path(test1) set l "" +} -body { lappend l [lsort [testchannel open]] set f [open $path(test1) w] lappend l [lsort [testchannel open]] @@ -2113,8 +2158,8 @@ test chan-io-28.4 {Tcl_Chan Close} {testchannel} { set x [list $consoleFileNames \ [lsort [list {*}$consoleFileNames $f]] \ $consoleFileNames] - string compare $l $x -} 0 + expr {$l eq $x ? "ok" : "{$l} != {$x}"} +} -result ok test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { file delete $path(script) } -constraints {stdio unix testchannel openpipe} -body { @@ -2124,7 +2169,7 @@ test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { chan puts [testchannel open] } chan close $f - set f [open "|[list [interpreter] $path(script)]" r] + set f [openpipe r $path(script)] set l [chan gets $f] chan close $f lsort $l @@ -2132,27 +2177,28 @@ test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { test chan-io-28.6 {Tcl_CloseEx (half-close) pipe} -setup { set cat [makeFile { fconfigure stdout -buffering line - while {[gets stdin line]>=0} {puts $line} + while {[gets stdin line] >= 0} {puts $line} puts DONE exit 0 } cat.tcl] + variable done } -body { - set ::ff [open "|[list [interpreter] $cat]" r+] - puts $::ff Hey - close $::ff w - set timer [after 1000 {set ::done Failed}] - set ::acc {} - fileevent $::ff readable { - if {[gets $::ff line]<0} { - set ::done Succeeded + set ff [openpipe r+ $cat] + puts $ff Hey + close $ff w + set timer [after 1000 [namespace code {set done Failed}]] + set acc {} + fileevent $ff readable [namespace code { + if {[gets $ff line] < 0} { + set done Succeeded } else { - lappend ::acc $line + lappend acc $line } - } - vwait ::done + }] + vwait [namespace which -variable done] after cancel $timer - close $::ff r - list $::done $::acc + close $ff r + list $done $acc } -cleanup { removeFile cat.tcl } -result {Succeeded {Hey DONE}} @@ -2163,102 +2209,108 @@ test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup { puts [lindex [fconfigure $s -sockname] 2] flush stdout vwait ::sok - fconfigure $::sok -buffering line - while {[gets $::sok line]>=0} {puts $::sok $line} - puts $::sok DONE + fconfigure $sok -buffering line + while {[gets $sok line]>=0} {puts $sok $line} + puts $sok DONE exit 0 } echo.tcl] } -body { - set ::ff [open "|[list [interpreter] $echo]" r] - gets $::ff port - set ::s [socket 127.0.0.1 $port] - puts $::s Hey - close $::s w - set timer [after 1000 {set ::done Failed}] - set ::acc {} - fileevent $::s readable { - if {[gets $::s line]<0} { - set ::done Succeeded + set ff [openpipe r $echo] + gets $ff port + set s [socket 127.0.0.1 $port] + puts $s Hey + close $s w + set timer [after 1000 [namespace code {set ::done Failed}]] + set acc {} + fileevent $s readable [namespace code { + if {[gets $s line]<0} { + set done Succeeded } else { - lappend ::acc $line + lappend acc $line } - } - vwait ::done + }] + vwait [namespace which -variable done] after cancel $timer - close $::s r - close $::ff - list $::done $::acc + close $s r + close $ff + list $done $acc } -cleanup { removeFile echo.tcl } -result {Succeeded {Hey DONE}} -test chan-io-29.1 {Tcl_WriteChars, channel not writable} { - list [catch {chan puts stdin hello} msg] $msg -} {1 {channel "stdin" wasn't opened for writing}} -test chan-io-29.2 {Tcl_WriteChars, empty string} { +test chan-io-29.1 {Tcl_WriteChars, channel not writable} -body { + chan puts stdin hello +} -returnCodes error -result {channel "stdin" wasn't opened for writing} +test chan-io-29.2 {Tcl_WriteChars, empty string} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -eofchar {} chan puts -nonewline $f "" chan close $f file size $path(test1) -} 0 -test chan-io-29.3 {Tcl_WriteChars, nonempty string} { +} -result 0 +test chan-io-29.3 {Tcl_WriteChars, nonempty string} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -eofchar {} chan puts -nonewline $f hello chan close $f file size $path(test1) -} 5 -test chan-io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} { +} -result 5 +test chan-io-29.4 {Tcl_WriteChars, buffering in full buffering mode} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffering full -eofchar {} chan puts $f hello - set l "" lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] chan flush $f lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] +} -cleanup { chan close $f - set l -} {6 0 0 6} -test chan-io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} { +} -result {6 0 0 6} +test chan-io-29.5 {Tcl_WriteChars, buffering in line buffering mode} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffering line -eofchar {} chan puts -nonewline $f hello - set l "" lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] chan puts $f hello lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] +} -cleanup { chan close $f - set l -} {5 0 0 11} -test chan-io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} { +} -result {5 0 0 11} +test chan-io-29.6 {Tcl_WriteChars, buffering in no buffering mode} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffering none -eofchar {} chan puts -nonewline $f hello - set l "" lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] chan puts $f hello lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] +} -cleanup { chan close $f - set l -} {0 5 0 11} -test chan-io-29.7 {Tcl_Flush, full buffering} {testchannel} { +} -result {0 5 0 11} +test chan-io-29.7 {Tcl_Flush, full buffering} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffering full -eofchar {} chan puts -nonewline $f hello - set l "" lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] chan puts $f hello @@ -2267,15 +2319,16 @@ test chan-io-29.7 {Tcl_Flush, full buffering} {testchannel} { chan flush $f lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] +} -cleanup { chan close $f - set l -} {5 0 11 0 0 11} -test chan-io-29.8 {Tcl_Flush, full buffering} {testchannel} { +} -result {5 0 11 0 0 11} +test chan-io-29.8 {Tcl_Flush, full buffering} -setup { file delete $path(test1) + set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] chan configure $f -translation lf -buffering line chan puts -nonewline $f hello - set l "" lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] chan flush $f @@ -2287,14 +2340,15 @@ test chan-io-29.8 {Tcl_Flush, full buffering} {testchannel} { chan flush $f lappend l [testchannel outputbuffered $f] lappend l [file size $path(test1)] +} -cleanup { chan close $f - set l -} {5 0 0 5 0 11 0 11} -test chan-io-29.9 {Tcl_Flush, channel not writable} { - list [catch {chan flush stdin} msg] $msg -} {1 {channel "stdin" wasn't opened for writing}} -test chan-io-29.10 {Tcl_WriteChars, looping and buffering} { +} -result {5 0 0 5 0 11 0 11} +test chan-io-29.9 {Tcl_Flush, channel not writable} -body { + chan flush stdin +} -returnCodes error -result {channel "stdin" wasn't opened for writing} +test chan-io-29.10 {Tcl_WriteChars, looping and buffering} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} set f2 [open $path(longfile) r] @@ -2304,9 +2358,10 @@ test chan-io-29.10 {Tcl_WriteChars, looping and buffering} { chan close $f2 chan close $f1 file size $path(test1) -} 387 -test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} { +} -result 387 +test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -eofchar {} set f2 [open $path(longfile) r] @@ -2316,10 +2371,11 @@ test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} { chan close $f1 chan close $f2 file size $path(test1) -} 377 -test chan-io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { +} -result 377 +test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup { file delete $path(test1) file delete $path(pipe) +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 "set f1 \[[list open $path(longfile) r]]" chan puts $f1 { @@ -2328,23 +2384,25 @@ test chan-io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { } } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r] + set f1 [openpipe r $path(pipe)] set f2 [open $path(longfile) r] set y ok for {set x 0} {$x < 10} {incr x} { set l1 [chan gets $f1] set l2 [chan gets $f2] - if {"$l1" != "$l2"} { - set y broken + if {$l1 ne $l2} { + set y broken:$x } } + return $y +} -cleanup { chan close $f1 chan close $f2 - set y -} ok -test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} { +} -result ok +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 { set f1 [open $path(pipe) w] chan puts $f1 { chan puts [chan gets stdin] @@ -2352,70 +2410,74 @@ test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} { } chan close $f1 set y ok - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan configure $f1 -buffering line set f2 [open $path(longfile) r] set line [chan gets $f2] chan puts $f1 $line set backline [chan gets $f1] - if {"$line" != "$backline"} { - set y broken + if {$line ne $backline} { + set y broken1 } set line [chan gets $f2] chan puts $f1 $line set backline [chan gets $f1] - if {"$line" != "$backline"} { - set y broken + if {$line ne $backline} { + set y broken2 } + return $y +} -cleanup { chan close $f1 chan close $f2 - set y -} ok -test chan-io-29.14 {Tcl_WriteChars, buffering and implicit flush at chan close} { +} -result ok +test chan-io-29.14 {Tcl_WriteChars, buffering and implicit flush at chan close} -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan puts -nonewline $f "Text1" chan puts -nonewline $f " Text 2" chan puts $f " Text 3" chan close $f set f [open $path(test3) r] - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} {Text1 Text 2 Text 3} -test chan-io-29.15 {Tcl_Flush, channel not open for writing} { +} -result {Text1 Text 2 Text 3} +test chan-io-29.15 {Tcl_Flush, channel not open for writing} -setup { file delete $path(test1) set fd [open $path(test1) w] chan close $fd +} -body { set fd [open $path(test1) r] - set x [list [catch {chan flush $fd} msg] $msg] - chan close $fd - string compare $x \ - [list 1 "channel \"$fd\" wasn't opened for writing"] -} 0 -test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} { - set fd [open "|[list [interpreter] cat longfile]" r] - set x [list [catch {chan flush $fd} msg] $msg] + chan flush $fd +} -returnCodes error -cleanup { catch {chan close $fd} - string compare $x \ - [list 1 "channel \"$fd\" wasn't opened for writing"] -} 0 -test chan-io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} { +} -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 { + chan flush $fd +} -returnCodes error -cleanup { + catch {chan close $fd} +} -match glob -result {channel "*" wasn't opened for writing} +test chan-io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf chan puts $f1 hello chan puts $f1 hello chan puts $f1 hello chan flush $f1 - set x [file size $path(test1)] + file size $path(test1) +} -cleanup { chan close $f1 - set x -} 18 -test chan-io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} { +} -result 18 +test chan-io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} -setup { file delete $path(test1) set x "" set f1 [open $path(test1) w] +} -body { chan configure $f1 -translation lf chan puts $f1 hello chan puts $f1 hello @@ -2428,11 +2490,12 @@ test chan-io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} { chan puts $f1 hello chan flush $f1 lappend x [file size $path(test1)] +} -cleanup { chan close $f1 - set x -} {18 24 30} -test chan-io-29.19 {Explicit and implicit flushes} { +} -result {18 24 30} +test chan-io-29.19 {Explicit and implicit flushes} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} set x "" @@ -2447,10 +2510,10 @@ test chan-io-29.19 {Explicit and implicit flushes} { chan puts $f1 hello chan close $f1 lappend x [file size $path(test1)] - set x -} {18 24 30} -test chan-io-29.20 {Implicit flush when buffer is full} { +} -result {18 24 30} +test chan-io-29.20 {Implicit flush when buffer is full} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" @@ -2465,24 +2528,25 @@ test chan-io-29.20 {Implicit flush when buffer is full} { lappend z [file size $path(test1)] chan close $f1 lappend z [file size $path(test1)] - set z -} {4096 12288 12600} -test chan-io-29.21 {Tcl_Flush to pipe} {stdio openpipe} { +} -result {4096 12288 12600} +test chan-io-29.21 {Tcl_Flush to pipe} -setup { file delete $path(pipe) +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 {set x [chan read stdin 6]} chan puts $f1 {set cnt [string length $x]} chan puts $f1 {chan puts "read $cnt characters"} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello chan flush $f1 - set x [chan gets $f1] + chan gets $f1 +} -cleanup { catch {chan close $f1} - set x -} "read 6 characters" -test chan-io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { +} -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 { set f1 [open $path(pipe) w] chan puts $f1 { chan configure stdout -buffering full @@ -2494,18 +2558,19 @@ test chan-io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { chan flush stdout } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] set x "" lappend x [chan gets $f1] lappend x [chan gets $f1] chan puts $f1 hello chan flush $f1 lappend x [chan gets $f1] +} -cleanup { chan close $f1 - set x -} {hello hello bye} -test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe} { +} -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 { set f1 [open $path(pipe) w] chan puts $f1 { chan puts hello @@ -2514,108 +2579,112 @@ test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe chan puts bye } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] set x "" lappend x [chan gets $f1] lappend x [chan gets $f1] chan puts $f1 hello chan flush $f1 lappend x [chan gets $f1] +} -cleanup { chan close $f1 - set x -} {hello hello bye} -test chan-io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} { +} -result {hello hello bye} +test chan-io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} -setup { + variable x {} +} -body { set f [open $path(test3) w] chan puts $f "Line 1" chan puts $f "Line 2" set f2 [open $path(test3)] - set x {} lappend x [chan read -nonewline $f2] chan close $f2 chan flush $f set f2 [open $path(test3)] lappend x [chan read -nonewline $f2] +} -cleanup { chan close $f2 chan close $f - set x -} "{} {Line 1\nLine 2}" -test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} { +} -result "{} {Line 1\nLine 2}" +test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup { file delete $path(test3) - set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w] +} -constraints {stdio openpipe fileevent} -body { + set f [openpipe w $path(cat) | [interpreter] $path(cat) > $path(test3)] chan puts $f "Line 1" chan puts $f "Line 2" chan close $f after 100 set f [open $path(test3) r] - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "Line 1\nLine 2\n" -test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs openpipe} { +} -result "Line 1\nLine 2\n" +test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs openpipe} -body { set f [open "|[list cat -u]" r+] chan puts $f "Line1" chan flush $f - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} {Line1} -test chan-io-29.27 {Tcl_Flush on chan closed pipeline} {stdio openpipe} { +} -result {Line1} +test chan-io-29.27 {Tcl_Flush on chan closed pipeline} -setup { file delete $path(pipe) set f [open $path(pipe) w] chan puts $f {exit} chan close $f - set f [open "|[list [interpreter] $path(pipe)]" r+] +} -constraints {stdio openpipe} -body { + set f [openpipe r+ $path(pipe)] chan gets $f chan puts $f output after 50 # - # The flush below will get a SIGPIPE. This is an expected part of - # test and indicates that the test operates correctly. If you run - # this test under a debugger, the signal will by intercepted unless - # you disable the debugger's signal interception. + # The flush below will get a SIGPIPE. This is an expected part of the test + # and indicates that the test operates correctly. If you run this test + # under a debugger, the signal will by intercepted unless you disable the + # debugger's signal interception. # if {[catch {chan flush $f} msg]} { set x [list 1 $msg $::errorCode] catch {chan close $f} + } elseif {[catch {chan close $f} msg]} { + set x [list 1 $msg $::errorCode] } else { - if {[catch {chan close $f} msg]} { - set x [list 1 $msg $::errorCode] - } else { - set x {this was supposed to fail and did not} - } + set x {this was supposed to fail and did not} } - regsub {".*":} $x {"":} x string tolower $x -} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}} -test chan-io-29.28 {Tcl_WriteChars, lf mode} { +} -match glob -result {1 {error flushing "*": broken pipe} {posix epipe {broken pipe}}} +test chan-io-29.28 {Tcl_WriteChars, lf mode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} chan puts $f hello\nthere\nand\nhere chan flush $f - set s [file size $path(test1)] + file size $path(test1) +} -cleanup { chan close $f - set s -} 21 -test chan-io-29.29 {Tcl_WriteChars, cr mode} { +} -result 21 +test chan-io-29.29 {Tcl_WriteChars, cr mode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar {} chan puts $f hello\nthere\nand\nhere chan close $f file size $path(test1) -} 21 -test chan-io-29.30 {Tcl_WriteChars, crlf mode} { +} -result 21 +test chan-io-29.30 {Tcl_WriteChars, crlf mode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar {} chan puts $f hello\nthere\nand\nhere chan close $f file size $path(test1) -} 25 -test chan-io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { +} -result 25 +test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { file delete $path(pipe) file delete $path(output) +} -constraints {stdio openpipe} -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} @@ -2633,7 +2702,7 @@ test chan-io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { } set f [open $path(output) w] chan close $f - set f [open "|[list [interpreter] $path(pipe)]" r+] + set f [openpipe r+ $path(pipe)] chan configure $f -blocking off chan puts -nonewline $f $x chan close $f @@ -2651,12 +2720,12 @@ test chan-io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { # 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 chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} \ - {stdio asyncPipeChan Close openpipe} { + return $result +} -result ok +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 { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f {chan configure $f -translation lf} @@ -2675,7 +2744,7 @@ test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} \ } set f [open $path(output) w] chan close $f - set f [open "|[list [interpreter] $path(pipe)]" r+] + set f [openpipe r+ $path(pipe)] chan configure $f -blocking off chan puts -nonewline $f $x chan close $f @@ -2689,8 +2758,8 @@ test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} \ } else { set result ok } -} ok -test chan-io-29.33 {Tcl_Flush, implicit flush on exit} {exec} { +} -result ok +test chan-io-29.33 {Tcl_Flush, implicit flush on exit} -setup { set f [open $path(script) w] chan puts $f "set f \[[list open $path(test1) w]]" chan puts $f {chan configure $f -translation lf @@ -2699,13 +2768,14 @@ test chan-io-29.33 {Tcl_Flush, implicit flush on exit} {exec} { chan puts $f strange } chan close $f +} -constraints exec -body { exec [interpreter] $path(script) set f [open $path(test1) r] - set r [chan read $f] + chan read $f +} -cleanup { chan close $f - set r -} "hello\nbye\nstrange\n" -test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} {socket tempNotMac fileevent} { +} -result "hello\nbye\nstrange\n" +test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} -setup { variable c 0 variable x running set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz @@ -2714,6 +2784,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 { proc accept {s a p} { variable x chan event $s readable [namespace code [list readit $s]] @@ -2739,13 +2810,14 @@ 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] - set c -} 2000 -test chan-io-29.35 {Tcl_Chan Close vs chan event 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(). + return $c +} -result 2000 +test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} -setup { catch {interp delete x} catch {interp delete y} +} -constraints {socket tempNotMac fileevent} -body { + # On Mac, this test screws up sockets such that subsequent tests using + # port 2828 either cause errors or panic(). interp create x interp create y set s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] @@ -2777,171 +2849,182 @@ test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} {sock y eval "chan event $c readable \{readit $c\}" y eval [list chan close $c] update +} -cleanup { chan close $s interp delete x interp delete y -} "" +} -result "" # Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read. -test chan-io-30.1 {Tcl_Write lf, Tcl_Read lf} { +test chan-io-30.1 {Tcl_Write lf, Tcl_Read lf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation lf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\nthere\nand\nhere\n" -test chan-io-30.2 {Tcl_Write lf, Tcl_Read cr} { +} -result "hello\nthere\nand\nhere\n" +test chan-io-30.2 {Tcl_Write lf, Tcl_Read cr} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation cr - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\nthere\nand\nhere\n" -test chan-io-30.3 {Tcl_Write lf, Tcl_Read crlf} { +} -result "hello\nthere\nand\nhere\n" +test chan-io-30.3 {Tcl_Write lf, Tcl_Read crlf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\nthere\nand\nhere\n" -test chan-io-30.4 {Tcl_Write cr, Tcl_Read cr} { +} -result "hello\nthere\nand\nhere\n" +test chan-io-30.4 {Tcl_Write cr, Tcl_Read cr} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation cr - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\nthere\nand\nhere\n" -test chan-io-30.5 {Tcl_Write cr, Tcl_Read lf} { +} -result "hello\nthere\nand\nhere\n" +test chan-io-30.5 {Tcl_Write cr, Tcl_Read lf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation lf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\rthere\rand\rhere\r" -test chan-io-30.6 {Tcl_Write cr, Tcl_Read crlf} { +} -result "hello\rthere\rand\rhere\r" +test chan-io-30.6 {Tcl_Write cr, Tcl_Read crlf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\rthere\rand\rhere\r" -test chan-io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { +} -result "hello\rthere\rand\rhere\r" +test chan-io-30.7 {Tcl_Write crlf, Tcl_Read crlf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\nthere\nand\nhere\n" -test chan-io-30.8 {Tcl_Write crlf, Tcl_Read lf} { +} -result "hello\nthere\nand\nhere\n" +test chan-io-30.8 {Tcl_Write crlf, Tcl_Read lf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation lf - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\r\nthere\r\nand\r\nhere\r\n" -test chan-io-30.9 {Tcl_Write crlf, Tcl_Read cr} { +} -result "hello\r\nthere\r\nand\r\nhere\r\n" +test chan-io-30.9 {Tcl_Write crlf, Tcl_Read cr} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation cr - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} "hello\n\nthere\n\nand\n\nhere\n\n" -test chan-io-30.10 {Tcl_Write lf, Tcl_Read auto} { +} -result "hello\n\nthere\n\nand\n\nhere\n\n" +test chan-io-30.10 {Tcl_Write lf, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] - set c [chan read $f] - set x [chan configure $f -translation] + list [chan read $f] [chan configure $f -translation] +} -cleanup { chan close $f - list $c $x -} {{hello +} -result {{hello there and here } auto} -test chan-io-30.11 {Tcl_Write cr, Tcl_Read auto} { +test chan-io-30.11 {Tcl_Write cr, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] - set c [chan read $f] - set x [chan configure $f -translation] + list [chan read $f] [chan configure $f -translation] +} -cleanup { chan close $f - list $c $x -} {{hello +} -result {{hello there and here } auto} -test chan-io-30.12 {Tcl_Write crlf, Tcl_Read auto} { +test chan-io-30.12 {Tcl_Write crlf, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] - set c [chan read $f] - set x [chan configure $f -translation] + list [chan read $f] [chan configure $f -translation] +} -cleanup { chan close $f - list $c $x -} {{hello +} -result {{hello there and here } auto} -test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { +test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf @@ -2952,12 +3035,13 @@ test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { chan close $f set f [open $path(test1) r] chan configure $f -translation auto - set c [chan read $f] + string length [chan read $f] +} -cleanup { chan close $f - string length $c -} [expr 700*15+1] -test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { +} -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 { set f [open $path(test1) w] chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf @@ -2968,60 +3052,64 @@ test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set c [chan read $f] + string length [chan read $f] +} -cleanup { chan close $f - string length $c -} [expr 700*15+1] -test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} { +} -result [expr 700*15+1] +test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] chan configure $f -translation auto - set c [chan read $f] + chan read $f +} -cleanup { chan close $f - set c -} {hello +} -result {hello there and here } -test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { +test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f hello\nthere\nand\rhere\n\x1a chan close $f set f [open $path(test1) r] chan configure $f -eofchar \x1a -translation auto - set c [chan read $f] + chan read $f +} -cleanup { chan close $f - set c -} {hello +} -result {hello there and here } -test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} { +test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} -setup { file delete $path(test1) +} -constraints {win} -body { set f [open $path(test1) w] chan configure $f -eofchar \x1a -translation lf chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] chan configure $f -eofchar \x1a -translation auto - set c [chan read $f] + chan read $f +} -cleanup { chan close $f - set c -} {hello +} -result {hello there and here } -test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { +test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf set s [format "abc\ndef\n%cghi\nqrs" 26] @@ -3037,11 +3125,12 @@ test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1 {} 1} -test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { +} -result {abc def 0 {} 1 {} 1} +test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf set s [format "abc\ndef\n%cghi\nqrs" 26] @@ -3057,19 +3146,19 @@ test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1 {} 1} -test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { +} -result {abc def 0 {} 1 {} 1} +test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set s [format "abc\ndef\n%cghi\nqrs" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cghi\nqrs" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation lf -eofchar {} - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3079,61 +3168,61 @@ test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "abc def 0 \x1aghi 0 qrs 0 {} 1" -test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { +} -result "abc def 0 \x1aghi 0 qrs 0 {} 1" +test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set s [format "abc\ndef\n%cghi\nqrs" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cghi\nqrs" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation cr -eofchar {} - set l "" set x [chan gets $f] - lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] + lappend l [string equal $x "abc\ndef\n\x1aghi\nqrs\n"] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {0 1 {} 1} -test chan-io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { +} -result {1 1 {} 1} +test chan-io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set s [format "abc\ndef\n%cghi\nqrs" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cghi\nqrs" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation crlf -eofchar {} - set l "" set x [chan gets $f] - lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] + lappend l [string equal $x "abc\ndef\n\x1aghi\nqrs\n"] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {0 1 {} 1} -test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { +} -result {1 1 {} 1} +test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf - set c [format abc\ndef\n%cqrs\ntuv 26] - chan puts $f $c + chan puts $f [format abc\ndef\n%cqrs\ntuv 26] chan close $f set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set c [string length [chan read $f]] - set e [chan eof $f] + list [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $e -} {8 1} -test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { +} -result {8 1} +test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf set c [format abc\ndef\n%cqrs\ntuv 26] @@ -3141,13 +3230,13 @@ test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { chan close $f set f [open $path(test1) r] chan configure $f -translation lf -eofchar \x1a - set c [string length [chan read $f]] - set e [chan eof $f] + list [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $e -} {8 1} -test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { +} -result {8 1} +test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr set c [format abc\ndef\n%cqrs\ntuv 26] @@ -3155,13 +3244,13 @@ test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { chan close $f set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set c [string length [chan read $f]] - set e [chan eof $f] + list [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $e -} {8 1} -test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { +} -result {8 1} +test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr set c [format abc\ndef\n%cqrs\ntuv 26] @@ -3169,13 +3258,13 @@ test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { chan close $f set f [open $path(test1) r] chan configure $f -translation cr -eofchar \x1a - set c [string length [chan read $f]] - set e [chan eof $f] + list [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $e -} {8 1} -test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { +} -result {8 1} +test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf set c [format abc\ndef\n%cqrs\ntuv 26] @@ -3183,13 +3272,13 @@ test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { chan close $f set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set c [string length [chan read $f]] - set e [chan eof $f] + list [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $e -} {8 1} -test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { +} -result {8 1} +test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf set c [format abc\ndef\n%cqrs\ntuv 26] @@ -3197,92 +3286,97 @@ test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { chan close $f set f [open $path(test1) r] chan configure $f -translation crlf -eofchar \x1a - set c [string length [chan read $f]] - set e [chan eof $f] + list [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $e -} {8 1} +} -result {8 1} -# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets. +# Test end of line translations. Functions tested are Tcl_Write and +# Tcl_Gets. -test chan-io-31.1 {Tcl_Write lf, Tcl_Gets auto} { +test chan-io-31.1 {Tcl_Write lf, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] +} -cleanup { chan close $f - set l -} {hello 6 auto there 12 auto} -test chan-io-31.2 {Tcl_Write cr, Tcl_Gets auto} { +} -result {hello 6 auto there 12 auto} +test chan-io-31.2 {Tcl_Write cr, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] +} -cleanup { chan close $f - set l -} {hello 6 auto there 12 auto} -test chan-io-31.3 {Tcl_Write crlf, Tcl_Gets auto} { +} -result {hello 6 auto there 12 auto} +test chan-io-31.3 {Tcl_Write crlf, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] +} -cleanup { chan close $f - set l -} {hello 7 auto there 14 auto} -test chan-io-31.4 {Tcl_Write lf, Tcl_Gets lf} { +} -result {hello 7 auto there 14 auto} +test chan-io-31.4 {Tcl_Write lf, Tcl_Gets lf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation lf - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] +} -cleanup { chan close $f - set l -} {hello 6 lf there 12 lf} -test chan-io-31.5 {Tcl_Write lf, Tcl_Gets cr} { +} -result {hello 6 lf there 12 lf} +test chan-io-31.5 {Tcl_Write lf, Tcl_Gets cr} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation cr - set l "" lappend l [string length [chan gets $f]] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3291,18 +3385,19 @@ test chan-io-31.5 {Tcl_Write lf, Tcl_Gets cr} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {21 21 cr 1 {} 21 cr 1} -test chan-io-31.6 {Tcl_Write lf, Tcl_Gets crlf} { +} -result {21 21 cr 1 {} 21 cr 1} +test chan-io-31.6 {Tcl_Write lf, Tcl_Gets crlf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set l "" lappend l [string length [chan gets $f]] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3311,18 +3406,19 @@ test chan-io-31.6 {Tcl_Write lf, Tcl_Gets crlf} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {21 21 crlf 1 {} 21 crlf 1} -test chan-io-31.7 {Tcl_Write cr, Tcl_Gets cr} { +} -result {21 21 crlf 1 {} 21 crlf 1} +test chan-io-31.7 {Tcl_Write cr, Tcl_Gets cr} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation cr - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3331,18 +3427,19 @@ test chan-io-31.7 {Tcl_Write cr, Tcl_Gets cr} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello 6 cr 0 there 12 cr 0} -test chan-io-31.8 {Tcl_Write cr, Tcl_Gets lf} { +} -result {hello 6 cr 0 there 12 cr 0} +test chan-io-31.8 {Tcl_Write cr, Tcl_Gets lf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation lf - set l "" lappend l [string length [chan gets $f]] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3351,18 +3448,19 @@ test chan-io-31.8 {Tcl_Write cr, Tcl_Gets lf} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {21 21 lf 1 {} 21 lf 1} -test chan-io-31.9 {Tcl_Write cr, Tcl_Gets crlf} { +} -result {21 21 lf 1 {} 21 lf 1} +test chan-io-31.9 {Tcl_Write cr, Tcl_Gets crlf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set l "" lappend l [string length [chan gets $f]] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3371,18 +3469,19 @@ test chan-io-31.9 {Tcl_Write cr, Tcl_Gets crlf} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {21 21 crlf 1 {} 21 crlf 1} -test chan-io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} { +} -result {21 21 crlf 1 {} 21 crlf 1} +test chan-io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3391,18 +3490,19 @@ test chan-io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello 7 crlf 0 there 14 crlf 0} -test chan-io-31.11 {Tcl_Write crlf, Tcl_Gets cr} { +} -result {hello 7 crlf 0 there 14 crlf 0} +test chan-io-31.11 {Tcl_Write crlf, Tcl_Gets cr} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation cr - set l "" lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3411,18 +3511,19 @@ test chan-io-31.11 {Tcl_Write crlf, Tcl_Gets cr} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello 6 cr 0 6 13 cr 0} -test chan-io-31.12 {Tcl_Write crlf, Tcl_Gets lf} { +} -result {hello 6 cr 0 6 13 cr 0} +test chan-io-31.12 {Tcl_Write crlf, Tcl_Gets lf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf chan puts $f hello\nthere\nand\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation lf - set l "" lappend l [string length [chan gets $f]] lappend l [chan tell $f] lappend l [chan configure $f -translation] @@ -3431,30 +3532,32 @@ test chan-io-31.12 {Tcl_Write crlf, Tcl_Gets lf} { lappend l [chan tell $f] lappend l [chan configure $f -translation] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {6 7 lf 0 6 14 lf 0} -test chan-io-31.13 {binary mode is synonym of lf mode} { +} -result {6 7 lf 0 6 14 lf 0} +test chan-io-31.13 {binary mode is synonym of lf mode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation binary - set x [chan configure $f -translation] + chan configure $f -translation +} -cleanup { chan close $f - set x -} lf +} -result lf # # Test chan-io-9.14 has been removed because "auto" output translation mode is # not supoprted. # -test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} { +test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts $f hello\nthere\rand\r\nhere chan close $f set f [open $path(test1) r] chan configure $f -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3462,18 +3565,19 @@ test chan-io-31.14 {Tcl_Write mixed, Tcl_Gets auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello there and here 0 {} 1} -test chan-io-31.15 {Tcl_Write mixed, Tcl_Gets auto} { +} -result {hello there and here 0 {} 1} +test chan-io-31.15 {Tcl_Write mixed, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f hello\nthere\rand\r\nhere\r chan close $f set f [open $path(test1) r] chan configure $f -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3481,17 +3585,18 @@ test chan-io-31.15 {Tcl_Write mixed, Tcl_Gets auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello there and here 0 {} 1} -test chan-io-31.16 {Tcl_Write mixed, Tcl_Gets auto} { +} -result {hello there and here 0 {} 1} +test chan-io-31.16 {Tcl_Write mixed, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f hello\nthere\rand\r\nhere\n chan close $f set f [open $path(test1) r] - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3499,18 +3604,19 @@ test chan-io-31.16 {Tcl_Write mixed, Tcl_Gets auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello there and here 0 {} 1} -test chan-io-31.17 {Tcl_Write mixed, Tcl_Gets auto} { +} -result {hello there and here 0 {} 1} +test chan-io-31.17 {Tcl_Write mixed, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f hello\nthere\rand\r\nhere\r\n chan close $f set f [open $path(test1) r] chan configure $f -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3518,19 +3624,19 @@ test chan-io-31.17 {Tcl_Write mixed, Tcl_Gets auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello there and here 0 {} 1} -test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { +} -result {hello there and here 0 {} 1} +test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf - set s [format "hello\nthere\nand\rhere\n\%c" 26] - chan puts $f $s + chan puts $f [format "hello\nthere\nand\rhere\n\%c" 26] chan close $f set f [open $path(test1) r] chan configure $f -eofchar \x1a -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3538,18 +3644,19 @@ test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello there and here 0 {} 1} -test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { +} -result {hello there and here 0 {} 1} +test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -eofchar \x1a -translation lf chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] chan configure $f -eofchar \x1a -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3557,56 +3664,56 @@ test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {hello there and here 0 {} 1} -test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { +} -result {hello there and here 0 {} 1} +test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -eofchar \x1a chan configure $f -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { +} -result {abc def 0 {} 1} +test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -eofchar \x1a -translation auto - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { +} -result {abc def 0 {} 1} +test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation lf -eofchar {} - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3616,19 +3723,19 @@ test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { +} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation cr -eofchar {} - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3638,19 +3745,19 @@ test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { +} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation crlf -eofchar {} - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3660,119 +3767,121 @@ test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "abc def 0 \x1aqrs 0 tuv 0 {} 1" -test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { +} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1" +test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { +} -result {abc def 0 {} 1} +test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation lf -eofchar \x1a - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { +} -result {abc def 0 {} 1} +test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { +} -result {abc def 0 {} 1} +test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation cr -eofchar \x1a - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { +} -result {abc def 0 {} 1} +test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { +} -result {abc def 0 {} 1} +test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar {} - set s [format "abc\ndef\n%cqrs\ntuv" 26] - chan puts $f $s + chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] chan configure $f -translation crlf -eofchar \x1a - set l "" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {abc def 0 {} 1} -test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { +} -result {abc def 0 {} 1} +test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} -setup { file delete $path(test1) + set c "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf @@ -3783,15 +3892,16 @@ test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { chan close $f set f [open $path(test1) r] chan configure $f -translation crlf - set c "" while {[chan gets $f line] >= 0} { append c $line\n } chan close $f string length $c -} [expr 700*15+1] -test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { +} -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 "" +} -body { set f [open $path(test1) w] chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf @@ -3802,45 +3912,41 @@ test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { chan close $f set f [open $path(test1) r] chan configure $f -translation auto - set c "" while {[chan gets $f line] >= 0} { append c $line\n } chan close $f string length $c -} [expr 700*15+1] +} -result [expr 700*15+1] # Test Tcl_Read and buffering. -test chan-io-32.1 {Tcl_Read, channel not readable} { - list [catch {read stdout} msg] $msg -} {1 {channel "stdout" wasn't opened for reading}} +test chan-io-32.1 {Tcl_Read, channel not readable} -body { + read stdout +} -returnCodes error -result {channel "stdout" wasn't opened for reading} test chan-io-32.2 {Tcl_Read, zero byte count} { chan read stdin 0 } "" -test chan-io-32.3 {Tcl_Read, negative byte count} { +test chan-io-32.3 {Tcl_Read, negative byte count} -setup { set f [open $path(longfile) r] - set l [list [catch {chan read $f -1} msg] $msg] +} -body { + chan read $f -1 +} -returnCodes error -cleanup { chan close $f - set l -} {1 {bad argument "-1": should be "nonewline"}} -test chan-io-32.4 {Tcl_Read, positive byte count} { +} -result {expected non-negative integer but got "-1"} +test chan-io-32.4 {Tcl_Read, positive byte count} -body { set f [open $path(longfile) r] - set x [chan read $f 1024] - set s [string length $x] - unset x + string length [chan read $f 1024] +} -cleanup { chan close $f - set s -} 1024 -test chan-io-32.5 {Tcl_Read, multiple buffers} { +} -result 1024 +test chan-io-32.5 {Tcl_Read, multiple buffers} -body { set f [open $path(longfile) r] chan configure $f -buffersize 100 - set x [chan read $f 1024] - set s [string length $x] - unset x + string length [chan read $f 1024] +} -cleanup { chan close $f - set s -} 1024 +} -result 1024 test chan-io-32.6 {Tcl_Read, very large read} { set f1 [open $path(longfile) r] set z [chan read $f1 1000000] @@ -3849,7 +3955,7 @@ test chan-io-32.6 {Tcl_Read, very large read} { set x ok set z [file size $path(longfile)] if {$z != $l} { - set x broken + set x "$z != $l" } set x } ok @@ -3861,7 +3967,7 @@ test chan-io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set l [string length $z] set x ok if {$l != 20} { - set x broken + set x "$l != 20" } set x } ok @@ -3874,7 +3980,7 @@ test chan-io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set l [string length $z] set z [file size $path(longfile)] if {$z != $l} { - set x broken + set x "$z != $l" } set x } ok @@ -3886,121 +3992,125 @@ test chan-io-32.9 {Tcl_Read, read to end of file} { set x ok set z [file size $path(longfile)] if {$z != $l} { - set x broken + set x "$z != $l" } set x } ok -test chan-io-32.10 {Tcl_Read from a pipe} {stdio openpipe} { +test chan-io-32.10 {Tcl_Read from a pipe} -setup { file delete $path(pipe) +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello chan flush $f1 - set x [chan read $f1] + chan read $f1 +} -cleanup { chan close $f1 - set x -} "hello\n" -test chan-io-32.11 {Tcl_Read from a pipe} {stdio openpipe} { +} -result "hello\n" +test chan-io-32.11 {Tcl_Read from a pipe} -setup { file delete $path(pipe) + set x "" +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello chan flush $f1 - set x "" lappend x [chan read $f1 6] chan puts $f1 hello chan flush $f1 lappend x [chan read $f1] +} -cleanup { chan close $f1 - set x -} {{hello +} -result {{hello } {hello }} -test chan-io-32.12 {Tcl_Read, -nonewline} { +test chan-io-32.12 {Tcl_Read, -nonewline} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan puts $f1 hello chan puts $f1 bye chan close $f1 set f1 [open $path(test1) r] - set c [chan read -nonewline $f1] + chan read -nonewline $f1 +} -cleanup { chan close $f1 - set c -} {hello +} -result {hello bye} -test chan-io-32.13 {Tcl_Read, -nonewline} { +test chan-io-32.13 {Tcl_Read, -nonewline} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan puts $f1 hello chan puts $f1 bye chan close $f1 set f1 [open $path(test1) r] set c [chan read -nonewline $f1] - chan close $f1 list [string length $c] $c -} {9 {hello +} -cleanup { + chan close $f1 +} -result {9 {hello bye}} -test chan-io-32.14 {Tcl_Read, reading in small chunks} { +test chan-io-32.14 {Tcl_Read, reading in small chunks} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan puts $f "Two lines: this one" chan puts $f "and this one" chan close $f set f [open $path(test1)] - set x [list [chan read $f 1] [chan read $f 2] [chan read $f]] + list [chan read $f 1] [chan read $f 2] [chan read $f] +} -cleanup { chan close $f - set x -} {T wo { lines: this one +} -result {T wo { lines: this one and this one }} -test chan-io-32.15 {Tcl_Read, asking for more input than available} { +test chan-io-32.15 {Tcl_Read, asking for more input than available} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan puts $f "Two lines: this one" chan puts $f "and this one" chan close $f set f [open $path(test1)] - set x [chan read $f 100] + chan read $f 100 +} -cleanup { chan close $f - set x -} {Two lines: this one +} -result {Two lines: this one and this one } -test chan-io-32.16 {Tcl_Read, read to end of file with -nonewline} { +test chan-io-32.16 {Tcl_Read, read to end of file with -nonewline} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan puts $f "Two lines: this one" chan puts $f "and this one" chan close $f set f [open $path(test1)] - set x [chan read -nonewline $f] + chan read -nonewline $f +} -cleanup { chan close $f - set x -} {Two lines: this one +} -result {Two lines: this one and this one} # Test Tcl_Gets. -test chan-io-33.1 {Tcl_Gets, reading what was written} { +test chan-io-33.1 {Tcl_Gets, reading what was written} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] - set y "first line" - chan puts $f1 $y + chan puts $f1 "first line" chan close $f1 set f1 [open $path(test1) r] - set x [chan gets $f1] - set z ok - if {"$x" != "$y"} { - set z broken - } + chan gets $f1 +} -cleanup { chan close $f1 - set z -} ok +} -result {first line} test chan-io-33.2 {Tcl_Gets into variable} { set f1 [open $path(longfile) r] set c [chan gets $f1 x] @@ -4012,24 +4122,22 @@ test chan-io-33.2 {Tcl_Gets into variable} { chan close $f1 set z } ok -test chan-io-33.3 {Tcl_Gets from pipe} {stdio openpipe} { +test chan-io-33.3 {Tcl_Gets from pipe} -setup { file delete $path(pipe) +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello chan flush $f1 - set x [chan gets $f1] + chan gets $f1 +} -cleanup { chan close $f1 - set z ok - if {"$x" != "hello"} { - set z broken - } - set z -} ok -test chan-io-33.4 {Tcl_Gets with long line} { +} -result hello +test chan-io-33.4 {Tcl_Gets with long line} -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" @@ -4038,44 +4146,46 @@ test chan-io-33.4 {Tcl_Gets with long line} { chan puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" chan close $f set f [open $path(test3)] - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +} -result {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} test chan-io-33.5 {Tcl_Gets with long line} { set f [open $path(test3)] set x [chan gets $f y] chan close $f list $x $y } {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} -test chan-io-33.6 {Tcl_Gets and end of file} { +test chan-io-33.6 {Tcl_Gets and end of file} -setup { file delete $path(test3) + set x {} +} -body { set f [open $path(test3) w] chan puts -nonewline $f "Test1\nTest2" chan close $f set f [open $path(test3)] - set x {} set y {} lappend x [chan gets $f y] $y set y {} lappend x [chan gets $f y] $y set y {} lappend x [chan gets $f y] $y +} -cleanup { chan close $f - set x -} {5 Test1 5 Test2 -1 {}} -test chan-io-33.7 {Tcl_Gets and bad variable} { +} -result {5 Test1 5 Test2 -1 {}} +test chan-io-33.7 {Tcl_Gets and bad variable} -setup { set f [open $path(test3) w] chan puts $f "Line 1" chan puts $f "Line 2" chan close $f catch {unset x} - set x 24 set f [open $path(test3) r] - set result [list [catch {chan gets $f x(0)} msg] $msg] +} -body { + set x 24 + chan gets $f x(0) +} -returnCodes error -cleanup { chan close $f - set result -} {1 {can't set "x(0)": variable isn't array}} +} -result {can't set "x(0)": variable isn't array} test chan-io-33.8 {Tcl_Gets, exercising double buffering} { set f [open $path(test3) w] chan configure $f -translation lf -eofchar {} @@ -4118,15 +4228,16 @@ test chan-io-33.10 {Tcl_Gets, exercising double buffering} { # Test Tcl_Seek and Tcl_Tell. -test chan-io-34.1 {Tcl_Seek to current position at start of file} { +test chan-io-34.1 {Tcl_Seek to current position at start of file} -body { set f1 [open $path(longfile) r] chan seek $f1 0 current - set c [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set c -} 0 -test chan-io-34.2 {Tcl_Seek to offset from start} { +} -result 0 +test chan-io-34.2 {Tcl_Seek to offset from start} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4134,12 +4245,13 @@ test chan-io-34.2 {Tcl_Seek to offset from start} { chan close $f1 set f1 [open $path(test1) r] chan seek $f1 10 start - set c [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set c -} 10 -test chan-io-34.3 {Tcl_Seek to end of file} { +} -result 10 +test chan-io-34.3 {Tcl_Seek to end of file} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4147,12 +4259,13 @@ test chan-io-34.3 {Tcl_Seek to end of file} { chan close $f1 set f1 [open $path(test1) r] chan seek $f1 0 end - set c [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set c -} 54 -test chan-io-34.4 {Tcl_Seek to offset from end of file} { +} -result 54 +test chan-io-34.4 {Tcl_Seek to offset from end of file} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4160,12 +4273,13 @@ test chan-io-34.4 {Tcl_Seek to offset from end of file} { chan close $f1 set f1 [open $path(test1) r] chan seek $f1 -10 end - set c [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set c -} 44 -test chan-io-34.5 {Tcl_Seek to offset from current position} { +} -result 44 +test chan-io-34.5 {Tcl_Seek to offset from current position} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4174,12 +4288,13 @@ test chan-io-34.5 {Tcl_Seek to offset from current position} { set f1 [open $path(test1) r] chan seek $f1 10 current chan seek $f1 10 current - set c [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set c -} 20 -test chan-io-34.6 {Tcl_Seek to offset from end of file} { +} -result 20 +test chan-io-34.6 {Tcl_Seek to offset from end of file} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4187,14 +4302,14 @@ test chan-io-34.6 {Tcl_Seek to offset from end of file} { chan close $f1 set f1 [open $path(test1) r] chan seek $f1 -10 end - set c [chan tell $f1] - set r [chan read $f1] + list [chan tell $f1] [chan read $f1] +} -cleanup { chan close $f1 - list $c $r -} {44 {rstuvwxyz +} -result {44 {rstuvwxyz }} -test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position} { +test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4205,19 +4320,20 @@ test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position set c1 [chan tell $f1] set r1 [chan read $f1 5] chan seek $f1 0 current - set c2 [chan tell $f1] - chan close $f1 - list $c1 $r1 $c2 -} {44 rstuv 49} -test chan-io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} { - set f1 [open "|[list [interpreter]]" r+] - set x [list [catch {chan seek $f1 0 current} msg] $msg] + list $c1 $r1 [chan tell $f1] +} -cleanup { chan close $f1 - regsub {".*":} $x {"":} x - string tolower $x -} {1 {error during seek on "": invalid argument}} -test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} { +} -result {44 rstuv 49} +test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup { + set pipe [openpipe] +} -constraints {stdio openpipe} -body { + chan seek $pipe 0 current +} -returnCodes error -cleanup { + chan close $pipe +} -match glob -result {error during seek on "*": invalid argument} +test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan configure $f -eofchar {} chan puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" @@ -4236,9 +4352,9 @@ test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} { lappend x [chan read $f 1] chan seek $f 1 lappend x [chan read $f 1] +} -cleanup { chan close $f - set x -} {a d a l Y {} b} +} -result {a d a l Y {} b} set path(test3) [makeFile {} test3] test chan-io-34.10 {Tcl_Seek testing flushing of buffered input} { set f [open $path(test3) w] @@ -4282,15 +4398,17 @@ test chan-io-34.12 {Tcl_Seek testing combination of write, seek back and read} { } {14 {xyz 123 xyzzy} zzy} -test chan-io-34.13 {Tcl_Tell at start of file} { +test chan-io-34.13 {Tcl_Tell at start of file} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] - set p [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set p -} 0 -test chan-io-34.14 {Tcl_Tell after seek to end of file} { +} -result 0 +test chan-io-34.14 {Tcl_Tell after seek to end of file} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4298,12 +4416,13 @@ test chan-io-34.14 {Tcl_Tell after seek to end of file} { chan close $f1 set f1 [open $path(test1) r] chan seek $f1 0 end - set c1 [chan tell $f1] + chan tell $f1 +} -cleanup { chan close $f1 - set c1 -} 54 -test chan-io-34.15 {Tcl_Tell combined with seeking} { +} -result 54 +test chan-io-34.15 {Tcl_Tell combined with seeking} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -eofchar {} chan puts $f1 "abcdefghijklmnopqrstuvwxyz" @@ -4313,18 +4432,18 @@ test chan-io-34.15 {Tcl_Tell combined with seeking} { chan seek $f1 10 start set c1 [chan tell $f1] chan seek $f1 10 current - set c2 [chan tell $f1] + list $c1 [chan tell $f1] +} -cleanup { chan close $f1 - list $c1 $c2 -} {10 20} -test chan-io-34.16 {Tcl_Tell on pipe: always -1} {stdio openpipe} { - set f1 [open "|[list [interpreter]]" r+] - set c [chan tell $f1] +} -result {10 20} +test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints {stdio openpipe} -body { + set f1 [openpipe] + chan tell $f1 +} -cleanup { chan close $f1 - set c -} -1 +} -result -1 test chan-io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { - set f1 [open "|[list [interpreter]]" r+] + set f1 [openpipe] chan puts $f1 {chan puts hello} chan flush $f1 set c [chan tell $f1] @@ -4332,8 +4451,9 @@ test chan-io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { chan close $f1 set c } -1 -test chan-io-34.18 {Tcl_Tell combined with seeking and reading} { +test chan-io-34.18 {Tcl_Tell combined with seeking and reading} -setup { file delete $path(test2) +} -body { set f [open $path(test2) w] chan configure $f -translation lf -eofchar {} chan puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n" @@ -4349,23 +4469,24 @@ test chan-io-34.18 {Tcl_Tell combined with seeking and reading} { lappend x [chan tell $f] chan seek $f 0 end lappend x [chan tell $f] +} -cleanup { chan close $f - set x -} {0 3 2 12 30} -test chan-io-34.19 {Tcl_Tell combined with opening in append mode} { +} -result {0 3 2 12 30} +test chan-io-34.19 {Tcl_Tell combined with opening in append mode} -body { set f [open $path(test3) w] chan configure $f -translation lf -eofchar {} chan puts $f "abcdefghijklmnopqrstuvwxyz" chan puts $f "abcdefghijklmnopqrstuvwxyz" chan close $f set f [open $path(test3) a] - set c [chan tell $f] + chan tell $f +} -cleanup { chan close $f - set c -} 54 -test chan-io-34.20 {Tcl_Tell combined with writing} { - set f [open $path(test3) w] +} -result 54 +test chan-io-34.20 {Tcl_Tell combined with writing} -setup { set l "" +} -body { + set f [open $path(test3) w] chan seek $f 29 start lappend l [chan tell $f] chan puts -nonewline $f a @@ -4375,14 +4496,15 @@ test chan-io-34.20 {Tcl_Tell combined with writing} { lappend l [chan tell $f] chan seek $f 407 end lappend l [chan tell $f] +} -cleanup { chan close $f - set l -} {29 39 40 447} -test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} { +} -result {29 39 40 447} +test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} -setup { file delete $path(test3) + set l "" +} -constraints {largefileSupport} -body { set f [open $path(test3) w] chan configure $f -encoding binary - set l "" lappend l [chan tell $f] chan puts -nonewline $f abcdef lappend l [chan tell $f] @@ -4398,13 +4520,13 @@ test chan-io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} { # truncate... chan close [open $path(test3) w] lappend l [file size $f] - set l -} {0 6 6 4294967296 4294967302 4294967302 0} +} -result {0 6 6 4294967296 4294967302 4294967302 0} # Test Tcl_Eof -test chan-io-35.1 {Tcl_Eof} { +test chan-io-35.1 {Tcl_Eof} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan puts $f hello chan puts $f hello @@ -4419,16 +4541,17 @@ test chan-io-35.1 {Tcl_Eof} { chan gets $f lappend x [chan eof $f] lappend x [chan eof $f] +} -cleanup { chan close $f - set x -} {0 0 0 0 1 1} -test chan-io-35.2 {Tcl_Eof with pipe} {stdio openpipe} { +} -result {0 0 0 0 1 1} +test chan-io-35.2 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { file delete $path(pipe) +} -body { set f1 [open $path(pipe) w] chan puts $f1 {chan gets stdin} chan puts $f1 {chan puts hello} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello set x [chan eof $f1] chan flush $f1 @@ -4437,16 +4560,17 @@ test chan-io-35.2 {Tcl_Eof with pipe} {stdio openpipe} { lappend x [chan eof $f1] chan gets $f1 lappend x [chan eof $f1] +} -cleanup { chan close $f1 - set x -} {0 0 0 1} -test chan-io-35.3 {Tcl_Eof with pipe} {stdio openpipe} { +} -result {0 0 0 1} +test chan-io-35.3 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { file delete $path(pipe) +} -body { set f1 [open $path(pipe) w] chan puts $f1 {chan gets stdin} chan puts $f1 {chan puts hello} chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan puts $f1 hello set x [chan eof $f1] chan flush $f1 @@ -4459,37 +4583,39 @@ test chan-io-35.3 {Tcl_Eof with pipe} {stdio openpipe} { lappend x [chan eof $f1] chan gets $f1 lappend x [chan eof $f1] +} -cleanup { chan close $f1 - set x -} {0 0 0 1 1 1} -test chan-io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { +} -result {0 0 0 1 1 1} +test chan-io-35.4 {Tcl_Eof, eof detection on nonblocking file} -setup { file delete $path(test1) - set f [open $path(test1) w] - chan close $f + set l "" +} -constraints {nonBlockFiles} -body { + chan close [open $path(test1) w] set f [open $path(test1) r] chan configure $f -blocking off - set l "" lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {{} 1} -test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} { +} -result {{} 1} +test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup { file delete $path(pipe) + set l "" +} -constraints {stdio openpipe} -body { set f [open $path(pipe) w] chan puts $f { exit } chan close $f - set f [open "|[list [interpreter] $path(pipe)]" r] - set l "" + set f [openpipe r $path(pipe)] lappend l [chan gets $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {{} 1} -test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} { +} -result {{} 1} +test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar \x1a chan puts $f abc\ndef @@ -4497,13 +4623,13 @@ test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} { set s [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $s [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $s $l $e -} {9 8 1} -test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} { +} -result {9 8 1} +test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar \x1a chan puts $f abc\ndef @@ -4511,13 +4637,13 @@ test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} { set s [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation lf -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $s [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $s $l $e -} {9 8 1} -test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} { +} -result {9 8 1} +test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar \x1a chan puts $f abc\ndef @@ -4525,13 +4651,13 @@ test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} { set s [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $s [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $s $l $e -} {9 8 1} -test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} { +} -result {9 8 1} +test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar \x1a chan puts $f abc\ndef @@ -4539,13 +4665,13 @@ test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} { set s [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation cr -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $s [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $s $l $e -} {9 8 1} -test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { +} -result {9 8 1} +test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar \x1a chan puts $f abc\ndef @@ -4553,13 +4679,13 @@ test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { set s [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $s [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $s $l $e -} {11 8 1} -test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { +} -result {11 8 1} +test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar \x1a chan puts $f abc\ndef @@ -4567,112 +4693,106 @@ test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { set s [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation crlf -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $s [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $s $l $e -} {11 8 1} -test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { +} -result {11 8 1} +test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set i [format abc\ndef\n%cqrs\nuvw 26] - chan puts $f $i + chan puts $f [format abc\ndef\n%cqrs\nuvw 26] chan close $f set c [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $c [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $l $e -} {17 8 1} -test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { +} -result {17 8 1} +test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation lf -eofchar {} - set i [format abc\ndef\n%cqrs\nuvw 26] - chan puts $f $i + chan puts $f [format abc\ndef\n%cqrs\nuvw 26] chan close $f set c [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation lf -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $c [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $l $e -} {17 8 1} -test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { +} -result {17 8 1} +test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar {} - set i [format abc\ndef\n%cqrs\nuvw 26] - chan puts $f $i + chan puts $f [format abc\ndef\n%cqrs\nuvw 26] chan close $f set c [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $c [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $l $e -} {17 8 1} -test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { +} -result {17 8 1} +test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation cr -eofchar {} - set i [format abc\ndef\n%cqrs\nuvw 26] - chan puts $f $i + chan puts $f [format abc\ndef\n%cqrs\nuvw 26] chan close $f set c [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation cr -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $c [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $l $e -} {17 8 1} -test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { +} -result {17 8 1} +test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar {} - set i [format abc\ndef\n%cqrs\nuvw 26] - chan puts $f $i + chan puts $f [format abc\ndef\n%cqrs\nuvw 26] chan close $f set c [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation auto -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $c [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $l $e -} {21 8 1} -test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { +} -result {21 8 1} +test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -translation crlf -eofchar {} - set i [format abc\ndef\n%cqrs\nuvw 26] - chan puts $f $i + chan puts $f [format abc\ndef\n%cqrs\nuvw 26] chan close $f set c [file size $path(test1)] set f [open $path(test1) r] chan configure $f -translation crlf -eofchar \x1a - set l [string length [chan read $f]] - set e [chan eof $f] + list $c [string length [chan read $f]] [chan eof $f] +} -cleanup { chan close $f - list $c $l $e -} {21 8 1} +} -result {21 8 1} # Test Tcl_InputBlocked -test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { - set f1 [open "|[list [interpreter]]" r+] +test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup { + set x "" +} -constraints {stdio openpipe} -body { + set f1 [openpipe] chan puts $f1 {chan puts hello_from_pipe} chan flush $f1 chan gets $f1 chan configure $f1 -blocking off -buffering full chan puts $f1 {chan puts hello} - set x "" lappend x [chan gets $f1] lappend x [chan blocked $f1] chan flush $f1 @@ -4681,133 +4801,135 @@ test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { lappend x [chan blocked $f1] lappend x [chan gets $f1] lappend x [chan blocked $f1] +} -cleanup { chan close $f1 - set x -} {{} 1 hello 0 {} 1} -test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} { - set f1 [open "|[list [interpreter]]" r+] +} -result {{} 1 hello 0 {} 1} +test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} -setup { + set x "" +} -constraints {stdio openpipe} -body { + set f1 [openpipe] chan configure $f1 -buffering line chan puts $f1 {chan puts hello_from_pipe} - set x "" lappend x [chan gets $f1] lappend x [chan blocked $f1] chan puts $f1 {exit} lappend x [chan gets $f1] lappend x [chan blocked $f1] lappend x [chan eof $f1] +} -cleanup { chan close $f1 - set x -} {hello_from_pipe 0 {} 0 1} -test chan-io-36.3 {Tcl_InputBlocked vs files, short read} { +} -result {hello_from_pipe 0 {} 0 1} +test chan-io-36.3 {Tcl_InputBlocked vs files, short read} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan puts $f abcdefghijklmnop chan close $f set f [open $path(test1) r] - set l "" lappend l [chan blocked $f] lappend l [chan read $f 3] lappend l [chan blocked $f] lappend l [chan read -nonewline $f] lappend l [chan blocked $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {0 abc 0 defghijklmnop 0 1} -test chan-io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} { - proc in {f} { - variable l - variable x - lappend l [chan read $f 3] - if {[chan eof $f]} {lappend l eof; chan close $f; set x done} - } +} -result {0 abc 0 defghijklmnop 0 1} +test chan-io-36.4 {Tcl_InputBlocked vs files, event driven read} -setup { file delete $path(test1) + set l "" + variable x +} -constraints {fileevent} -body { set f [open $path(test1) w] chan puts $f abcdefghijklmnop chan close $f set f [open $path(test1) r] - set l "" - chan event $f readable [namespace code [list in $f]] - variable x + chan event $f readable [namespace code { + lappend l [chan read $f 3] + if {[chan eof $f]} {lappend l eof; chan close $f; set x done} + }] vwait [namespace which -variable x] - set l -} {abc def ghi jkl mno {p + return $l +} -result {abc def ghi jkl mno {p } eof} -test chan-io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} { +test chan-io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} -setup { file delete $path(test1) + set l "" +} -constraints {nonBlockFiles} -body { set f [open $path(test1) w] chan puts $f abcdefghijklmnop chan close $f set f [open $path(test1) r] chan configure $f -blocking off - set l "" lappend l [chan blocked $f] lappend l [chan read $f 3] lappend l [chan blocked $f] lappend l [chan read -nonewline $f] lappend l [chan blocked $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} {0 abc 0 defghijklmnop 0 1} -test chan-io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} { - proc in {f} { - variable l - variable x - lappend l [chan read $f 3] - if {[chan eof $f]} {lappend l eof; chan close $f; set x done} - } +} -result {0 abc 0 defghijklmnop 0 1} +test chan-io-36.6 {Tcl_InputBlocked vs files, event driven read} -setup { file delete $path(test1) + set l "" + variable x +} -constraints {nonBlockFiles fileevent} -body { set f [open $path(test1) w] chan puts $f abcdefghijklmnop chan close $f set f [open $path(test1) r] chan configure $f -blocking off - set l "" - chan event $f readable [namespace code [list in $f]] - variable x + chan event $f readable [namespace code { + lappend l [chan read $f 3] + if {[chan eof $f]} {lappend l eof; chan close $f; set x done} + }] vwait [namespace which -variable x] - set l -} {abc def ghi jkl mno {p + return $l +} -result {abc def ghi jkl mno {p } eof} # Test Tcl_InputBuffered -test chan-io-37.1 {Tcl_InputBuffered} {testchannel} { +test chan-io-37.1 {Tcl_InputBuffered} -setup { + set l "" +} -constraints {testchannel} -body { set f [open $path(longfile) r] chan configure $f -buffersize 4096 chan read $f 3 - set l "" lappend l [testchannel inputbuffered $f] lappend l [chan tell $f] +} -cleanup { chan close $f - set l -} {4093 3} -test chan-io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} { +} -result {4093 3} +test chan-io-37.2 {Tcl_InputBuffered, test input flushing on seek} -setup { + set l "" +} -constraints {testchannel} -body { set f [open $path(longfile) r] chan configure $f -buffersize 4096 chan read $f 3 - set l "" lappend l [testchannel inputbuffered $f] lappend l [chan tell $f] chan seek $f 0 current lappend l [testchannel inputbuffered $f] lappend l [chan tell $f] +} -cleanup { chan close $f - set l -} {4093 3 0 3} +} -result {4093 3 0 3} # Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize -test chan-io-38.1 {Tcl_GetChannelBufferSize, default buffer size} { +test chan-io-38.1 {Tcl_GetChannelBufferSize, default buffer size} -body { set f [open $path(longfile) r] - set s [chan configure $f -buffersize] + chan configure $f -buffersize +} -cleanup { chan close $f - set s -} 4096 -test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { - set f [open $path(longfile) r] +} -result 4096 +test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} -setup { set l "" +} -body { + set f [open $path(longfile) r] lappend l [chan configure $f -buffersize] chan configure $f -buffersize 10000 lappend l [chan configure $f -buffersize] @@ -4821,9 +4943,9 @@ test chan-io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { lappend l [chan configure $f -buffersize] chan configure $f -buffersize 10000000 lappend l [chan configure $f -buffersize] +} -cleanup { chan close $f - set l -} {4096 10000 1 1 1 100000 1048576} +} -result {4096 10000 1 1 1 100000 1048576} test chan-io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { # This test crashes the interp if Bug #427196 is not fixed set chan [open [info script] r] @@ -4836,35 +4958,39 @@ test chan-io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} # Test Tcl_SetChannelOption, Tcl_GetChannelOption -test chan-io-39.1 {Tcl_GetChannelOption} { +test chan-io-39.1 {Tcl_GetChannelOption} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] - set x [chan configure $f1 -blocking] + chan configure $f1 -blocking +} -cleanup { chan close $f1 - set x -} 1 +} -result 1 # # Test 17.2 was removed. # -test chan-io-39.2 {Tcl_GetChannelOption} { +test chan-io-39.2 {Tcl_GetChannelOption} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] - set x [chan configure $f1 -buffering] + chan configure $f1 -buffering +} -cleanup { chan close $f1 - set x -} full -test chan-io-39.3 {Tcl_GetChannelOption} { +} -result full +test chan-io-39.3 {Tcl_GetChannelOption} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -buffering line - set x [chan configure $f1 -buffering] + chan configure $f1 -buffering +} -cleanup { chan close $f1 - set x -} line -test chan-io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { +} -result line +test chan-io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} -setup { file delete $path(test1) - set f1 [open $path(test1) w] set l "" +} -body { + set f1 [open $path(test1) w] lappend l [chan configure $f1 -buffering] chan configure $f1 -buffering line lappend l [chan configure $f1 -buffering] @@ -4874,47 +5000,51 @@ test chan-io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { lappend l [chan configure $f1 -buffering] chan configure $f1 -buffering full lappend l [chan configure $f1 -buffering] +} -cleanup { chan close $f1 - set l -} {full line none line full} -test chan-io-39.5 {Tcl_GetChannelOption, invariance} { +} -result {full line none line full} +test chan-io-39.5 {Tcl_GetChannelOption, invariance} -setup { file delete $path(test1) - set f1 [open $path(test1) w] set l "" +} -body { + set f1 [open $path(test1) w] lappend l [chan configure $f1 -buffering] lappend l [list [catch {chan configure $f1 -buffering green} msg] $msg] lappend l [chan configure $f1 -buffering] +} -cleanup { chan close $f1 - set l -} {full {1 {bad value for -buffering: must be one of full, line, or none}} full} -test chan-io-39.6 {Tcl_SetChannelOption, multiple options} { +} -result {full {1 {bad value for -buffering: must be one of full, line, or none}} full} +test chan-io-39.6 {Tcl_SetChannelOption, multiple options} -setup { file delete $path(test1) +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf -buffering line chan puts $f1 hello chan puts $f1 bye - set x [file size $path(test1)] + file size $path(test1) +} -cleanup { chan close $f1 - set x -} 10 -test chan-io-39.7 {Tcl_SetChannelOption, buffering, translation} { +} -result 10 +test chan-io-39.7 {Tcl_SetChannelOption, buffering, translation} -setup { file delete $path(test1) + set x "" +} -body { set f1 [open $path(test1) w] chan configure $f1 -translation lf chan puts $f1 hello chan puts $f1 bye - set x "" chan configure $f1 -buffering line lappend x [file size $path(test1)] chan puts $f1 really_bye lappend x [file size $path(test1)] +} -cleanup { chan close $f1 - set x -} {0 21} -test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} { +} -result {0 21} +test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} -setup { file delete $path(test1) - set f1 [open $path(test1) w] set l "" +} -body { + set f1 [open $path(test1) w] chan configure $f1 -translation lf -buffering none -eofchar {} chan puts -nonewline $f1 hello lappend l [file size $path(test1)] @@ -4929,14 +5059,14 @@ test chan-io-39.8 {Tcl_SetChannelOption, different buffering options} { lappend l [file size $path(test1)] chan close $f1 lappend l [file size $path(test1)] - set l -} {5 10 10 10 20 20} -test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { +} -result {5 10 10 10 20 20} +test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} -setup { file delete $path(test1) + set x "" +} -constraints {nonBlockFiles} -body { set f1 [open $path(test1) w] chan close $f1 set f1 [open $path(test1) r] - set x "" lappend x [chan configure $f1 -blocking] chan configure $f1 -blocking off lappend x [chan configure $f1 -blocking] @@ -4944,11 +5074,13 @@ test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { lappend x [chan read $f1 1000] lappend x [chan blocked $f1] lappend x [chan eof $f1] +} -cleanup { chan close $f1 - set x -} {1 0 {} {} 0 1} -test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { +} -result {1 0 {} {} 0 1} +test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup { file delete $path(pipe) + set x "" +} -constraints {stdio openpipe} -body { set f1 [open $path(pipe) w] chan puts $f1 { chan gets stdin @@ -4957,8 +5089,7 @@ test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { chan gets stdin } chan close $f1 - set x "" - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan configure $f1 -blocking off -buffering line lappend x [chan configure $f1 -blocking] lappend x [chan gets $f1] @@ -4980,71 +5111,78 @@ test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { lappend x [chan eof $f1] lappend x [chan gets $f1] lappend x [chan eof $f1] +} -cleanup { chan close $f1 - set x -} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1} -test chan-io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size clipped to lower bound} { +} -result {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1} +test chan-io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size clipped to lower bound} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -buffersize -10 - set x [chan configure $f -buffersize] + chan configure $f -buffersize +} -cleanup { chan close $f - set x -} 1 -test chan-io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size clipped to upper bound} { +} -result 1 +test chan-io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size clipped to upper bound} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -buffersize 10000000 - set x [chan configure $f -buffersize] + chan configure $f -buffersize +} -cleanup { chan close $f - set x -} 1048576 -test chan-io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { +} -result 1048576 +test chan-io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -buffersize 40000 - set x [chan configure $f -buffersize] + chan configure $f -buffersize +} -cleanup { chan close $f - set x -} 40000 -test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { +} -result 40000 +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 puts -nonewline $f \xe7\x89\xa6 chan close $f set f [open $path(test1) r] chan configure $f -encoding utf-8 - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} \u7266 -test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { +} -result \u7266 +test chan-io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] chan configure $f -encoding binary chan puts -nonewline $f \xe7\x89\xa6 chan close $f set f [open $path(test1) r] chan configure $f -encoding utf-8 - set x [chan read $f] + chan read $f +} -cleanup { chan close $f - set x -} \u7266 -test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} { +} -result \u7266 +test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup { file delete $path(test1) set f [open $path(test1) w] - set result [list [catch {chan configure $f -encoding foobar} msg] $msg] +} -body { + chan configure $f -encoding foobar +} -returnCodes error -cleanup { chan close $f - set result -} {1 {unknown encoding "foobar"}} -test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} { - set f [open "|[list [interpreter] $path(cat)]" r+] +} -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 { + set f [openpipe r+ $path(cat)] chan configure $f -encoding binary chan puts -nonewline $f "\xe7" chan flush $f chan configure $f -encoding utf-8 -blocking 0 - variable x {} chan event $f readable [namespace code { lappend x [chan read $f] }] vwait [namespace which -variable x] after 300 [namespace code { lappend x timeout }] @@ -5057,105 +5195,113 @@ test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_ vwait [namespace which -variable x] after 300 [namespace code { lappend x timeout }] vwait [namespace which -variable x] + return $x +} -cleanup { chan close $f - set x -} "{} timeout {} timeout \xe7 timeout" +} -result "{} timeout {} timeout \xe7 timeout" test chan-io-39.18 {Tcl_SetChannelOption, setting read mode independently} \ - {socket} { + -constraints {socket} -body { proc accept {s a p} {chan close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update chan configure $s2 -translation {auto lf} - set modes [chan configure $s2 -translation] + chan configure $s2 -translation +} -cleanup { chan close $s1 chan close $s2 - set modes -} {auto lf} +} -result {auto lf} test chan-io-39.19 {Tcl_SetChannelOption, setting read mode independently} \ - {socket} { + -constraints {socket} -body { proc accept {s a p} {chan close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update chan configure $s2 -translation {auto crlf} - set modes [chan configure $s2 -translation] + chan configure $s2 -translation +} -cleanup { chan close $s1 chan close $s2 - set modes -} {auto crlf} +} -result {auto crlf} test chan-io-39.20 {Tcl_SetChannelOption, setting read mode independently} \ - {socket} { + -constraints {socket} -body { proc accept {s a p} {chan close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update chan configure $s2 -translation {auto cr} - set modes [chan configure $s2 -translation] + chan configure $s2 -translation +} -cleanup { chan close $s1 chan close $s2 - set modes -} {auto cr} +} -result {auto cr} test chan-io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ - {socket} { + -constraints {socket} -body { proc accept {s a p} {chan close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update chan configure $s2 -translation {auto auto} - set modes [chan configure $s2 -translation] + chan configure $s2 -translation +} -cleanup { chan close $s1 chan close $s2 - set modes -} {auto crlf} -test chan-io-39.22 {Tcl_SetChannelOption, invariance} {unix} { +} -result {auto crlf} +test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { file delete $path(test1) - set f1 [open $path(test1) w+] set l "" +} -constraints {unix} -body { + set f1 [open $path(test1) w+] lappend l [chan configure $f1 -eofchar] chan configure $f1 -eofchar {ON GO} lappend l [chan configure $f1 -eofchar] chan configure $f1 -eofchar D lappend l [chan configure $f1 -eofchar] +} -cleanup { chan close $f1 - set l -} {{{} {}} {O G} {D D}} -test chan-io-39.22a {Tcl_SetChannelOption, invariance} { +} -result {{{} {}} {O G} {D D}} +test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup { file delete $path(test1) - set f1 [open $path(test1) w+] set l [list] +} -body { + set f1 [open $path(test1) w+] chan configure $f1 -eofchar {ON GO} lappend l [chan configure $f1 -eofchar] chan configure $f1 -eofchar D lappend l [chan configure $f1 -eofchar] lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg] +} -cleanup { chan close $f1 - set l -} {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} -test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or - writeable, it should still have valid -eofchar and -translation options } { +} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} +test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or\ + writeable, it should still have valid -eofchar and -translation options} -setup { set l [list] +} -body { set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - lappend l [chan configure $sock -eofchar] [chan configure $sock -translation] + lappend l [chan configure $sock -eofchar] \ + [chan configure $sock -translation] +} -cleanup { chan close $sock - set l -} {{{}} auto} -test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or - writable so we can't change -eofchar or -translation } { +} -result {{{}} auto} +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 { 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] [chan configure $sock -translation] + lappend l [chan configure $sock -eofchar] \ + [chan configure $sock -translation] +} -cleanup { chan close $sock - set l -} {{{}} auto} +} -result {{{}} auto} -test chan-io-40.1 {POSIX open access modes: RDWR} { +test chan-io-40.1 {POSIX open access modes: RDWR} -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan puts $f xyzzy chan close $f @@ -5166,11 +5312,12 @@ test chan-io-40.1 {POSIX open access modes: RDWR} { chan close $f set f [open $path(test3) r] lappend x [chan gets $f] +} -cleanup { chan close $f - set x -} {zzy abzzy} -test chan-io-40.2 {POSIX open access modes: CREAT} {unix} { +} -result {zzy abzzy} +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] file stat $path(test3) stats set x [format "0%o" [expr $stats(mode)&0o777]] @@ -5178,19 +5325,20 @@ test chan-io-40.2 {POSIX open access modes: CREAT} {unix} { chan close $f set f [open $path(test3) r] lappend x [chan gets $f] +} -cleanup { chan close $f - set x -} {0600 {line 1}} -test chan-io-40.3 {POSIX open access modes: CREAT} {unix umask} { - # This test only works if your umask is 2, like ouster's. +} -result {0600 {line 1}} +test chan-io-40.3 {POSIX open access modes: CREAT} -setup { file delete $path(test3) - set f [open $path(test3) {WRONLY CREAT}] - chan close $f +} -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] -} [format %04o [expr {0o666 & ~ $umaskValue}]] -test chan-io-40.4 {POSIX open access modes: CREAT} { +} -result [format %04o [expr {0o666 & ~ $umaskValue}]] +test chan-io-40.4 {POSIX open access modes: CREAT} -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan configure $f -eofchar {} chan puts $f xyzzy @@ -5200,12 +5348,14 @@ test chan-io-40.4 {POSIX open access modes: CREAT} { chan puts -nonewline $f "ab" chan close $f set f [open $path(test3) r] - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} abzzy -test chan-io-40.5 {POSIX open access modes: APPEND} { +} -result abzzy +test chan-io-40.5 {POSIX open access modes: APPEND} -setup { file delete $path(test3) + set x "" +} -body { set f [open $path(test3) w] chan configure $f -translation lf -eofchar {} chan puts $f xyzzy @@ -5218,30 +5368,32 @@ test chan-io-40.5 {POSIX open access modes: APPEND} { chan close $f set f [open $path(test3) r] chan configure $f -translation lf - set x "" chan seek $f 6 current lappend x [chan gets $f] lappend x [chan gets $f] +} -cleanup { chan close $f - set x -} {{new line} abc} -test chan-io-40.6 {POSIX open access modes: EXCL} -match regexp -body { +} -result {{new line} abc} +test chan-io-40.6 {POSIX open access modes: EXCL} -match regexp -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan puts $f xyzzy chan close $f open $path(test3) {WRONLY CREAT EXCL} } -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists} -test chan-io-40.7 {POSIX open access modes: EXCL} { +test chan-io-40.7 {POSIX open access modes: EXCL} -setup { file delete $path(test3) +} -body { set f [open $path(test3) {WRONLY CREAT EXCL}] chan configure $f -eofchar {} chan puts $f "A test line" chan close $f viewFile test3 -} {A test line} -test chan-io-40.8 {POSIX open access modes: TRUNC} { +} -result {A test line} +test chan-io-40.8 {POSIX open access modes: TRUNC} -setup { file delete $path(test3) +} -body { set f [open $path(test3) w] chan puts $f xyzzy chan close $f @@ -5249,32 +5401,31 @@ test chan-io-40.8 {POSIX open access modes: TRUNC} { chan puts $f abc chan close $f set f [open $path(test3) r] - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} abc -test chan-io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable unix} { +} -result abc +test chan-io-40.9 {POSIX open access modes: NONBLOCK} -setup { file delete $path(test3) +} -constraints {nonPortable unix} -body { set f [open $path(test3) {WRONLY NONBLOCK CREAT}] chan puts $f "NONBLOCK test" chan close $f set f [open $path(test3) r] - set x [chan gets $f] + chan gets $f +} -cleanup { chan close $f - set x -} {NONBLOCK test} -test chan-io-40.10 {POSIX open access modes: RDONLY} { +} -result {NONBLOCK test} +test chan-io-40.10 {POSIX open access modes: RDONLY} -body { set f [open $path(test1) w] chan puts $f "two lines: this one" chan puts $f "and this" chan close $f set f [open $path(test1) RDONLY] - set x [list [chan gets $f] [catch {chan puts $f Test} msg] $msg] + list [chan gets $f] [catch {chan puts $f Test} msg] $msg +} -cleanup { chan close $f - string compare [string tolower $x] \ - [list {two lines: this one} 1 \ - [format "channel \"%s\" wasn't opened for writing" $f]] -} 0 +} -match glob -result {{two lines: this one} 1 {channel "*" wasn't opened for writing}} test chan-io-40.11 {POSIX open access modes: RDONLY} -match regexp -body { file delete $path(test3) open $path(test3) RDONLY @@ -5283,7 +5434,7 @@ test chan-io-40.12 {POSIX open access modes: WRONLY} -match regexp -body { file delete $path(test3) open $path(test3) WRONLY } -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} -test chan-io-40.13 {POSIX open access modes: WRONLY} { +test chan-io-40.13 {POSIX open access modes: WRONLY} -body { makeFile xyzzy test3 set f [open $path(test3) WRONLY] chan configure $f -eofchar {} @@ -5292,9 +5443,7 @@ test chan-io-40.13 {POSIX open access modes: WRONLY} { set x [list [catch {chan gets $f} msg] $msg] chan close $f lappend x [viewFile test3] - string compare [string tolower $x] \ - [list 1 "channel \"$f\" wasn't opened for reading" abzzy] -} 0 +} -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 @@ -5315,29 +5464,30 @@ test chan-io-40.16 {tilde substitution in open} -constraints makeFileInHome -set } -cleanup { removeFile _test_ ~ } -result 1 -test chan-io-40.17 {tilde substitution in open} { +test chan-io-40.17 {tilde substitution in open} -setup { set home $::env(HOME) +} -body { unset ::env(HOME) - set x [list [catch {open ~/foo} msg] $msg] + open ~/foo +} -returnCodes error -cleanup { set ::env(HOME) $home - set x -} {1 {couldn't find HOME environment variable to expand path}} +} -result {couldn't find HOME environment variable to expand path} -test chan-io-41.1 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {chan event foo} msg] $msg -} {1 {wrong # args: should be "chan event channelId event ?script?"}} -test chan-io-41.2 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {chan event foo bar baz q} msg] $msg -} {1 {wrong # args: should be "chan event channelId event ?script?"}} -test chan-io-41.3 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {chan event gorp readable} msg] $msg -} {1 {can not find channel named "gorp"}} -test chan-io-41.4 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {chan event gorp writable} msg] $msg -} {1 {can not find channel named "gorp"}} -test chan-io-41.5 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {chan event gorp who-knows} msg] $msg -} {1 {bad event name "who-knows": must be readable or writable}} +test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body { + chan event foo +} -returnCodes error -result {wrong # args: should be "chan event channelId event ?script?"} +test chan-io-41.2 {Tcl_FileeventCmd: errors} -constraints fileevent -body { + chan event foo bar baz q +} -returnCodes error -result {wrong # args: should be "chan event channelId event ?script?"} +test chan-io-41.3 {Tcl_FileeventCmd: errors} -constraints fileevent -body { + chan event gorp readable +} -returnCodes error -result {can not find channel named "gorp"} +test chan-io-41.4 {Tcl_FileeventCmd: errors} -constraints fileevent -body { + chan event gorp writable +} -returnCodes error -result {can not find channel named "gorp"} +test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body { + chan event gorp who-knows +} -returnCodes error -result {bad event name "who-knows": must be readable or writable} # # Test chan event on a file @@ -5372,7 +5522,6 @@ test chan-io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {file lappend result [chan event $f readable] } {13 11 12 {}} - test chan-io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs fileevent} { set result {} chan event $f readable "script 1" @@ -5387,8 +5536,8 @@ test chan-io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixEx 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+] -} -constraints {stdio unixExecs fileevent openpipe} -body { set result {} +} -constraints {stdio unixExecs fileevent openpipe} -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" @@ -5415,14 +5564,12 @@ test chan-io-44.1 {FileEventProc procedure: normal read event} -setup { chan puts $f2 text; chan flush $f2 variable x initial vwait [namespace which -variable x] - set x + return $x } -cleanup { catch {chan close $f2} catch {chan close $f3} } -result {text} -test chan-io-44.2 {FileEventProc procedure: error in read event} -constraints { - stdio unixExecs fileevent openpipe -} -setup { +test chan-io-44.2 {FileEventProc procedure: error in read event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] proc myHandler {msg options} { @@ -5430,7 +5577,7 @@ test chan-io-44.2 {FileEventProc procedure: error in read event} -constraints { } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] -} -body { +} -constraints {stdio unixExecs fileevent openpipe} -body { chan event $f2 readable {error bogus} chan puts $f2 text; chan flush $f2 variable x initial @@ -5457,14 +5604,12 @@ test chan-io-44.3 {FileEventProc procedure: normal write event} -setup { vwait [namespace which -variable x] vwait [namespace which -variable x] vwait [namespace which -variable x] - set x + return $x } -cleanup { catch {chan close $f2} catch {chan close $f3} } -result {initial triggered triggered triggered} -test chan-io-44.4 {FileEventProc procedure: eror in write event} -constraints { - stdio unixExecs fileevent openpipe -} -setup { +test chan-io-44.4 {FileEventProc procedure: eror in write event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] proc myHandler {msg options} { @@ -5472,7 +5617,7 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -constraints { } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] -} -body { +} -constraints {stdio unixExecs fileevent openpipe} -body { chan event $f2 writable {error bad-write} variable x initial vwait [namespace which -variable x] @@ -5483,7 +5628,7 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -constraints { catch {chan close $f3} } -result {bad-write {}} test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { - set f4 [open "|[list [interpreter] $path(cat) << foo]" r] + set f4 [openpipe r $path(cat) << foo] chan event $f4 readable [namespace code { if {[chan gets $f4 line] < 0} { lappend x eof @@ -5510,7 +5655,9 @@ test chan-io-45.1 {DeleteFileEvent, cleanup on chan close} {fileevent} { }] chan close $f set x initial - after 100 [namespace code { set y done }] + after 100 [namespace code { + set y done + }] variable y vwait [namespace which -variable y] set x @@ -5519,9 +5666,9 @@ test chan-io-45.2 {DeleteFileEvent, cleanup on chan close} {fileevent} { set f [open $path(foo) r] set f2 [open $path(foo) r] chan event $f readable [namespace code { - lappend x "f triggered: \"[chan gets $f]\"" - chan event $f readable {} - }] + lappend x "f triggered: \"[chan gets $f]\"" + chan event $f readable {} + }] chan event $f2 readable [namespace code { lappend x "f2 triggered: \"[chan gets $f2]\"" chan event $f2 readable {} @@ -5595,30 +5742,32 @@ test chan-io-46.3 {Tcl event loop vs multiple interpreters} testfevent { } } {0 0 {0 timer}} -test chan-io-47.1 {chan event vs multiple interpreters} {testfevent fileevent} { +test chan-io-47.1 {chan event vs multiple interpreters} -setup { set f [open $path(foo) r] set f2 [open $path(foo) r] set f3 [open $path(foo) r] + set x {} +} -constraints {testfevent fileevent} -body { chan event $f readable {script 1} testfevent create testfevent share $f2 testfevent cmd "chan event $f2 readable {script 2}" chan event $f3 readable {sript 3} - set x {} lappend x [chan event $f2 readable] testfevent delete lappend x [chan event $f readable] [chan event $f2 readable] \ [chan event $f3 readable] +} -cleanup { chan close $f chan close $f2 chan close $f3 - set x -} {{} {script 1} {} {sript 3}} -test chan-io-47.2 {deleting chan event on interpreter delete} {testfevent fileevent} { +} -result {{} {script 1} {} {sript 3}} +test chan-io-47.2 {deleting chan event on interpreter delete} -setup { set f [open $path(foo) r] set f2 [open $path(foo) r] set f3 [open $path(foo) r] set f4 [open $path(foo) r] +} -constraints {testfevent fileevent} -body { chan event $f readable {script 1} testfevent create testfevent share $f2 @@ -5627,19 +5776,20 @@ test chan-io-47.2 {deleting chan event on interpreter delete} {testfevent fileev chan event $f3 readable {script 3}" chan event $f4 readable {script 4} testfevent delete - set x [list [chan event $f readable] [chan event $f2 readable] \ - [chan event $f3 readable] [chan event $f4 readable]] + list [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] [chan event $f4 readable] +} -cleanup { chan close $f chan close $f2 chan close $f3 chan close $f4 - set x -} {{script 1} {} {} {script 4}} -test chan-io-47.3 {deleting chan event on interpreter delete} {testfevent fileevent} { +} -result {{script 1} {} {} {script 4}} +test chan-io-47.3 {deleting chan event on interpreter delete} -setup { set f [open $path(foo) r] set f2 [open $path(foo) r] set f3 [open $path(foo) r] set f4 [open $path(foo) r] +} -constraints {testfevent fileevent} -body { testfevent create testfevent share $f3 testfevent share $f4 @@ -5648,56 +5798,56 @@ test chan-io-47.3 {deleting chan event on interpreter delete} {testfevent fileev testfevent cmd "chan event $f3 readable {script 3} chan event $f4 readable {script 4}" testfevent delete - set x [list [chan event $f readable] [chan event $f2 readable] \ - [chan event $f3 readable] [chan event $f4 readable]] + list [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] [chan event $f4 readable] +} -cleanup { chan close $f chan close $f2 chan close $f3 chan close $f4 - set x -} {{script 1} {script 2} {} {}} -test chan-io-47.4 {file events on shared files and multiple interpreters} {testfevent fileevent} { +} -result {{script 1} {script 2} {} {}} +test chan-io-47.4 {file events on shared files and multiple interpreters} -setup { set f [open $path(foo) r] set f2 [open $path(foo) r] +} -constraints {testfevent fileevent} -body { testfevent create testfevent share $f testfevent cmd "chan event $f readable {script 1}" chan event $f readable {script 2} chan event $f2 readable {script 3} - set x [list [chan event $f2 readable] \ - [testfevent cmd "chan event $f readable"] \ - [chan event $f readable]] + list [chan event $f2 readable] [testfevent cmd "chan event $f readable"] \ + [chan event $f readable] +} -cleanup { testfevent delete chan close $f chan close $f2 - set x -} {{script 3} {script 1} {script 2}} -test chan-io-47.5 {file events on shared files, deleting file events} {testfevent fileevent} { +} -result {{script 3} {script 1} {script 2}} +test chan-io-47.5 {file events on shared files, deleting file events} -setup { set f [open $path(foo) r] +} -body { testfevent create testfevent share $f testfevent cmd "chan event $f readable {script 1}" chan event $f readable {script 2} testfevent cmd "chan event $f readable {}" - set x [list [testfevent cmd "chan event $f readable"] \ - [chan event $f readable]] + list [testfevent cmd "chan event $f readable"] [chan event $f readable] +} -constraints {testfevent fileevent} -cleanup { testfevent delete chan close $f - set x -} {{} {script 2}} -test chan-io-47.6 {file events on shared files, deleting file events} {testfevent fileevent} { +} -result {{} {script 2}} +test chan-io-47.6 {file events on shared files, deleting file events} -setup { set f [open $path(foo) r] +} -body { testfevent create testfevent share $f testfevent cmd "chan event $f readable {script 1}" chan event $f readable {script 2} chan event $f readable {} - set x [list [testfevent cmd "chan event $f readable"] \ - [chan event $f readable]] + list [testfevent cmd "chan event $f readable"] [chan event $f readable] +} -constraints {testfevent fileevent} -cleanup { testfevent delete chan close $f - set x -} {{script 1} {}} +} -result {{script 1} {}} set path(bar) [makeFile {} bar] @@ -5710,10 +5860,7 @@ test chan-io-48.1 {testing readability conditions} {fileevent} { chan puts $f abcdefg chan close $f set f [open $path(bar) r] - chan event $f readable [namespace code [list consume $f]] - proc consume {f} { - variable l - variable x + chan event $f readable [namespace code { lappend l called if {[chan eof $f]} { chan close $f @@ -5721,7 +5868,7 @@ test chan-io-48.1 {testing readability conditions} {fileevent} { } else { chan gets $f } - } + }] set l "" variable x not_done vwait [namespace which -variable x] @@ -5736,11 +5883,7 @@ test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { chan puts $f abcdefg chan close $f set f [open $path(bar) r] - chan event $f readable [namespace code [list consume $f]] - chan configure $f -blocking off - proc consume {f} { - variable x - variable l + chan event $f readable [namespace code { lappend l called if {[chan eof $f]} { chan close $f @@ -5748,14 +5891,17 @@ test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { } else { chan gets $f } - } + }] + chan configure $f -blocking off set l "" variable x not_done vwait [namespace which -variable x] list $x $l } {done {called called called called called called called}} set path(my_script) [makeFile {} my_script] -test chan-io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe fileevent} { +test chan-io-48.3 {testing readability conditions} -setup { + set l "" +} -constraints {stdio unix nonBlockFiles openpipe fileevent} -body { set f [open $path(bar) w] chan puts $f abcdefg chan puts $f abcdefg @@ -5774,13 +5920,8 @@ test chan-io-48.3 {testing readability conditions} {stdio unix nonBlockFiles ope } } chan close $f - set f [open "|[list [interpreter]]" r+] - chan event $f readable [namespace code [list consume $f]] - chan configure $f -buffering line - chan configure $f -blocking off - proc consume {f} { - variable l - variable x + set f [openpipe] + chan event $f readable [namespace code { if {[chan eof $f]} { set x done } else { @@ -5789,28 +5930,31 @@ test chan-io-48.3 {testing readability conditions} {stdio unix nonBlockFiles ope chan gets $f lappend l [chan blocked $f] } - } - set l "" + }] + chan configure $f -buffering line + chan configure $f -blocking off variable x not_done chan puts $f [list source $path(my_script)] chan puts $f "set f \[[list open $path(bar) r]]" chan puts $f {copy_slowly $f} chan puts $f {exit} vwait [namespace which -variable x] - chan close $f list $x $l -} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} -test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} { +} -cleanup { + chan close $f +} -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} +test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation lf - variable c [format "abc\ndef\n%c" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable l - variable c - variable x + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5818,27 +5962,23 @@ test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation lf - set c [format "abc\ndef\n%cfoo\nbar\n" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5846,27 +5986,23 @@ test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation cr - set c [format "abc\ndef\n%c" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5874,27 +6010,23 @@ test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation cr - set c [format "abc\ndef\n%cfoo\nbar\n" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable c - variable x + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5902,27 +6034,23 @@ test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation crlf - set c [format "abc\ndef\n%c" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5930,27 +6058,23 @@ test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mo lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation crlf - set c [format "abc\ndef\n%cfoo\nbar\n" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable c - variable x + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5958,27 +6082,23 @@ test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation lf - set c [format "abc\ndef\n%cfoo\nbar\n" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable c - variable x + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation lf + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -5986,27 +6106,23 @@ test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} { lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation lf - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation lf - set c [format "abc\ndef\n%c" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -translation lf -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6014,27 +6130,23 @@ test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation cr - set c [format "abc\ndef\n%cfoo\nbar\n" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable l - variable x - variable c + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation cr + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6042,27 +6154,23 @@ test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} { lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation cr - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation cr - set c [format "abc\ndef\n%c" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable c - variable x - variable l + set f [open $path(test1) r] + chan configure $f -translation cr -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6070,27 +6178,23 @@ test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation crlf - set c [format "abc\ndef\n%cfoo\nbar\n" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f - proc consume {f} { - variable c - variable x - variable l + set f [open $path(test1) r] + chan configure $f -eofchar \x1a -translation crlf + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6098,27 +6202,23 @@ test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mod lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation crlf - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} -test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {fileevent} { +} -result {3 {abc def {}}} +test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} -setup { file delete $path(test1) + set c 0 + set l "" +} -constraints {fileevent} -body { set f [open $path(test1) w] chan configure $f -translation crlf - set c [format "abc\ndef\n%c" 26] - chan puts -nonewline $f $c + chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f - proc consume {f} { - variable c - variable x - variable l + set f [open $path(test1) r] + chan configure $f -translation crlf -eofchar \x1a + chan event $f readable [namespace code { if {[chan eof $f]} { set x done chan close $f @@ -6126,25 +6226,21 @@ test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} { lappend l [chan gets $f] incr c } - } - set c 0 - set l "" - set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1a - chan event $f readable [namespace code [list consume $f]] + }] variable x vwait [namespace which -variable x] list $c $l -} {3 {abc def {}}} +} -result {3 {abc def {}}} -test chan-io-49.1 {testing crlf reading, leftover cr disgorgment} { +test chan-io-49.1 {testing crlf reading, leftover cr disgorgment} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\rb\rc\r\n" chan close $f set f [open $path(test1) r] - set l "" lappend l [file size $path(test1)] chan configure $f -translation crlf lappend l [chan read $f 1] @@ -6162,18 +6258,19 @@ test chan-io-49.1 {testing crlf reading, leftover cr disgorgment} { lappend l [chan eof $f] lappend l [chan read $f 1] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 { +} -result "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 { } 7 0 {} 1" -test chan-io-49.2 {testing crlf reading, leftover cr disgorgment} { +test chan-io-49.2 {testing crlf reading, leftover cr disgorgment} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\rb\rc\r\n" chan close $f set f [open $path(test1) r] - set l "" lappend l [file size $path(test1)] chan configure $f -translation crlf lappend l [chan read $f 2] @@ -6186,17 +6283,18 @@ test chan-io-49.2 {testing crlf reading, leftover cr disgorgment} { lappend l [chan read $f 2] lappend l [chan tell $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1" -test chan-io-49.3 {testing crlf reading, leftover cr disgorgment} { +} -result "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1" +test chan-io-49.3 {testing crlf reading, leftover cr disgorgment} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\rb\rc\r\n" chan close $f set f [open $path(test1) r] - set l "" lappend l [file size $path(test1)] chan configure $f -translation crlf lappend l [chan read $f 3] @@ -6207,17 +6305,18 @@ test chan-io-49.3 {testing crlf reading, leftover cr disgorgment} { lappend l [chan read $f 3] lappend l [chan tell $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1" -test chan-io-49.4 {testing crlf reading, leftover cr disgorgment} { +} -result "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1" +test chan-io-49.4 {testing crlf reading, leftover cr disgorgment} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\rb\rc\r\n" chan close $f set f [open $path(test1) r] - set l "" lappend l [file size $path(test1)] chan configure $f -translation crlf lappend l [chan read $f 3] @@ -6228,17 +6327,18 @@ test chan-io-49.4 {testing crlf reading, leftover cr disgorgment} { lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1" -test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} { +} -result "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1" +test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} -setup { file delete $path(test1) + set l "" +} -body { set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "a\rb\rc\r\n" chan close $f set f [open $path(test1) r] - set l "" lappend l [file size $path(test1)] chan configure $f -translation crlf lappend l [set x [chan gets $f]] @@ -6246,30 +6346,31 @@ test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} { lappend l [chan gets $f] lappend l [chan tell $f] lappend l [chan eof $f] +} -cleanup { chan close $f - set l -} [list 7 a\rb\rc 7 {} 7 1] +} -result [list 7 a\rb\rc 7 {} 7 1] -test chan-io-50.1 {testing handler deletion} {testchannelevent} { +test chan-io-50.1 {testing handler deletion} -setup { file delete $path(test1) +} -constraints {testchannelevent} -body { set f [open $path(test1) w] chan close $f set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f]] - proc delhandler {f} { - variable z - set z called + testchannelevent $f add readable [namespace code { + variable z called testchannelevent $f delete 0 - } - set z not_called + }] + variable z not_called update + return $z +} -cleanup { chan close $f - set z -} called -test chan-io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} { +} -result called +test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) - set f [open $path(test1) w] - chan close $f + 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]] @@ -6278,20 +6379,20 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} {testchannel lappend z "called delhandler $f $i" testchannelevent $f delete 0 } - set z "" update - chan close $f - string compare [string tolower $z] \ + string equal $z \ [list [list called delhandler $f 0] [list called delhandler $f 1]] -} 0 -test chan-io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} { - file delete $path(test1) - set f [open $path(test1) w] +} -cleanup { chan close $f +} -result 1 +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]] - set z "" proc notcalled {f i} { variable z lappend z "notcalled was called!! $f $i" @@ -6303,23 +6404,21 @@ test chan-io-50.3 {testing handler deletion with multiple handlers} {testchannel testchannelevent $f delete 0 lappend z "delhandler $f $i deleted myself" } - set z "" update - chan close $f - string compare [string tolower $z] \ + string equal $z \ [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] -} 0 -test chan-io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -cleanup { + chan close $f +} -result 1 +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 { set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delrecursive $f]] - proc delrecursive {f} { - variable z - variable u - if {"$u" == "recursive"} { + testchannelevent $f add readable [namespace code { + if {$u eq "recursive"} { testchannelevent $f delete 0 lappend z "delrecursive deleting recursive" } else { @@ -6327,18 +6426,19 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} {testchanneleven set u recursive update } - } + }] variable u toplevel variable z "" update + return $z +} -cleanup { chan close $f - string compare [string tolower $z] \ - {{delrecursive calling recursive} {delrecursive deleting recursive}} -} 0 -test chan-io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -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]] @@ -6349,7 +6449,7 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} {testchanneleven proc del {f} { variable u variable z - if {"$u" == "recursive"} { + if {$u eq "recursive"} { testchannelevent $f delete 1 testchannelevent $f delete 0 lappend z "del deleted notcalled" @@ -6364,22 +6464,23 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} {testchanneleven set z "" set u toplevel update + return $z +} -cleanup { chan close $f - string compare [string tolower $z] \ - [list {del calling recursive} {del deleted notcalled} \ - {del deleted myself} {del after update}] -} 0 -test chan-io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -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]] proc first {f} { variable u variable z - if {"$u" == "toplevel"} { + if {$u eq "toplevel"} { lappend z "first called" set u first update @@ -6391,11 +6492,11 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} {testchanneleven proc second {f} { variable u variable z - if {"$u" == "first"} { + if {$u eq "first"} { lappend z "second called, first time" set u second testchannelevent $f delete 0 - } elseif {"$u" == "second"} { + } elseif {$u eq "second"} { lappend z "second called, second time" testchannelevent $f delete 0 } else { @@ -6406,74 +6507,74 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} {testchanneleven set z "" set u toplevel update + return $z +} -cleanup { chan 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 update}] -test chan-io-51.1 {Test old socket deletion on Macintosh} {socket} { +test chan-io-51.1 {Test old socket deletion on Macintosh} -setup { set x 0 set result "" + variable wait "" +} -constraints {socket} -body { proc accept {s a p} { variable x - variable wait chan configure $s -blocking off chan puts $s "sock[incr x]" chan close $s - set wait done + variable wait done } set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set port [lindex [chan configure $ss -sockname] 2] - variable wait "" set cs [socket 127.0.0.1 $port] vwait [namespace which -variable wait] lappend result [chan gets $cs] chan close $cs - set wait "" set cs [socket 127.0.0.1 $port] vwait [namespace which -variable wait] lappend result [chan gets $cs] chan close $cs - set wait "" set cs [socket 127.0.0.1 $port] vwait [namespace which -variable wait] lappend result [chan gets $cs] chan close $cs - set wait "" set cs [socket 127.0.0.1 $port] vwait [namespace which -variable wait] lappend result [chan gets $cs] +} -cleanup { chan close $cs chan close $ss - set result -} {sock1 sock2 sock3 sock4} +} -result {sock1 sock2 sock3 sock4} -test chan-io-52.1 {TclCopyChannel} {fcopy} { +test chan-io-52.1 {TclCopyChannel} -constraints {fcopy} -setup { file delete $path(test1) +} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] - chan copy $f1 $f2 -command { # } - catch { chan copy $f1 $f2 } msg + chan copy $f1 $f2 -command " # " + chan copy $f1 $f2 +} -returnCodes error -cleanup { chan close $f1 chan close $f2 - string compare $msg "channel \"$f1\" is busy" -} {0} -test chan-io-52.2 {TclCopyChannel} {fcopy} { +} -match glob -result {channel "*" is busy} +test chan-io-52.2 {TclCopyChannel} -constraints {fcopy} -setup { file delete $path(test1) +} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] set f3 [open $thisScript] - chan copy $f1 $f2 -command { # } - catch { chan copy $f3 $f2 } msg + chan copy $f1 $f2 -command " # " + chan copy $f3 $f2 +} -returnCodes error -cleanup { chan close $f1 chan close $f2 chan close $f3 - string compare $msg "channel \"$f2\" is busy" -} {0} -test chan-io-52.3 {TclCopyChannel} {fcopy} { +} -match glob -result {channel "*" is busy} +test chan-io-52.3 {TclCopyChannel} -constraints {fcopy} -setup { file delete $path(test1) +} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6484,13 +6585,14 @@ test chan-io-52.3 {TclCopyChannel} {fcopy} { chan close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } - set result -} {0 0 ok} -test chan-io-52.4 {TclCopyChannel} {fcopy} { + return $result +} -result {0 0 ok} +test chan-io-52.4 {TclCopyChannel} -constraints {fcopy} -setup { file delete $path(test1) +} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6500,9 +6602,10 @@ test chan-io-52.4 {TclCopyChannel} {fcopy} { chan close $f1 chan close $f2 lappend result [file size $path(test1)] -} {0 0 40} -test chan-io-52.5 {TclCopyChannel, all} {fcopy} { +} -result {0 0 40} +test chan-io-52.5 {TclCopyChannel, all} -constraints {fcopy} -setup { file delete $path(test1) +} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6511,15 +6614,14 @@ test chan-io-52.5 {TclCopyChannel, all} {fcopy} { set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 chan close $f2 - set s1 [file size $thisScript] - set s2 [file size $path(test1)] - if {"$s1" == "$s2"} { + if {[file size $thisScript] == [file size $path(test1)]} { lappend result ok } - set result -} {0 0 ok} -test chan-io-52.5a {TclCopyChannel, all, other negative value} {fcopy} { + return $result +} -result {0 0 ok} +test chan-io-52.5a {TclCopyChannel, all, other negative value} -setup { file delete $path(test1) +} -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6528,15 +6630,14 @@ test chan-io-52.5a {TclCopyChannel, all, other negative value} {fcopy} { set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 chan close $f2 - set s1 [file size $thisScript] - set s2 [file size $path(test1)] - if {"$s1" == "$s2"} { + if {[file size $thisScript] == [file size $path(test1)]} { lappend result ok } - set result -} {0 0 ok} -test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} { + return $result +} -result {0 0 ok} +test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} -setup { file delete $path(test1) +} -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6545,15 +6646,14 @@ test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} { set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 chan close $f2 - set s1 [file size $thisScript] - set s2 [file size $path(test1)] - if {"$s1" == "$s2"} { + if {[file size $thisScript] == [file size $path(test1)]} { lappend result ok } - set result -} {0 0 ok} -test chan-io-52.6 {TclCopyChannel} {fcopy} { + return $result +} -result {0 0 ok} +test chan-io-52.6 {TclCopyChannel} -setup { file delete $path(test1) +} -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6564,31 +6664,32 @@ test chan-io-52.6 {TclCopyChannel} {fcopy} { chan close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } - set result -} {0 0 ok} -test chan-io-52.7 {TclCopyChannel} {fcopy} { + return $result +} -result {0 0 ok} +test chan-io-52.7 {TclCopyChannel} -constraints {fcopy} -setup { file delete $path(test1) +} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 chan configure $f2 -translation lf -blocking 0 chan copy $f1 $f2 set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] - set s1 [file size $thisScript] - set s2 [file size $path(test1)] - chan close $f1 - chan close $f2 - if {"$s1" == "$s2"} { + if {[file size $thisScript] == [file size $path(test1)]} { lappend result ok } - set result -} {0 0 ok} -test chan-io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { + return $result +} -cleanup { + chan close $f1 + chan close $f2 +} -result {0 0 ok} +test chan-io-52.8 {TclCopyChannel} -setup { file delete $path(test1) file delete $path(pipe) +} -constraints {stdio openpipe fcopy} -body { set f1 [open $path(pipe) w] chan configure $f1 -translation lf chan puts $f1 " @@ -6600,7 +6701,7 @@ test chan-io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { chan close \$f1 " chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] chan configure $f1 -translation lf chan gets $f1 chan puts $f1 ready @@ -6611,7 +6712,7 @@ test chan-io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { catch {chan close $f1} chan close $f2 list $s0 [file size $path(test1)] -} {40 40} +} -result {40 40} # Empty files, to register them with the test facility set path(kyrillic.txt) [makeFile {} kyrillic.txt] set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt] @@ -6668,8 +6769,9 @@ test chan-io-52.11 {TclCopyChannel & encodings} {fcopy} { file size $path(kyrillic.txt) } 3 -test chan-io-53.1 {CopyData} {fcopy} { +test chan-io-53.1 {CopyData} -setup { file delete $path(test1) +} -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6679,9 +6781,10 @@ test chan-io-53.1 {CopyData} {fcopy} { chan close $f1 chan close $f2 lappend result [file size $path(test1)] -} {0 0 0} -test chan-io-53.2 {CopyData} {fcopy} { +} -result {0 0 0} +test chan-io-53.2 {CopyData} -setup { file delete $path(test1) +} -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 @@ -6694,18 +6797,19 @@ test chan-io-53.2 {CopyData} {fcopy} { chan close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } - set result -} {0 0 ok} -test chan-io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} { + return $result +} -result {0 0 ok} +test chan-io-53.3 {CopyData: background read underflow} -setup { file delete $path(test1) file delete $path(pipe) +} -constraints {stdio unix openpipe fcopy} -body { set f1 [open $path(pipe) w] chan puts -nonewline $f1 { chan puts ready - chan flush stdout ;# Don't assume line buffered! + chan flush stdout ;# Don't assume line buffered! chan copy stdin stdout -command { set x } vwait x set f [} @@ -6716,7 +6820,7 @@ test chan-io-53.3 {CopyData: background read underflow} {stdio unix openpipe fco chan close $f } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] set result [chan gets $f1] chan puts $f1 line1 chan flush $f1 @@ -6728,10 +6832,10 @@ test chan-io-53.3 {CopyData: background read underflow} {stdio unix openpipe fco after 500 set f [open $path(test1)] lappend result [chan read $f] +} -cleanup { chan close $f - set result -} "ready line1 line2 {done\n}" -test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileevent fcopy} { +} -result "ready line1 line2 {done\n}" +test chan-io-53.4 {CopyData: background write overflow} -setup { set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n variable x for {set x 0} {$x < 12} {incr x} { @@ -6739,6 +6843,7 @@ test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fil } file delete $path(test1) file delete $path(pipe) +} -constraints {stdio unix openpipe fileevent fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts ready @@ -6750,7 +6855,7 @@ test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fil chan close $f } chan close $f1 - set f1 [open "|[list [interpreter] $path(pipe)]" r+] + set f1 [openpipe r+ $path(pipe)] set result [chan gets $f1] chan configure $f1 -blocking 0 chan puts $f1 $big @@ -6764,10 +6869,11 @@ test chan-io-53.4 {CopyData: background write overflow} {stdio unix openpipe fil } }] vwait [namespace which -variable x] - chan close $f1 + return $x +} -cleanup { set big {} - set x -} done + chan close $f1 +} -result done set result {} proc FcopyTestAccept {sock args} { after 1000 "chan close $sock" @@ -6796,25 +6902,27 @@ test chan-io-53.5 {CopyData: error during chan copy} {socket fcopy} { chan close $out set fcopyTestDone ;# 1 for error condition } 1 -test chan-io-53.6 {CopyData: error during chan copy} {stdio openpipe fcopy} { +test chan-io-53.6 {CopyData: error during chan copy} -setup { variable fcopyTestDone file delete $path(pipe) file delete $path(test1) catch {unset fcopyTestDone} +} -constraints {stdio openpipe fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 "exit 1" chan close $f1 - set in [open "|[list [interpreter] $path(pipe)]" r+] + set in [openpipe r+ $path(pipe)] set out [open $path(test1) w] chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone if ![info exists fcopyTestDone] { vwait [namespace which -variable fcopyTestDone] } + return $fcopyTestDone ;# 0 for plain end of file +} -cleanup { catch {chan close $in} chan close $out - set fcopyTestDone ;# 0 for plain end of file -} {0} +} -result 0 proc doFcopy {in out {bytes 0} {error {}}} { variable fcopyTestDone variable fcopyTestCount @@ -6829,10 +6937,11 @@ proc doFcopy {in out {bytes 0} {error {}}} { -command [namespace code [list doFcopy $in $out]]] } } -test chan-io-53.7 {CopyData: Flooding chan copy from pipe} {stdio openpipe fcopy} { +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 { set fcopyTestCount 0 set f1 [open $path(pipe) w] chan puts $f1 { @@ -6851,21 +6960,22 @@ test chan-io-53.7 {CopyData: Flooding chan copy from pipe} {stdio openpipe fcopy exit 0 } chan close $f1 - set in [open "|[list [interpreter] $path(pipe) &]" r+] + set in [openpipe r+ $path(pipe) &] 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 {chan close $in} - chan close $out # -1=error 0=script error N=number of bytes expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1 -} {3450} +} -cleanup { + catch {chan close $in} + chan close $out +} -result {3450} test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { # copy progress callback. errors out intentionally - proc ::cmd args { + proc cmd args { lappend ::RES "CMD $args" error !STOP } @@ -6885,12 +6995,12 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. - chan copy $f $g -size 2 -command ::cmd + chan copy $f $g -size 2 -command [namespace code cmd] # Check that -command was not called synchronously set sbs [file size $bar] lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs - # Now let the async part happen. Should capture the error in cmd - # via bgerror. If not break the event loop via timer. + # Now let the async part happen. Should capture the error in cmd via + # bgerror. If not break the event loop via timer. set token [after 1000 { lappend ::RES {bgerror/FAIL timeout} set ::forever has-been-reached @@ -6898,20 +7008,19 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se vwait ::forever catch {after cancel $token} # Report - set ::RES + return $::RES } -cleanup { chan close $f chan close $g catch {unset ::RES} catch {unset ::forever} - rename ::cmd {} rename ::bgerror {} removeFile foo removeFile bar } -result {0 sync/OK 0 {CMD 2} {bgerror/OK !STOP}} test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} -setup { - # copy progress callback. errors out intentionally - proc ::cmd args { + # copy progress callback. + proc cmd args { lappend ::RES "CMD $args" set ::forever has-been-reached return @@ -6927,7 +7036,7 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at chan seek $f 0 end ; chan read $f 1 set ::RES [chan eof $f] # Run the copy. Should not invoke -command now. - chan copy $f $g -size 2 -command ::cmd + chan copy $f $g -size 2 -command [namespace code cmd] # Check that -command was not called synchronously lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}] # Now let the async part happen. Should capture the eof in cmd @@ -6939,13 +7048,12 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at vwait ::forever catch {after cancel $token} # Report - set ::RES + return $::RES } -cleanup { chan close $f chan close $g catch {unset ::RES} catch {unset ::forever} - rename ::cmd {} removeFile foo removeFile bar } -result {1 sync/OK {CMD 0}} @@ -6992,8 +7100,10 @@ test chan-io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { } -cleanup { chan close $pipe rename ::done {} - after 1000; # Allow Windows time to figure out that the + if {[testConstraint win]} { + after 1000; # Allow Windows time to figure out that the # process is gone + } catch {close $out} catch {removeFile out} catch {removeFile err} @@ -7021,7 +7131,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { global l srv chan configure $sok -translation binary -buffering none lappend l $sok - if {[llength $l]==2} { + if {[llength $l] == 2} { chan close $srv foreach {a b} $l break chan copy $a $b -command [list geof $a] @@ -7041,7 +7151,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { # wait for OK from server. chan gets $pipe # Now the two clients. - proc ::done {sock} { + proc done {sock} { if {[chan eof $sock]} { chan close $sock ; return } lappend ::forever [chan gets $sock] return @@ -7050,8 +7160,8 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { set b [socket 127.0.0.1 9999] chan configure $a -translation binary -buffering none chan configure $b -translation binary -buffering none - chan event $a readable [list ::done $a] - chan event $b readable [list ::done $b] + chan event $a readable [namespace code "done $a"] + chan event $b readable [namespace code "done $b"] } -constraints {stdio openpipe fcopy} -body { # Now pass data through the server in both directions. set ::forever {} @@ -7064,8 +7174,9 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { catch {chan close $a} catch {chan close $b} chan close $pipe - rename ::done {} - after 1000 ;# Give Windows time to kill the process + if {[testConstraint win]} { + after 1000 ;# Give Windows time to kill the process + } removeFile err catch {unset ::forever} } -result {AB BA} @@ -7095,7 +7206,9 @@ test chan-io-54.1 {Recursive channel events} {socket fileevent} { # completes. set done 0 for {set i 0} {$i < 10} {incr i} { - if {![catch {set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]}]} { + if {![catch { + set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]] + }]} then { set done 1 break } @@ -7121,9 +7234,11 @@ test chan-io-54.1 {Recursive channel events} {socket fileevent} { chan close $cs list $result $x } {{{line 1} 1 2} 2} -test chan-io-54.2 {Testing for busy-wait in recursive channel events} {socket fileevent} { +test chan-io-54.2 {Testing for busy-wait in recursive channel events} -setup { set accept {} set after {} + variable done 0 +} -constraints {socket fileevent} -body { variable s [socket -server [namespace code accept] -myaddr 127.0.0.1 0] proc accept {s a p} { variable counter 0 @@ -7135,17 +7250,20 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} {socket fi variable counter variable after incr counter - set l [chan gets $s] - if {"$l" == ""} { + if {[chan gets $s] eq ""} { chan event $s readable [namespace code "doit1 $s"] - set after [after 1000 [namespace code newline]] + set after [after 1000 [namespace code { + chan puts $writer hello + chan flush $writer + set done 1 + }]] } } proc doit1 {s} { variable counter variable accept incr counter - set l [chan gets $s] + chan gets $s chan close $s set accept {} } @@ -7157,22 +7275,15 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} {socket fi chan puts -nonewline $writer hello chan flush $writer } - proc newline {} { - variable done - variable writer - chan puts $writer hello - chan flush $writer - set done 1 - } producer - variable done vwait [namespace which -variable done] chan close $writer chan close $s after cancel $after + return $counter +} -cleanup { if {$accept ne {}} {chan close $accept} - set counter -} 1 +} -result 1 set path(fooBar) [makeFile {} fooBar] @@ -7196,7 +7307,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] - set x + return $x } -cleanup { interp bgerror {} $handler } -result {got_error} @@ -7222,14 +7333,15 @@ test chan-io-56.1 {ChannelTimerProc} {testchannelevent} { lappend result $y } {2 done} -test chan-io-57.1 {buffered data and file events, gets} {fileevent} { +test chan-io-57.1 {buffered data and file events, gets} -setup { + variable s2 +} -constraints {fileevent} -body { proc accept {sock args} { variable s2 set s2 $sock } set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]] - variable s2 vwait [namespace which -variable s2] update chan event $s2 readable [namespace code {lappend result readable}] @@ -7240,19 +7352,21 @@ test chan-io-57.1 {buffered data and file events, gets} {fileevent} { vwait [namespace which -variable result] lappend result [chan gets $s2] vwait [namespace which -variable result] + return $result +} -cleanup { chan close $s chan close $s2 chan close $server - set result -} {12 readable 34567890 timer} -test chan-io-57.2 {buffered data and file events, read} {fileevent} { +} -result {12 readable 34567890 timer} +test chan-io-57.2 {buffered data and file events, read} -setup { + variable s2 +} -constraints {fileevent} -body { proc accept {sock args} { variable s2 set s2 $sock } set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0] set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]] - variable s2 vwait [namespace which -variable s2] update chan event $s2 readable [namespace code {lappend result readable}] @@ -7263,11 +7377,12 @@ test chan-io-57.2 {buffered data and file events, read} {fileevent} { vwait [namespace which -variable result] lappend result [chan read $s2 9] vwait [namespace which -variable result] + return $result +} -cleanup { chan close $s chan close $s2 chan close $server - set result -} {1 readable 234567890 timer} +} -result {1 readable 234567890 timer} test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} { set out [open $path(script) w] @@ -7288,7 +7403,7 @@ test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc ope } } chan close $out - set pipe [open "|[list [interpreter] $path(script)]" r] + set pipe [openpipe r $path(script)] chan event $pipe readable [namespace code [list readit $pipe]] variable x "" set result "" @@ -7301,7 +7416,6 @@ test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} { # More complicated tests (like that the reference changes as a channel is # moved from thread to thread) can be done only in the extension which # fully implements the moving of channels between threads, i.e. 'Threads'. - # Or we have to extend [testthread] as well. set f [open $path(longfile) r] set result [testchannel mthread $f] chan close $f @@ -7327,7 +7441,7 @@ test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent} { } } chan close $out - set pipe [open "|[list [interpreter] $path(script)]" r] + set pipe [openpipe r $path(script)] chan event $pipe readable [namespace code [list readit $pipe]] variable x "" set result "" @@ -7358,9 +7472,8 @@ test chan-io-61.1 {Reset eof state after changing the eof char} -setup { #chan seek $f 0 start #chan seek $f 0 current #lappend res [chan read $f; chan tell $f] - chan close $f - set res } -cleanup { + chan close $f removeFile eofchar } -result {77 = 23431} @@ -7369,51 +7482,42 @@ test chan-io-61.1 {Reset eof state after changing the eof char} -setup { # can also be used to emulate transfer of channels between threads, and is # used for that here. -test chan-io-70.0 {Cutting & Splicing channels} {testchannel} { +test chan-io-70.0 {Cutting & Splicing channels} -setup { set f [makeFile {... dummy ...} cutsplice] + set res {} +} -constraints {testchannel} -body { set c [open $f r] - set res {} lappend res [catch {chan seek $c 0 start}] testchannel cut $c lappend res [catch {chan seek $c 0 start}] testchannel splice $c lappend res [catch {chan seek $c 0 start}] +} -cleanup { chan close $c removeFile cutsplice - set res -} {0 1 0} -# Duplicate of code in "thread.test". Find a better way of doing this without -# duplication. Maybe placement into a proc which transforms to nop after the -# first call, and placement of its defintion in a central location. -if {[testConstraint testthread]} { - testthread errorproc ThreadError - proc ThreadError {id info} { - global threadError - set threadError $info - } - proc ThreadNullError {id info} { - # ignore - } -} -test chan-io-70.1 {Transfer channel} {testchannel testthread} { +} -result {0 1 0} + +test chan-io-70.1 {Transfer channel} -setup { set f [makeFile {... dummy ...} cutsplice] + set res {} +} -constraints {testchannel thread} -body { set c [open $f r] - set res {} lappend res [catch {chan seek $c 0 start}] testchannel cut $c lappend res [catch {chan seek $c 0 start}] - set tid [testthread create] - testthread send $tid [list set c $c] - lappend res [testthread send $tid { + set tid [thread::create -preserved] + thread::send $tid [list set c $c] + thread::send $tid {load {} Tcltest} + lappend res [thread::send $tid { testchannel splice $c set res [catch {chan seek $c 0 start}] chan close $c set res }] - tcltest::threadReap +} -cleanup { + thread::release $tid removeFile cutsplice - set res -} {0 1 0} +} -result {0 1 0} # ### ### ### ######### ######### ######### @@ -7578,34 +7682,36 @@ foreach {n msg expected} { f2 {-code ok -code 0 -level X -f ba} {-code 1 -level 0 -f ba} f3 {-code boss -code 0 -level X -f ba} {-code 1 -level 0 -f ba} } { - test chan-io-71.$n {Tcl_SetChannelError} {testchannel} { + test chan-io-71.$n {Tcl_SetChannelError} -setup { set f [makeFile {... dummy ...} cutsplice] + } -constraints {testchannel} -body { set c [open $f r] - set res [testchannel setchannelerror $c [lrange $msg 0 end]] + testchannel setchannelerror $c [lrange $msg 0 end] + } -cleanup { chan close $c removeFile cutsplice - set res - } [lrange $expected 0 end] - test chan-io-72.$n {Tcl_SetChannelErrorInterp} {testchannel} { + } -result [lrange $expected 0 end] + test chan-io-72.$n {Tcl_SetChannelErrorInterp} -setup { set f [makeFile {... dummy ...} cutsplice] + } -constraints {testchannel} -body { set c [open $f r] - set res [testchannel setchannelerrorinterp $c [lrange $msg 0 end]] + testchannel setchannelerrorinterp $c [lrange $msg 0 end] + } -cleanup { chan close $c removeFile cutsplice - set res - } [lrange $expected 0 end] + } -result [lrange $expected 0 end] } -test chan-io-73.1 {channel Tcl_Obj SetChannelFromAny} {} { +test chan-io-73.1 {channel Tcl_Obj SetChannelFromAny} -body { # Test for Bug 1847044 - don't spoil type unless we have a valid channel - catch {chan close [lreplace [list a] 0 end]} -} {1} + chan close [lreplace [list a] 0 end] +} -returnCodes error -match glob -result * # ### ### ### ######### ######### ######### # cleanup foreach file [list fooBar longfile script output test1 pipe my_script \ - test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { + test2 test3 cat kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { removeFile $file } cleanupTests diff --git a/tests/clock.test b/tests/clock.test index d5957bd..0202fc7 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: clock.test,v 1.94 2009/10/29 01:17:54 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -19,11 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } if {[testConstraint win]} { - if {[catch {package require registry 1.1}] - && [catch {load {} Registry}] - && [catch { + if {[catch { ::tcltest::loadTestedCommands - load $::reglib Registry + package require registry }]} { namespace eval ::tcl::clock {variable NoRegistry {}} } @@ -35897,6 +35893,39 @@ test clock-38.1 {regression - convertUTCToLocalViaC - east of Greenwich} \ } \ -result {01:00:00} +test clock-38.2 {make sure TZ is not cached after unset} \ + -setup { + if { [info exists env(TZ)] } { + set oldTZ $env(TZ) + unset env(TZ) + } + if { [info exists env(TCL_TZ)] } { + set oldTCLTZ $env(TCL_TZ) + unset env(TCL_TZ) + } + } \ + -body { + set t1 [clock format 0] + # a time zone that is unlikely to anywhere + set env(TZ) "+04:20" + set t2 [clock format 0] + unset env(TZ) + set t3 [clock format 0] + expr {$t1 eq $t3 && $t1 ne $t2} + } \ + -cleanup { + if { [info exists oldTZ] } { + set env(TZ) $oldTZ + unset oldTZ + } + if { [info exists oldTclTZ] } { + set env(TCL_TZ) $oldTclTZ + unset oldTclTZ + } + } \ + -result 1 + + test clock-39.1 {regression - synonym timezones} { clock format 0 -format {%H:%M:%S} -timezone :US/Eastern } {19:00:00} @@ -36519,6 +36548,154 @@ test clock-56.3 {use of zoneinfo, version 2, Y2038 compliance} {*}{ -result {2040-07-01 00:00:00 PDT} } +test clock-56.4 {Bug 3470928} {*}{ + -setup { + clock format [clock seconds] + set tzdir [makeDirectory zoneinfo] + set tzdir2 [makeDirectory Test $tzdir] + set tzfile [makeFile {} Windhoek $tzdir2] + set f [open $tzfile wb] + puts -nonewline $f [binary format c* { + 0x54 0x5a 0x69 0x66 0x32 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 + 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x06 0x00 0x00 + 0x00 0x06 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x5c 0x00 0x00 0x00 + 0x06 0x00 0x00 0x00 0x13 0x82 0x46 0xcf 0x68 0xcc 0xae 0x8c 0x80 + 0xcd 0x9e 0x6f 0x70 0x26 0x06 0xa7 0xe0 0x2d 0x9d 0xea 0xe0 0x2e + 0x69 0x1c 0x10 0x2f 0x7d 0xe9 0x00 0x30 0x48 0xfe 0x10 0x31 0x67 + 0x05 0x80 0x32 0x28 0xe0 0x10 0x33 0x46 0xe7 0x80 0x34 0x11 0xfc + 0x90 0x35 0x26 0xc9 0x80 0x35 0xf1 0xde 0x90 0x37 0x06 0xab 0x80 + 0x37 0xd1 0xc0 0x90 0x38 0xe6 0x8d 0x80 0x39 0xb1 0xa2 0x90 0x3a + 0xc6 0x6f 0x80 0x3b 0x91 0x84 0x90 0x3c 0xaf 0x8c 0x00 0x3d 0x71 + 0x66 0x90 0x3e 0x8f 0x6e 0x00 0x3f 0x5a 0x83 0x10 0x40 0x6f 0x50 + 0x00 0x41 0x3a 0x65 0x10 0x42 0x4f 0x32 0x00 0x43 0x1a 0x47 0x10 + 0x44 0x2f 0x14 0x00 0x44 0xfa 0x29 0x10 0x46 0x0e 0xf6 0x00 0x46 + 0xda 0x0b 0x10 0x47 0xf8 0x12 0x80 0x48 0xc3 0x27 0x90 0x49 0xd7 + 0xf4 0x80 0x4a 0xa3 0x09 0x90 0x4b 0xb7 0xd6 0x80 0x4c 0x82 0xeb + 0x90 0x4d 0x97 0xb8 0x80 0x4e 0x62 0xcd 0x90 0x4f 0x77 0x9a 0x80 + 0x50 0x42 0xaf 0x90 0x51 0x60 0xb7 0x00 0x52 0x22 0x91 0x90 0x53 + 0x40 0x99 0x00 0x54 0x0b 0xae 0x10 0x55 0x20 0x7b 0x00 0x55 0xeb + 0x90 0x10 0x57 0x00 0x5d 0x00 0x57 0xcb 0x72 0x10 0x58 0xe0 0x3f + 0x00 0x59 0xab 0x54 0x10 0x5a 0xc0 0x21 0x00 0x5b 0x8b 0x36 0x10 + 0x5c 0xa9 0x3d 0x80 0x5d 0x6b 0x18 0x10 0x5e 0x89 0x1f 0x80 0x5f + 0x54 0x34 0x90 0x60 0x69 0x01 0x80 0x61 0x34 0x16 0x90 0x62 0x48 + 0xe3 0x80 0x63 0x13 0xf8 0x90 0x64 0x28 0xc5 0x80 0x64 0xf3 0xda + 0x90 0x66 0x11 0xe2 0x00 0x66 0xd3 0xbc 0x90 0x67 0xf1 0xc4 0x00 + 0x68 0xbc 0xd9 0x10 0x69 0xd1 0xa6 0x00 0x6a 0x9c 0xbb 0x10 0x6b + 0xb1 0x88 0x00 0x6c 0x7c 0x9d 0x10 0x6d 0x91 0x6a 0x00 0x6e 0x5c + 0x7f 0x10 0x6f 0x71 0x4c 0x00 0x70 0x3c 0x61 0x10 0x71 0x5a 0x68 + 0x80 0x72 0x1c 0x43 0x10 0x73 0x3a 0x4a 0x80 0x74 0x05 0x5f 0x90 + 0x75 0x1a 0x2c 0x80 0x75 0xe5 0x41 0x90 0x76 0xfa 0x0e 0x80 0x77 + 0xc5 0x23 0x90 0x78 0xd9 0xf0 0x80 0x79 0xa5 0x05 0x90 0x7a 0xb9 + 0xd2 0x80 0x7b 0x84 0xe7 0x90 0x7c 0xa2 0xef 0x00 0x7d 0x6e 0x04 + 0x10 0x7e 0x82 0xd1 0x00 0x7f 0x4d 0xe6 0x10 0x01 0x02 0x01 0x03 + 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 + 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 + 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 + 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 + 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 + 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 + 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x05 0x04 0x00 0x00 0x15 + 0x18 0x00 0x00 0x00 0x00 0x1c 0x20 0x00 0x05 0x00 0x00 0x2a 0x30 + 0x01 0x05 0x00 0x00 0x1c 0x20 0x00 0x0a 0x00 0x00 0x1c 0x20 0x01 + 0x0e 0x00 0x00 0x0e 0x10 0x00 0x01 0x53 0x57 0x41 0x54 0x00 0x53 + 0x41 0x53 0x54 0x00 0x43 0x41 0x54 0x00 0x57 0x41 0x53 0x54 0x00 + 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x54 + 0x5a 0x69 0x66 0x32 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 + 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x07 0x00 0x00 0x00 + 0x07 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x5d 0x00 0x00 0x00 0x07 + 0x00 0x00 0x00 0x17 0xff 0xff 0xff 0xff 0x6d 0x7b 0x4b 0x78 0xff + 0xff 0xff 0xff 0x82 0x46 0xcf 0x68 0xff 0xff 0xff 0xff 0xcc 0xae + 0x8c 0x80 0xff 0xff 0xff 0xff 0xcd 0x9e 0x6f 0x70 0x00 0x00 0x00 + 0x00 0x26 0x06 0xa7 0xe0 0x00 0x00 0x00 0x00 0x2d 0x9d 0xea 0xe0 + 0x00 0x00 0x00 0x00 0x2e 0x69 0x1c 0x10 0x00 0x00 0x00 0x00 0x2f + 0x7d 0xe9 0x00 0x00 0x00 0x00 0x00 0x30 0x48 0xfe 0x10 0x00 0x00 + 0x00 0x00 0x31 0x67 0x05 0x80 0x00 0x00 0x00 0x00 0x32 0x28 0xe0 + 0x10 0x00 0x00 0x00 0x00 0x33 0x46 0xe7 0x80 0x00 0x00 0x00 0x00 + 0x34 0x11 0xfc 0x90 0x00 0x00 0x00 0x00 0x35 0x26 0xc9 0x80 0x00 + 0x00 0x00 0x00 0x35 0xf1 0xde 0x90 0x00 0x00 0x00 0x00 0x37 0x06 + 0xab 0x80 0x00 0x00 0x00 0x00 0x37 0xd1 0xc0 0x90 0x00 0x00 0x00 + 0x00 0x38 0xe6 0x8d 0x80 0x00 0x00 0x00 0x00 0x39 0xb1 0xa2 0x90 + 0x00 0x00 0x00 0x00 0x3a 0xc6 0x6f 0x80 0x00 0x00 0x00 0x00 0x3b + 0x91 0x84 0x90 0x00 0x00 0x00 0x00 0x3c 0xaf 0x8c 0x00 0x00 0x00 + 0x00 0x00 0x3d 0x71 0x66 0x90 0x00 0x00 0x00 0x00 0x3e 0x8f 0x6e + 0x00 0x00 0x00 0x00 0x00 0x3f 0x5a 0x83 0x10 0x00 0x00 0x00 0x00 + 0x40 0x6f 0x50 0x00 0x00 0x00 0x00 0x00 0x41 0x3a 0x65 0x10 0x00 + 0x00 0x00 0x00 0x42 0x4f 0x32 0x00 0x00 0x00 0x00 0x00 0x43 0x1a + 0x47 0x10 0x00 0x00 0x00 0x00 0x44 0x2f 0x14 0x00 0x00 0x00 0x00 + 0x00 0x44 0xfa 0x29 0x10 0x00 0x00 0x00 0x00 0x46 0x0e 0xf6 0x00 + 0x00 0x00 0x00 0x00 0x46 0xda 0x0b 0x10 0x00 0x00 0x00 0x00 0x47 + 0xf8 0x12 0x80 0x00 0x00 0x00 0x00 0x48 0xc3 0x27 0x90 0x00 0x00 + 0x00 0x00 0x49 0xd7 0xf4 0x80 0x00 0x00 0x00 0x00 0x4a 0xa3 0x09 + 0x90 0x00 0x00 0x00 0x00 0x4b 0xb7 0xd6 0x80 0x00 0x00 0x00 0x00 + 0x4c 0x82 0xeb 0x90 0x00 0x00 0x00 0x00 0x4d 0x97 0xb8 0x80 0x00 + 0x00 0x00 0x00 0x4e 0x62 0xcd 0x90 0x00 0x00 0x00 0x00 0x4f 0x77 + 0x9a 0x80 0x00 0x00 0x00 0x00 0x50 0x42 0xaf 0x90 0x00 0x00 0x00 + 0x00 0x51 0x60 0xb7 0x00 0x00 0x00 0x00 0x00 0x52 0x22 0x91 0x90 + 0x00 0x00 0x00 0x00 0x53 0x40 0x99 0x00 0x00 0x00 0x00 0x00 0x54 + 0x0b 0xae 0x10 0x00 0x00 0x00 0x00 0x55 0x20 0x7b 0x00 0x00 0x00 + 0x00 0x00 0x55 0xeb 0x90 0x10 0x00 0x00 0x00 0x00 0x57 0x00 0x5d + 0x00 0x00 0x00 0x00 0x00 0x57 0xcb 0x72 0x10 0x00 0x00 0x00 0x00 + 0x58 0xe0 0x3f 0x00 0x00 0x00 0x00 0x00 0x59 0xab 0x54 0x10 0x00 + 0x00 0x00 0x00 0x5a 0xc0 0x21 0x00 0x00 0x00 0x00 0x00 0x5b 0x8b + 0x36 0x10 0x00 0x00 0x00 0x00 0x5c 0xa9 0x3d 0x80 0x00 0x00 0x00 + 0x00 0x5d 0x6b 0x18 0x10 0x00 0x00 0x00 0x00 0x5e 0x89 0x1f 0x80 + 0x00 0x00 0x00 0x00 0x5f 0x54 0x34 0x90 0x00 0x00 0x00 0x00 0x60 + 0x69 0x01 0x80 0x00 0x00 0x00 0x00 0x61 0x34 0x16 0x90 0x00 0x00 + 0x00 0x00 0x62 0x48 0xe3 0x80 0x00 0x00 0x00 0x00 0x63 0x13 0xf8 + 0x90 0x00 0x00 0x00 0x00 0x64 0x28 0xc5 0x80 0x00 0x00 0x00 0x00 + 0x64 0xf3 0xda 0x90 0x00 0x00 0x00 0x00 0x66 0x11 0xe2 0x00 0x00 + 0x00 0x00 0x00 0x66 0xd3 0xbc 0x90 0x00 0x00 0x00 0x00 0x67 0xf1 + 0xc4 0x00 0x00 0x00 0x00 0x00 0x68 0xbc 0xd9 0x10 0x00 0x00 0x00 + 0x00 0x69 0xd1 0xa6 0x00 0x00 0x00 0x00 0x00 0x6a 0x9c 0xbb 0x10 + 0x00 0x00 0x00 0x00 0x6b 0xb1 0x88 0x00 0x00 0x00 0x00 0x00 0x6c + 0x7c 0x9d 0x10 0x00 0x00 0x00 0x00 0x6d 0x91 0x6a 0x00 0x00 0x00 + 0x00 0x00 0x6e 0x5c 0x7f 0x10 0x00 0x00 0x00 0x00 0x6f 0x71 0x4c + 0x00 0x00 0x00 0x00 0x00 0x70 0x3c 0x61 0x10 0x00 0x00 0x00 0x00 + 0x71 0x5a 0x68 0x80 0x00 0x00 0x00 0x00 0x72 0x1c 0x43 0x10 0x00 + 0x00 0x00 0x00 0x73 0x3a 0x4a 0x80 0x00 0x00 0x00 0x00 0x74 0x05 + 0x5f 0x90 0x00 0x00 0x00 0x00 0x75 0x1a 0x2c 0x80 0x00 0x00 0x00 + 0x00 0x75 0xe5 0x41 0x90 0x00 0x00 0x00 0x00 0x76 0xfa 0x0e 0x80 + 0x00 0x00 0x00 0x00 0x77 0xc5 0x23 0x90 0x00 0x00 0x00 0x00 0x78 + 0xd9 0xf0 0x80 0x00 0x00 0x00 0x00 0x79 0xa5 0x05 0x90 0x00 0x00 + 0x00 0x00 0x7a 0xb9 0xd2 0x80 0x00 0x00 0x00 0x00 0x7b 0x84 0xe7 + 0x90 0x00 0x00 0x00 0x00 0x7c 0xa2 0xef 0x00 0x00 0x00 0x00 0x00 + 0x7d 0x6e 0x04 0x10 0x00 0x00 0x00 0x00 0x7e 0x82 0xd1 0x00 0x00 + 0x00 0x00 0x00 0x7f 0x4d 0xe6 0x10 0x01 0x02 0x03 0x02 0x04 0x06 + 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 + 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 + 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 + 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 + 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 + 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 + 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x06 0x05 0x00 0x00 0x10 0x08 + 0x00 0x00 0x00 0x00 0x15 0x18 0x00 0x04 0x00 0x00 0x1c 0x20 0x00 + 0x09 0x00 0x00 0x2a 0x30 0x01 0x09 0x00 0x00 0x1c 0x20 0x00 0x0e + 0x00 0x00 0x1c 0x20 0x01 0x12 0x00 0x00 0x0e 0x10 0x00 0x05 0x4c + 0x4d 0x54 0x00 0x53 0x57 0x41 0x54 0x00 0x53 0x41 0x53 0x54 0x00 + 0x43 0x41 0x54 0x00 0x57 0x41 0x53 0x54 0x00 0x00 0x00 0x00 0x00 + 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x0a 0x57 0x41 + 0x54 0x2d 0x31 0x57 0x41 0x53 0x54 0x2c 0x4d 0x39 0x2e 0x31 0x2e + 0x30 0x2c 0x4d 0x34 0x2e 0x31 0x2e 0x30 0x0a + }] + close $f + set ::tcl::clock::ZoneinfoPaths \ + [linsert $::tcl::clock::ZoneinfoPaths 0 $tzdir] + ::tcl::clock::ClearCaches + } + -body { + clock format 1326054606 -timezone :Test/Windhoek + } + -cleanup { + set ::tcl::clock::ZoneinfoPaths \ + [lrange $::tcl::clock::ZoneinfoPaths 1 end] + ::tcl::clock::ClearCaches + removeFile Windhoek $tzdir2 + removeDirectory Test $tzdir + removeDirectory zoneinfo + } + -result {Sun Jan 08 22:30:06 WAST 2012} +} + test clock-57.1 {clock scan - abbreviated options} { clock scan 1970-01-01 -f %Y-%m-%d -g true } 0 diff --git a/tests/cmdAH.test b/tests/cmdAH.test index f7ba584..3051bfb 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -9,14 +9,15 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: cmdAH.test,v 1.68 2010/02/05 14:33:09 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] @@ -69,6 +70,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 @@ -218,10 +225,10 @@ test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file -} -result {wrong # args: should be "file option ?arg ...?"} +} -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, 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, tempfile, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -236,14 +243,15 @@ test cmdAH-6.1 {Tcl_FileObjCmd: volumes} -returnCodes error -body { test cmdAH-6.2 {Tcl_FileObjCmd: volumes} -body { lindex [file volumes] 0 } -match glob -result ?* -test cmdAH-6.3 {Tcl_FileObjCmd: volumes} {unix} { +test cmdAH-6.3 {Tcl_FileObjCmd: volumes} -constraints unix -body { set volumeList [file volumes] - catch [list glob -nocomplain [lindex $volumeList 0]*] -} {0} -test cmdAH-6.4 {Tcl_FileObjCmd: volumes} win { + glob -nocomplain [lindex $volumeList 0]* +} -match glob -result * +test cmdAH-6.4 {Tcl_FileObjCmd: volumes} -constraints win -body { set volumeList [string tolower [file volumes]] - list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}] -} {0 1 0} + set element [lsearch -exact $volumeList "c:/"] + list [expr {$element>-1}] [glob -nocomplain [lindex $volumeList $element]*] +} -match glob -result {1 *} # attributes test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} -setup { @@ -251,11 +259,11 @@ test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} -setup { catch {file delete -force $foofile} } -body { close [open $foofile w] - catch {file attributes $foofile} + file attributes $foofile } -cleanup { # We used [makeFile] so we undo with [removeFile] removeFile $foofile -} -result {0} +} -match glob -result * # dirname test cmdAH-8.1 {Tcl_FileObjCmd: dirname} -returnCodes error -body { @@ -497,33 +505,36 @@ test cmdAH-9.26 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {//foo/bar} } {} -test cmdAH-9.42 {Tcl_FileObjCmd: tail} testsetplatform { +test cmdAH-9.42 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) +} -body { set env(HOME) "/home/test" testsetplatform unix - set result [file tail ~] + file tail ~ +} -cleanup { set env(HOME) $temp - set result -} test -test cmdAH-9.43 {Tcl_FileObjCmd: tail} testsetplatform { +} -result test +test cmdAH-9.43 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) +} -body { set env(HOME) "~" testsetplatform unix - set result [file tail ~] + file tail ~ +} -cleanup { set env(HOME) $temp - set result -} {} -test cmdAH-9.44 {Tcl_FileObjCmd: tail} testsetplatform { +} -result {} +test cmdAH-9.44 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) +} -body { set env(HOME) "/home/test" testsetplatform windows - set result [file tail ~] + file tail ~ +} -cleanup { set env(HOME) $temp - set result -} test +} -result test test cmdAH-9.46 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail {f.oo\bar/baz.bat} @@ -923,10 +934,10 @@ test cmdAH-19.7 {Tcl_FileObjCmd: nativename} -body { test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} { file exists ~nOsUcHuSeR } 0 -test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} { - # should probably be 0 in fact... - catch {file nativename ~nOsUcHuSeR} -} 1 +test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} -body { + # should probably be a non-error in fact... + file nativename ~nOsUcHuSeR +} -returnCodes error -match glob -result * # The test below has to be done in /tmp rather than the current directory in # order to guarantee (?) a local file system: some NFS file systems won't do # the stuff below correctly. @@ -963,7 +974,7 @@ test cmdAH-20.1 {Tcl_FileObjCmd: atime} -returnCodes error -body { file atime a b c } -result {wrong # args: should be "file atime name ?time?"} test cmdAH-20.2 {Tcl_FileObjCmd: atime} -setup { - catch {unset stat} + unset -nocomplain stat } -body { file stat $gorpfile stat list [expr {[file mtime $gorpfile] == $stat(mtime)}] \ @@ -1031,13 +1042,13 @@ test cmdAH-23.2 {Tcl_FileObjCmd: lstat} -returnCodes error -body { file lstat a b c } -result {wrong # args: should be "file lstat name varName"} test cmdAH-23.3 {Tcl_FileObjCmd: lstat} -setup { - catch {unset stat} + unset -nocomplain stat } -constraints {unix nonPortable} -body { file lstat $linkfile stat lsort [array names stat] } -result {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-23.4 {Tcl_FileObjCmd: lstat} -setup { - catch {unset stat} + unset -nocomplain stat } -constraints {unix nonPortable} -body { file lstat $linkfile stat list $stat(nlink) [expr $stat(mode)&0777] $stat(type) @@ -1047,12 +1058,12 @@ test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} -setup { - catch {unset x} + unset -nocomplain x } -body { set x 44 list [catch {file lstat $gorpfile x} msg] $msg $errorCode } -result {1 {can't set "x(dev)": variable isn't array} {TCL LOOKUP VARNAME x}} -catch {unset stat} +unset -nocomplain stat # mkdir set dirA [file join [temporaryDirectory] a] set dirB [file join [temporaryDirectory] a] @@ -1128,7 +1139,7 @@ test cmdAH-24.2 {Tcl_FileObjCmd: mtime} -setup { } } -result {1} test cmdAH-24.3 {Tcl_FileObjCmd: mtime} -setup { - catch {unset stat} + unset -nocomplain stat } -body { file stat $gorpfile stat list [expr {[file mtime $gorpfile] == $stat(mtime)}] \ @@ -1294,7 +1305,7 @@ test cmdAH-28.2 {Tcl_FileObjCmd: stat} -returnCodes error -body { file stat _bogus_ a b } -result {wrong # args: should be "file stat name varName"} test cmdAH-28.3 {Tcl_FileObjCmd: stat} -setup { - catch {unset stat} + unset -nocomplain stat set stat(blocks) [set stat(blksize) {}] } -body { file stat $gorpfile stat @@ -1302,13 +1313,13 @@ test cmdAH-28.3 {Tcl_FileObjCmd: stat} -setup { lsort [array names stat] } -result {atime ctime dev gid ino mode mtime nlink size type uid} test cmdAH-28.4 {Tcl_FileObjCmd: stat} -setup { - catch {unset stat} + unset -nocomplain stat } -body { file stat $gorpfile stat list $stat(nlink) $stat(size) $stat(type) } -result {1 12 file} test cmdAH-28.5 {Tcl_FileObjCmd: stat} -constraints {unix} -setup { - catch {unset stat} + unset -nocomplain stat } -body { file stat $gorpfile stat expr {$stat(mode) & 0o777} @@ -1317,7 +1328,7 @@ 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}}} test cmdAH-28.7 {Tcl_FileObjCmd: stat} -setup { - catch {unset x} + unset -nocomplain x } -returnCodes error -body { set x 44 file stat $gorpfile x @@ -1371,7 +1382,7 @@ test cmdAH-28.12 {Tcl_FileObjCmd: stat} -setup { } -cleanup { removeFile $filename } -result 1 -catch {unset stat} +unset -nocomplain stat # type test cmdAH-29.1 {Tcl_FileObjCmd: type} -returnCodes error -body { @@ -1415,25 +1426,25 @@ test cmdAH-29.5 {Tcl_FileObjCmd: type} { # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, 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, tempfile, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x -} -match glob -result {ambiguous option "ex": must be *} +} -match glob -result {unknown or ambiguous subcommand "ex": must be *} test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file is x -} -match glob -result {ambiguous option "is": must be *} +} -match glob -result {unknown or ambiguous subcommand "is": must be *} test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file z x -} -match glob -result {bad option "z": must be *} +} -match glob -result {unknown or ambiguous subcommand "z": must be *} test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file read x -} -match glob -result {ambiguous option "read": must be *} +} -match glob -result {unknown or ambiguous subcommand "read": must be *} test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file s x -} -match glob -result {ambiguous option "s": must be *} +} -match glob -result {unknown or ambiguous subcommand "s": must be *} test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file t x -} -match glob -result {ambiguous option "t": must be *} +} -match glob -result {unknown or ambiguous subcommand "t": must be *} test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file dirname ~woohgy } -result {user "woohgy" doesn't exist} @@ -1445,7 +1456,7 @@ test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { interp create simpleInterp interp create -safe safeInterp interp create -safeInterp expose file file +catch {safeInterp expose file file} test cmdAH-31.1 {Tcl_FileObjCmd: channels, too many args} -body { file channels a b @@ -1513,7 +1524,7 @@ test cmdAH-32.2 {file tempfile - returns a read/write channel} -body { catch {close $f} } -result ok test cmdAH-32.3 {file tempfile - makes filenames} -setup { - catch {unset name} + unset -nocomplain name } -body { set result [info exists name] set f [file tempfile name] @@ -1556,7 +1567,7 @@ interp delete simpleInterp # cleanup catch {testsetplatform $platform} -catch {unset platform} +unset -nocomplain platform # Tcl_ForObjCmd is tested in for.test diff --git a/tests/cmdIL.test b/tests/cmdIL.test index ca81ea5..721773f 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -7,14 +7,15 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: cmdIL.test,v 1.43 2009/12/22 19:49:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] @@ -458,6 +459,9 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { } -result 0 -cleanup { rename test_lsort "" } +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}} # Compiled version test cmdIL-6.1 {lassign command syntax} -returnCodes error -body { @@ -713,6 +717,16 @@ test cmdIL-7.8 {lreverse command - shared intrep [Bug 1675044]} -setup { rename K {} } -result 1 +# 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 010d3d1..69d7171 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -12,14 +12,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: cmdInfo.test,v 1.10 2006/11/03 00:34:52 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testcmdinfo [llength [info commands testcmdinfo]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index c7f6e44..2d68138 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: cmdMZ.test,v 1.30 2010/04/05 19:44:45 ferrieux Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -38,7 +36,7 @@ namespace eval ::tcl::test::cmdMZ { return 1 } customMatch listGlob [namespace which ListGlobMatch] - + # Tcl_PwdObjCmd test cmdMZ-1.1 {Tcl_PwdObjCmd} -returnCodes error -body { @@ -166,35 +164,31 @@ test cmdMZ-return-2.13 {return option handling} -body { test cmdMZ-return-2.14 {return option handling} -body { return -level 0 -code error -options {-code foo -options {-code break}} } -returnCodes break -result {} -test cmdMZ-return-2.15 {return opton handling} -setup { - proc p {} { - return -code error -errorcode {a b} c - } -} -body { - list [catch p result] $result $::errorCode -} -cleanup { - rename p {} -} -result {1 c {a b}} -test cmdMZ-return-2.16 {return opton handling} -setup { - proc p {} { - return -code error -errorcode [list a b] c - } -} -body { - list [catch p result] $result $::errorCode -} -cleanup { - rename p {} -} -result {1 c {a b}} -test cmdMZ-return-2.17 {return opton handling} -setup { - proc p {} { - return -code error -errorcode a\ b c - } -} -body { - list [catch p result] $result $::errorCode -} -cleanup { - rename p {} -} -result {1 c {a b}} +test cmdMZ-return-2.15 {return opton handling} { + list [catch { + apply {{} { + return -code error -errorcode {a b} c + }} + } result] $result $::errorCode +} {1 c {a b}} +test cmdMZ-return-2.16 {return opton handling} { + list [catch { + apply {{} { + return -code error -errorcode [list a b] c + }} + } result] $result $::errorCode +} {1 c {a b}} +test cmdMZ-return-2.17 {return opton handling} { + list [catch { + apply {{} { + return -code error -errorcode a\ b c + }} + } result] $result $::errorCode +} {1 c {a b}} test cmdMZ-return-2.18 {return option handling} { - list [catch {return -code error -errorstack [list CALL a CALL b] yo} -> foo] [dictSort $foo] [info errorstack] + list [catch { + return -code error -errorstack [list CALL a CALL b] yo + } -> foo] [dictSort $foo] [info errorstack] } {2 {-code 1 -errorcode NONE -errorstack {CALL a CALL b} -level 1} {CALL a CALL b}} # Check that the result of a [return -options $opts $result] is @@ -349,7 +343,7 @@ test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} { "time {error foo}"}} # The tests for Tcl_WhileObjCmd are in while.test - + # cleanup cleanupTests } diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index f7fe427..bae26a0 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -11,14 +11,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: compExpr-old.test,v 1.23 2007/12/13 15:26:06 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 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 { diff --git a/tests/compExpr.test b/tests/compExpr.test index c3e68c1..14c875d 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -1,20 +1,21 @@ -# This file contains a collection of tests for the procedures in the -# file tclCompExpr.c. 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 the procedures in the 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. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: compExpr.test,v 1.17 2008/01/16 21:54:33 dgp Exp $ +# 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 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 { @@ -25,7 +26,7 @@ if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1" testConstraint memory [llength [info commands memory]] catch {unset a} - + test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} { expr 1+2 } 3 @@ -35,17 +36,17 @@ test compExpr-1.2 {TclCompileExpr procedure, error parsing expr} -body { test compExpr-1.3 {TclCompileExpr procedure, error compiling expr} -body { list [catch {expr "foo(123)"} msg] $msg } -match glob -result {1 {* "*foo"}} - test compExpr-1.4 {TclCompileExpr procedure, expr has no operators} { set a {0o00123} expr {$a} } 83 -test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} { - catch {unset a} +test compExpr-2.1 {CompileSubExpr procedure, TCL_TOKEN_WORD parse token} -setup { + unset -nocomplain a +} -body { set a 27 expr {"foo$a" < "bar"} -} 0 +} -result 0 test compExpr-2.2 {CompileSubExpr procedure, error compiling TCL_TOKEN_WORD parse token} -body { expr {"00[expr 1+]" + 17} } -returnCodes error -match glob -result * @@ -68,30 +69,33 @@ test compExpr-2.7 {CompileSubExpr procedure, TCL_TOKEN_COMMAND parse token} { test compExpr-2.8 {CompileSubExpr procedure, error in TCL_TOKEN_COMMAND parse token} -body { expr {[foo "bar"xxx] + 17} } -returnCodes error -match glob -result * -test compExpr-2.9 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} { - catch {unset a} +test compExpr-2.9 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} -setup { + unset -nocomplain a +} -body { set a 123 expr {$a*2} -} 246 -test compExpr-2.10 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} { - catch {unset a} - catch {unset b} +} -result 246 +test compExpr-2.10 {CompileSubExpr procedure, TCL_TOKEN_VARIABLE parse token} -setup { + unset -nocomplain a + unset -nocomplain b +} -body { set a(george) martha set b geo expr {$a(${b}rge)} -} martha -test compExpr-2.11 {CompileSubExpr procedure, error in TCL_TOKEN_VARIABLE parse token} { - catch {unset a} - list [catch {expr {$a + 17}} msg] $msg -} {1 {can't read "a": no such variable}} +} -result martha +test compExpr-2.11 {CompileSubExpr procedure, error in TCL_TOKEN_VARIABLE parse token} -body { + unset -nocomplain a + expr {$a + 17} +} -returnCodes error -result {can't read "a": no such variable} test compExpr-2.12 {CompileSubExpr procedure, TCL_TOKEN_SUB_EXPR parse token} { expr {27||3? 3<<(1+4) : 4&&9} } 96 -test compExpr-2.13 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { - catch {unset a} +test compExpr-2.13 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} -setup { + unset -nocomplain a +} -body { set a 15 list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg -} {0 1} +} -result {0 1} test compExpr-2.14 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, op found} { expr {5*6} } 30 @@ -149,11 +153,12 @@ test compExpr-2.31 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal o test compExpr-2.32 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, 1 operand} { expr {~4} } -5 -test compExpr-2.33 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, comparison} { - catch {unset a} +test compExpr-2.33 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, normal operator, comparison} -setup { + unset -nocomplain a +} -body { set a 15 expr {$a==15} ;# compiled out-of-line to runtime call on Tcl_ExprObjCmd -} 1 +} -result 1 test compExpr-2.34 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { expr {+2} } 2 @@ -175,72 +180,84 @@ test compExpr-2.39 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special test compExpr-2.40 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { expr {4-2} } 2 -test compExpr-2.41 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { - catch {unset a} +test compExpr-2.41 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} -setup { + unset -nocomplain a +} -body { set a true expr {0||$a} -} 1 -test compExpr-2.42 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { - catch {unset a} +} -result 1 +test compExpr-2.42 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} -setup { + unset -nocomplain a +} -body { set a 15 list [catch {expr {27 || "$a[expr 1+]00"}} msg] $msg -} {0 1} -test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { - catch {unset a} +} -result {0 1} +test compExpr-2.43 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} -setup { + unset -nocomplain a +} -body { set a false expr {3&&$a} -} 0 -test compExpr-2.44 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} { - catch {unset a} +} -result 0 +test compExpr-2.44 {CompileSubExpr procedure, TCL_TOKEN_OPERATOR token, special operator} -setup { + unset -nocomplain a +} -body { set a false expr {$a||1? 1 : 0} -} 1 -test compExpr-2.45 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} { - catch {unset a} +} -result 1 +test compExpr-2.45 {CompileSubExpr procedure, error in TCL_TOKEN_SUB_EXPR parse token} -setup { + unset -nocomplain a +} -body { set a 15 list [catch {expr {1? 54 : "$a[expr 1+]00"}} msg] $msg -} {0 54} +} -result {0 54} -test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} { - catch {unset a} +test compExpr-3.1 {CompileLandOrLorExpr procedure, numeric 1st operand} -setup { + unset -nocomplain a +} -body { set a 2 expr {[set a]||0} -} 1 -test compExpr-3.2 {CompileLandOrLorExpr procedure, nonnumeric 1st operand} { - catch {unset a} +} -result 1 +test compExpr-3.2 {CompileLandOrLorExpr procedure, nonnumeric 1st operand} -setup { + unset -nocomplain a +} -body { set a no expr {$a&&1} -} 0 +} -result 0 test compExpr-3.3 {CompileSubExpr procedure, error in 1st operand} -body { expr {[expr *2]||0} } -returnCodes error -match glob -result * -test compExpr-3.4 {CompileLandOrLorExpr procedure, result is 1 or 0} { - catch {unset a} - catch {unset b} +test compExpr-3.4 {CompileLandOrLorExpr procedure, result is 1 or 0} -setup { + unset -nocomplain a + unset -nocomplain b +} -body { set a no set b true expr {$a || $b} -} 1 -test compExpr-3.5 {CompileLandOrLorExpr procedure, short-circuit semantics} { - catch {unset a} +} -result 1 +test compExpr-3.5 {CompileLandOrLorExpr procedure, short-circuit semantics} -setup { + unset -nocomplain a +} -body { set a yes expr {$a || [exit]} -} 1 -test compExpr-3.6 {CompileLandOrLorExpr procedure, short-circuit semantics} { - catch {unset a} +} -result 1 +test compExpr-3.6 {CompileLandOrLorExpr procedure, short-circuit semantics} -setup { + unset -nocomplain a +} -body { set a no expr {$a && [exit]} -} 0 -test compExpr-3.7 {CompileLandOrLorExpr procedure, numeric 2nd operand} { - catch {unset a} +} -result 0 +test compExpr-3.7 {CompileLandOrLorExpr procedure, numeric 2nd operand} -setup { + unset -nocomplain a +} -body { set a 2 expr {0||[set a]} -} 1 -test compExpr-3.8 {CompileLandOrLorExpr procedure, nonnumeric 2nd operand} { - catch {unset a} +} -result 1 +test compExpr-3.8 {CompileLandOrLorExpr procedure, nonnumeric 2nd operand} -setup { + unset -nocomplain a +} -body { set a no expr {1&&$a} -} 0 +} -result 0 test compExpr-3.9 {CompileLandOrLorExpr procedure, error in 2nd operand} -body { expr {0||[expr %2]} } -returnCodes error -match glob -result * @@ -250,42 +267,48 @@ test compExpr-3.10 {CompileLandOrLorExpr procedure, long lor/land arm} { expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]} } 1 -test compExpr-4.1 {CompileCondExpr procedure, simple test} { - catch {unset a} +test compExpr-4.1 {CompileCondExpr procedure, simple test} -setup { + unset -nocomplain a +} -body { set a 2 expr {($a > 1)? "ok" : "nope"} -} ok -test compExpr-4.2 {CompileCondExpr procedure, complex test, convert to numeric} { - catch {unset a} +} -result ok +test compExpr-4.2 {CompileCondExpr procedure, complex test, convert to numeric} -setup { + unset -nocomplain a +} -body { set a no expr {[set a]? 27 : -54} -} -54 +} -result -54 test compExpr-4.3 {CompileCondExpr procedure, error in test} -body { expr {[expr *2]? +1 : -1} } -returnCodes error -match glob -result * -test compExpr-4.4 {CompileCondExpr procedure, simple "true" clause} { - catch {unset a} +test compExpr-4.4 {CompileCondExpr procedure, simple "true" clause} -setup { + unset -nocomplain a +} -body { set a no expr {1? (27-2) : -54} -} 25 -test compExpr-4.5 {CompileCondExpr procedure, convert "true" clause to numeric} { - catch {unset a} +} -result 25 +test compExpr-4.5 {CompileCondExpr procedure, convert "true" clause to numeric} -setup { + unset -nocomplain a +} -body { set a no expr {1? $a : -54} -} no +} -result no test compExpr-4.6 {CompileCondExpr procedure, error in "true" clause} -body { expr {1? [expr *2] : -127} } -returnCodes error -match glob -result * -test compExpr-4.7 {CompileCondExpr procedure, simple "false" clause} { - catch {unset a} +test compExpr-4.7 {CompileCondExpr procedure, simple "false" clause} -setup { + unset -nocomplain a +} -body { set a no expr {(2-2)? -3.14159 : "nope"} -} nope -test compExpr-4.8 {CompileCondExpr procedure, convert "false" clause to numeric} { - catch {unset a} +} -result nope +test compExpr-4.8 {CompileCondExpr procedure, convert "false" clause to numeric} -setup { + unset -nocomplain a +} -body { set a 0o0123 expr {0? 42 : $a} -} 83 +} -result 83 test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} { list [catch {expr {1? 15 : [expr *2]}} msg] $msg } {0 15} @@ -294,8 +317,8 @@ test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { format %.6g [expr atan2(1.0, 2.0)] } 0.463648 test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body { - list [catch {expr {do_it()}} msg] $msg -} -match glob -result {1 {* "*do_it"}} + 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 @@ -303,8 +326,8 @@ test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathf expr T2()*3 } 1035 test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body { - list [catch {expr {atan2(1.0)}} msg] $msg -} -match glob -result {1 {too few arguments for math function*}} + expr {atan2(1.0)} +} -returnCodes error -match glob -result {too few arguments for math function*} test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} { format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))] } 9.97424 @@ -312,11 +335,11 @@ test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} -body { expr {sinh(2.*)} } -returnCodes error -match glob -result * test compExpr-5.8 {CompileMathFuncCall procedure, too many arguments} -body { - list [catch {expr {sinh(2.0, 3.0)}} msg] $msg -} -match glob -result {1 {too many arguments for math function*}} + expr {sinh(2.0, 3.0)} +} -returnCodes error -match glob -result {too many arguments for math function*} test compExpr-5.9 {CompileMathFuncCall procedure, too many arguments} -body { - list [catch {expr {0 <= rand(5.2)}} msg] $msg -} -match glob -result {1 {too many arguments for math function*}} + expr {0 <= rand(5.2)} +} -returnCodes error -match glob -result {too many arguments for math function*} test compExpr-6.1 {LogSyntaxError procedure, error in expr longer than 60 chars} -body { expr {(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)*(+0123456)/} -1 foo 3 @@ -360,9 +383,14 @@ test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setu unset end i tmp rename getbytes {} } -result 0 - + # cleanup catch {unset a} catch {unset b} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/compile.test b/tests/compile.test index d9567cc..4d91940 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -1,21 +1,22 @@ -# This file contains tests for the files tclCompile.c, tclCompCmds.c -# and tclLiteral.c +# This file contains tests for the files tclCompile.c, tclCompCmds.c and +# tclLiteral.c # -# 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) 1997 by 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. -# -# RCS: @(#) $Id: compile.test,v 1.51 2009/10/29 17:21:48 dgp Exp $ +# 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::* +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint exec [llength [info commands exec]] testConstraint memory [llength [info commands memory]] testConstraint testevalex [llength [info commands testevalex]] @@ -28,10 +29,11 @@ catch {namespace delete test_ns_compile} catch {unset x} catch {unset y} catch {unset a} - -test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} { + +test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} -setup { catch {namespace delete test_ns_compile} catch {unset x} +} -body { set x 123 namespace eval test_ns_compile { proc set {args} { @@ -43,63 +45,70 @@ test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} { } } list [test_ns_compile::p] [set x] -} {{123 test_ns_compile::set} {123 test_ns_compile::set}} +} -result {{123 test_ns_compile::set} {123 test_ns_compile::set}} test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} { proc p {x} {info commands 3m} list [catch {p} msg] $msg } {1 {wrong # args: should be "p x"}} -test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} { + +test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} -setup { catch {unset x} +} -body { set x 123 - list $::x [expr {[lsearch -exact [info globals] x] != 0}] -} {123 1} -test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} { + list $::x [expr {"x" in [info globals]}] +} -result {123 1} +test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} -setup { catch {unset y} +} -body { proc p {} { set ::y 789 return $::y } - list [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] -} {789 789 1} -test compile-2.3 {TclCompileDollarVar: global array name with ::s} { + list [p] $::y [expr {"y" in [info globals]}] +} -result {789 789 1} +test compile-2.3 {TclCompileDollarVar: global array name with ::s} -setup { catch {unset a} +} -body { set ::a(1) 2 - list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {[lsearch -exact [info globals] a] != 0}] -} {2 3 3 1} -test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} { + list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {"a" in [info globals]}] +} -result {2 3 3 1} +test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} -setup { catch {unset a} +} -body { proc p {} { set ::a(1) 1 return $::a($::a(1)) } - list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] -} {1 1 1} -test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} { + list [p] $::a(1) [expr {"a" in [info globals]}] +} -result {1 1 1} +test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} -setup { catch {unset a} +} -body { proc p {} { global a set a(1) 1 return ${a(1)}$::a(1)$a(1) } - list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] -} {111 1 1} + list [p] $::a(1) [expr {"a" in [info globals]}] +} -result {111 1 1} -test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} { +test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} -setup { catch {unset a} +} -body { set a(1) xyzzyx proc p {} { global a catch {set x 123} a(1) } list [p] $a(1) -} {0 123} +} -result {0 123} test compile-3.2 {TclCompileCatchCmd: non-local variables} { set ::foo 1 proc catch-test {} { catch {set x 3} ::foo } catch-test - set ::foo + return $::foo } 3 test compile-3.3 {TclCompileCatchCmd: overagressive compiling [bug 219184]} { proc catch-test {str} { @@ -107,7 +116,7 @@ test compile-3.3 {TclCompileCatchCmd: overagressive compiling [bug 219184]} { error BAD } catch {catch-test error} ::foo - set ::foo + return $::foo } {GOOD} test compile-3.4 {TclCompileCatchCmd: bcc'ed [return] is caught} { proc foo {} { @@ -128,6 +137,35 @@ test compile-3.5 {TclCompileCatchCmd: recover from error, [Bug 705406]} { } list [catch foo msg] $msg } {0 1} +test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*}{ + -setup { + namespace eval catchtest { + variable result1 {} + } + trace add variable catchtest::result1 write catchtest::failtrace + proc catchtest::failtrace {n1 n2 op} { + return -code error "trace on $n1 fails by request" + } + } + -body { + proc catchtest::x {} { + variable result1 + 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 "result1": trace on result1 fails by request}} + -cleanup {namespace delete catchtest} +} test compile-4.1 {TclCompileForCmd: command substituted test expression} { set i 0 @@ -157,29 +195,32 @@ test compile-5.2 {TclCompileForeachCmd: non-local variables} { set ::foo } 3 -test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} { +test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} -setup { catch {unset x} catch {unset y} +} -body { set x 123 proc p {} { set ::y 789 return $::y } - list $::x [expr {[lsearch -exact [info globals] x] != 0}] \ - [p] $::y [expr {[lsearch -exact [info globals] y] != 0}] -} {123 1 789 789 1} -test compile-6.2 {TclCompileSetCmd: global array names with ::s} { + list $::x [expr {"x" in [info globals]}] \ + [p] $::y [expr {"y" in [info globals]}] +} -result {123 1 789 789 1} +test compile-6.2 {TclCompileSetCmd: global array names with ::s} -setup { catch {unset a} +} -body { set ::a(1) 2 proc p {} { set ::a(1) 1 return $::a($::a(1)) } - list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}] -} {2 1 3 3 1} -test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} { + list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {"a" in [info globals]}] +} -result {2 1 3 3 1} +test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} -setup { catch {namespace delete test_ns_compile} catch {unset x} +} -body { namespace eval test_ns_compile { variable v hello variable arr @@ -187,7 +228,7 @@ test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} { set ::test_ns_compile::arr(1) 123 } list $::x $::test_ns_compile::arr(1) -} {hello 123} +} -result {hello 123} test compile-7.1 {TclCompileWhileCmd: command substituted test expression} { set i 0 @@ -228,53 +269,45 @@ test compile-10.1 {BLACKBOX: exception stack overflow} { } } {} -test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { +test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { # shared object - Interp result && Var 'r' set r [list foobar] # command that will add error to result lindex a bogus - } - list [catch {p} msg] $msg -} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} -test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; string index a bogus } - list [catch {p} msg] $msg -} {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} + }} +} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} +test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; string index a bogus }} +} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { - proc p {} { set r [list foobar] ; string index a 0o9 } - list [catch {p} msg] $msg -} -match glob -result {1 {*invalid octal number*}} -test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; array set var {one two many} } - list [catch {p} msg] $msg -} {1 {list must have an even number of elements}} -test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; incr foo bar baz} - list [catch {p} msg] $msg -} {1 {wrong # args: should be "incr varName ?increment?"}} -test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; incr} - list [catch {p} msg] $msg -} {1 {wrong # args: should be "incr varName ?increment?"}} + apply {{} { set r [list foobar] ; string index a 0o9 }} +} -returnCodes error -match glob -result {*invalid octal number*} +test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; array set var {one two many} }} +} -returnCodes error -result {list must have an even number of elements} +test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; incr foo bar baz}} +} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} +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 { - proc p {} { set r [list foobar] ; expr !a } - p + apply {{} { set r [list foobar] ; expr !a }} } -returnCodes error -match glob -result * test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { - proc p {} { set r [list foobar] ; expr {!a} } - p + apply {{} { set r [list foobar] ; expr {!a} }} } -returnCodes error -match glob -result * -test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { - proc p {} { set r [list foobar] ; llength "\{" } +test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { + apply {{} { set r [list foobar] ; llength "\{" }} list [catch {p} msg] $msg -} {1 {unmatched open brace in list}} +} -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 +# TclReleaseLiteral. They are only effective when tcl is compiled with +# TCL_MEM_DEBUG # # Special test for leak on interp delete [Bug 467523]. test compile-12.1 {testing literal leak on interp delete} -setup { @@ -298,9 +331,9 @@ test compile-12.1 {testing literal leak on interp delete} -setup { rename getbytes {} unset -nocomplain end i tmp leakedBytes } -result 0 -# Special test for a memory error in a preliminary fix of [Bug 467523]. -# It requires executing a helpfile. Presumably the child process is -# used because when this test fails, it crashes. +# Special test for a memory error in a preliminary fix of [Bug 467523]. It +# requires executing a helpfile. Presumably the child process is used because +# when this test fails, it crashes. test compile-12.2 {testing error on literal deletion} -constraints {memory exec} -body { set sourceFile [makeFile { for {set i 0} {$i < 5} {incr i} { @@ -325,29 +358,28 @@ test compile-12.3 {check for a buffer overrun} -body { test compile-12.4 {TclCleanupLiteralTable segfault} -body { # Tcl Bug 1001997 # Here, we're trying to test a case that causes a crash in - # TclCleanupLiteralTable. The conditions that we're trying to - # establish are: - # - TclCleanupLiteralTable is attempting to clean up a bytecode - # object in the literal table. - # - The bytecode object in question contains the only reference - # to another literal. + # TclCleanupLiteralTable. The conditions that we're trying to establish + # are: + # - TclCleanupLiteralTable is attempting to clean up a bytecode object in + # the literal table. + # - The bytecode object in question contains the only reference to another + # literal. # - The literal in question is in the same hash bucket as the bytecode # object, and immediately follows it in the chain. - # Since newly registered literals are added at the FRONT of the - # bucket chains, and since the bytecode object is registered before - # its literals, this is difficult to achieve. What we do is: - # (a) do a [namespace eval] of a string that's calculated to - # hash into the same bucket as a literal that it contains. - # In this case, the script and the variable 'bugbug' - # land in the same bucket. - # (b) do a [namespace eval] of a string that contains enough - # literals to force TclRegisterLiteral to rebuild the global - # literal table. The newly created hash buckets will contain - # the literals, IN REVERSE ORDER, thus putting the bytecode - # immediately ahead of 'bugbug' and 'bug4345bug'. The bytecode - # object will contain the only references to those two literals. - # (c) Delete the interpreter to invoke TclCleanupLiteralTable - # and tickle the bug. + # Since newly registered literals are added at the FRONT of the bucket + # chains, and since the bytecode object is registered before its literals, + # this is difficult to achieve. What we do is: + # (a) do a [namespace eval] of a string that's calculated to hash into + # the same bucket as a literal that it contains. In this case, the + # script and the variable 'bugbug' land in the same bucket. + # (b) do a [namespace eval] of a string that contains enough literals to + # force TclRegisterLiteral to rebuild the global literal table. The + # newly created hash buckets will contain the literals, IN REVERSE + # ORDER, thus putting the bytecode immediately ahead of 'bugbug' and + # 'bug4345bug'. The bytecode object will contain the only references + # to those two literals. + # (c) Delete the interpreter to invoke TclCleanupLiteralTable and tickle + # the bug. proc foo {} { set i [interp create] $i eval { @@ -381,9 +413,8 @@ test compile-12.4 {TclCleanupLiteralTable segfault} -body { rename foo {} } -result ok -# Special test for underestimating the maxStackSize required for a -# compiled command. A failure will cause a segfault in the child -# process. +# Special test for underestimating the maxStackSize required for a compiled +# command. A failure will cause a segfault in the child process. test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} { set body {set x [list} for {set i 0} {$i < 3000} {incr i} { @@ -394,8 +425,8 @@ 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] +# Special test for compiling tokens from a copy of the source string. [Bug +# 599788] test compile-14.1 {testing errors in element name; segfault?} {} { catch {set a([error])} msg1 catch {set bubba([join $abba $jubba]) $vol} msg2 @@ -404,34 +435,19 @@ test compile-14.1 {testing errors in element name; segfault?} {} { # Tests compile-15.* cover Tcl Bug 633204 test compile-15.1 {proper TCL_RETURN code from [return]} { - proc p {} {catch return} - set result [p] - rename p {} - set result + apply {{} {catch return}} } 2 test compile-15.2 {proper TCL_RETURN code from [return]} { - proc p {} {catch {return foo}} - set result [p] - rename p {} - set result + apply {{} {catch {return foo}}} } 2 test compile-15.3 {proper TCL_RETURN code from [return]} { - proc p {} {catch {return $::tcl_library}} - set result [p] - rename p {} - set result + apply {{} {catch {return $::tcl_library}}} } 2 test compile-15.4 {proper TCL_RETURN code from [return]} { - proc p {} {catch {return [info library]}} - set result [p] - rename p {} - set result + apply {{} {catch {return [info library]}}} } 2 test compile-15.5 {proper TCL_RETURN code from [return]} { - proc p {} {catch {set a 1}; return} - set result [p] - rename p {} - set result + apply {{} {catch {set a 1}; return}} } "" for {set noComp 0} {$noComp <= 1} {incr noComp} { @@ -506,17 +522,16 @@ test compile-16.17.$noComp {TclCompileScript: word expansion} $constraints { run {list {*}x y z} } {x y z} -# These tests note that expansion can in theory cause the number of -# arguments to a command to exceed INT_MAX, which is as big as objc -# is allowed to get. +# These tests note that expansion can in theory cause the number of arguments +# to a command to exceed INT_MAX, which is as big as objc is allowed to get. # -# In practice, it seems we will run out of memory before we confront -# this issue. Note that compiled operations run out of memory at -# smaller objc values than direct string evaluation. +# In practice, it seems we will run out of memory before we confront this +# issue. Note that compiled operations run out of memory at smaller objc +# values than direct string evaluation. # -# These tests are constrained as knownBug because they are likely -# to cause memory allocation panics somewhere, and we don't want -# panics in the test suite. +# These tests are constrained as knownBug because they are likely to cause +# memory allocation panics somewhere, and we don't want panics in the test +# suite. # test compile-16.18.$noComp {TclCompileScript: word expansion} -body { proc LongList {} {return [lrepeat [expr {1<<10}] x]} @@ -578,8 +593,8 @@ test compile-16.26.$noComp {TclCompileScript: word expansion, protected backslas } {a {\n} b} } ;# End of noComp loop -# These tests are messy because it wrecks the interpreter it runs in! -# They demonstrate issues arising from [FRQ 1101710] +# These tests are messy because it wrecks the interpreter it runs in! They +# demonstrate issues arising from [FRQ 1101710] test compile-17.1 {Command interpretation binding for compiled code} -constraints knownBug -setup { set i [interp create] } -body { @@ -693,7 +708,7 @@ test compile-18.19 {disassembler - basics} -setup { foo destroy } -match glob -result * # TODO sometime - check that bytecode from tbcload is *not* disassembled. - + # cleanup catch {rename p ""} catch {namespace delete test_ns_compile} @@ -702,3 +717,8 @@ catch {unset y} catch {unset a} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/concat.test b/tests/concat.test index c369340..eeb11ca 100644 --- a/tests/concat.test +++ b/tests/concat.test @@ -1,23 +1,21 @@ # Commands covered: concat # -# 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-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. -# -# RCS: @(#) $Id: concat.test,v 1.6 2004/05/19 10:55:05 dkf Exp $ +# 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} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } - + test concat-1.1 {simple concatenation} { concat a b c d e f g } {a b c d e f g} @@ -48,7 +46,12 @@ test concat-4.2 {pruning off extra white space} { test concat-4.3 {pruning off extra white space sets length correctly} { llength [concat { {{a}} }] } 1 - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/config.test b/tests/config.test index cc951fb..d14837e 100644 --- a/tests/config.test +++ b/tests/config.test @@ -11,8 +11,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: config.test,v 1.5 2008/07/19 22:50:38 nijtmans Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/coroutine.test b/tests/coroutine.test index d7b30bc..8272717 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -8,14 +8,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: coroutine.test,v 1.14 2010/08/11 23:38:57 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testnrelevels [llength [info commands testnrelevels]] testConstraint memory [llength [info commands memory]] @@ -437,6 +438,31 @@ test coroutine-4.5 {bug #2724403} -constraints {memory} \ unset i ns start end } -result 0 +test coroutine-4.6 {compile context, bug #3282869} -setup { + unset ::x + proc f x { + coroutine D eval {yield X$x;yield Y} + } +} -body { + f 12 +} -cleanup { + rename f {} +} -returnCodes error -match glob -result {can't read *} + +test coroutine-4.7 {compile context, bug #3282869} -setup { + proc f x { + coroutine D eval {yield X$x;yield Y$x} + } +} -body { + set ::x 15 + set ::x [f 12] + D +} -cleanup { + D + unset ::x + rename f {} +} -result YX15 + test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} \ -setup { proc nestedYield {{val {}}} { @@ -534,12 +560,25 @@ test coroutine-6.3 {coroutine nargs} -body { } -cleanup { rename a {} } -returnCodes error -result {wrong # args: should be "a ?arg?"} -test coroutine-6.4 {unsupported: multi-argument yield} -body { + +test coroutine-7.1 {yieldto} -body { + coroutine c apply {{} { + yield + yieldto return -level 0 -code 1 quux + return quuy + }} + set res [list [catch c msg] $msg] + lappend res [catch c msg] $msg + lappend res [catch c msg] $msg +} -cleanup { + unset res +} -result [list 1 quux 0 quuy 1 {invalid command name "c"}] +test coroutine-7.2 {multi-argument yielding with yieldto} -body { proc corobody {} { set a 1 while 1 { set a [yield $a] - set a [::tcl::unsupported::yieldm $a] + set a [yieldto return -level 0 $a] lappend a [llength $a] } } @@ -550,20 +589,26 @@ test coroutine-6.4 {unsupported: multi-argument yield} -body { } -cleanup { rename corobody {} } -result {x {y z 2} \{p {\{q r 2} {} 0 {} ok {}} - -test coroutine-7.1 {yieldTo} -body { - coroutine c apply {{} { - yield - tcl::unsupported::yieldTo return -level 0 -code 1 quux - return quuy - }} - set res [list [catch c msg] $msg] - lappend res [catch c msg] $msg - lappend res [catch c msg] $msg +test coroutine-7.3 {yielding between coroutines} -body { + proc juggler {target {value ""}} { + if {$value eq ""} { + set value [yield [info coroutine]] + } + while {[llength $value]} { + lappend ::result $value [info coroutine] + set value [lrange $value 0 end-1] + lassign [yieldto $target $value] value + } + # Clear nested collection of coroutines + catch $target + } + set result "" + coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\ + {a b c d e} + list $result [info command j1] [info command j2] [info command j3] } -cleanup { - unset res -} -result [list 1 quux 0 quuy 1 {invalid command name "c"}] - + catch {rename juggler ""} +} -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} # cleanup unset lambda diff --git a/tests/dcall.test b/tests/dcall.test index 55f6731..3df0ac8 100644 --- a/tests/dcall.test +++ b/tests/dcall.test @@ -10,14 +10,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: dcall.test,v 1.6 2004/05/19 10:54:20 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testdcall [llength [info commands testdcall]] test dcall-1.1 {deletion callbacks} testdcall { diff --git a/tests/dict.test b/tests/dict.test index c7d186d..72a336c 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -8,8 +8,6 @@ # Copyright (c) 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. -# -# RCS: @(#) $Id: dict.test,v 1.37 2010/05/20 08:37:09 ferrieux Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -80,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 @@ -216,9 +232,7 @@ test dict-9.2 {dict exists command} {dict exists {a b} b} 0 test dict-9.3 {dict exists command} {dict exists {a {b c}} a b} 1 test dict-9.4 {dict exists command} {dict exists {a {b c}} a c} 0 test dict-9.5 {dict exists command} {dict exists {a {b c}} b c} 0 -test dict-9.6 {dict exists command} -returnCodes error -body { - dict exists {a {b c d}} a c -} -result {missing value to go with key} +test dict-9.6 {dict exists command} {dict exists {a {b c d}} a c} 0 test dict-9.7 {dict exists command} -returnCodes error -body { dict exists } -result {wrong # args: should be "dict exists dictionary key ?key ...?"} @@ -426,6 +440,9 @@ test dict-12.10 {dict lappend command: write failure} -setup { } -returnCodes error -cleanup { unset dictVar } -result {can't set "dictVar": variable is array} +test dict-12.11 {compiled dict append: invalidate string rep - Bug 3079830} { + apply {{} {set d {a 1 b 2 c 3}; dict lappend d b 22}} +} {a 1 b {2 22} c 3} test dict-13.1 {dict append command} -body { set dictv {a a} @@ -487,6 +504,9 @@ test dict-13.9 {dict append command: write failure} -setup { test dict-13.10 {compiled dict append: crash case} { apply {{} {dict append dictVar a o k}} } {a ok} +test dict-13.11 {compiled dict append: invalidate string rep - Bug 3079830} { + apply {{} {set d {a 1 b 2 c 3}; dict append d b 22}} +} {a 1 b 222 c 3} test dict-14.1 {dict for command: syntax} -returnCodes error -body { dict for @@ -779,6 +799,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 varName 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} @@ -1109,6 +1178,36 @@ 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-21.1 {dict update command} -returnCodes 1 -body { dict update @@ -1354,6 +1453,433 @@ test dict-22.11 {dict with command: no recursive structures [Bug 1786481]} -body } -cleanup { unset foo t inner } -result OK +test dict-22.12 {dict with: compiled} { + apply {{} { + set d {a 1 b 2} + list [dict with d { + set a $b + unset b + dict set d c 3 + list ok + }] $d + }} +} {ok {a 2 c 3}} +test dict-22.13 {dict with: compiled} { + apply {i { + set d($i) {a 1 b 2} + list [dict with d($i) { + set a $b + unset b + dict set d($i) c 3 + list ok + }] [array get d] + }} e +} {ok {e {a 2 c 3}}} +test dict-22.14 {dict with: compiled} { + apply {{} { + set d {a 1 b 2} + foreach x {1 2 3} { + dict with d { + incr a $b + if {$x == 2} break + } + unset a b + } + list $a $b $x $d + }} +} {5 2 2 {a 5 b 2}} +test dict-22.15 {dict with: compiled} { + apply {i { + set d($i) {a 1 b 2} + foreach x {1 2 3} { + dict with d($i) { + incr a $b + if {$x == 2} break + } + unset a b + } + list $a $b $x [array get d] + }} e +} {5 2 2 {e {a 5 b 2}}} +test dict-22.16 {dict with: compiled} { + apply {{} { + set d {p {q {a 1 b 2}}} + dict with d p q { + set a $b.$a + } + return $d + }} +} {p {q {a 2.1 b 2}}} +test dict-22.17 {dict with: compiled} { + apply {i { + set d($i) {p {q {a 1 b 2}}} + dict with d($i) p q { + set a $b.$a + } + array get d + }} e +} {e {p {q {a 2.1 b 2}}}} +test dict-22.18 {dict with: compiled} { + set ::d {a 1 b 2} + apply {{} { + dict with ::d { + set a $b.$a + } + return $::d + }} +} {a 2.1 b 2} +test dict-22.19 {dict with: compiled} { + set ::d {p {q {r {a 1 b 2}}}} + apply {{} { + dict with ::d p q r { + set a $b.$a + } + return $::d + }} +} {p {q {r {a 2.1 b 2}}}} +test dict-22.20 {dict with: compiled} { + apply {d { + dict with d { + } + return $a,$b + }} {a 1 b 2} +} 1,2 +test dict-22.21 {dict with: compiled} { + apply {d { + dict with d p q { + } + return $a,$b + }} {p {q {a 1 b 2}}} +} 1,2 +test dict-22.22 {dict with: compiled} { + set ::d {a 1 b 2} + apply {{} { + dict with ::d { + } + return $a,$b + }} +} 1,2 +test dict-22.23 {dict with: compiled} { + set ::d {p {q {a 1 b 2}}} + apply {{} { + dict with ::d p q { + } + return $a,$b + }} +} 1,2 + +proc linenumber {} { + dict get [info frame -1] line +} +test dict-23.1 {dict compilation crash: Bug 3487626} { + apply {{} {apply {n { + set e {} + set k {} + dict for {a b} {c {d {e {f g}}}} { + ::tcl::dict::for {h i} $b { + dict update i e j { + ::tcl::dict::update j f k { + return [expr {$n - [linenumber]}] + } + } + } + } + }} [linenumber]}} +} 5 +test dict-23.2 {dict compilation crash: Bug 3487626} knownBug { + # 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 + # confusing things. + apply {{} {apply {n { + set e {} + set k {} + dict for {a { +b +}} {c {d {e {f g}}}} { + ::tcl::dict::for {h { +i +}} ${ +b +} { + dict update { +i +} e { +j +} { + ::tcl::dict::update { +j +} f k { + return [expr {$n - [linenumber]}] + } + } + } + } + }} [linenumber]}} +} 5 +rename linenumber {} + +test dict-24.1 {dict map command: syntax} -returnCodes error -body { + dict map +} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +test dict-24.2 {dict map command: syntax} -returnCodes error -body { + dict map x +} -result {wrong # args: should be "dict map {keyVar valueVar} dictionary script"} +test dict-24.3 {dict map command: syntax} -returnCodes error -body { + dict map x x +} -result {wrong # args: should be "dict map {keyVar valueVar} 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 {keyVar valueVar} 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} knownBug { + 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 +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 + # cleanup ::tcltest::cleanupTests diff --git a/tests/dstring.test b/tests/dstring.test index 033e29e..06121a3 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -1,44 +1,57 @@ # Commands covered: none # -# This file contains a collection of tests for Tcl's dynamic string -# library procedures. 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 Tcl's dynamic string 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 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. -# -# RCS: @(#) $Id: dstring.test,v 1.8 2004/06/24 10:34:12 dkf Exp $ +# 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} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } -testConstraint testdstring [llength [info commands testdstring]] +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] -test dstring-1.1 {appending and retrieving} testdstring { +testConstraint testdstring [llength [info commands testdstring]] +if {[testConstraint testdstring]} { + testdstring free +} + +test dstring-1.1 {appending and retrieving} -constraints testdstring -setup { testdstring free +} -body { testdstring append "abc" -1 list [testdstring get] [testdstring length] -} {abc 3} -test dstring-1.2 {appending and retrieving} testdstring { +} -cleanup { testdstring free +} -result {abc 3} +test dstring-1.2 {appending and retrieving} -constraints testdstring -setup { + testdstring free +} -body { testdstring append "abc" -1 testdstring append " xyzzy" 3 testdstring append " 12345" -1 list [testdstring get] [testdstring length] -} {{abc xy 12345} 12} -test dstring-1.3 {appending and retrieving} testdstring { +} -cleanup { + testdstring free +} -result {{abc xy 12345} 12} +test dstring-1.3 {appending and retrieving} -constraints testdstring -setup { testdstring free +} -body { foreach l {a b c d e f g h i j k l m n o p} { testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 } list [testdstring get] [testdstring length] -} {{aaaaaaaaaaaaaaaaaaaaa +} -cleanup { + testdstring free +} -result {{aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd @@ -56,101 +69,143 @@ ooooooooooooooooooooo ppppppppppppppppppppp } 352} -test dstring-2.1 {appending list elements} testdstring { +test dstring-2.1 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { testdstring element "abc" testdstring element "d e f" list [testdstring get] [testdstring length] -} {{abc {d e f}} 11} -test dstring-2.2 {appending list elements} testdstring { +} -cleanup { testdstring free +} -result {{abc {d e f}} 11} +test dstring-2.2 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { testdstring element "x" testdstring element "\{" testdstring element "ab\}" testdstring get -} {x \{ ab\}} -test dstring-2.3 {appending list elements} testdstring { +} -cleanup { + testdstring free +} -result {x \{ ab\}} +test dstring-2.3 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { foreach l {a b c d e f g h i j k l m n o p} { testdstring element $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l } testdstring get -} {aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd eeeeeeeeeeeeeeeeeeeee fffffffffffffffffffff ggggggggggggggggggggg hhhhhhhhhhhhhhhhhhhhh iiiiiiiiiiiiiiiiiiiii jjjjjjjjjjjjjjjjjjjjj kkkkkkkkkkkkkkkkkkkkk lllllllllllllllllllll mmmmmmmmmmmmmmmmmmmmm nnnnnnnnnnnnnnnnnnnnn ooooooooooooooooooooo ppppppppppppppppppppp} -test dstring-2.4 {appending list elements} testdstring { +} -cleanup { testdstring free +} -result {aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd eeeeeeeeeeeeeeeeeeeee fffffffffffffffffffff ggggggggggggggggggggg hhhhhhhhhhhhhhhhhhhhh iiiiiiiiiiiiiiiiiiiii jjjjjjjjjjjjjjjjjjjjj kkkkkkkkkkkkkkkkkkkkk lllllllllllllllllllll mmmmmmmmmmmmmmmmmmmmm nnnnnnnnnnnnnnnnnnnnn ooooooooooooooooooooo ppppppppppppppppppppp} +test dstring-2.4 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { testdstring append "a\{" -1 testdstring element abc testdstring append " \{" -1 testdstring element xyzzy testdstring get -} "a{ abc {xyzzy" -test dstring-2.5 {appending list elements} testdstring { +} -cleanup { + testdstring free +} -result "a{ abc {xyzzy" +test dstring-2.5 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { testdstring append " \{" -1 testdstring element abc testdstring get -} " {abc" -test dstring-2.6 {appending list elements} testdstring { +} -cleanup { + testdstring free +} -result " {abc" +test dstring-2.6 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { testdstring append " " -1 testdstring element abc testdstring get -} { abc} -test dstring-2.7 {appending list elements} testdstring { +} -cleanup { testdstring free +} -result { abc} +test dstring-2.7 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { testdstring append "\\ " -1 testdstring element abc testdstring get -} "\\ abc" -test dstring-2.8 {appending list elements} testdstring { +} -cleanup { + testdstring free +} -result "\\ abc" +test dstring-2.8 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { testdstring append "x " -1 testdstring element abc testdstring get -} {x abc} -test dstring-2.9 {appending list elements} testdstring { +} -cleanup { + testdstring free +} -result {x abc} +test dstring-2.9 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { testdstring element # testdstring get -} {{#}} -test dstring-2.10 {appending list elements} testdstring { +} -cleanup { testdstring free +} -result {{#}} +test dstring-2.10 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { testdstring append " " -1 testdstring element # testdstring get -} { {#}} -test dstring-2.11 {appending list elements} testdstring { +} -cleanup { + testdstring free +} -result { {#}} +test dstring-2.11 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { testdstring append \t -1 testdstring element # testdstring get -} \t{#} -test dstring-2.12 {appending list elements} testdstring { +} -cleanup { + testdstring free +} -result \t{#} +test dstring-2.12 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { testdstring append x -1 testdstring element # testdstring get -} {x #} -test dstring-2.13 {appending list elements} testdstring { +} -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. testdstring free testdstring append "x " -1 testdstring element # testdstring get -} {x {#}} +} -cleanup { + testdstring free +} -result {x {#}} -test dstring-3.1 {nested sublists} testdstring { +test dstring-3.1 {nested sublists} -constraints testdstring -setup { testdstring free +} -body { testdstring start testdstring element foo testdstring element bar testdstring end testdstring element another testdstring get -} {{foo bar} another} -test dstring-3.2 {nested sublists} testdstring { +} -cleanup { testdstring free +} -result {{foo bar} another} +test dstring-3.2 {nested sublists} -constraints testdstring -setup { + testdstring free +} -body { testdstring start testdstring start testdstring element abc @@ -159,9 +214,12 @@ test dstring-3.2 {nested sublists} testdstring { testdstring end testdstring element ghi testdstring get -} {{{abc def}} ghi} -test dstring-3.3 {nested sublists} testdstring { +} -cleanup { + testdstring free +} -result {{{abc def}} ghi} +test dstring-3.3 {nested sublists} -constraints testdstring -setup { testdstring free +} -body { testdstring start testdstring start testdstring start @@ -173,9 +231,12 @@ test dstring-3.3 {nested sublists} testdstring { testdstring end testdstring element foo4 testdstring get -} {{{{foo foo2}} foo3} foo4} -test dstring-3.4 {nested sublists} testdstring { +} -cleanup { + testdstring free +} -result {{{{foo foo2}} foo3} foo4} +test dstring-3.4 {nested sublists} -constraints testdstring -setup { testdstring free +} -body { testdstring element before testdstring start testdstring element during @@ -183,52 +244,69 @@ test dstring-3.4 {nested sublists} testdstring { testdstring end testdstring element last testdstring get -} {before {during more} last} -test dstring-3.5 {nested sublists} testdstring { +} -cleanup { testdstring free +} -result {before {during more} last} +test dstring-3.5 {nested sublists} -constraints testdstring -setup { + testdstring free +} -body { testdstring element "\{" testdstring start testdstring element first testdstring element second testdstring end testdstring get -} {\{ {first second}} -test dstring-3.6 {appending list elements} testdstring { +} -cleanup { + testdstring free +} -result {\{ {first second}} +test dstring-3.6 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { testdstring append x -1 testdstring start testdstring element # testdstring end testdstring get -} {x {{#}}} -test dstring-3.7 {appending list elements} testdstring { +} -cleanup { + testdstring free +} -result {x {{#}}} +test dstring-3.7 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { testdstring append x -1 testdstring start testdstring append " " -1 testdstring element # testdstring end testdstring get -} {x { {#}}} -test dstring-3.8 {appending list elements} testdstring { +} -cleanup { testdstring free +} -result {x { {#}}} +test dstring-3.8 {appending list elements} -constraints testdstring -setup { + testdstring free +} -body { testdstring append x -1 testdstring start testdstring append \t -1 testdstring element # testdstring end testdstring get -} "x {\t{#}}" -test dstring-3.9 {appending list elements} testdstring { +} -cleanup { + testdstring free +} -result "x {\t{#}}" +test dstring-3.9 {appending list elements} -constraints testdstring -setup { testdstring free +} -body { testdstring append x -1 testdstring start testdstring append x -1 testdstring element # testdstring end testdstring get -} {x {x #}} -test dstring-3.10 {appending list elements} testdstring { +} -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. testdstring free @@ -238,36 +316,50 @@ test dstring-3.10 {appending list elements} testdstring { testdstring element # testdstring end testdstring get -} {x {x {#}}} +} -cleanup { + testdstring free +} -result {x {x {#}}} -test dstring-4.1 {truncation} testdstring { +test dstring-4.1 {truncation} -constraints testdstring -setup { testdstring free +} -body { testdstring append "abcdefg" -1 testdstring trunc 3 list [testdstring get] [testdstring length] -} {abc 3} -test dstring-4.2 {truncation} testdstring { +} -cleanup { + testdstring free +} -result {abc 3} +test dstring-4.2 {truncation} -constraints testdstring -setup { testdstring free +} -body { testdstring append "xyzzy" -1 testdstring trunc 0 list [testdstring get] [testdstring length] -} {{} 0} +} -cleanup { + testdstring free +} -result {{} 0} -test dstring-5.1 {copying to result} testdstring { +test dstring-5.1 {copying to result} -constraints testdstring -setup { testdstring free +} -body { testdstring append xyz -1 testdstring result -} xyz -test dstring-5.2 {copying to result} testdstring { +} -cleanup { + testdstring free +} -result xyz +test dstring-5.2 {copying to result} -constraints testdstring -setup { testdstring free - catch {unset a} + unset -nocomplain a +} -body { foreach l {a b c d e f g h i j k l m n o p} { testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 } set a [testdstring result] testdstring append abc -1 list $a [testdstring get] -} {{aaaaaaaaaaaaaaaaaaaaa +} -cleanup { + testdstring free +} -result {{aaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccc ddddddddddddddddddddd @@ -285,23 +377,31 @@ ooooooooooooooooooooo ppppppppppppppppppppp } abc} -test dstring-6.1 {Tcl_DStringGetResult} testdstring { +test dstring-6.1 {Tcl_DStringGetResult} -constraints testdstring -setup { testdstring free +} -body { list [testdstring gresult staticsmall] [testdstring get] -} {{} short} -test dstring-6.2 {Tcl_DStringGetResult} testdstring { +} -cleanup { testdstring free +} -result {{} short} +test dstring-6.2 {Tcl_DStringGetResult} -constraints testdstring -setup { + testdstring free +} -body { foreach l {a b c d e f g h i j k l m n o p} { testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 } list [testdstring gresult staticsmall] [testdstring get] -} {{} short} -test dstring-6.3 {Tcl_DStringGetResult} testdstring { +} -cleanup { + testdstring free +} -result {{} short} +test dstring-6.3 {Tcl_DStringGetResult} -constraints testdstring -body { set result {} lappend result [testdstring gresult staticlarge] testdstring append x 1 lappend result [testdstring get] -} {{} {first0 first1 first2 first3 first4 first5 first6 first7 first8 first9 +} -cleanup { + testdstring free +} -result {{} {first0 first1 first2 first3 first4 first5 first6 first7 first8 first9 second0 second1 second2 second3 second4 second5 second6 second7 second8 second9 third0 third1 third2 third3 third4 third5 third6 third7 third8 third9 fourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9 @@ -309,22 +409,31 @@ fifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9 sixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9 seventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9 x}} -test dstring-6.4 {Tcl_DStringGetResult} testdstring { +test dstring-6.4 {Tcl_DStringGetResult} -constraints testdstring -body { set result {} lappend result [testdstring gresult free] testdstring append y 1 lappend result [testdstring get] -} {{} {This is a malloc-ed stringy}} -test dstring-6.5 {Tcl_DStringGetResult} testdstring { +} -cleanup { + testdstring free +} -result {{} {This is a malloc-ed stringy}} +test dstring-6.5 {Tcl_DStringGetResult} -constraints testdstring -body { set result {} lappend result [testdstring gresult special] testdstring append z 1 lappend result [testdstring get] -} {{} {This is a specially-allocated stringz}} - +} -cleanup { + testdstring free +} -result {{} {This is a specially-allocated stringz}} + # cleanup if {[testConstraint testdstring]} { testdstring free } ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/encoding.test b/tests/encoding.test index bc57b2d..0374e2d 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -1,14 +1,12 @@ # This file contains a collection of tests for tclEncoding.c -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# 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. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: encoding.test,v 1.29 2009/11/16 17:38:09 ferrieux Exp $ +# 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 @@ -17,6 +15,11 @@ namespace eval ::tcl::test::encoding { namespace import -force ::tcltest::* +catch { + ::tcltest::loadTestedCommands + package require -exact Tcltest [info patchlevel] +} + proc toutf {args} { variable x lappend x "toutf $args" @@ -27,32 +30,34 @@ proc fromutf {args} { } proc runtests {} { - variable x # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] testConstraint exec [llength [info commands exec]] - +testConstraint testgetdefenc [llength [info commands testgetdefenc]] + # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested -test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} { - testencoding create foo [namespace origin toutf] [namespace origin fromutf] +test encoding-1.1 {Tcl_GetEncoding: system encoding} -setup { set old [encoding system] +} -constraints {testencoding} -body { + testencoding create foo [namespace origin toutf] [namespace origin fromutf] encoding system foo set x {} encoding convertto abcd + return $x +} -cleanup { encoding system $old testencoding delete foo - set x -} {{fromutf }} +} -result {{fromutf }} test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} { testencoding create foo [namespace origin toutf] [namespace origin fromutf] set x {} encoding convertto foo abcd testencoding delete foo - set x + return $x } {{fromutf }} test encoding-1.3 {Tcl_GetEncoding: load encoding} { list [encoding convertto jis0208 \u4e4e] \ @@ -62,71 +67,77 @@ test encoding-1.3 {Tcl_GetEncoding: load encoding} { test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} { encoding convertto jis0208 \u4e4e } {8C} -test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} { +test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { set system [encoding system] set path [encoding dirs] +} -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 llength shiftjis ;# Shimmer away any cache of Tcl_Encoding lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg +} -cleanup { encoding system identity encoding dirs $path encoding system $system - set x -} "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" +} -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" -test encoding-3.1 {Tcl_GetEncodingName, NULL} { +test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup { set old [encoding system] +} -body { encoding system shiftjis - set x [encoding system] + encoding system +} -cleanup { encoding system $old - set x -} {shiftjis} -test encoding-3.2 {Tcl_GetEncodingName, non-null} { +} -result {shiftjis} +test encoding-3.2 {Tcl_GetEncodingName, non-null} -setup { set old [fconfigure stdout -encoding] +} -body { fconfigure stdout -encoding jis0208 - set x [fconfigure stdout -encoding] + fconfigure stdout -encoding +} -cleanup { fconfigure stdout -encoding $old - set x -} {jis0208} +} -result {jis0208} -test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} { +test encoding-4.1 {Tcl_GetEncodingNames} -constraints {testencoding} -setup { cd [makeDirectory tmp] makeDirectory [file join tmp encoding] - makeFile {} [file join tmp encoding junk.enc] - makeFile {} [file join tmp encoding junk2.enc] set path [encoding dirs] encoding dirs {} catch {unset encodings} catch {unset x} +} -body { foreach encoding [encoding names] { set encodings($encoding) 1 } + makeFile {} [file join tmp encoding junk.enc] + makeFile {} [file join tmp encoding junk2.enc] encoding dirs [list [file join [pwd] encoding]] foreach encoding [encoding names] { if {![info exists encodings($encoding)]} { lappend x $encoding } } + lsort $x +} -cleanup { encoding dirs $path cd [workingDirectory] removeFile [file join tmp encoding junk2.enc] removeFile [file join tmp encoding junk.enc] removeDirectory [file join tmp encoding] removeDirectory tmp - lsort $x -} {junk junk2} +} -result {junk junk2} -test encoding-5.1 {Tcl_SetSystemEncoding} { +test encoding-5.1 {Tcl_SetSystemEncoding} -setup { set old [encoding system] +} -body { encoding system jis0208 - set x [encoding convertto \u4e4e] + encoding convertto \u4e4e +} -cleanup { encoding system identity encoding system $old - set x -} {8C} +} -result {8C} test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} { set old [encoding system] encoding system $old @@ -140,7 +151,7 @@ test encoding-6.1 {Tcl_CreateEncoding: new} {testencoding} { encoding convertfrom foo abcd encoding convertto foo abcd testencoding delete foo - set x + return $x } {{toutf 1} {fromutf 2}} test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} { testencoding create foo [namespace code {toutf a}] \ @@ -149,7 +160,7 @@ test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} { encoding convertfrom foo abcd encoding convertto foo abcd testencoding delete foo - set x + return $x } {{toutf a} {fromutf b}} test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} { @@ -175,7 +186,7 @@ test encoding-8.1 {Tcl_ExternalToUtf} { set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] - set x + return $x } "ab\u4e4eg" test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} { @@ -203,7 +214,7 @@ test encoding-10.1 {Tcl_UtfToExternal} { set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] - set x + return $x } "ab\x8c\xc1g" proc viewable {str} { @@ -244,10 +255,11 @@ test encoding-11.5 {LoadEncodingFile: escape file} { test encoding-11.5.1 {LoadEncodingFile: escape file} { viewable [encoding convertto iso2022-jp \u4e4e] } [viewable "\x1b\$B8C\x1b(B"] -test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} { +test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup { set system [encoding system] set path [encoding dirs] encoding system identity +} -body { cd [temporaryDirectory] encoding dirs [file join tmp encoding] makeDirectory tmp @@ -256,15 +268,15 @@ test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} { fconfigure $f -translation binary puts $f "abcdefghijklmnop" close $f - set x [list [catch {encoding convertto splat \u4e4e} msg] $msg] + encoding convertto splat \u4e4e +} -returnCodes error -cleanup { file delete [file join [temporaryDirectory] tmp encoding splat.enc] removeDirectory [file join tmp encoding] removeDirectory tmp cd [workingDirectory] encoding dirs $path encoding system $system - set x -} {1 {invalid encoding file "splat"}} +} -result {invalid encoding file "splat"} # OpenEncodingFile is fully tested by the rest of the tests in this file. @@ -302,7 +314,6 @@ test encoding-14.1 {BinaryProc} { 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] @@ -310,7 +321,6 @@ test encoding-15.2 {UtfToUtfProc null character output} { 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] @@ -390,44 +400,41 @@ test encoding-23.3 {iso2022-jp escape encoding test} { fconfigure $fid -encoding iso2022-jp set data [read $fid 50] close $fid - set data + return $data } [string range $iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50 cd [workingDirectory] -test encoding-24.1 {EscapeFreeProc on open channels} -constraints { - exec -} -setup { - # Bug #524674 input - set file [makeFile { +# Code to make the next few tests more intelligible; the code being tested +# should be in the body of the test! +proc runInSubprocess {contents {filename iso2022.tcl}} { + set theFile [makeFile $contents $filename] + try { + exec [interpreter] $theFile + } finally { + removeFile $theFile + } +} + +test encoding-24.1 {EscapeFreeProc on open channels} exec { + runInSubprocess { set f [open [file join [file dirname [info script]] iso2022.txt]] fconfigure $f -encoding iso2022-jp gets $f - } iso2022.tcl] -} -body { - exec [interpreter] $file -} -cleanup { - removeFile iso2022.tcl -} -result {} - -test encoding-24.2 {EscapeFreeProc on open channels} -constraints { - exec -} -setup { + } +} {} +test encoding-24.2 {EscapeFreeProc on open channels} {exec} { # Bug #524674 output - set file [makeFile { + viewable [runInSubprocess { encoding system cp1252; # Bug #2891556 crash revelator fconfigure stdout -encoding iso2022-jp puts ab\u4e4e\u68d9g - testfinexit - } iso2022.tcl] -} -body { - viewable [exec [interpreter] $file] -} -cleanup { - removeFile iso2022.tcl -} -result "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)" - + set env(TCL_FINALIZE_ON_EXIT) 1 + exit + }] +} "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 + # 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 @@ -471,18 +478,14 @@ proc foreach-jisx0208 {varName command} { } { if {[llength $range] == 2} { # for adhoc range. simple {first last}. inclusive. - set first [scan [lindex $range 0] %x] - set last [scan [lindex $range 1] %x] + scan $range %x%x first last for {set i $first} {$i <= $last} {incr i} { set code $i uplevel 1 $command } } elseif {[llength $range] == 4} { # for uniform range. - set h0 [scan [lindex $range 0] %x] - set l0 [scan [lindex $range 1] %x] - set hend [scan [lindex $range 2] %x] - set lend [scan [lindex $range 3] %x] + scan $range %x%x%x%x h0 l0 hend lend for {set hi $h0} {$hi <= $hend} {incr hi} { for {set lo $l0} {$lo <= $lend} {incr lo} { set code [expr {$hi << 8 | ($lo & 0xff)}] @@ -526,7 +529,7 @@ proc channel-diff {fa fb} { binary scan [lindex $lb 1] H* got lappend diff [list $code $expected $got] } - set diff + return $diff } # Create char tables. @@ -545,8 +548,9 @@ file copy -force cp932.chars shiftjis.chars set NUM 0 foreach from {cp932 shiftjis euc-jp iso2022-jp} { foreach to {cp932 shiftjis euc-jp iso2022-jp} { - test encoding-25.[incr NUM] "jisx0208 $from => $to" { + test encoding-25.[incr NUM] "jisx0208 $from => $to" -setup { cd [temporaryDirectory] + } -body { set f [open $from.chars] fconfigure $f -encoding $from set out [open $from.$to.tcltestout w] @@ -554,40 +558,43 @@ foreach from {cp932 shiftjis euc-jp iso2022-jp} { puts -nonewline $out [read $f] close $out close $f - # then compare $to.chars <=> $from.to.tcltestout as binary. - set fa [open $to.chars] - fconfigure $fa -encoding binary - set fb [open $from.$to.tcltestout] - fconfigure $fb -encoding binary - set diff [channel-diff $fa $fb] + set fa [open $to.chars rb] + set fb [open $from.$to.tcltestout rb] + channel-diff $fa $fb + # Difference should be empty. + } -cleanup { close $fa close $fb - - # Difference should be empty. - set diff - } {} + } -result {} } } -testConstraint testgetdefenc [llength [info commands testgetdefenc]] - test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints { - testgetdefenc + testgetdefenc } -setup { - set origDir [testgetdefenc] - testsetdefenc slappy + set origDir [testgetdefenc] + testsetdefenc slappy } -body { - testgetdefenc + testgetdefenc } -cleanup { - testsetdefenc $origDir + testsetdefenc $origDir } -result slappy file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout] # ===> Cut here <=== -# EscapeFreeProc, GetTableEncoding, unilen -# are fully tested by the rest of this file +# EscapeFreeProc, GetTableEncoding, unilen are fully tested by the rest of +# this file. + + +test encoding-27.1 {encoding dirs basic behavior} -returnCodes error -body { + encoding dirs ? ? +} -result {wrong # args: should be "encoding dirs ?dirList?"} +test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body { + encoding dirs "\{not a list" +} -result "expected directory list but got \"\{not a list\"" + } runtests @@ -597,3 +604,7 @@ runtests namespace delete ::tcl::test::encoding ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/env.test b/tests/env.test index f5669d7..9010f52 100644 --- a/tests/env.test +++ b/tests/env.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: env.test,v 1.32 2009/12/21 23:25:40 nijtmans Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -91,6 +89,7 @@ set printenvScript [makeFile { 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 } { lrem names $name } @@ -99,6 +98,7 @@ set printenvScript [makeFile { } exit } printenv] + # [exec] is required here to see the actual environment received by child # processes. proc getenv {} { @@ -121,6 +121,7 @@ foreach name [array names env] { 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) } diff --git a/tests/error.test b/tests/error.test index e30fd50..97bcc0a 100644 --- a/tests/error.test +++ b/tests/error.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: error.test,v 1.33 2010/06/02 23:36:26 ferrieux Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -140,7 +138,7 @@ test error-3.3 {errors in catch command} { catch {unset a} set a(0) 22 list [catch {catch {format 44} a} msg] $msg -} {1 {couldn't save command result in variable}} +} {1 {can't set "a": variable is array}} catch {unset a} # More tests related to errorInfo and errorCode @@ -174,13 +172,13 @@ test error-4.6 {errorstack via info } -body { proc g x {error G:$x} catch {f 12} info errorstack -} -match glob -result {CALL {g 1212} CALL {f 12} UP 1} +} -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} test error-4.7 {errorstack via options dict } -body { proc f x {g $x$x} proc g x {error G:$x} catch {f 12} m d dict get $d -errorstack -} -match glob -result {CALL {g 1212} CALL {f 12} UP 1} +} -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} # Errors in error command itself @@ -244,7 +242,7 @@ test error-6.10 {catch must reset errorstack} -body { catch {f 13} set e2 [info errorstack] list $e1 $e2 -} -match glob -result {{CALL {g 1212} CALL {f 12} UP 1} {CALL {g 1313} CALL {f 13} UP 1}} +} -match glob -result {{INNER * CALL {g 1212} CALL {f 12} UP 1} {INNER * CALL {g 1313} CALL {f 13} UP 1}} test error-7.1 {Bug 1397843} -body { variable cmds @@ -419,7 +417,7 @@ test error-12.4 {try with result/opts variable assignment in on handler} { } {bar,FOO} test error-12.5 {try with result/opts variable assignment in on handler, vars remain in scope} { try { throw FOO bar } on error {res opts} { list d e f } - set r "$res,[dict get $opts -errorcode]" + set r "$res,[dict get $opts -errorcode]" } {bar,FOO} test error-12.6 {try result is propagated if no matching handler} { try { list a b c } on error {} { list d e f } @@ -461,7 +459,7 @@ test error-13.8 {try with multiple handlers and finally (ok)} { try list on error {} {} trap {} {} {} finally {} } {} test error-13.9 {last handler body can't be a fallthrough #1} -body { - try list on error {} {} on break {} - + try list on error {} {} on break {} - } -returnCodes error -result {last non-finally clause must not have a body of "-"} test error-13.10 {last handler body can't be a fallthrough #2} -body { try list on error {} {} on break {} - finally { list d e f } @@ -473,7 +471,7 @@ test error-14.1 {try with multiple handlers (only one matches) #1} { try { throw FOO bar } on ok {} { list a b c } trap FOO {} { list d e f } } {d e f} test error-14.2 {try with multiple handlers (only one matches) #2} { - try { throw FOO bar } trap FOO {} { list d e f } on ok {} { list a b c } + try { throw FOO bar } trap FOO {} { list d e f } on ok {} { list a b c } } {d e f} test error-14.3 {try with multiple handlers (only one matches) #3} { try { @@ -484,7 +482,7 @@ test error-14.3 {try with multiple handlers (only one matches) #3} { list d e f } on ok {} { list a b c - } + } } {d e f} test error-14.4 {try with multiple matching handlers (only the first in left-to-right order runs) #1} { try { throw FOO bar } on error {} { list a b c } trap FOO {} { list d e f } @@ -595,16 +593,16 @@ test error-16.6 {try with variable assignment and propagation #1} { catch { try { throw FOO bar } trap FOO {em} { throw BAR baz } } - set em + set em } {bar} test error-16.7 {try with variable assignment and propagation #2} { catch { try { throw FOO bar } trap FOO {em opts} { throw BAR baz } } - list $em [dict get $opts -errorcode] + list $em [dict get $opts -errorcode] } {bar FOO} test error-16.8 {exception chaining (try=ok, handler=error)} { - #FIXME is the intent of this test correct? + #FIXME is the intent of this test correct? catch { try { list a b c } on ok {em opts} { throw BAR baz } } tryem tryopts @@ -688,7 +686,7 @@ test error-17.11 {successful finally doesn't affect variable assignment or propa catch { try { throw FOO bar } trap FOO {em opts} { throw BAR baz } finally { list d e f } } - list $em [dict get $opts -errorcode] + list $em [dict get $opts -errorcode] } {bar FOO} # try tests - propagation (exceptions in finally, exception chaining) @@ -709,11 +707,11 @@ test error-18.5 {exception in finally doesn't affect variable assignment} { catch { try { throw FOO bar } trap FOO {em opts} { throw BAR baz } finally { throw BAZ zing } } - list $em [dict get $opts -errorcode] + list $em [dict get $opts -errorcode] } {bar FOO} test error-18.6 {exception chaining in finally (try=ok)} { catch { - list a b c + list a b c } em expopts catch { try { list a b c } finally { throw BAR foo } @@ -784,14 +782,14 @@ test error-19.1 {try with fallthrough body #1} { } {1} test error-19.2 {try with fallthrough body #2} { set RES {} - try { - throw FOO bar + try { + throw FOO bar } trap BAR {} { } trap FOO {} - trap {} {} { set RES foo } on error {} { set RES err - } + } set RES } {foo} test error-19.3 {try with cascade fallthrough} { @@ -807,22 +805,22 @@ test error-19.4 {multiple unrelated fallthroughs #1} { set RES {} try { throw FOO bar - } trap FOO {} - trap BAR {} { + } trap FOO {} - trap BAR {} { set RES foo } trap {} {} - on error {} { set RES err - } + } set RES } {foo} test error-19.5 {multiple unrelated fallthroughs #2} { set RES {} try { throw BAZ zing - } trap FOO {} - trap BAR {} { + } trap FOO {} - trap BAR {} { set RES foo } trap {} {} - on error {} { set RES err - } + } set RES } {err} proc addmsg msg { @@ -912,6 +910,72 @@ test error-19.10 {compiled try with chained clauses} -setup { } -cleanup { unset RES } -result {handler {ok good finally}} +test error-19.11 {compiled try and errors on variable write} -setup { + set RES {} +} -body { + apply {{} { + array set foo {bar boo} + set bar unset + catch { + try { + addmsg body + return a + } on return {bar foo} { + addmsg handler + return b + } finally { + addmsg finally,$bar + } + } msg + addmsg $msg + } ::tcl::test::error} +} -cleanup { + unset RES +} -result {body finally,a {can't set "foo": variable is array}} +test error-19.12 {interpreted try and errors on variable write} -setup { + set RES {} +} -body { + apply {try { + array set foo {bar boo} + set bar unset + catch { + $try { + addmsg body + return a + } on return {bar foo} { + addmsg handler + return b + } finally { + addmsg finally,$bar + } + } msg + addmsg $msg + } ::tcl::test::error} try +} -cleanup { + unset RES +} -result {body finally,a {can't set "foo": variable is array}} +test error-19.13 {compiled try and errors on variable write} -setup { + set RES {} +} -body { + apply {{} { + array set foo {bar boo} + set bar unset + catch { + try { + addmsg body + return a + } on return {bar foo} - on error {bar foo} { + addmsg handler + return b + } finally { + addmsg finally,$bar + } + } msg + addmsg $msg + } ::tcl::test::error} +} -cleanup { + unset RES +} -result {body finally,a {can't set "foo": variable is array}} rename addmsg {} # FIXME test what vars get set on fallthough ... what is the correct behavior? @@ -990,7 +1054,7 @@ namespace delete ::tcl::test::error # cleanup catch {rename p ""} ::tcltest::cleanupTests -return +return # Local Variables: # mode: tcl diff --git a/tests/eval.test b/tests/eval.test index 98acd08..70ceac8 100644 --- a/tests/eval.test +++ b/tests/eval.test @@ -1,23 +1,21 @@ # Commands covered: eval # -# 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-1993 The Regents of the University of California. # Copyright (c) 1994 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. -# -# RCS: @(#) $Id: eval.test,v 1.9 2006/10/09 19:15:44 msofer Exp $ +# 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} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } - + test eval-1.1 {single argument} { eval {format 22} } 22 @@ -80,7 +78,12 @@ test eval-3.4 {concatenating eval and canonical lists} { unset dummy eval $cmd $cmd2 } {1 2 3 4 5} - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/event.test b/tests/event.test index c6ac019..0d1b06c 100644 --- a/tests/event.test +++ b/tests/event.test @@ -8,12 +8,17 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: event.test,v 1.29 2010/07/05 09:50:10 dkf Exp $ package require tcltest 2 namespace import -force ::tcltest::* +catch { + ::tcltest::loadTestedCommands + package require -exact Tcltest [info patchlevel] + set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] +} + + testConstraint testfilehandler [llength [info commands testfilehandler]] testConstraint testexithandler [llength [info commands testexithandler]] testConstraint testfilewait [llength [info commands testfilewait]] @@ -429,6 +434,7 @@ catch {rename bgerror {}} test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} { set child [open |[list [interpreter]] r+] + puts $child "catch {load $::tcltestlib Tcltest}" puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; exit" flush $child @@ -442,6 +448,7 @@ odd 41 test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { set child [open |[list [interpreter]] r+] + puts $child "catch {load $::tcltestlib Tcltest}" puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; testexithandler delete 41" puts $child "testexithandler create 16; exit" @@ -455,6 +462,7 @@ even 4 } test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { set child [open |[list [interpreter]] r+] + puts $child "catch {load $::tcltestlib Tcltest}" puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; testexithandler delete 4" puts $child "testexithandler create 16; exit" @@ -468,6 +476,7 @@ odd 41 } test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { set child [open |[list [interpreter]] r+] + puts $child "catch {load $::tcltestlib Tcltest}" puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; testexithandler delete 6" puts $child "testexithandler create 16; exit" @@ -481,6 +490,7 @@ odd 41 } test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { set child [open |[list [interpreter]] r+] + puts $child "catch {load $::tcltestlib Tcltest}" puts $child "testexithandler create 41; testexithandler delete 41" puts $child "testexithandler create 16; exit" flush $child diff --git a/tests/exec.test b/tests/exec.test index 61b818e..64d3517 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: exec.test,v 1.33 2009/05/08 08:13:31 dkf Exp $ package require tcltest 2 namespace import -force ::tcltest::* diff --git a/tests/execute.test b/tests/execute.test index 9e5b1f6..94af158 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -1,26 +1,27 @@ -# This file contains tests for the tclExecute.c source file. Tests appear -# in the same order as the C code that they test. The set of tests is -# currently incomplete since it currently includes only new tests for -# code changed for the addition of Tcl namespaces. Other execution- -# related tests appear in several other test files including -# namespace.test, basic.test, eval.test, for.test, etc. +# This file contains tests for the tclExecute.c source file. Tests appear in +# the same order as the C code that they test. The set of tests is currently +# incomplete since it currently includes only new tests for code changed for +# the addition of Tcl namespaces. Other execution-related tests appear in +# several other test files including namespace.test, basic.test, eval.test, +# for.test, etc. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# 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. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: execute.test,v 1.36 2010/09/22 17:21:03 msofer Exp $ +# 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} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} catch {unset x} @@ -35,7 +36,7 @@ testConstraint testobj [expr { testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint testexprlongobj [llength [info commands testexprlongobj]] - + # Tests for the omnibus TclExecuteByteCode function: # INST_DONE not tested @@ -498,10 +499,11 @@ test execute-3.77 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is non-numeri # INST_PUSH_RESULT not tested # INST_PUSH_RETURN_CODE not tested -test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { +test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} - catch {unset x} - catch {unset y} + unset -nocomplain x + unset -nocomplain y +} -body { namespace eval test_ns_1 { namespace export cmd1 proc cmd1 {args} {return "cmd1: $args"} @@ -515,11 +517,12 @@ test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { list [namespace which -command ${x}${y}cmd1] \ [catch {namespace which -command ${x}${y}cmd2} msg] $msg \ [catch {namespace which -command ${x}${y}:cmd2} msg] $msg -} {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}} -test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} { +} -result {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}} +test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} - catch {unset l} + unset -nocomplain l +} -body { proc foo {} { return "global foo" } @@ -536,11 +539,11 @@ test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is inval } } lappend l [test_ns_1::whichFoo] - set l -} {::foo ::test_ns_1::foo} -test execute-4.3 {Tcl_GetCommandFromObj, command never found} { +} -result {::foo ::test_ns_1::foo} +test execute-4.3 {Tcl_GetCommandFromObj, command never found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} +} -body { namespace eval test_ns_1 { proc foo {} { return "namespace foo" @@ -554,17 +557,18 @@ test execute-4.3 {Tcl_GetCommandFromObj, command never found} { list [namespace eval test_ns_1 {namespace which -command foo}] \ [rename test_ns_1::foo ""] \ [catch {namespace eval test_ns_1 {namespace which -command foo}} msg] $msg -} {::test_ns_1::foo {} 0 {}} +} -result {::test_ns_1::foo {} 0 {}} -test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} { +test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} - catch {unset l} + unset -nocomplain l +} -body { proc {} {} {return {}} {} set l {} lindex {} 0 {} -} {} +} -result {} test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} { proc {} {} {} @@ -600,7 +604,7 @@ test execute-6.4 {TclCompEvalObj: don't use cached expr bytecode [Bug 1899164]} } -cleanup { rename 0+0 {} } -result SCRIPT -test execute-6.5 {TclCompEvalObj: bytecode epoch validation} { +test execute-6.5 {TclCompEvalObj: bytecode epoch validation} -body { set script { llength {} } set result {} lappend result [if 1 $script] @@ -608,20 +612,22 @@ test execute-6.5 {TclCompEvalObj: bytecode epoch validation} { rename $origName llength.orig proc $origName {args} {return AHA!} lappend result [if 1 $script] +} -cleanup { rename $origName {} rename llength.orig $origName - set result -} {0 AHA!} -test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} { +} -result {0 AHA!} +test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} -body { proc foo {} {set a 1} set a untouched set result {} lappend result [foo] $a lappend result [if 1 [info body foo]] $a +} -cleanup { rename foo {} - set result -} {1 untouched 1 1} -test execute-6.7 {TclCompEvalObj: bytecode context validation} { +} -result {1 untouched 1 1} +test execute-6.7 {TclCompEvalObj: bytecode context validation} -setup { + namespace eval foo {} +} -body { set script { llength {} } namespace eval foo { proc llength {args} {return AHA!} @@ -629,10 +635,12 @@ test execute-6.7 {TclCompEvalObj: bytecode context validation} { set result {} lappend result [if 1 $script] lappend result [namespace eval foo $script] +} -cleanup { namespace delete foo - set result -} {0 AHA!} -test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} { +} -result {0 AHA!} +test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} -setup { + namespace eval foo {} +} -body { set script { llength {} } set result {} lappend result [namespace eval foo $script] @@ -640,20 +648,21 @@ test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} { proc llength {args} {return AHA!} } lappend result [namespace eval foo $script] +} -cleanup { namespace delete foo - set result -} {0 AHA!} -test execute-6.9 {TclCompEvalObj: bytecode interp validation} { - set script { llength {} } +} -result {0 AHA!} +test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup { interp create slave +} -body { + set script { llength {} } slave eval {proc llength args {return AHA!}} set result {} lappend result [if 1 $script] lappend result [slave eval $script] +} -cleanup { interp delete slave - set result -} {0 AHA!} -test execute-6.10 {TclCompEvalObj: bytecode interp validation} { +} -result {0 AHA!} +test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body { set script { llength {} } interp create slave set result {} @@ -661,13 +670,14 @@ test execute-6.10 {TclCompEvalObj: bytecode interp validation} { interp delete slave interp create slave lappend result [slave eval $script] - interp delete slave - set result -} {0 0} -test execute-6.11 {Tcl_ExprObj: exprcode interp validation} testexprlongobj { +} -cleanup { + catch {interp delete slave} +} -result {0 0} +test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup { + interp create slave +} -constraints testexprlongobj -body { set e { [llength {}]+1 } set result {} - interp create slave load {} Tcltest slave interp alias {} e slave testexprlongobj lappend result [e $e] @@ -676,23 +686,24 @@ test execute-6.11 {Tcl_ExprObj: exprcode interp validation} testexprlongobj { load {} Tcltest slave interp alias {} e slave testexprlongobj lappend result [e $e] +} -cleanup { interp delete slave - set result -} {{This is a result: 1} {This is a result: 1}} -test execute-6.12 {Tcl_ExprObj: exprcode interp validation} { +} -result {{This is a result: 1} {This is a result: 1}} +test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup { + interp create slave +} -body { set e { [llength {}]+1 } set result {} - interp create slave interp alias {} e slave expr lappend result [e $e] interp delete slave interp create slave interp alias {} e slave expr lappend result [e $e] +} -cleanup { interp delete slave - set result -} {1 1} -test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} { +} -result {1 1} +test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body { set e { [llength {}]+1 } set result {} lappend result [expr $e] @@ -700,11 +711,13 @@ test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} { rename $origName llength.orig proc $origName {args} {return 1} lappend result [expr $e] +} -cleanup { rename $origName {} rename llength.orig $origName - set result -} {1 2} -test execute-6.14 {Tcl_ExprObj: exprcode context validation} { +} -result {1 2} +test execute-6.14 {Tcl_ExprObj: exprcode context validation} -setup { + namespace eval foo {} +} -body { set e { [llength {}]+1 } namespace eval foo { proc llength {args} {return 1} @@ -712,10 +725,12 @@ test execute-6.14 {Tcl_ExprObj: exprcode context validation} { set result {} lappend result [expr $e] lappend result [namespace eval foo {expr $e}] +} -cleanup { namespace delete foo - set result -} {1 2} -test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} { +} -result {1 2} +test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setup { + namespace eval foo {} +} -body { set e { [llength {}]+1 } set result {} lappend result [namespace eval foo {expr $e}] @@ -723,42 +738,43 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} { proc llength {args} {return 1} } lappend result [namespace eval foo {expr $e}] +} -cleanup { namespace delete foo - set result -} {1 2} -test execute-6.16 {Tcl_ExprObj: exprcode interp validation} { - set e { [llength {}]+1 } +} -result {1 2} +test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup { interp create slave +} -body { + set e { [llength {}]+1 } interp alias {} e slave expr slave eval {proc llength args {return 1}} set result {} lappend result [expr $e] lappend result [e $e] +} -cleanup { interp delete slave - set result -} {1 2} -test execute-6.17 {Tcl_ExprObj: exprcode context validation} { - set e { $v } +} -result {1 2} +test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body { proc foo e {set v 0; expr $e} proc bar e {set v 1; expr $e} + set e { $v } set result {} lappend result [foo $e] lappend result [bar $e] +} -cleanup { rename foo {} rename bar {} - set result -} {0 1} -test execute-6.18 {Tcl_ExprObj: exprcode context validation} { - set e { [llength $v] } +} -result {0 1} +test execute-6.18 {Tcl_ExprObj: exprcode context validation} -body { proc foo e {set v {}; expr $e} proc bar e {set v v; expr $e} + set e { [llength $v] } set result {} lappend result [foo $e] lappend result [bar $e] +} -cleanup { rename foo {} rename bar {} - set result -} {0 1} +} -result {0 1} test execute-7.0 {Wide int handling in INST_JUMP_FALSE/LAND} { set x 0x100000000 @@ -882,8 +898,8 @@ test execute-7.34 {Wide int handling} { } 1099511627776 test execute-8.1 {Stack protection} -setup { - # If [Bug #804681] has not been properly - # taken care of, this should segfault + # If [Bug #804681] has not been properly taken care of, this should + # segfault proc whatever args {llength $args} trace add variable ::errorInfo {write unset} whatever } -body { @@ -892,23 +908,27 @@ test execute-8.1 {Stack protection} -setup { trace remove variable ::errorInfo {write unset} whatever rename whatever {} } -returnCodes error -match glob -result * -test execute-8.2 {Stack restoration} -body { - # Test for [Bug #816641], correct restoration - # of the stack top after the stack is grown - proc f {args} { f bee bop } - catch f msg - set msg -} -setup { +test execute-8.2 {Stack restoration} -setup { # Avoid crashes when system stack size is limited (thread-enabled!) set limit [interp recursionlimit {}] interp recursionlimit {} 100 +} -body { + # Test for [Bug #816641], correct restoration of the stack top after the + # stack is grown + proc f {args} { f bee bop } + catch f msg + set msg } -cleanup { interp recursionlimit {} $limit } -result {too many nested evaluations (infinite loop?)} -test execute-8.3 {Stack restoration} -body { - # Test for [Bug #1055676], correct restoration - # of the stack top after the epoch is bumped and - # the stack is grown in a call from a nested evaluation +test execute-8.3 {Stack restoration} -setup { + # Avoid crashes when system stack size is limited (thread-enabled!) + set limit [interp recursionlimit {}] + interp recursionlimit {} 100 +} -body { + # Test for [Bug #1055676], correct restoration of the stack top after the + # epoch is bumped and the stack is grown in a call from a nested + # evaluation set arglst [string repeat "a " 1000] proc f {args} "f $arglst" proc run {} { @@ -919,10 +939,6 @@ test execute-8.3 {Stack restoration} -body { set msg } run -} -setup { - # Avoid crashes when system stack size is limited (thread-enabled!) - set limit [interp recursionlimit {}] - interp recursionlimit {} 100 } -cleanup { interp recursionlimit {} $limit } -result {too many nested evaluations (infinite loop?)} @@ -979,7 +995,6 @@ test execute-9.1 {Interp result resetting [Bug 1522803]} { 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 } -body { @@ -992,7 +1007,6 @@ test execute-10.2 {Bug 2802881} -setup { } -cleanup { interp delete slave } -returnCodes error -match glob -result * - test execute-10.3 {Bug 3072640} -setup { proc generate {n} { for {set i 0} {$i < $n} {incr i} { @@ -1014,6 +1028,22 @@ test execute-10.3 {Bug 3072640} -setup { rename coro {} } -result 4 +test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup { + interp create slave +} -body { + slave eval { + set x [lrepeat 1320 199] + for {set i 0} {$i < 20} {incr i} { + lappend x $i + lsort -integer $x + } + # Crashes on failure + return ok + } +} -cleanup { + interp delete slave +} -result ok + # cleanup if {[info commands testobj] != {}} { testobj freeallvars @@ -1031,4 +1061,5 @@ return # Local Variables: # mode: tcl +# fill-column: 78 # End: diff --git a/tests/expr-old.test b/tests/expr-old.test index 40a38dd..4f3cb2e 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -12,14 +12,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: expr-old.test,v 1.40 2007/12/13 15:26:06 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] diff --git a/tests/expr.test b/tests/expr.test index 05fc956..6ad7208 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -9,14 +9,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: expr.test,v 1.78 2010/02/21 20:09:38 nijtmans Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 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"}) }] @@ -7169,6 +7170,10 @@ test expr-49.1 {Bug 2823282} { foo 1 } 1 +test expr-50.1 {test sqrt() of bignums with non-Inf answer} { + expr {sqrt("1[string repeat 0 616]") == 1e308} +} 1 + # cleanup diff --git a/tests/fCmd.test b/tests/fCmd.test index 1436a28..325b374 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -9,29 +9,31 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: fCmd.test,v 1.70 2009/11/24 00:08:27 patthoyts Exp $ -# -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +cd [temporaryDirectory] + testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testchmod [llength [info commands testchmod]] testConstraint winVista 0 testConstraint win2000orXP 0 -testConstraint winOlderThan2000 0 # Don't know how to determine this constraint correctly testConstraint notNetworkFilesystem 0 -testConstraint 95or98 [expr {[testConstraint 95] || [testConstraint 98]}] -testConstraint 2000orNewer [expr {[testConstraint win] && ![testConstraint 95or98]}] testConstraint reg 0 if {[testConstraint win]} { catch { # Is the registry extension already static to this shell? - if [catch {load {} Registry; set ::reglib {}}] { + try { + load {} Registry + set ::reglib {} + } on error {} { # try the location given to use on the commandline to tcltest ::tcltest::loadTestedCommands load $::reglib Registry @@ -40,6 +42,7 @@ if {[testConstraint win]} { } } +set tmpspace /tmp;# default value # Find a group that exists on this Unix system, or else skip tests that # require Unix groups. testConstraint foundGroup [expr {![testConstraint unix]}] @@ -49,10 +52,19 @@ if {[testConstraint unix]} { set group [lindex $groupList 0] testConstraint foundGroup 1 } + + proc dev dir { + file stat $dir stat + return $stat(dev) + } + + if {[catch {makeDirectory tcl[pid] /tmp} tmpspace] == 0} { + testConstraint xdev [expr {([dev .] != [dev $tmpspace])}] + } } # Also used in winFCmd... -if {[testConstraint winOnly]} { +if {[testConstraint win]} { set major [string index $tcl_platform(osVersion) 0] if {[testConstraint nt] && $major > 4} { if {$major > 5} { @@ -60,15 +72,14 @@ if {[testConstraint winOnly]} { } elseif {$major == 5} { testConstraint win2000orXP 1 } - } else { - testConstraint winOlderThan2000 1 } } -testConstraint darwin9 [expr {[testConstraint unix] && - $tcl_platform(os) eq "Darwin" && - int([string range $tcl_platform(osVersion) 0 \ - [string first . $tcl_platform(osVersion)]]) >= 9}] +testConstraint darwin9 [expr { + [testConstraint unix] + && $tcl_platform(os) eq "Darwin" + && [package vsatisfies 1.$tcl_platform(osVersion) 1.9] +}] testConstraint notDarwin9 [expr {![testConstraint darwin9]}] testConstraint fileSharing 0 @@ -106,11 +117,11 @@ proc createfile {file {string a}} { # if the file does not exist, or has a different content # proc checkcontent {file matchString} { - if {[catch { + try { set f [open $file] set fileString [read $f] close $f - }]} then { + } on error {} { return 0 } return [string match $matchString $fileString] @@ -153,18 +164,11 @@ proc contents {file} { return $r } -cd [temporaryDirectory] - -proc dev dir { - file stat $dir stat - return $stat(dev) -} -testConstraint xdev [expr {[testConstraint unix] && ([dev .] != [dev /tmp])}] set root [lindex [file split [pwd]] 0] -# A really long file name -# length of long is 1216 chars, which should be greater than any static buffer +# A really long file name. +# Length of long is 1216 chars, which should be greater than any static buffer # or allowable filename. set long "abcdefghihjllmnopqrstuvwxyz01234567890" @@ -173,7 +177,7 @@ append long $long append long $long append long $long append long $long - + test fCmd-1.1 {TclFileRenameCmd} -constraints {notRoot} -setup { cleanup } -body { @@ -192,7 +196,7 @@ test fCmd-2.1 {TclFileCopyCmd} -constraints {notRoot} -setup { test fCmd-3.1 {FileCopyRename: FileForceOption fails} -constraints {notRoot} -body { file rename -xyz -} -returnCodes error -result {bad option "-xyz": should be -force or --} +} -returnCodes error -result {bad option "-xyz": must be -force or --} test fCmd-3.2 {FileCopyRename: not enough args} -constraints {notRoot} -body { file rename xyz } -returnCodes error -result {wrong # args: should be "file rename ?-option value ...? source ?source ...? target"} @@ -390,7 +394,7 @@ test fCmd-4.16 {TclFileMakeDirsCmd: TclpCreateDirectory succeeds} -setup { test fCmd-5.1 {TclFileDeleteCmd: FileForceOption fails} -constraints {notRoot} -body { file delete -xyz -} -returnCodes error -result {bad option "-xyz": should be -force or --} +} -returnCodes error -result {bad option "-xyz": must be -force or --} test fCmd-5.2 {TclFileDeleteCmd: accept 0 files (TIP 323)} -body { file delete -force -force } -result {} @@ -590,12 +594,12 @@ test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} -setup { } -returnCodes error -match glob -result \ [subst {error renaming "td2" to "[file join td1 td2]": file *}] test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} -setup { - cleanup /tmp + cleanup $tmpspace } -constraints {unix notRoot} -body { createfile tf1 - file rename tf1 /tmp - glob -nocomplain tf* /tmp/tf1 -} -result {/tmp/tf1} + file rename tf1 $tmpspace + glob -nocomplain tf* [file join $tmpspace tf1] +} -result [file join $tmpspace tf1] test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} -constraints {win} -setup { catch {file delete -force c:/tcl8975@ d:/tcl8975@} } -body { @@ -609,28 +613,29 @@ test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} -constraints {win} -setup { catch {file delete -force d:/tcl8975@} } -result {d:/tcl8975@} test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} -setup { - cleanup /tmp + cleanup $tmpspace } -constraints {unix notRoot} -body { file mkdir td1 - file rename td1 /tmp - glob -nocomplain td* /tmp/td* -} -result {/tmp/td1} + file rename td1 $tmpspace + glob -nocomplain td* [file join $tmpspace td*] +} -result [file join $tmpspace td1] test fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} -setup { - cleanup /tmp + cleanup $tmpspace } -constraints {unix notRoot} -body { createfile tf1 - file rename tf1 /tmp - glob -nocomplain tf* /tmp/tf* -} -result {/tmp/tf1} + file rename tf1 $tmpspace + glob -nocomplain tf* [file join $tmpspace tf*] +} -result [file join $tmpspace tf1] test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { - cleanup /tmp -} -constraints {unix notRoot xdev} -body { + cleanup $tmpspace +} -constraints {xdev notRoot} -body { file mkdir td1/td2/td3 file attributes td1 -permissions 0000 - file rename td1 /tmp + file rename td1 $tmpspace } -returnCodes error -cleanup { file attributes td1 -permissions 0755 -} -match regexp -result {^error renaming "td1"( to "/tmp/td1")?: permission denied$} + cleanup +} -match regexp -result {^error renaming "td1"( to "/tmp/tcl\d+/td1")?: permission denied$} test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup { cleanup } -constraints {unix notRoot} -body { @@ -666,54 +671,54 @@ test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} -setup { 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 { - cleanup /tmp -} -constraints {unix notRoot xdev} -returnCodes error -body { + cleanup $tmpspace +} -constraints {notRoot xdev} -returnCodes error -body { file mkdir td1/td2/td3 - file mkdir /tmp/td1 - createfile /tmp/td1/tf1 - file rename -force td1 /tmp -} -result {error renaming "td1" to "/tmp/td1": file already exists} + file mkdir [file join $tmpspace td1] + createfile [file join $tmpspace td1 tf1] + file rename -force td1 $tmpspace +} -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": file already exists} test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { - cleanup /tmp -} -constraints {unix notRoot xdev} -body { + cleanup $tmpspace +} -constraints {notRoot xdev} -body { file mkdir td1/td2/td3 file attributes td1/td2/td3 -permissions 0000 - file rename td1 /tmp + file rename td1 $tmpspace } -returnCodes error -cleanup { file attributes td1/td2/td3 -permissions 0755 -} -result {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied} + 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 { - cleanup /tmp -} -constraints {unix notRoot xdev} -body { + cleanup $tmpspace +} -constraints {notRoot xdev} -body { file mkdir td1/td2/td3 - file rename td1 /tmp - glob td* /tmp/td1/t* -} -result {/tmp/td1/td2} + file rename td1 $tmpspace + glob td* [file join $tmpspace td1 t*] +} -result [file join $tmpspace td1 td2] test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} -setup { - cleanup + cleanup $tmpspace } -constraints {unix notRoot} -body { file mkdir foo/bar file attr foo -perm 040555 - file rename foo/bar /tmp + file rename foo/bar $tmpspace } -returnCodes error -cleanup { - catch {file delete /tmp/bar} + catch {file delete [file join $tmpspace bar]} catch {file attr foo -perm 040777} catch {file delete -force foo} } -match glob -result {*: permission denied} test fCmd-6.31 {CopyRenameOneFile: TclpDeleteFile passed} -setup { - catch {cleanup /tmp} -} -constraints {unix notRoot xdev} -body { - file mkdir /tmp/td1 - createfile /tmp/td1/tf1 - file rename /tmp/td1/tf1 tf1 - list [file exists /tmp/td1/tf1] [file exists tf1] + cleanup $tmpspace +} -constraints {notRoot xdev} -body { + file mkdir [file join $tmpspace td1] + createfile [file join $tmpspace td1 tf1] + file rename [file join $tmpspace td1 tf1] tf1 + list [file exists [file join $tmpspace td1 tf1]] [file exists tf1] } -result {0 1} test fCmd-6.32 {CopyRenameOneFile: copy} -constraints {notRoot} -setup { cleanup } -returnCodes error -body { file copy tf1 tf2 } -result {error copying "tf1": no such file or directory} -catch {cleanup /tmp} test fCmd-7.1 {FileForceOption: none} -constraints {notRoot} -setup { cleanup @@ -737,7 +742,7 @@ test fCmd-7.4 {FileForceOption: bad option} -constraints {notRoot} -setup { file delete -tf1 } -returnCodes error -cleanup { file delete -- -tf1 -} -result {bad option "-tf1": should be -force or --} +} -result {bad option "-tf1": must be -force or --} test fCmd-7.5 {FileForceOption: multiple times through loop} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { @@ -791,9 +796,20 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup { file rename tf2 tf4 list [lsort [glob tf*]] [file writable tf3] [file writable tf4] } -result {{tf3 tf4} 1 0} -test fCmd-9.4 {file rename: comprehensive: dir to new name} -setup { +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 -} -constraints {unixOrPc notRoot testchmod notDarwin9 win2000orXP} -body { +} -result {{td3 td4} 1 0} +test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup { + cleanup +} -constraints {unix notRoot testchmod notDarwin9} -body { file mkdir td1 td2 testchmod 555 td2 file rename td1 td3 @@ -812,9 +828,19 @@ test fCmd-9.5 {file rename: comprehensive: file to self} -setup { 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 {file rename: comprehensive: dir to self} -setup { +test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup { cleanup -} -constraints {notRoot unixOrPc testchmod win2000orXP} -body { +} -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 { + cleanup +} -constraints {unix notRoot testchmod} -body { file mkdir td1 file mkdir td2 testchmod 555 td2 @@ -1022,7 +1048,7 @@ test fCmd-10.2 {file copy: comprehensive: file to new name} -setup { } -result {{tf1 tf2 tf3 tf4} tf1 tf2 1 0} test fCmd-10.3 {file copy: comprehensive: dir to new name} -setup { cleanup -} -constraints {notRoot unixOrPc 95or98 testchmod} -body { +} -constraints {unix notRoot testchmod} -body { file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] testchmod 555 td2 @@ -1036,7 +1062,7 @@ test fCmd-10.3 {file copy: comprehensive: dir to new name} -setup { } -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 -} -constraints {notRoot 2000orNewer testchmod} -body { +} -constraints {win notRoot testchmod} -body { # On Windows with ACLs, copying a directory is defined like this file mkdir [file join td1 tdx] file mkdir [file join td2 tdy] @@ -1123,7 +1149,7 @@ test fCmd-10.7 {file rename: comprehensive: file to new name and dir} -setup { } -result [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}] test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} -setup { cleanup -} -constraints {notRoot unixOrPc 95or98 testchmod} -body { +} -constraints {unix notRoot testchmod} -body { file mkdir td1 file mkdir td2 file mkdir td3 @@ -1135,7 +1161,7 @@ test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} -setup { } -result [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}] test fCmd-10.8.1 {file rename: comprehensive: dir to new name and dir} -setup { cleanup -} -constraints {notRoot 2000orNewer testchmod} -body { +} -constraints {win notRoot testchmod} -body { # On Windows with ACLs, copying a directory is defined like this file mkdir td1 file mkdir td2 @@ -1330,23 +1356,23 @@ test fCmd-12.8 {renamefile: generic error} -setup { file delete -force tfa } -result {1} test fCmd-12.9 {renamefile: moving a file across volumes} -setup { - catch {file delete -force -- tfa /tmp/tfa} + cleanup $tmpspace } -constraints {unix notRoot} -body { set s [createfile tfa] - file rename tfa /tmp - list [checkcontent /tmp/tfa $s] [file exists tfa] + file rename tfa $tmpspace + list [checkcontent [file join $tmpspace tfa] $s] [file exists tfa] } -cleanup { - file delete /tmp/tfa + cleanup $tmpspace } -result {1 0} test fCmd-12.10 {renamefile: moving a directory across volumes} -setup { - catch {file delete -force -- tfad /tmp/tfad} -} -constraints {unix notRoot} -body { + cleanup $tmpspace +} -constraints {xdev notRoot} -body { file mkdir tfad set s [createfile tfad/a] - file rename tfad /tmp - list [checkcontent /tmp/tfad/a $s] [file exists tfad] + file rename tfad $tmpspace + list [checkcontent [file join $tmpspace tfad a] $s] [file exists tfad] } -cleanup { - file delete -force /tmp/tfad + cleanup $tmpspace } -result {1 0} # @@ -1529,8 +1555,7 @@ test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} -setup { set ::env(HOME) $temp } -result {1} # -# Can Tcl_SplitPath return argc == 0? If so them we need a -# test for that code. +# Can Tcl_SplitPath return argc == 0? If so them we need a test for that code. # test fCmd-15.2 {TclMakeDirsCmd - one directory} -setup { catch {file delete -force -- tfa} @@ -1710,7 +1735,6 @@ test fCmd-17.3 {mkdir several levels deep - absolute} -setup { # # Functionality tests for TclFileRenameCmd() # - test fCmd-18.1 {TclFileRenameCmd: rename (first form) in the same directory} \ -setup { catch {file delete -force -- tfad} @@ -1918,7 +1942,6 @@ test fCmd-19.3 {recursive remove} -constraints {notRoot} -setup { # # Coverage tests for TraverseUnixTree(), called from TclDeleteFilesCmd # - test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory} -setup { catch {file delete -force -- tfa} } -constraints {unix notRoot} -body { @@ -2150,7 +2173,6 @@ test fCmd-22.5 {TclMacCopyFile: copy and overwrite in a single dir} -setup { # TclMacRmdir # Error cases are not covered. # - test fCmd-23.1 {TclMacRmdir: trying to remove a nonempty directory} -setup { catch {file delete -force -- tfad} } -constraints {notRoot} -body { @@ -2212,7 +2234,6 @@ test fCmd-25.3 {TclMacCopyDirectory: copying dirs between different dirs} -setup # # Functionality tests for TclDeleteFilesCmd # - test fCmd-26.1 {TclDeleteFilesCmd: delete symlink} -setup { catch {file delete -force -- tfad1 tfad2} } -constraints {unix notRoot} -body { @@ -2405,7 +2426,7 @@ test fCmd-28.12 {file link: cd into a link} -setup { cd .. set up [pwd] cd $orig - # now '$up' should be either $orig or [file dirname abc.dir], depending on + # Now '$up' should be either $orig or [file dirname abc.dir], depending on # whether 'cd' actually moves to the destination of a link, or simply # treats the link as a directory. (On windows the former, on unix the # latter, I believe) @@ -2530,35 +2551,35 @@ test fCmd-28.22 {file link: relative paths} -setup { catch {file delete -force d1} cd [workingDirectory] } -result d2/d3 - -test fCmd-29.1 {weird memory corruption fault} -body { - open [file join ~a_totally_bogus_user_id/foo bar] -} -returnCodes error -match glob -result * - -cd [temporaryDirectory] -file delete -force abc.link -file delete -force d1/d2 -file delete -force d1 -cd [workingDirectory] - +try { + cd [temporaryDirectory] + file delete -force abc.link + file delete -force d1/d2 + file delete -force d1 +} finally { + cd [workingDirectory] +} removeFile abc2.file removeFile abc.file removeDirectory abc2.dir removeDirectory abc.dir +test fCmd-29.1 {weird memory corruption fault} -body { + open [file join ~a_totally_bogus_user_id/foo bar] +} -returnCodes error -match glob -result * + test fCmd-30.1 {file writable on 'My Documents'} -setup { # Get the localized version of the folder name by looking in the registry. set mydocsname [registry get {HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders} Personal] -} -constraints {2000orNewer reg} -body { +} -constraints {win reg} -body { file writable $mydocsname } -result 1 -test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {2000orNewer} -body { +test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win} -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 {2000orNewer} -body { +test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win} -body { set r {} if {[info exists env(SystemDrive)]} { set path $env(SystemDrive)/pagefile.sys @@ -2568,12 +2589,16 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {2000orNewer} -bod } return $r } -result {exists 1 readable 0 stat 0 {}} - + # cleanup cleanup +if {[testConstraint unix]} { + removeDirectory tcl[pid] /tmp +} ::tcltest::cleanupTests return # Local Variables: # mode: tcl +# fill-column: 78 # End: diff --git a/tests/fileName.test b/tests/fileName.test index d46391a..51f00d1 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -9,14 +9,15 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: fileName.test,v 1.66 2010/01/05 18:58:36 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testtranslatefilename [llength [info commands testtranslatefilename]] testConstraint linkDirectory 1 @@ -42,7 +43,7 @@ global env if {[testConstraint testsetplatform]} { set platform [testgetplatform] } - + # Caution: when using 'testsetplatform' to test different file name platform # descriptions in this file, one must be very careful not to combine such # platform manipulation with commands like 'cd', 'pwd'. That is because the @@ -198,7 +199,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 @@ -435,11 +436,11 @@ test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join //a b -} {/a/b} +} "/a/b" test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join /// a b -} {/a/b} +} "/a/b" test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win @@ -748,7 +749,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 @@ -1434,7 +1435,7 @@ test filename-16.13 {windows specific globbing} {win sharedCdrive} { } //[info hostname]/c/globTest test filename-16.14 {windows specific globbing} {win} { cd [lindex [glob -types d -dir C:/ *] 0] - expr {[lsearch -exact [glob {{.,*}*}] ".."] != -1} + expr {".." in [glob {{.,*}*}]} } {1} test filename-16.15 {windows specific globbing} {win} { cd [lindex [glob -types d -dir C:/ *] 0] @@ -1529,7 +1530,6 @@ test fileName-20.4 {Bug 1750300} -setup { removeFile TAGS $d removeDirectory foo } -result 0 - test fileName-20.5 {Bug 2837800} -setup { set dd [makeDirectory isolate] set d [makeDirectory ./~foo $dd] @@ -1544,7 +1544,6 @@ test fileName-20.5 {Bug 2837800} -setup { removeDirectory ./~foo $dd removeDirectory isolate } -result ~foo/test - test fileName-20.6 {Bug 2837800} -setup { # Recall that we have $env(HOME) set so that references # to ~ point to [temporaryDirectory] @@ -1561,7 +1560,6 @@ test fileName-20.6 {Bug 2837800} -setup { removeDirectory isolate removeFile test ~ } -result {} - test fileName-20.7 {Bug 2806250} -setup { set savewd [pwd] cd [temporaryDirectory] @@ -1574,7 +1572,6 @@ test fileName-20.7 {Bug 2806250} -setup { removeDirectory isolate cd $savewd } -result 1 - test fileName-20.8 {Bug 2806250} -setup { set savewd [pwd] cd [temporaryDirectory] @@ -1587,8 +1584,7 @@ test fileName-20.8 {Bug 2806250} -setup { removeDirectory isolate cd $savewd } -result ./~test - -test fileName-20.9 {} -setup { +test fileName-20.9 {globbing for special chars} -setup { makeFile {} test ~ set d [makeDirectory isolate] set savewd [pwd] @@ -1600,8 +1596,7 @@ test fileName-20.9 {} -setup { removeDirectory isolate removeFile test ~ } -result ~/test - -test fileName-20.10 {} -setup { +test fileName-20.10 {globbing for special chars} -setup { set s [makeDirectory sub ~] makeFile {} fileName-20.10 $s set d [makeDirectory isolate] @@ -1615,12 +1610,13 @@ test fileName-20.10 {} -setup { removeFile fileName-20.10 $s removeDirectory sub ~ } -result ~/sub/fileName-20.10 - + # cleanup 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 2fe13d7..b098f35 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -19,6 +19,17 @@ namespace eval ::tcl::test::fileSystem { file delete -force [file join dir.dir linkinside.file] } +testConstraint loaddll 0 +catch { + ::tcltest::loadTestedCommands + package require -exact Tcltest [info patchlevel] + set ::ddever [package require dde] + set ::ddelib [lindex [package ifneeded dde $::ddever] 1] + set ::regver [package require registry] + set ::reglib [lindex [package ifneeded registry $::regver] 1] + testConstraint loaddll 1 +} + # Test for commands defined in Tcltest executable testConstraint testfilesystem [llength [info commands ::testfilesystem]] testConstraint testsetplatform [llength [info commands ::testsetplatform]] @@ -31,44 +42,39 @@ makeDirectory [file join dir.dir dirinside.dir] makeFile "test file in directory" [file join dir.dir inside.file] testConstraint unusedDrive 0 -set drive {} -if {[testConstraint win]} { - set vols [string map [list :/ {}] [file volumes]] - for {set i 0} {$i < 26} {incr i} { - set drive [format %c [expr {$i + 65}]] - if {[lsearch -exact $vols $drive] == -1} { - testConstraint unusedDrive 1 - break +testConstraint moreThanOneDrive 0 +apply {{} { + # The variables 'drive' and 'drives' will be used below. + variable drive {} drives {} + if {[testConstraint win]} { + set vols [string map [list :/ {}] [file volumes]] + for {set i 0} {$i < 26} {incr i} { + set drive [format %c [expr {$i + 65}]] + if {$drive ni $vols} { + testConstraint unusedDrive 1 + break + } } - } - unset i vols - # The variable 'drive' will be used below -} -testConstraint moreThanOneDrive 0 -set drives [list] -if {[testConstraint win]} { - set dir [pwd] - foreach vol [file volumes] { - if {![catch {cd $vol}]} { - lappend drives $vol - } - } - if {[llength $drives] > 1} { - testConstraint moreThanOneDrive 1 + set dir [pwd] + try { + foreach vol [file volumes] { + if {![catch {cd $vol}]} { + lappend drives $vol + } + } + testConstraint moreThanOneDrive [llength $drives] + } finally { + cd $dir + } } - # The variable 'drives' will be used below - unset vol - cd $dir - unset dir -} +} ::tcl::test::fileSystem} proc testPathEqual {one two} { if {$one eq $two} { - return 1 - } else { - return "not equal: $one $two" + return "ok" } + return "not equal: $one $two" } testConstraint hasLinks [expr {![catch { @@ -100,19 +106,19 @@ test filesystem-1.1 {link normalisation} {hasLinks} { test filesystem-1.2 {link normalisation} {hasLinks unix} { testPathEqual [file normalize [file join gorp.file foo]] \ [file normalize [file join link.file foo]] -} {1} +} ok test filesystem-1.3 {link normalisation} {hasLinks} { testPathEqual [file normalize [file join dir.dir foo]] \ [file normalize [file join dir.link foo]] -} {1} +} ok test filesystem-1.4 {link normalisation} {hasLinks} { testPathEqual [file normalize [file join dir.dir inside.file]] \ [file normalize [file join dir.link inside.file]] -} {1} +} ok test filesystem-1.5 {link normalisation} {hasLinks} { testPathEqual [file normalize [file join dir.dir linkinside.file]] \ [file normalize [file join dir.dir linkinside.file]] -} {1} +} ok test filesystem-1.6 {link normalisation} {hasLinks} { string equal [file normalize [file join dir.dir linkinside.file]] \ [file normalize [file join dir.link inside.file]] @@ -120,28 +126,29 @@ test filesystem-1.6 {link normalisation} {hasLinks} { test filesystem-1.7 {link normalisation} {hasLinks unix} { testPathEqual [file normalize [file join dir.link linkinside.file foo]] \ [file normalize [file join dir.dir inside.file foo]] -} {1} +} ok test filesystem-1.8 {link normalisation} {hasLinks} { string equal [file normalize [file join dir.dir linkinside.filefoo]] \ [file normalize [file join dir.link inside.filefoo]] } {0} -test filesystem-1.9 {link normalisation} {unix hasLinks} { +test filesystem-1.9 {link normalisation} -setup { file delete -force dir.link +} -constraints {unix hasLinks} -body { file link dir.link [file nativename dir.dir] testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \ [file normalize [file join dir.link inside.file foo]] -} {1} +} -result ok test filesystem-1.10 {link normalisation: double link} {unix hasLinks} { 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]] -} {1} +} ok makeDirectory dir2.file test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} { 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]] -} {1} +} ok test filesystem-1.12 {file new native path} {} { for {set i 0} {$i < 10} {incr i} { foreach f [lsort [glob -nocomplain -type l *]] { @@ -198,39 +205,35 @@ test filesystem-1.25 {file normalisation} {win unusedDrive} { test filesystem-1.25.1 {file normalisation} {win unusedDrive} { file normalize ${drive}:/./.././..\\..\\a\\bb } "${drive}:/a/bb" -test filesystem-1.26 {link normalisation: link and ..} {hasLinks} { +test filesystem-1.26 {link normalisation: link and ..} -setup { file delete -force dir2.link +} -constraints {hasLinks} -body { set dir [file join dir2 foo bar] file mkdir $dir file link dir2.link [file join dir2 foo bar] - set res [list [file normalize [file join dir2 foo x]] \ - [file normalize [file join dir2.link .. x]]] - testPathEqual [lindex $res 0] [lindex $res 1] -} 1 + testPathEqual [file normalize [file join dir2 foo x]] \ + [file normalize [file join dir2.link .. x]] +} -result ok test filesystem-1.27 {file normalisation: up and down with ..} { set dir [file join dir2 foo bar] file mkdir $dir set dir2 [file join dir2 .. dir2 foo .. foo bar] - set res [list [file normalize $dir] [file normalize $dir2]] - set res2 [list [file exists $dir] [file exists $dir2]] - if {![string equal [lindex $res 0] [lindex $res 1]]} { - set res "exists: $res2, $res not equal" - } else { - set res "ok: $res2" - } -} {ok: 1 1} -test filesystem-1.28 {link normalisation: link with .. and ..} {hasLinks} { + list [testPathEqual [file normalize $dir] [file normalize $dir2]] \ + [file exists $dir] [file exists $dir2] +} {ok 1 1} +test filesystem-1.28 {link normalisation: link with .. and ..} -setup { file delete -force dir2.link +} -constraints {hasLinks} -body { set dir [file join dir2 foo bar] file mkdir $dir set to [file join dir2 .. dir2 foo .. foo bar] file link dir2.link $to - set res [list [file normalize [file join dir2 foo x]] \ - [file normalize [file join dir2.link .. x]]] - testPathEqual [lindex $res 0] [lindex $res 1] -} 1 -test filesystem-1.29 {link normalisation: link with ..} {hasLinks} { + testPathEqual [file normalize [file join dir2 foo x]] \ + [file normalize [file join dir2.link .. x]] +} -result ok +test filesystem-1.29 {link normalisation: link with ..} -setup { file delete -force dir2.link +} -constraints {hasLinks} -body { set dir [file join dir2 foo bar] file mkdir $dir set to [file join dir2 .. dir2 foo .. foo bar] @@ -240,11 +243,11 @@ test filesystem-1.29 {link normalisation: link with ..} {hasLinks} { return "$res must not contain '..'" } return "ok" -} {ok} +} -result {ok} test filesystem-1.29.1 {link normalisation with two consecutive links} {hasLinks} { testPathEqual [file normalize [file join dir.link dirinside.link abc]] \ [file normalize [file join dir.dir dirinside.dir abc]] -} {1} +} ok file delete -force dir2.file file delete -force dir2.link file delete -force link.file dir.link @@ -277,208 +280,96 @@ test filesystem-1.33 {link normalisation: link near filesystem root} {testsetpla if {[testConstraint testsetplatform]} { testsetplatform $platform } -test filesystem-1.34 {file normalisation with '/./'} { - set res [file normalize /foo/bar/anc/./.tml] - if {[string first "/./" $res] != -1} { - set res "normalization of /foo/bar/anc/./.tml is: $res" - } else { - set res "ok" - } - set res -} {ok} -test filesystem-1.35 {file normalisation with '/./'} { - set res [file normalize /ffo/bar/anc/./foo/.tml] - if {[string first "/./" $res] != -1 || ([regsub -all "foo" $res "" reg] == 2)} { - set res "normalization of /ffo/bar/anc/./foo/.tml is: $res" - } else { - set res "ok" - } - set res -} {ok} -test filesystem-1.36 {file normalisation with '/./'} { - set res [file normalize /foo/bar/anc/././asdasd/.tml] - if {[string first "/./" $res] != -1 || ([regsub -all "asdasd" $res "" reg] == 2) } { - set res "normalization of /foo/bar/anc/././asdasd/.tml is: $res" - } else { - set res "ok" - } - set res -} {ok} -test filesystem-1.37 {file normalisation with '/./'} { +test filesystem-1.34 {file normalisation with '/./'} -body { + file normalize /foo/bar/anc/./.tml +} -match regexp -result {^(?:(?!/\./).)*$} +test filesystem-1.35a {file normalisation with '/./'} -body { + file normalize /ffo/bar/anc/./foo/.tml +} -match regexp -result {^(?:(?!/\./).)*$} +test filesystem-1.35b {file normalisation with '/./'} { + llength [regexp -all foo [file normalize /ffo/bar/anc/./foo/.tml]] +} 1 +test filesystem-1.36a {file normalisation with '/./'} -body { + file normalize /foo/bar/anc/././asdasd/.tml +} -match regexp -result {^(?:(?!/\./).)*$} +test filesystem-1.36b {file normalisation with '/./'} { + llength [regexp -all asdasd [file normalize /foo/bar/anc/././asdasd/.tml]] +} 1 +test filesystem-1.37 {file normalisation with '/./'} -body { set fname "/abc/./def/./ghi/./asda/.././.././asd/x/../../../../....." - set res [file norm $fname] - if {[string first "//" $res] != -1} { - set res "normalization of $fname is: $res" - } else { - set res "ok" - } - set res -} {ok} -test filesystem-1.38 {file normalisation with volume relative} \ - {win moreThanOneDrive} { - set path "[string range [lindex $drives 0] 0 1]foo" + file norm $fname +} -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$} +test filesystem-1.38 {file normalisation with volume relative} -setup { set dir [pwd] +} -constraints {win moreThanOneDrive} -body { + set path "[string range [lindex $drives 0] 0 1]foo" cd [lindex $drives 1] - set res [file norm $path] + file norm $path +} -cleanup { cd $dir - set res -} "[lindex $drives 0]foo" -test filesystem-1.39 {file normalisation with volume relative} {win} { - set drv C:/ - set dir [lindex [glob -type d -dir $drv *] 0] +} -result "[lindex $drives 0]foo" +test filesystem-1.39 {file normalisation with volume relative} -setup { set old [pwd] - cd $dir - set res [file norm [string range $drv 0 1]] +} -constraints {win} -body { + set drv C:/ + cd [lindex [glob -type d -dir $drv *] 0] + file norm [string range $drv 0 1] +} -cleanup { cd $old - if {[string index $res end] eq "/"} { - set res "Bad normalized path: $res" - } else { - set res "ok" - } -} {ok} +} -match regexp -result {.*[^/]} test filesystem-1.40 {file normalisation with repeated separators} { - set a [file norm foo////bar] - set b [file norm foo/bar] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm foo////bar] [file norm foo/bar] +} ok test filesystem-1.41 {file normalisation with repeated separators} {win} { - set a [file norm foo\\\\\\bar] - set b [file norm foo/bar] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm foo\\\\\\bar] [file norm foo/bar] +} ok test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /xxx/..] - set b [file norm /] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /xxx/..] [file norm /] +} ok test filesystem-1.42.1 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /xxx/../] - set b [file norm /] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /xxx/../] [file norm /] +} ok test filesystem-1.43 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /xxx/foo/../..] - set b [file norm /] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /xxx/foo/../..] [file norm /] +} ok test filesystem-1.43.1 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /xxx/foo/../../] - set b [file norm /] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /xxx/foo/../../] [file norm /] +} ok test filesystem-1.44 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /xxx/foo/../../bar] - set b [file norm /bar] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /xxx/foo/../../bar] [file norm /bar] +} ok test filesystem-1.45 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /xxx/../../bar] - set b [file norm /bar] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /xxx/../../bar] [file norm /bar] +} ok test filesystem-1.46 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /xxx/../bar] - set b [file norm /bar] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /xxx/../bar] [file norm /bar] +} ok test filesystem-1.47 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /..] - set b [file norm /] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /..] [file norm /] +} ok test filesystem-1.48 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /../] - set b [file norm /] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /../] [file norm /] +} ok test filesystem-1.49 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /.] - set b [file norm /] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /.] [file norm /] +} ok test filesystem-1.50 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /./] - set b [file norm /] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /./] [file norm /] +} ok test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /../..] - set b [file norm /] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /../..] [file norm /] +} ok test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} { - set a [file norm /../../] - set b [file norm /] - if {![string equal $a $b]} { - set res "Paths should be equal: $a , $b" - } else { - set res "ok" - } -} {ok} + testPathEqual [file norm /../../] [file norm /] +} ok test filesystem-2.0 {new native path} {unix} { foreach f [lsort [glob -nocomplain /usr/bin/c*]] { catch {file readlink $f} } # If we reach here we've succeeded. We used to crash above. - expr 1 -} {1} + return ok +} ok # Make sure the testfilesystem hasn't been registered. if {[testConstraint testfilesystem]} { @@ -511,28 +402,28 @@ test filesystem-4.0 {testfilesystem} -constraints testfilesystem -body { set filesystemReport {} file exists foo testfilesystem 0 - set filesystemReport + return $filesystemReport } -match glob -result {*{access foo}} test filesystem-4.1 {testfilesystem} -constraints testfilesystem -body { testfilesystem 1 set filesystemReport {} catch {file stat foo bar} testfilesystem 0 - set filesystemReport + return $filesystemReport } -match glob -result {*{stat foo}} test filesystem-4.2 {testfilesystem} -constraints testfilesystem -body { testfilesystem 1 set filesystemReport {} catch {file lstat foo bar} testfilesystem 0 - set filesystemReport + return $filesystemReport } -match glob -result {*{lstat foo}} test filesystem-4.3 {testfilesystem} -constraints testfilesystem -body { testfilesystem 1 set filesystemReport {} catch {glob *} testfilesystem 0 - set filesystemReport + return $filesystemReport } -match glob -result {*{matchindirectory *}*} test filesystem-5.1 {cache and ~} -constraints testfilesystem -setup { @@ -593,21 +484,21 @@ 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} test filesystem-6.26 {empty file name} {file rootname ""} {} test filesystem-6.27 {empty file name} -returnCodes error -body { file separator "" -} -result {Unrecognised path} +} -result {unrecognised path} test filesystem-6.28 {empty file name} -returnCodes error -body { file size "" } -result {could not read "": no such file or directory} test filesystem-6.29 {empty file name} {file split ""} {} test filesystem-6.30 {empty file name} -returnCodes error -body { file system "" -} -result {Unrecognised path} +} -result {unrecognised path} test filesystem-6.31 {empty file name} {file tail ""} {} test filesystem-6.32 {empty file name} -returnCodes error -body { file type "" @@ -621,13 +512,12 @@ if {[testConstraint testfilesystem]} { test filesystem-7.1.1 {load from vfs} -setup { set dir [pwd] -} -constraints {win testsimplefilesystem} -body { +} -constraints {win testsimplefilesystem loaddll} -body { # This may cause a crash on exit - cd [file dirname [info nameof]] - set dde [lindex [glob *dde*[info sharedlib]] 0] + cd [file dirname $::ddelib] testsimplefilesystem 1 # This loads dde via a complex copy-to-temp operation - load simplefs:/$dde dde + load simplefs:/[file tail $::ddelib] dde testsimplefilesystem 0 return ok # The real result of this test is what happens when Tcl exits. @@ -636,14 +526,13 @@ test filesystem-7.1.1 {load from vfs} -setup { } -result ok test filesystem-7.1.2 {load from vfs, and then unload again} -setup { set dir [pwd] -} -constraints {win testsimplefilesystem} -body { +} -constraints {win testsimplefilesystem loaddll} -body { # This may cause a crash on exit - cd [file dirname [info nameof]] - set reg [lindex [glob tclreg*[info sharedlib]] 0] + cd [file dirname $::reglib] testsimplefilesystem 1 # This loads reg via a complex copy-to-temp operation - load simplefs:/$reg Registry - unload simplefs:/$reg + load simplefs:/[file tail $::reglib] Registry + unload simplefs:/[file tail $::reglib] testsimplefilesystem 0 return ok # The real result of this test is what happens when Tcl exits. @@ -1040,8 +929,12 @@ test filesystem-9.9 {path objects and glob and file tail and tilde} -setup { # ---------------------------------------------------------------------- +test filesystem-10.1 {Bug 3414754} { + string match */ [file join [pwd] foo/] +} 0 + cleanupTests -unset -nocomplain drive +unset -nocomplain drive drives } namespace delete ::tcl::test::fileSystem return diff --git a/tests/for-old.test b/tests/for-old.test index db63a16..a11a791 100644 --- a/tests/for-old.test +++ b/tests/for-old.test @@ -11,8 +11,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: for-old.test,v 1.6 2004/05/19 12:25:30 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/for.test b/tests/for.test index 04aed84..ff4dc0e 100644 --- a/tests/for.test +++ b/tests/for.test @@ -8,8 +8,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: for.test,v 1.17 2008/11/17 08:11:45 ferrieux Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 diff --git a/tests/foreach.test b/tests/foreach.test index 4042b3c..6c69b29 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -9,8 +9,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: foreach.test,v 1.15 2009/06/24 15:17:40 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -268,6 +266,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 54d9ffb..27eac31 100644 --- a/tests/format.test +++ b/tests/format.test @@ -9,8 +9,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: format.test,v 1.30 2010/01/18 09:31:02 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -551,10 +549,7 @@ test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} { 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} @@ -571,7 +566,7 @@ test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body { format %s $x # After this, obj in $x should be a dict with a non-NULL bytes field tcl::unsupported::representation $x -} -match glob -result {value is a dict with *, string representation "*".} +} -match glob -result {value is a dict with *, string representation "*"} # cleanup catch {unset a} diff --git a/tests/get.test b/tests/get.test index 112632f..d51ec6d 100644 --- a/tests/get.test +++ b/tests/get.test @@ -9,14 +9,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: get.test,v 1.12 2005/08/08 14:08:05 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testgetint [llength [info commands testgetint]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] diff --git a/tests/history.test b/tests/history.test index 3f02aa0..c562796 100644 --- a/tests/history.test +++ b/tests/history.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: history.test,v 1.7 2009/07/25 21:51:02 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/http.test b/tests/http.test index d879e45..9861e0e 100644 --- a/tests/http.test +++ b/tests/http.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: http.test,v 1.55 2009/11/18 21:04:32 nijtmans Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -53,14 +51,13 @@ if {![file exists $httpdFile]} { set removeHttpd 1 } -if {[info commands testthread] == "testthread" && [file exists $httpdFile]} { - set httpthread [testthread create " - source [list $httpdFile] - testthread wait - "] - testthread send $httpthread [list set port $port] - testthread send $httpthread [list set bindata $bindata] - testthread send $httpthread {httpd_init $port} +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} puts "Running httpd in thread $httpthread" } else { if {![file exists $httpdFile]} { @@ -138,6 +135,7 @@ 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 ipv6url http://\[::1\]:$port/ test http-3.4 {http::geturl} -body { set token [http::geturl $url] http::data $token @@ -367,6 +365,46 @@ test http-3.26 {http::meta} -setup { http::cleanup $token unset -nocomplain m token } -result {Content-Length Content-Type Date X-Check} +test http-3.27 {http::geturl: -headers override -type} -body { + set token [http::geturl $url/headers -type "text/plain" -query dummy \ + -headers [list "Content-Type" "text/plain;charset=utf-8"]] + http::data $token +} -cleanup { + http::cleanup $token +} -match regexp -result {(?n)Accept \*/\* +Host .* +User-Agent .* +Connection close +Content-Type {text/plain;charset=utf-8} +Accept-Encoding .* +Content-Length 5} +test http-3.28 {http::geturl: -headers override -type default} -body { + set token [http::geturl $url/headers -query dummy \ + -headers [list "Content-Type" "text/plain;charset=utf-8"]] + http::data $token +} -cleanup { + http::cleanup $token +} -match regexp -result {(?n)Accept \*/\* +Host .* +User-Agent .* +Connection close +Content-Type {text/plain;charset=utf-8} +Accept-Encoding .* +Content-Length 5} +test http-3.29 "http::geturl $ipv6url" -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-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] @@ -523,7 +561,7 @@ test http-4.15 {http::Event} -body { http::status $token # error codes vary among platforms. } -cleanup { - http::cleanup $token + catch {http::cleanup $token} } -returnCodes 1 -match glob -result "couldn't open socket*" test http-5.1 {http::formatQuery} { @@ -532,17 +570,17 @@ test http-5.1 {http::formatQuery} { # test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5 test http-5.3 {http::formatQuery} { http::formatQuery lines "line1\nline2\nline3" -} {lines=line1%0d%0aline2%0d%0aline3} +} {lines=line1%0D%0Aline2%0D%0Aline3} test http-5.4 {http::formatQuery} { http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 -} {name1=~bwelch&name2=%c2%a1%c2%a2%c2%a2} +} {name1=~bwelch&name2=%C2%A1%C2%A2%C2%A2} test http-5.5 {http::formatQuery} { set enc [http::config -urlencoding] http::config -urlencoding iso8859-1 set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2] http::config -urlencoding $enc set res -} {name1=~bwelch&name2=%a1%a2%a2} +} {name1=~bwelch&name2=%A1%A2%A2} test http-6.1 {http::ProxyRequired} -body { http::config -proxyhost [info hostname] -proxyport $port @@ -560,12 +598,12 @@ test http-6.1 {http::ProxyRequired} -body { test http-7.1 {http::mapReply} { http::mapReply "abc\$\[\]\"\\()\}\{" -} {abc%24%5b%5d%22%5c%28%29%7d%7b} +} {abc%24%5B%5D%22%5C%28%29%7D%7B} test http-7.2 {http::mapReply} { # RFC 2718 specifies that we pass urlencoding on utf-8 chars by default, # so make sure this gets converted to utf-8 then urlencoded. http::mapReply "\u2208" -} {%e2%88%88} +} {%E2%88%88} test http-7.3 {http::formatQuery} -setup { set enc [http::config -urlencoding] } -returnCodes error -body { @@ -584,7 +622,7 @@ test http-7.4 {http::formatQuery} -setup { http::mapReply "\u2208" } -cleanup { http::config -urlencoding $enc -} -result {%3f} +} -result {%3F} # cleanup catch {unset url} @@ -592,9 +630,7 @@ catch {unset badurl} catch {unset port} catch {unset data} if {[info exists httpthread]} { - testthread send -async $httpthread { - testthread exit - } + thread::release $httpthread } else { close $listen } diff --git a/tests/http11.test b/tests/http11.test index 0cecaa1..230ce5a 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -62,7 +62,7 @@ proc meta {tok {key ""}} { proc check_crc {tok args} { set crc [meta $tok x-crc32] - if {[llength $args]} {set data [lindex $args 0]} else {set data [http::data $tok]} + set data [expr {[llength $args] ? [lindex $args 0] : [http::data $tok]}] set chk [format %x [zlib crc32 $data]] if {$crc ne $chk} { return "crc32 mismatch: $crc ne $chk" diff --git a/tests/httpd b/tests/httpd index 93ee08a..f810797 100644 --- a/tests/httpd +++ b/tests/httpd @@ -7,8 +7,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# SCCS: @(#) httpd 1.2 98/02/20 14:51:59 #set httpLog 1 @@ -177,6 +175,14 @@ proc httpdRespond { sock } { set html "Got [string length $data(query)] bytes" set type text/plain } + *headers* { + set html "" + set type text/plain + foreach {key value} $data(meta) { + append html [list $key $value] "\n" + } + set html [string trim $html] + } default { set type text/html diff --git a/tests/httpold.test b/tests/httpold.test index fe7c607..aeba311 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: httpold.test,v 1.12 2004/05/19 12:44:27 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/if-old.test b/tests/if-old.test index 3a850b9..fbcf56c 100644 --- a/tests/if-old.test +++ b/tests/if-old.test @@ -12,8 +12,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: if-old.test,v 1.6 2003/03/27 13:19:15 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/if.test b/tests/if.test index 59fb24a..040364a 100644 --- a/tests/if.test +++ b/tests/if.test @@ -9,8 +9,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: if.test,v 1.13 2009/10/29 15:51:50 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 diff --git a/tests/incr-old.test b/tests/incr-old.test index 96c68b7..ed457cf 100644 --- a/tests/incr-old.test +++ b/tests/incr-old.test @@ -12,8 +12,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: incr-old.test,v 1.10 2006/10/09 19:15:44 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 diff --git a/tests/incr.test b/tests/incr.test index c5a41ad..9243be0 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -1,53 +1,56 @@ # Commands covered: incr # -# 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) 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. -# -# RCS: @(#) $Id: incr.test,v 1.16 2007/12/13 15:26:06 dgp Exp $ +# 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} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } +unset -nocomplain x i +proc readonly varName { + upvar 1 $varName var + trace add variable var write \ + {apply {{args} {error "variable is read-only"}}} +} + # Basic "incr" operation. -catch {unset x} -catch {unset i} - -test incr-1.1 {TclCompileIncrCmd: missing variable name} { - list [catch {incr} msg] $msg -} {1 {wrong # args: should be "incr varName ?increment?"}} +test incr-1.1 {TclCompileIncrCmd: missing variable name} -returnCodes error -body { + incr +} -result {wrong # args: should be "incr varName ?increment?"} test incr-1.2 {TclCompileIncrCmd: simple variable name} { set i 10 list [incr i] $i } {11 11} -test incr-1.3 {TclCompileIncrCmd: error compiling variable name} { +test incr-1.3 {TclCompileIncrCmd: error compiling variable name} -body { set i 10 - catch {incr "i"xxx} msg - set msg -} {extra characters after close-quote} + incr "i"xxx +} -returnCodes error -result {extra characters after close-quote} test incr-1.4 {TclCompileIncrCmd: simple variable name in quotes} { set i 17 list [incr "i"] $i } {18 18} -test incr-1.5 {TclCompileIncrCmd: simple variable name in braces} { - catch {unset {a simple var}} +test incr-1.5 {TclCompileIncrCmd: simple variable name in braces} -setup { + unset -nocomplain {a simple var} +} -body { set {a simple var} 27 list [incr {a simple var}] ${a simple var} -} {28 28} -test incr-1.6 {TclCompileIncrCmd: simple array variable name} { - catch {unset a} +} -result {28 28} +test incr-1.6 {TclCompileIncrCmd: simple array variable name} -setup { + unset -nocomplain a +} -body { set a(foo) 37 list [incr a(foo)] $a(foo) -} {38 38} +} -result {38 38} test incr-1.7 {TclCompileIncrCmd: non-simple (computed) variable name} { set x "i" set i 77 @@ -58,7 +61,6 @@ test incr-1.8 {TclCompileIncrCmd: non-simple (computed) variable name} { set i 77 list [incr [set x] +2] $i } {79 79} - test incr-1.9 {TclCompileIncrCmd: increment given} { set i 10 list [incr i +07] $i @@ -67,7 +69,6 @@ test incr-1.10 {TclCompileIncrCmd: no increment given} { set i 10 list [incr i] $i } {11 11} - test incr-1.11 {TclCompileIncrCmd: simple global name} { proc p {} { global i @@ -149,22 +150,23 @@ test incr-1.14 {TclCompileIncrCmd: simple local name, >255 locals} { } 260locals } {1} -test incr-1.15 {TclCompileIncrCmd: variable is array} { - catch {unset a} +test incr-1.15 {TclCompileIncrCmd: variable is array} -setup { + unset -nocomplain a +} -body { set a(foo) 27 - set x [incr a(foo) 11] - catch {unset a} - set x -} 38 -test incr-1.16 {TclCompileIncrCmd: variable is array, elem substitutions} { - catch {unset a} + incr a(foo) 11 +} -cleanup { + unset -nocomplain a +} -result 38 +test incr-1.16 {TclCompileIncrCmd: variable is array, elem substitutions} -setup { + unset -nocomplain a +} -body { set i 5 set a(foo5) 27 - set x [incr a(foo$i) 11] - catch {unset a} - set x -} 38 - + incr a(foo$i) 11 +} -cleanup { + unset -nocomplain a +} -result 38 test incr-1.17 {TclCompileIncrCmd: increment given, simple int} { set i 5 incr i 123 @@ -175,8 +177,8 @@ test incr-1.18 {TclCompileIncrCmd: increment given, simple int} { } -95 test incr-1.19 {TclCompileIncrCmd: increment given, but erroneous} -body { set i 5 - catch {incr i [set]} msg - set ::errorInfo + catch {incr i [set]} -> opts + dict get $opts -errorinfo } -match glob -result {wrong # args: should be "set varName ?newValue?" while *ing "set"*} @@ -196,19 +198,14 @@ test incr-1.23 {TclCompileIncrCmd: increment given, formatted int != int} { set i 25 incr i 0o00012345 ;# an octal literal } 5374 -test incr-1.24 {TclCompileIncrCmd: increment given, formatted int != int} { +test incr-1.24 {TclCompileIncrCmd: increment given, formatted int != int} -body { set i 25 - catch {incr i 1a} msg - set msg -} {expected integer but got "1a"} - -test incr-1.25 {TclCompileIncrCmd: too many arguments} { + incr i 1a +} -returnCodes error -result {expected integer but got "1a"} +test incr-1.25 {TclCompileIncrCmd: too many arguments} -body { set i 10 - catch {incr i 10 20} msg - set msg -} {wrong # args: should be "incr varName ?increment?"} - - + incr i 10 20 +} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} test incr-1.26 {TclCompileIncrCmd: runtime error, bad variable name} { unset -nocomplain {"foo} incr {"foo} @@ -219,69 +216,68 @@ test incr-1.27 {TclCompileIncrCmd: runtime error, bad variable name} -body { while *ing "set"*}} test incr-1.28 {TclCompileIncrCmd: runtime error, readonly variable} -body { - proc readonly args {error "variable is read-only"} set x 123 - trace var x w readonly + readonly x list [catch {incr x 1} msg] $msg $::errorInfo -} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only +} -match glob -cleanup { + unset -nocomplain x +} -result {1 {can't set "x": variable is read-only} {*variable is read-only while executing * "incr x 1"}} -catch {unset x} -test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} { +test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} -body { set x " - " - list [catch {incr x 1} msg] $msg -} {1 {expected integer but got " - "}} - -test incr-1.30 {TclCompileIncrCmd: array var, braced (no subs)} { + incr x 1 +} -returnCodes error -result {expected integer but got " - "} +test incr-1.30 {TclCompileIncrCmd: array var, braced (no subs)} -setup { catch {unset array} +} -body { set array(\$foo) 4 incr {array($foo)} -} 5 - +} -result 5 + # Check "incr" and computed command names. +unset -nocomplain x i test incr-2.0 {incr and computed command names} { set i 5 set z incr $z i -1 - set i + return $i } 4 -catch {unset x} -catch {unset i} - -test incr-2.1 {incr command (not compiled): missing variable name} { +test incr-2.1 {incr command (not compiled): missing variable name} -body { set z incr - list [catch {$z} msg] $msg -} {1 {wrong # args: should be "incr varName ?increment?"}} + $z +} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} test incr-2.2 {incr command (not compiled): simple variable name} { set z incr set i 10 list [$z i] $i } {11 11} -test incr-2.3 {incr command (not compiled): error compiling variable name} { +test incr-2.3 {incr command (not compiled): error compiling variable name} -body { set z incr set i 10 - catch {$z "i"xxx} msg - set msg -} {extra characters after close-quote} + $z "i"xxx +} -returnCodes error -result {extra characters after close-quote} test incr-2.4 {incr command (not compiled): simple variable name in quotes} { set z incr set i 17 list [$z "i"] $i } {18 18} -test incr-2.5 {incr command (not compiled): simple variable name in braces} { +test incr-2.5 {incr command (not compiled): simple variable name in braces} -setup { + unset -nocomplain {a simple var} +} -body { set z incr - catch {unset {a simple var}} set {a simple var} 27 list [$z {a simple var}] ${a simple var} -} {28 28} -test incr-2.6 {incr command (not compiled): simple array variable name} { +} -result {28 28} +test incr-2.6 {incr command (not compiled): simple array variable name} -setup { + unset -nocomplain a +} -body { set z incr - catch {unset a} set a(foo) 37 list [$z a(foo)] $a(foo) -} {38 38} +} -result {38 38} test incr-2.7 {incr command (not compiled): non-simple (computed) variable name} { set z incr set x "i" @@ -294,7 +290,6 @@ test incr-2.8 {incr command (not compiled): non-simple (computed) variable name} set i 77 list [$z [set x] +2] $i } {79 79} - test incr-2.9 {incr command (not compiled): increment given} { set z incr set i 10 @@ -305,7 +300,6 @@ test incr-2.10 {incr command (not compiled): no increment given} { set i 10 list [$z i] $i } {11 11} - test incr-2.11 {incr command (not compiled): simple global name} { proc p {} { set z incr @@ -391,24 +385,25 @@ test incr-2.14 {incr command (not compiled): simple local name, >255 locals} { } 260locals } {1} -test incr-2.15 {incr command (not compiled): variable is array} { +test incr-2.15 {incr command (not compiled): variable is array} -setup { + unset -nocomplain a +} -body { set z incr - catch {unset a} set a(foo) 27 - set x [$z a(foo) 11] - catch {unset a} - set x -} 38 -test incr-2.16 {incr command (not compiled): variable is array, elem substitutions} { + $z a(foo) 11 +} -cleanup { + unset -nocomplain a +} -result 38 +test incr-2.16 {incr command (not compiled): variable is array, elem substitutions} -setup { + unset -nocomplain a +} -body { set z incr - catch {unset a} set i 5 set a(foo5) 27 - set x [$z a(foo$i) 11] - catch {unset a} - set x -} 38 - + $z a(foo$i) 11 +} -cleanup { + unset -nocomplain a +} -result 38 test incr-2.17 {incr command (not compiled): increment given, simple int} { set z incr set i 5 @@ -422,8 +417,8 @@ test incr-2.18 {incr command (not compiled): increment given, simple int} { test incr-2.19 {incr command (not compiled): increment given, but erroneous} -body { set z incr set i 5 - catch {$z i [set]} msg - set ::errorInfo + catch {$z i [set]} -> opts + dict get $opts -errorinfo } -match glob -result {wrong # args: should be "set varName ?newValue?" while *ing "set"*} @@ -447,26 +442,22 @@ test incr-2.23 {incr command (not compiled): increment given, formatted int != i set i 25 $z i 0o00012345 ;# an octal literal } 5374 -test incr-2.24 {incr command (not compiled): increment given, formatted int != int} { +test incr-2.24 {incr command (not compiled): increment given, formatted int != int} -body { set z incr set i 25 - catch {$z i 1a} msg - set msg -} {expected integer but got "1a"} - -test incr-2.25 {incr command (not compiled): too many arguments} { + $z i 1a +} -returnCodes error -result {expected integer but got "1a"} +test incr-2.25 {incr command (not compiled): too many arguments} -body { set z incr set i 10 - catch {$z i 10 20} msg - set msg -} {wrong # args: should be "incr varName ?increment?"} - - -test incr-2.26 {incr command (not compiled): runtime error, bad variable name} { + $z i 10 20 +} -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} +test incr-2.26 {incr command (not compiled): runtime error, bad variable name} -setup { unset -nocomplain {"foo} +} -body { set z incr $z {"foo} -} 1 +} -result 1 test incr-2.27 {incr command (not compiled): runtime error, bad variable name} -body { set z incr list [catch {$z [set]} msg] $msg $::errorInfo @@ -475,20 +466,20 @@ test incr-2.27 {incr command (not compiled): runtime error, bad variable name} - "set"*}} test incr-2.28 {incr command (not compiled): runtime error, readonly variable} -body { set z incr - proc readonly args {error "variable is read-only"} set x 123 - trace var x w readonly + readonly x list [catch {$z x 1} msg] $msg $::errorInfo -} -match glob -result {1 {can't set "x": variable is read-only} {*variable is read-only +} -match glob -cleanup { + unset -nocomplain x +} -result {1 {can't set "x": variable is read-only} {*variable is read-only while executing * "$z x 1"}} -catch {unset x} -test incr-2.29 {incr command (not compiled): runtime error, bad variable value} { +test incr-2.29 {incr command (not compiled): runtime error, bad variable value} -body { set z incr set x " - " - list [catch {$z x 1} msg] $msg -} {1 {expected integer but got " - "}} + $z x 1 +} -returnCodes error -result {expected integer but got " - "} test incr-2.30 {incr command (not compiled): bad increment} { set z incr set x 0 @@ -520,7 +511,12 @@ test incr-4.1 {increment non-existing array element [Bug 1445454]} -body { } -cleanup { rename x {} } -result 1 - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/indexObj.test b/tests/indexObj.test index 495af3c..646cb02 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -1,22 +1,24 @@ # This file is a Tcl script to test out the the procedures in file -# tkIndexObj.c, which implement indexed table lookups. The tests here -# are organized in the standard fashion for Tcl tests. +# 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. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: indexObj.test,v 1.17 2008/07/21 21:25:22 nijtmans Exp $ +# 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 + package require tcltest 2 namespace import -force ::tcltest::* } -testConstraint testindexobj [llength [info commands testindexobj]] +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] +testConstraint testindexobj [llength [info commands testindexobj]] +testConstraint testparseargs [llength [info commands testparseargs]] + test indexObj-1.1 {exact match} testindexobj { testindexobj 1 1 xyz abc def xyz alm } {2} @@ -130,6 +132,31 @@ test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj { testgetindexfromobjstruct $x 1 } "wrong # args: should be \"testgetindexfromobjstruct c 1\"" +test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs { + testparseargs +} {0 1 testparseargs} +test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs { + testparseargs -bool +} {1 1 testparseargs} +test indexObj-7.3 {Tcl_ParseArgsObjv} testparseargs { + testparseargs -bool bar +} {1 2 {testparseargs bar}} +test indexObj-7.4 {Tcl_ParseArgsObjv} testparseargs { + testparseargs bar +} {0 2 {testparseargs bar}} +test indexObj-7.5 {Tcl_ParseArgsObjv} -constraints testparseargs -body { + testparseargs -help +} -returnCodes error -result {Command-specific options: + -bool: booltest + --: Marks the end of the options + -help: Print summary of command-line options and abort} +test indexObj-7.6 {Tcl_ParseArgsObjv} testparseargs { + testparseargs -- -bool -help +} {0 3 {testparseargs -bool -help}} +test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs { + testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0 +} {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}} + # cleanup ::tcltest::cleanupTests return diff --git a/tests/info.test b/tests/info.test index fd126a7..5078e11 100644 --- a/tests/info.test +++ b/tests/info.test @@ -13,13 +13,16 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: info.test,v 1.78 2010/08/03 20:15:53 andreas_kupries Exp $ +# DO NOT DELETE THIS LINE if {{::tcltest} ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. @@ -215,14 +218,14 @@ test info-6.9 {info default option} -returnCodes error -setup { set a(0) 88 proc t1 {a b} {} info default t1 a a -} -returnCodes error -result {couldn't store default value in variable "a"} +} -returnCodes error -result {can't set "a": variable is array} test info-6.10 {info default option} -setup { catch {unset a} } -cleanup {unset a} -body { set a(0) 88 proc t1 {{a 18} b} {} info default t1 a a -} -returnCodes error -result {couldn't store default value in variable "a"} +} -returnCodes error -result {can't set "a": variable is array} test info-6.11 {info default option} { catch {namespace delete test_ns_info2} namespace eval test_ns_info2 { @@ -231,7 +234,6 @@ test info-6.11 {info default option} { } } {0 {} 1 27} - test info-7.1 {info exists option} -body { set value foo info exists value @@ -690,14 +692,12 @@ test info-21.5 {miscellaneous error conditions} -returnCodes error -body { ## # ### ### ### ######### ######### ######### ## 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 @@ -714,7 +714,9 @@ proc reduce {frame} { } set 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 @@ -731,8 +733,6 @@ proc etrace {} { return $res } -## - test info-22.0 {info frame, levels} {!singleTestInterp} { info frame } 7 @@ -763,7 +763,7 @@ test info-22.7 {info frame, global, absolute} {!singleTestInterp} { } {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0} test info-22.8 {info frame, basic trace} -match glob -body { join [lrange [etrace] 0 2] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} * {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest} * {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} unset -nocomplain msg @@ -803,7 +803,7 @@ test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body { test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body { set script {etrace} join [lrange [eval $script] 0 2] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 1 cmd etrace proc ::tcltest::RunTest} * {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}} @@ -1318,7 +1318,7 @@ test info-37.0 {eval pure list, single line} -match glob -body { }] eval $cmd return $res -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 2 cmd etrace proc ::tcltest::RunTest} * {type eval line 1 cmd foreac proc ::tcltest::RunTest}} -cleanup {unset foo cmd res b c} @@ -1359,18 +1359,18 @@ test info-38.1 {location information for uplevel, dv, direct-var} -match glob -b etrace } join [lrange [uplevel \#0 $script] 0 2] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::tcltest::RunTest} * {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y} -test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -body { - join [lrange [uplevel \#0 { - set y DL. - etrace - }] 0 2] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 1369 file info.test cmd etrace proc ::tcltest::RunTest} -* {type source line 1367 file info.test cmd uplevel\\ \\\\ proc ::tcltest::RunTest}} -cleanup {unset y} +# 38.2 moved to bottom to not disturb other tests with the necessary changes to this one. + + + + + + + test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body { set script { @@ -1378,41 +1378,41 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g etrace } join [lrange [control y $script] 0 3] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::control} * {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} * {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y} -test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -body { - join [lrange [control y { - set y DPL - etrace - }] 0 3] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 1389 file info.test cmd etrace proc ::control} -* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1387 file info.test cmd control proc ::tcltest::RunTest}} -cleanup {unset y} +# 38.4 moved to bottom to not disturb other tests with the necessary changes to this one. + + + + + + + + test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body { join [lrange [datav] 0 4] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::control} * {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} * {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1} * {type source line 1397 file info.test cmd datav proc ::tcltest::RunTest}} -test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -body { - join [lrange [datal] 0 4] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 1344 file info.test cmd etrace proc ::control} -* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1342 file info.test cmd control proc ::datal level 1} -* {type source line 1405 file info.test cmd datal proc ::tcltest::RunTest}} +# 38.6 moved to bottom to not disturb other tests with the necessary changes to this one. + + + + + + testConstraint testevalex [llength [info commands testevalex]] test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body { join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n -} -result {* {type source line 728 file info.test cmd {info frame \$level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame \$level} proc ::etrace level 0} * {type eval line 1 cmd etrace proc ::tcltest::RunTest} * {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest} * {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} @@ -1543,18 +1543,18 @@ test info-30.12 {bs+nl in computed word, nested eval} -body { } -cleanup {unset res x} -result { type source line 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.13 {bs+nl in literal words, uplevel script, with nested words} -body { - uplevel #0 { + subinterp ; set res [interp eval sub { uplevel #0 { if {1} \ { set ::res \ [reduce [info frame 0]];# line 1550 } } - return $res -} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + set res }] ; interp delete sub ; set res +} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} level 0} test info-30.14 {bs+nl, literal word, uplevel through proc} { - proc abra {script} { + subinterp ; set res [interp eval sub { proc abra {script} { uplevel 1 $script } set res [abra { @@ -1562,7 +1562,7 @@ test info-30.14 {bs+nl, literal word, uplevel through proc} { [reduce [info frame 0]]";# line 1562 }] rename abra {} - set res + set res }] ; interp delete sub ; set res } { type source line 1562 file info.test cmd {info frame 0} proc ::abra} test info-30.15 {bs+nl in literal words, nested proc body, compiled} { @@ -1826,7 +1826,7 @@ test info-30.46 {TIP 280 for compiled [subst]} { } YES test info-30.47 {TIP 280 for compiled [subst]} { unset -nocomplain a - set a(\n1831) YES; set a(\n1830) 1830; set a(\n1832) 1832 + set a(\n1831) YES; set a(\n1830) 1830; set a(\n1832) 1832 subst {$a( [dict get [info frame 0] line])} ; # 1831 } YES @@ -1879,6 +1879,89 @@ test info-39.1 {location information not confused by literal sharing, bug 293308 type source line 1859 file info.test cmd print_one proc ::test_info_frame level 1} # ------------------------------------------------------------------------- +# Tests moved to the end to not disturb other tests and their locations. + +test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -setup {subinterp} -body { + interp eval sub { + proc etrace {} { + set res {} + set level [info frame] + while {$level} { + lappend res [list $level [reduce [info frame $level]]] + incr level -1 + } + return $res + } + proc control {vv script} { + upvar 1 $vv var + return [uplevel 1 $script] + } + proc datal {} { + control y { + set y PPL + etrace + } + } + join [lrange [datal] 0 4] \n + } +} -result {* {type source line 1890 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1902 file info.test cmd etrace proc ::control} +* {type source line 1897 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1900 file info.test cmd control proc ::datal level 1} +* {type source line 1905 file info.test cmd datal level 2}} -cleanup {interp delete sub} + +test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -setup {subinterp} -body { + interp eval sub { + proc etrace {} { + set res {} + set level [info frame] + while {$level} { + lappend res [list $level [reduce [info frame $level]]] + incr level -1 + } + return $res + } + proc control {vv script} { + upvar 1 $vv var + return [uplevel 1 $script] + } + join [lrange [control y { + set y DPL + etrace + }] 0 3] \n + } +} -result {* {type source line 1919 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1930 file info.test cmd etrace proc ::control} +* {type source line 1926 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1928 file info.test cmd control level 1}} -cleanup {interp delete sub} + +test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -setup {subinterp} -body { + interp eval sub { + proc etrace {} { + set res {} + set level [info frame] + while {$level} { + lappend res [list $level [reduce [info frame $level]]] + incr level -1 + } + return $res + } + join [lrange [uplevel \#0 { + set y DL. + etrace + }] 0 2] \n + } +} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0} +* {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"} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup diff --git a/tests/init.test b/tests/init.test index 9c16ee3..41b8624 100644 --- a/tests/init.test +++ b/tests/init.test @@ -9,11 +9,9 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: init.test,v 1.22 2010/04/05 19:44:45 ferrieux Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.3.4 namespace import -force ::tcltest::* } @@ -52,28 +50,28 @@ test init-1.8 {auto_qualify - multiple colons 2} { # places where auto_loading occur (before loading the indexes files and after) set testInterp [interp create] -interp eval $testInterp [list set argv $argv] -interp eval $testInterp [list package require tcltest] -interp eval $testInterp [list namespace import -force ::tcltest::*] - +tcltest::loadIntoSlaveInterpreter $testInterp {*}$argv interp eval $testInterp { + namespace import -force ::tcltest::* + customMatch pairwise {apply {{mode pair} { + if {[llength $pair] != 2} {error "need a pair of values to check"} + string $mode [lindex $pair 0] [lindex $pair 1] + }}} -auto_reset -catch {rename parray {}} + auto_reset + catch {rename parray {}} -test init-2.0 {load parray - stage 1} { - set ret [catch {parray} error] +test init-2.0 {load parray - stage 1} -body { + parray +} -returnCodes error -cleanup { rename parray {} ;# remove it, for the next test - that should not fail. - list $ret $error -} {1 {wrong # args: should be "parray a ?pattern?"}} -test init-2.1 {load parray - stage 2} { - set ret [catch {parray} error] - list $ret $error -} {1 {wrong # args: should be "parray a ?pattern?"}} +} -result {wrong # args: should be "parray a ?pattern?"} +test init-2.1 {load parray - stage 2} -body { + parray +} -returnCodes error -result {wrong # args: should be "parray a ?pattern?"} auto_reset catch {rename ::safe::setLogCmd {}} -#unset auto_index(::safe::setLogCmd) -#unset auto_oldpath +#unset -nocomplain auto_index(::safe::setLogCmd) auto_oldpath test init-2.2 {load ::safe::setLogCmd - stage 1} { ::safe::setLogCmd rename ::safe::setLogCmd {} ;# should not fail @@ -107,30 +105,30 @@ test init-2.8 {load tcl::HistAdd} -setup { catch {rename ::tcl::HistAdd {}} } -body { # 3 ':' on purpose - list [catch {tcl:::HistAdd} error] $error -} -cleanup { + tcl:::HistAdd +} -returnCodes error -cleanup { rename ::tcl::HistAdd {} -} -result {1 {wrong # args: should be "tcl:::HistAdd event ?exec?"}} - +} -result {wrong # args: should be "tcl:::HistAdd event ?exec?"} + test init-3.0 {random stuff in the auto_index, should still work} { set auto_index(foo:::bar::blah) { namespace eval foo {namespace eval bar {proc blah {} {return 1}}} } foo:::bar::blah } 1 - + # Tests that compare the error stack trace generated when autoloading with # that generated when no autoloading is necessary. Ideally they should be the # same. set count 0 foreach arg [subst -nocommands -novariables { - c - {argument + c + {argument which spans multiple lines} - {argument which is all on one line but which is of such great length that the Tcl C library will truncate it when appending it onto the global error stack} - {argument which spans multiple lines + {argument which is all on one line but which is of such great length that the Tcl C library will truncate it when appending it onto the global error stack} + {argument which spans multiple lines 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} @@ -139,37 +137,37 @@ foreach arg [subst -nocommands -novariables { 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 "} - {argument that contains non-ASCII character, \u20ac, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library} - }] { + {argument that contains non-ASCII character, \u20ac, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library} + }] { ;# emacs needs -> " - test init-4.$count.0 {::errorInfo produced by [unknown]} { + test init-4.$count.0 {::errorInfo produced by [unknown]} -setup { auto_reset + } -body { catch {parray a b $arg} set first $::errorInfo catch {parray a b $arg} - set second $::errorInfo - string equal $first $second - } 1 - test init-4.$count.1 {::errorInfo produced by [unknown]} { + list $first $::errorInfo + } -match pairwise -result equal + test init-4.$count.1 {::errorInfo produced by [unknown]} -setup { auto_reset + } -body { namespace eval junk [list array set $arg [list 1 2 3 4]] trace variable ::junk::$arg r \ "[list error [subst {Variable \"$arg\" is write-only}]] ;# " catch {parray ::junk::$arg} set first $::errorInfo catch {parray ::junk::$arg} - set second $::errorInfo - string equal $first $second - } 1 + list $first $::errorInfo + } -match pairwise -result equal incr count } - + test init-5.0 {return options passed through ::unknown} -setup { catch {rename xxx {}} set ::auto_index(::xxx) {proc ::xxx {} { diff --git a/tests/interp.test b/tests/interp.test index 45254ad..0af9887 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -9,17 +9,18 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: interp.test,v 1.68 2009/12/29 14:55:42 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source unload} +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} foreach i [interp slaves] { interp delete $i @@ -31,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, 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, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.3 {options for interp command} { interp delete } "" @@ -49,13 +50,13 @@ test interp-1.6 {options for interp command} -returnCodes error -body { } -result {wrong # args: should be "interp slaves ?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, 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, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, 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, 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, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, 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, 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, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, 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"} @@ -147,7 +148,7 @@ test interp-3.8 {testing interp exists and interp slaves} -body { } -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} test interp-3.9 {testing interp exists and interp slaves} { interp create {a a2} -safe - expr {[lsearch [interp slaves a] a2] >= 0} + expr {"a2" in [interp slaves a]} } 1 test interp-3.10 {testing interp exists and interp slaves} { interp exists {a a2} @@ -174,7 +175,7 @@ test interp-4.5 {testing interp delete} { interp create a interp create {a x1} interp delete {a x1} - expr {[lsearch [interp slaves a] x1] >= 0} + expr {"x1" in [interp slaves a]} } 0 test interp-4.6 {testing interp delete} { interp create c1 @@ -586,7 +587,6 @@ test interp-14.10 {testing interp-alias: error messages} -setup { invoked from within "a 1"} - # part 15: testing file sharing test interp-15.1 {testing file sharing} { catch {interp delete z} @@ -667,8 +667,7 @@ test interp-15.8 {testing file transferring} -body { # Torture tests for interpreter deletion order # proc kill {} {interp delete xxx} - -test interp-15.9 {testing deletion order} { +test interp-16.0 {testing deletion order} { catch {interp delete xxx} interp create xxx xxx alias kill kill @@ -1607,67 +1606,73 @@ test interp-21.1 {interp hidden} { test interp-21.2 {interp hidden} { interp hidden } "" -test interp-21.3 {interp hidden vs interp hide, interp expose} { +test interp-21.3 {interp hidden vs interp hide, interp expose} -setup { set l "" +} -body { lappend l [interp hidden] interp hide {} pwd lappend l [interp hidden] interp expose {} pwd lappend l [interp hidden] - set l -} {{} pwd {}} -test interp-21.4 {interp hidden} { +} -result {{} pwd {}} +test interp-21.4 {interp hidden} -setup { catch {interp delete a} +} -body { interp create a - set l [interp hidden a] + interp hidden a +} -cleanup { interp delete a - set l -} "" -test interp-21.5 {interp hidden} { +} -result "" +test interp-21.5 {interp hidden} -setup { catch {interp delete a} +} -body { interp create -safe a - set l [lsort [interp hidden a]] + lsort [interp hidden a] +} -cleanup { interp delete a - set l -} $hidden_cmds -test interp-21.6 {interp hidden vs interp hide, interp expose} { +} -result $hidden_cmds +test interp-21.6 {interp hidden vs interp hide, interp expose} -setup { catch {interp delete a} - interp create a set l "" +} -body { + interp create a lappend l [interp hidden a] interp hide a pwd lappend l [interp hidden a] interp expose a pwd lappend l [interp hidden a] +} -cleanup { interp delete a - set l -} {{} pwd {}} -test interp-21.7 {interp hidden} { +} -result {{} pwd {}} +test interp-21.7 {interp hidden} -setup { catch {interp delete a} +} -body { interp create a - set l [a hidden] + a hidden +} -cleanup { interp delete a - set l -} "" -test interp-21.8 {interp hidden} { +} -result "" +test interp-21.8 {interp hidden} -setup { catch {interp delete a} +} -body { interp create a -safe - set l [lsort [a hidden]] + lsort [a hidden] +} -cleanup { interp delete a - set l -} $hidden_cmds -test interp-21.9 {interp hidden vs interp hide, interp expose} { +} -result $hidden_cmds +test interp-21.9 {interp hidden vs interp hide, interp expose} -setup { catch {interp delete a} - interp create a set l "" +} -body { + interp create a lappend l [a hidden] a hide pwd lappend l [a hidden] a expose pwd lappend l [a hidden] +} -cleanup { interp delete a - set l -} {{} pwd {}} +} -result {{} pwd {}} test interp-22.1 {testing interp marktrusted} { catch {interp delete a} @@ -1767,183 +1772,161 @@ test interp-22.9 {testing interp marktrusted} { set l } {1 1 1 0 0} -test interp-23.1 {testing hiding vs aliases} { +test interp-23.1 {testing hiding vs aliases: unsafe interp} -setup { catch {interp delete a} - interp create a set l "" +} -body { + interp create a lappend l [interp hidden a] a alias bar bar - lappend l [interp aliases a] - lappend l [interp hidden a] + lappend l [interp aliases a] [interp hidden a] a hide bar - lappend l [interp aliases a] - lappend l [interp hidden a] + lappend l [interp aliases a] [interp hidden a] a alias bar {} - lappend l [interp aliases a] - lappend l [interp hidden a] + lappend l [interp aliases a] [interp hidden a] +} -cleanup { interp delete a - set l -} {{} bar {} bar bar {} {}} -test interp-23.2 {testing hiding vs aliases} {unixOrPc} { +} -result {{} bar {} bar bar {} {}} +test interp-23.2 {testing hiding vs aliases: safe interp} -setup { catch {interp delete a} - interp create a -safe set l "" +} -constraints {unixOrPc} -body { + interp create a -safe lappend l [lsort [interp hidden a]] a alias bar bar - lappend l [lsort [interp aliases a]] - lappend l [lsort [interp hidden a]] + lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a hide bar - lappend l [lsort [interp aliases a]] - lappend l [lsort [interp hidden a]] + lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a alias bar {} - lappend l [lsort [interp aliases a]] - lappend l [lsort [interp hidden a]] + lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] +} -cleanup { interp delete a - set l -} {{cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} {bar cd encoding exec exit fconfigure file glob load open pwd socket source unload} {::tcl::mathfunc::max ::tcl::mathfunc::min clock} {cd encoding exec exit fconfigure file glob load open pwd socket source unload}} +} -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] -test interp-24.1 {result resetting on error} { +test interp-24.1 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a - proc foo args {error $args} - interp alias a foo {} foo - set l [interp eval a { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp alias a foo {} apply {args {error $args}} + interp eval a { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - rename foo {} - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.2 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.2 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a -safe - proc foo args {error $args} - interp alias a foo {} foo - set l [interp eval a { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp alias a foo {} apply {args {error $args}} + interp eval a { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - rename foo {} - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.3 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.3 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a interp create {a b} interp eval a { proc foo args {error $args} } interp alias {a b} foo a foo - set l [interp eval {a b} { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp eval {a b} { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.4 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.4 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a -safe interp create {a b} interp eval a { proc foo args {error $args} } interp alias {a b} foo a foo - set l [interp eval {a b} { - set l {} + interp eval {a b} { lappend l [catch {foo 1 2 3} msg] lappend l $msg lappend l [catch {foo 3 4 5} msg] lappend l $msg - set l - }] + } +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.5 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.5 {result resetting on error} -setup { catch {interp delete a} catch {interp delete b} +} -body { interp create a interp create b interp eval a { proc foo args {error $args} } interp alias b foo a foo - set l [interp eval b { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp eval b { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.6 {result resetting on error} { + interp delete b +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.6 {result resetting on error} -setup { catch {interp delete a} catch {interp delete b} +} -body { interp create a -safe interp create b -safe interp eval a { proc foo args {error $args} } interp alias b foo a foo - set l [interp eval b { - set l {} - lappend l [catch {foo 1 2 3} msg] - lappend l $msg - lappend l [catch {foo 3 4 5} msg] - lappend l $msg - set l - }] + interp eval b { + lappend l [catch {foo 1 2 3} msg] $msg + lappend l [catch {foo 3 4 5} msg] $msg + } +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.7 {result resetting on error} { + interp delete b +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.7 {result resetting on error} -setup { catch {interp delete a} + set l {} +} -body { interp create a interp eval a { proc foo args {error $args} } - set l {} - lappend l [catch {interp eval a foo 1 2 3} msg] - lappend l $msg - lappend l [catch {interp eval a foo 3 4 5} msg] - lappend l $msg + lappend l [catch {interp eval a foo 1 2 3} msg] $msg + lappend l [catch {interp eval a foo 3 4 5} msg] $msg +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.8 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.8 {result resetting on error} -setup { catch {interp delete a} + set l {} +} -body { interp create a -safe interp eval a { proc foo args {error $args} } - set l {} - lappend l [catch {interp eval a foo 1 2 3} msg] - lappend l $msg - lappend l [catch {interp eval a foo 3 4 5} msg] - lappend l $msg + lappend l [catch {interp eval a foo 1 2 3} msg] $msg + lappend l [catch {interp eval a foo 3 4 5} msg] $msg +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.9 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.9 {result resetting on error} -setup { catch {interp delete a} + set l {} +} -body { interp create a interp create {a b} interp eval {a b} { @@ -1954,16 +1937,15 @@ test interp-24.9 {result resetting on error} { eval interp eval b foo $args } } - set l {} - lappend l [catch {interp eval a foo 1 2 3} msg] - lappend l $msg - lappend l [catch {interp eval a foo 3 4 5} msg] - lappend l $msg + lappend l [catch {interp eval a foo 1 2 3} msg] $msg + lappend l [catch {interp eval a foo 3 4 5} msg] $msg +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.10 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.10 {result resetting on error} -setup { catch {interp delete a} + set l {} +} -body { interp create a -safe interp create {a b} interp eval {a b} { @@ -1974,16 +1956,14 @@ test interp-24.10 {result resetting on error} { eval interp eval b foo $args } } - set l {} - lappend l [catch {interp eval a foo 1 2 3} msg] - lappend l $msg - lappend l [catch {interp eval a foo 3 4 5} msg] - lappend l $msg + lappend l [catch {interp eval a foo 1 2 3} msg] $msg + lappend l [catch {interp eval a foo 3 4 5} msg] $msg +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {3 4 5}} -test interp-24.11 {result resetting on error} { +} -result {1 {1 2 3} 1 {3 4 5}} +test interp-24.11 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a interp create {a b} interp eval {a b} { @@ -1991,20 +1971,17 @@ test interp-24.11 {result resetting on error} { } interp eval a { proc foo args { - set l {} - lappend l [catch {eval interp eval b foo $args} msg] - lappend l $msg - lappend l [catch {eval interp eval b foo $args} msg] - lappend l $msg - set l + lappend l [catch {eval interp eval b foo $args} msg] $msg + lappend l [catch {eval interp eval b foo $args} msg] $msg } } - set l [interp eval a foo 1 2 3] + interp eval a foo 1 2 3 +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {1 2 3}} -test interp-24.12 {result resetting on error} { +} -result {1 {1 2 3} 1 {1 2 3}} +test interp-24.12 {result resetting on error} -setup { catch {interp delete a} +} -body { interp create a -safe interp create {a b} interp eval {a b} { @@ -2012,27 +1989,22 @@ test interp-24.12 {result resetting on error} { } interp eval a { proc foo args { - set l {} - lappend l [catch {eval interp eval b foo $args} msg] - lappend l $msg - lappend l [catch {eval interp eval b foo $args} msg] - lappend l $msg - set l + lappend l [catch {eval interp eval b foo $args} msg] $msg + lappend l [catch {eval interp eval b foo $args} msg] $msg } } - set l [interp eval a foo 1 2 3] + interp eval a foo 1 2 3 +} -cleanup { interp delete a - set l -} {1 {1 2 3} 1 {1 2 3}} +} -result {1 {1 2 3} 1 {1 2 3}} -unset hidden_cmds - -test interp-25.1 {testing aliasing of string commands} { +test interp-25.1 {testing aliasing of string commands} -setup { catch {interp delete a} +} -body { interp create a a alias exec foo ;# Relies on exec being a string command! interp delete a -} "" +} -result "" # # Interps result transmission @@ -2357,17 +2329,17 @@ test interp-28.1 {getting fooled by slave's namespace ?} -setup { } -result {} test interp-28.2 {master's nsName cache should not cross} -setup { set i [interp create] + $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}} } -body { $i eval { set x {namespace children ::} set y [list namespace children ::] - namespace delete {*}[{*}$y] + namespace delete {*}[filter [{*}$y]] set j [interp create] - $j eval {namespace delete {*}[namespace children ::]} + $j alias filter filter + $j eval {namespace delete {*}[filter [namespace children ::]]} namespace eval foo {} - set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]] - interp delete $j - set res + list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]] } } -cleanup { interp delete $i @@ -3058,7 +3030,7 @@ test interp-31.1 {alias invocation scope} { myNewSet a $value return $a } - catch {unset a} + unset -nocomplain a set result [testMyNewSet "ok"] rename testMyNewSet {} rename mySet {} @@ -3526,6 +3498,13 @@ test interp-35.22 {interp time limits normalize milliseconds} -body { } -cleanup { interp delete $i } -result {2 500} +# Bug 3398794 +test interp-35.23 {interp command limits can't touch current interp} -body { + interp limit {} commands -value 10 +} -returnCodes error -result {limits on current interpreter inaccessible} +test interp-35.24 {interp time limits can't touch current interp} -body { + interp limit {} time -seconds 2 +} -returnCodes error -result {limits on current interpreter inaccessible} test interp-36.1 {interp bgerror syntax} -body { interp bgerror @@ -3580,7 +3559,7 @@ test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { set result } -cleanup { variable result {} - unset result + unset -nocomplain result interp delete slave } -result foo @@ -3593,11 +3572,55 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { 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 result + unset -nocomplain result interp delete a } -result {26 26} + +test interp-38.1 {interp debug one-way switch} -setup { + catch {interp delete a} + interp create a + interp debug a -frame 1 +} -body { + # TIP #3xx interp debug frame is a one-way switch + interp debug a -frame 0 +} -cleanup { + interp delete a +} -result {1} +test interp-38.2 {interp debug env var} -setup { + catch {interp delete a} + set ::env(TCL_INTERP_DEBUG_FRAME) 1 + interp create a +} -body { + interp debug a +} -cleanup { + unset -nocomplain ::env(TCL_INTERP_DEBUG_FRAME) + interp delete a +} -result {-frame 1} +test interp-38.3 {interp debug wrong args} -body { + interp debug +} -returnCodes { + error +} -result {wrong # args: should be "interp debug path ?-frame ?bool??"} +test interp-38.4 {interp debug basic setup} -body { + interp debug {} +} -result {-frame 0} +test interp-38.5 {interp debug basic setup} -body { + interp debug {} -f +} -result {0} +test interp-38.6 {interp debug basic setup} -body { + interp debug -frames +} -returnCodes error -result {could not find interpreter "-frames"} +test interp-38.7 {interp debug basic setup} -body { + interp debug {} -frames +} -returnCodes error -result {bad debug option "-frames": must be -frame} +test interp-38.8 {interp debug basic setup} -body { + interp debug {} -frame 0 bogus +} -returnCodes { + error +} -result {wrong # args: should be "interp debug path ?-frame ?bool??"} # cleanup +unset -nocomplain hidden_cmds foreach i [interp slaves] { interp delete $i } diff --git a/tests/io.test b/tests/io.test index c69bff9..0688c14 100644 --- a/tests/io.test +++ b/tests/io.test @@ -12,13 +12,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: io.test,v 1.96 2010/02/07 08:03:11 dkf Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -39,7 +41,7 @@ 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 testthread [llength [info commands testthread]] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... @@ -2088,6 +2090,8 @@ set path(pipe) [makeFile {} pipe] set path(output) [makeFile {} output] test io-27.6 {FlushChannel, async flushing, async close} \ {stdio asyncPipeClose openpipe} { + # 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) file delete $path(output) set f [open $path(pipe) w] @@ -2647,6 +2651,8 @@ test io-29.30 {Tcl_WriteChars, crlf mode} { file size $path(test1) } 25 test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { + # 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) file delete $path(output) set f [open $path(pipe) w] @@ -2688,6 +2694,8 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { } ok test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ {stdio asyncPipeClose openpipe} { + # 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) file delete $path(output) set f [open $path(pipe) w] @@ -2738,6 +2746,26 @@ test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} { close $f set r } "hello\nbye\nstrange\n" +set path(script2) [makeFile {} script2] +test io-29.33b {TIP#398, no implicit flush of nonblocking on exit} {exec} { + set f [open $path(script) w] + puts $f { + fconfigure stdout -blocking 0 + puts -nonewline stdout [string repeat A 655360] + flush stdout + } + close $f + set f [open $path(script2) w] + puts $f {after 2000} + close $f + set t1 [clock milliseconds] + set ff [open "|[list [interpreter] $path(script2)]" w] + catch {unset ::env(TCL_FLUSH_NONBLOCKING_ON_EXIT)} + exec [interpreter] $path(script) >@ $ff + set t2 [clock milliseconds] + close $ff + expr {($t2-$t1)/2000 ? $t2-$t1 : 0} +} 0 test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} { variable c 0 variable x running @@ -3858,7 +3886,7 @@ test io-32.3 {Tcl_Read, negative byte count} { set l [list [catch {read $f -1} msg] $msg] close $f set l -} {1 {bad argument "-1": should be "nonewline"}} +} {1 {expected non-negative integer but got "-1"}} test io-32.4 {Tcl_Read, positive byte count} { set f [open $path(longfile) r] set x [read $f 1024] @@ -5207,16 +5235,16 @@ test io-40.1 {POSIX open access modes: RDWR} { } {zzy abzzy} test io-40.2 {POSIX open access modes: CREAT} {unix} { file delete $path(test3) - 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%o" [expr $stats(mode)&0o777]] puts $f "line 1" close $f set f [open $path(test3) r] lappend x [gets $f] close $f set x -} {0600 {line 1}} +} {0o600 {line 1}} test io-40.3 {POSIX open access modes: CREAT} {unix umask} { # This test only works if your umask is 2, like ouster's. file delete $path(test3) @@ -7007,6 +7035,44 @@ test io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} removeFile foo removeFile bar } -result {1 sync/OK {CMD 0}} +test io-53.8b {CopyData: async callback and -size 0} -setup { + # copy progress callback. errors out intentionally + proc ::cmd args { + lappend ::RES "CMD $args" + set ::forever has-been-reached + return + } + # Files we use for our channels + set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] + set bar [makeFile {} bar] + # 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 { + set ::RES {} + # Run the copy. Should not invoke -command now. + fcopy $f $g -size 0 -command ::cmd + # Check that -command was not called synchronously + lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}] + # Now let the async part happen. Should capture the eof in cmd + # If not break the event loop via timer. + set token [after 1000 { + lappend ::RES {cmd/FAIL timeout} + set ::forever has-been-reached + }] + vwait ::forever + catch {after cancel $token} + # Report + set ::RES +} -cleanup { + close $f + close $g + catch {unset ::RES} + catch {unset ::forever} + rename ::cmd {} + removeFile foo + removeFile bar +} -result {sync/OK {CMD 0}} test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { set out [makeFile {} out] set err [makeFile {} err] @@ -7399,7 +7465,7 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} { # More complicated tests (like that the reference changes as a # channel is moved from thread to thread) can be done only in the # extension which fully implements the moving of channels between - # threads, i.e. 'Threads'. Or we have to extend [testthread] as well. + # threads, i.e. 'Threads'. set f [open $path(longfile) r] set result [testchannel mthread $f] @@ -7491,25 +7557,7 @@ test io-70.0 {Cutting & Splicing channels} {testchannel} { } {0 1 0} -# Duplicate of code in "thread.test". Find a better way of doing this -# without duplication. Maybe placement into a proc which transforms to -# nop after the first call, and placement of its defintion in a -# central location. - -if {[testConstraint testthread]} { - testthread errorproc ThreadError - - proc ThreadError {id info} { - global threadError - set threadError $info - } - - proc ThreadNullError {id info} { - # ignore - } -} - -test io-70.1 {Transfer channel} {testchannel testthread} { +test io-70.1 {Transfer channel} {testchannel thread} { set f [makeFile {... dummy ...} cutsplice] set c [open $f r] @@ -7518,16 +7566,17 @@ test io-70.1 {Transfer channel} {testchannel testthread} { testchannel cut $c lappend res [catch {seek $c 0 start}] - set tid [testthread create] - testthread send $tid [list set c $c] - lappend res [testthread send $tid { + set tid [thread::create -preserved] + thread::send $tid [list set c $c] + thread::send $tid {load {} Tcltest} + lappend res [thread::send $tid { testchannel splice $c set res [catch {seek $c 0 start}] close $c set res }] - tcltest::threadReap + thread::release $tid removeFile cutsplice set res @@ -7742,7 +7791,7 @@ test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} -setup { # ### ### ### ######### ######### ######### # cleanup -foreach file [list fooBar longfile script output test1 pipe my_script \ +foreach file [list fooBar longfile script script2 output test1 pipe my_script \ test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { removeFile $file } diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 920238c..03242be 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -12,18 +12,19 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: ioCmd.test,v 1.53 2010/08/03 20:06:47 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Custom constraints used in this file testConstraint fcopy [llength [info commands fcopy]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint testthread [llength [info commands testthread]] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] #---------------------------------------------------------------------- @@ -35,7 +36,7 @@ test iocmd-1.2 {puts command} { } {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} test iocmd-1.3 {puts command} { list [catch {puts froboz -nonewline kablooie} msg] $msg -} {1 {bad argument "kablooie": should be "nonewline"}} +} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}} test iocmd-1.4 {puts command} { list [catch {puts froboz hello} msg] $msg } {1 {can not find channel named "froboz"}} @@ -138,7 +139,7 @@ test iocmd-4.8 {read command with incorrect combination of arguments} { } {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} {TCL WRONGARGS}} test iocmd-4.9 {read command} { list [catch {read stdin foo} msg] $msg $::errorCode -} {1 {bad argument "foo": should be "nonewline"} NONE} +} {1 {expected non-negative integer but got "foo"} {TCL VALUE NUMBER}} test iocmd-4.10 {read command} { list [catch {read file107} msg] $msg $::errorCode } {1 {can not find channel named "file107"} {TCL LOOKUP CHANNEL file107}} @@ -156,7 +157,7 @@ test iocmd-4.12 {read command} -setup { list [catch {read $f 12z} msg] $msg $::errorCode } -cleanup { close $f -} -result {1 {expected integer but got "12z"} {TCL VALUE NUMBER}} +} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}} test iocmd-5.1 {seek command} -returnCodes error -body { seek @@ -388,13 +389,13 @@ test iocmd-11.1 {I/O to command pipelines} {unixOrPc 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} NONE} +} {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} { list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode -} {1 {can't read output from command: standard output was redirected} NONE} +} {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} { list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode -} {1 {can't read output from command: standard output was redirected} NONE} +} {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 { 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}}} @@ -1993,7 +1994,6 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m # response. interp eval $idb [list set chan $chan] - interp eval $idb [list set mid $tcltest::mainThread] set res [interp eval $idb { # wait a bit, give the main thread the time to start its event # loop to wait for the response from B @@ -2030,23 +2030,6 @@ test iocmd-32.2 {delete interp of reflected chan} { ## forwarding, and gaps due to tests not applicable to forwarding are ## left to keep this asociation. -# Duplicate of code in "thread.test". Find a better way of doing this -# without duplication. Maybe placement into a proc which transforms to -# nop after the first call, and placement of its defintion in a -# central location. - -if {[testConstraint testthread]} { - testthread errorproc ThreadError - - proc ThreadError {id info} { - global threadError - set threadError $info - } - proc ThreadNullError {id info} { - # ignore - } -} - # ### ### ### ######### ######### ######### ## Helper command. Runs a script in a separate thread and returns the ## result. A channel is transfered into the thread as well, and list of @@ -2055,7 +2038,8 @@ if {[testConstraint testthread]} { proc inthread {chan script args} { # Test thread. - set tid [testthread create] + set tid [thread::create -preserved] + thread::send $tid {load {} Tcltest} # Init thread configuration. # - Listed variables @@ -2064,22 +2048,23 @@ proc inthread {chan script args} { foreach v $args { upvar 1 $v x - testthread send $tid [list set $v $x] + thread::send $tid [list set $v $x] + } - testthread send $tid [list set mid $tcltest::mainThread] - testthread send $tid { + thread::send $tid [list set mid [thread::id]] + thread::send $tid { proc note {item} {global notes; lappend notes $item} proc notes {} {global notes; return $notes} proc noteOpts opts {global notes; lappend notes [dict merge { -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! } $opts]} } - testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*) + thread::send $tid [list proc s {} [list uplevel 1 $script]]; # (*) # Transfer channel (cut/splice aka detach/attach) testchannel cut $chan - testthread send $tid [list testchannel splice $chan] + thread::send $tid [list testchannel splice $chan] # Run test script, also run local event loop! # The local event loop waits for the result to come back. @@ -2087,15 +2072,15 @@ proc inthread {chan script args} { # operations. set ::tres "" - testthread send -async $tid { + thread::send -async $tid { after 500 catch {s} res; # This runs the script, 's' was defined at (*) - testthread send -async $mid [list set ::tres $res] + thread::send -async $mid [list set ::tres $res] } vwait ::tres # Remove test thread, and return the captured result. - tcltest::threadReap + thread::release $tid return $::tres } @@ -2116,7 +2101,7 @@ test iocmd.tf-22.2 {chan finalize, for close} -match glob -body { note [info command foo] rename foo {} set res -} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} +} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -code error 5} @@ -2129,7 +2114,7 @@ test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -b } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} +} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -body { set res {} proc foo {args} {track; oninit; error FOO} @@ -2140,7 +2125,7 @@ test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob - } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} +} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -body { set res {} proc foo {args} {track; oninit; return SOMETHING} @@ -2151,7 +2136,7 @@ test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -bod } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} +} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -code 3} @@ -2163,7 +2148,7 @@ test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -b rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -code 4} @@ -2175,7 +2160,7 @@ test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -code 777 BANG} @@ -2187,7 +2172,7 @@ test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match g rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match glob -body { set res {} proc foo {args} {track; oninit; return -level 5 -code 777 BANG} @@ -2199,7 +2184,7 @@ test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match rename foo {} set res } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method read @@ -2218,7 +2203,7 @@ test iocmd.tf-23.1 {chan read, regular data return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} +} -constraints {testchannel thread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body { set res {} proc foo {args} { @@ -2233,7 +2218,7 @@ test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{read rc* 4096} 1 {read delivered more than requested}} +} -constraints {testchannel thread} -result {{read rc* 4096} 1 {read delivered more than requested}} test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body { set res {} proc foo {args} { @@ -2247,7 +2232,7 @@ test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for reading}} +} -constraints {testchannel thread} -result {1 {channel "rc*" wasn't opened for reading}} test iocmd.tf-23.4 {chan read, error return} -match glob -body { set res {} proc foo {args} { @@ -2263,7 +2248,7 @@ test iocmd.tf-23.4 {chan read, error return} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-23.5 {chan read, break return is error} -match glob -body { set res {} proc foo {args} { @@ -2279,7 +2264,7 @@ test iocmd.tf-23.5 {chan read, break return is error} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -2295,7 +2280,7 @@ test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -2311,7 +2296,7 @@ test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { set res {} proc foo {args} { @@ -2327,7 +2312,7 @@ test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { rename foo {} set res } -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup { set res {} proc foo {args} { @@ -2347,7 +2332,7 @@ test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup { rename foo {} unset res } -result {{read rc* 4096} {} 1} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glob -setup { set res {} proc foo {args} { @@ -2367,7 +2352,7 @@ test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match rename foo {} unset res } -result {{read rc* 4096} {} 0} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method write @@ -2387,7 +2372,7 @@ test iocmd.tf-24.1 {chan write, regular write} -match glob -body { } c rename foo {} set res -} -constraints {testchannel testthread} -result {{write rc* snarf} 5} +} -constraints {testchannel thread} -result {{write rc* snarf} 5} test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body { set res {} proc foo {args} { @@ -2404,7 +2389,7 @@ test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body { } c rename foo {} set res -} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} +} -constraints {testchannel thread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} test iocmd.tf-24.3 {chan write, failed write} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note -1; return -1} @@ -2415,7 +2400,7 @@ test iocmd.tf-24.3 {chan write, failed write} -match glob -body { } c rename foo {} set res -} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} -1} +} -constraints {testchannel thread} -result {{write rc* snarfsnarfsnarf} -1} test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} @@ -2428,7 +2413,7 @@ test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for writing}} +} -constraints {testchannel thread} -result {1 {channel "rc*" wasn't opened for writing}} test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return 10000} @@ -2441,7 +2426,7 @@ test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}} +} -constraints {testchannel thread} -result {{write rc* snarf} 1 {write wrote more than requested}} test iocmd.tf-24.6 {chan write, zero writes} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return 0} @@ -2454,7 +2439,7 @@ test iocmd.tf-24.6 {chan write, zero writes} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}} +} -constraints {testchannel thread} -result {{write rc* snarf} 1 {write wrote more than requested}} test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code error BOOM!} @@ -2468,7 +2453,7 @@ test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body { rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; error BOOM!} @@ -2482,7 +2467,7 @@ test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body { rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code break BOOM!} @@ -2496,7 +2481,7 @@ test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} @@ -2510,7 +2495,7 @@ test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} @@ -2524,7 +2509,7 @@ test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match gl rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return BANG} @@ -2538,7 +2523,7 @@ test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -mat rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} @@ -2553,7 +2538,7 @@ test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -bo rename foo {} set res } -result {{write rc* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this time, bug 2936225} -match glob -setup { set res {} proc foo {args} { @@ -2572,7 +2557,7 @@ test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this rename foo {} unset res } -result {{write rc* ABC} {}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at this time, bug 2936225} -match glob -setup { set res {} proc foo {args} { @@ -2592,10 +2577,161 @@ test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at thi } c] set res } -cleanup { + proc foo {args} {onfinal; set ::done-24.15 1; return 3} + after 1000 {set ::done-24.15 2} + vwait done-24.15 rename foo {} unset res } -result {{write rc* ABC} {watch rc* write} {}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} + +test iocmd.tf-24.16 {chan write, note the background flush setup by close due to the EAGAIN leaving data in buffers.} -match glob -setup { + set res {} + proc foo {args} { + oninit; onfinal; track + # Note: The EAGAIN signals that the channel cannot accept + # write requests right now, this in turn causes the IO core to + # request the generation of writable events (see expected + # result below, and compare to case 24.14 above). + error EAGAIN + } + set c [chan create {r w} foo] +} -body { + notes [inthread $c { + note [puts -nonewline $c ABC ; flush $c] + close $c + notes + } c] + # Replace handler with all-tracking one which doesn't error. + # This will tell us if a write-due-flush is there. + proc foo {args} { onfinal; note BG ; track ; set ::endbody-24.16 1} + # Flush (sic!) the event-queue to capture the write from a + # BG-flush. + after 1000 {set ::endbody-24.16 2} + vwait endbody-24.16 + set res +} -cleanup { + proc foo {args} {onfinal; set ::done-24.16 1; return 3} + after 1000 {set ::done-24.16 2} + vwait done-24.16 + rename foo {} + unset res +} -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC}} \ + -constraints {testchannel thread} + +test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ + -constraints {testchannel thread} -setup { + # This test exposes how the execution of postevent in the handler thread causes + # a crash if we are not properly injecting the events into the owning thread instead. + # With the injection the test will simply complete without crash. + + set beat 10000 + set drive 999 + set data ...---... + + proc LOG {text} { + #puts stderr "[thread::id]: $text" + return + } + + proc POST {hi} { + LOG "-> [info level 0]" + chan postevent $hi read + LOG "<- [info level 0]" + + set ::timer [after $::drive [info level 0]] + return + } + + proc HANDLER {op ch args} { + lappend ::res [lrange [info level 0] 1 end] + LOG "-> [info level 0]" + set ret {} + switch -glob -- $op { + init* {set ret {initialize finalize watch read}} + watch { + set l [lindex $args 0] + if {[llength $l]} { + set ::timer [after $::drive [list POST $ch]] + } else { + after cancel $::timer + } + } + finalize { + catch { after cancel $::timer } + after 500 {set ::forever now} + } + read { + set ret $::data + set ::data {} ; # Next is EOF. + } + } + LOG "<- [info level 0] : $ret" + return $ret + } +} -body { + LOG BEGIN + set ch [chan create {read} HANDLER] + + set tid [thread::create { + proc LOG {text} { + #puts stderr "\t\t\t\t\t\t[thread::id]: $text" + return + } + LOG THREAD-STARTED + load {} Tcltest + proc bgerror s { + LOG BGERROR:$s + } + vwait forever + LOG THREAD-DONE + }] + + testchannel cut $ch + thread::send $tid [list set thech $ch] + thread::send $tid [list set beat $beat] + thread::send -async $tid { + LOG SPLICE-BEG + testchannel splice $thech + LOG SPLICE-END + proc PROCESS {ch} { + LOG "-> [info level 0]" + if {[eof $ch]} { + close $ch + set ::done 1 + set c <<EOF>> + } else { + set c [read $ch 1] + } + LOG "GOTCHAR: $c" + LOG "<- [info level 0]" + } + LOG THREAD-FILEEVENT + fconfigure $thech -translation binary -blocking 0 + fileevent $thech readable [list PROCESS $thech] + LOG THREAD-NOEVENT-LOOP + set done 0 + while {!$done} { + after $beat + LOG THREAD-HEARTBEAT + update + } + LOG THREAD-LOOP-DONE + thread::exit + } + + LOG MAIN_WAITING + vwait forever + LOG MAIN_DONE + + set res +} -cleanup { + rename LOG {} + rename POST {} + rename HANDLER {} + unset beat drive data forever res tid ch +} -match glob \ + -result {{initialize rc* read} {watch rc* read} {read rc* 4096} {watch rc* {}} {watch rc* read} {read rc* 4096} {watch rc* {}} {finalize rc*}} # --- === *** ########################### # method cgetall @@ -2611,7 +2747,7 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body } c] rename foo {} set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} @@ -2624,7 +2760,7 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} @@ -2640,7 +2776,7 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} @@ -2657,7 +2793,7 @@ test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} +} -constraints {testchannel thread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body { set res {} proc foo {args} { @@ -2673,7 +2809,7 @@ test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {unmatched open brace in list}} +} -constraints {testchannel thread} -result {{cgetall rc*} 1 {unmatched open brace in list}} test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body { set res {} proc foo {args} { @@ -2689,7 +2825,7 @@ test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{cgetall rc*} 1 BOOM!} +} -constraints {testchannel thread} -result {{cgetall rc*} 1 BOOM!} test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob -body { set res {} proc foo {args} { @@ -2706,7 +2842,7 @@ test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob rename foo {} set res } -result {{cgetall rc*} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -2723,7 +2859,7 @@ test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match gl rename foo {} set res } -result {{cgetall rc*} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -2740,7 +2876,7 @@ test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob rename foo {} set res } -result {{cgetall rc*} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -body { set res {} proc foo {args} { @@ -2758,7 +2894,7 @@ test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -bod rename foo {} set res } -result {{cgetall rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cgetall"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method configure @@ -2776,7 +2912,7 @@ test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{}} +} -constraints {testchannel thread} -result {{}} test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body { set res {} proc foo {args} { @@ -2792,7 +2928,7 @@ test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} 1 BOOM!} +} -constraints {testchannel thread} -result {{configure rc* -rc-foo bar} 1 BOOM!} test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body { set res {} proc foo {args} {oninit configure; onfinal; track; return} @@ -2804,7 +2940,7 @@ test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} {}} +} -constraints {testchannel thread} -result {{configure rc* -rc-foo bar} {}} test iocmd.tf-26.4 {chan configure, set option, break return is error} -match glob -body { set res {} proc foo {args} { @@ -2821,7 +2957,7 @@ test iocmd.tf-26.4 {chan configure, set option, break return is error} -match gl rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -2838,7 +2974,7 @@ test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -2855,7 +2991,7 @@ test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match g rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -body { set res {} proc foo {args} { @@ -2873,7 +3009,7 @@ test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -b rename foo {} set res } -result {{configure rc* -rc-foo bar} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "configure"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method cget @@ -2889,7 +3025,7 @@ test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} foo} +} -constraints {testchannel thread} -result {{cget rc* -rc-foo} foo} test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body { set res {} proc foo {args} { @@ -2905,7 +3041,7 @@ test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} 1 BOOM!} +} -constraints {testchannel thread} -result {{cget rc* -rc-foo} 1 BOOM!} test iocmd.tf-27.3 {chan configure, get option, break return is error} -match glob -body { set res {} proc foo {args} { @@ -2922,7 +3058,7 @@ test iocmd.tf-27.3 {chan configure, get option, break return is error} -match gl rename foo {} set res } -result {{cget rc* -rc-foo} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -2939,7 +3075,7 @@ test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match rename foo {} set res } -result {{cget rc* -rc-foo} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -2956,7 +3092,7 @@ test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match g rename foo {} set res } -result {{cget rc* -rc-foo} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -body { set res {} proc foo {args} { @@ -2974,7 +3110,7 @@ test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -b rename foo {} set res } -result {{cget rc* -rc-foo} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cget"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method seek @@ -2991,7 +3127,7 @@ test iocmd.tf-28.1 {chan tell, not supported by handler} -match glob -body { rename foo {} set res } -result {-1} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.2 {chan tell, error return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!} @@ -3005,7 +3141,7 @@ test iocmd.tf-28.2 {chan tell, error return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!} @@ -3019,7 +3155,7 @@ test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!} @@ -3033,7 +3169,7 @@ test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code 222 BOOM!} @@ -3047,7 +3183,7 @@ test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -level 11 -code 222 BANG} @@ -3062,7 +3198,7 @@ test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.7 {chan tell, regular return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return 88} @@ -3075,7 +3211,7 @@ test iocmd.tf-28.7 {chan tell, regular return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 88} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.8 {chan tell, negative return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -1} @@ -3089,7 +3225,7 @@ test iocmd.tf-28.8 {chan tell, negative return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 {Tried to seek before origin}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.9 {chan tell, string return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return BOGUS} @@ -3103,7 +3239,7 @@ test iocmd.tf-28.9 {chan tell, string return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} @@ -3117,7 +3253,7 @@ test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body { rename foo {} set res } -result {1 {error during seek on "rc*": invalid argument}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.11 {chan seek, error return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!} @@ -3131,7 +3267,7 @@ test iocmd.tf-28.11 {chan seek, error return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!} @@ -3145,7 +3281,7 @@ test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!} @@ -3159,7 +3295,7 @@ test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -code 99 BOOM!} @@ -3173,7 +3309,7 @@ test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -level 33 -code 99 BANG} @@ -3188,7 +3324,7 @@ test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return -45} @@ -3202,7 +3338,7 @@ test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -bo rename foo {} set res } -result {{seek rc* 0 start} 1 {Tried to seek before origin}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return BOGUS} @@ -3216,7 +3352,7 @@ test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body { rename foo {} set res } -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-28.18 {chan seek, ok result} -match glob -body { set res {} proc foo {args} {oninit seek; onfinal; track; return 23} @@ -3229,7 +3365,7 @@ test iocmd.tf-28.18 {chan seek, ok result} -match glob -body { rename foo {} set res } -result {{seek rc* 0 current} {}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} foreach {testname code} { iocmd.tf-28.19.0 start iocmd.tf-28.19.1 current @@ -3247,7 +3383,7 @@ foreach {testname code} { rename foo {} set res } -result [list [list seek rc* 0 $code] {}] \ - -constraints {testchannel testthread} + -constraints {testchannel thread} } # --- === *** ########################### @@ -3265,7 +3401,7 @@ test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body { rename foo {} set res } -result {1} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} @@ -3279,7 +3415,7 @@ test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body { rename foo {} set res } -result {{} 0} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; note MUST_NOT_HAPPEN; return} @@ -3292,7 +3428,7 @@ test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body rename foo {} set res } -result {1} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return} @@ -3306,7 +3442,7 @@ test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body rename foo {} set res } -result {{blocking rc* 0} {} 0} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return} @@ -3320,7 +3456,7 @@ test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body { rename foo {} set res } -result {{blocking rc* 1} {} 1} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.6 {chan blocking, error return} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; error BOOM!} @@ -3335,7 +3471,7 @@ test iocmd.tf-29.6 {chan blocking, error return} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 BOOM!} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code break BOOM!} @@ -3349,7 +3485,7 @@ test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code continue BOOM!} @@ -3363,7 +3499,7 @@ test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code 44 BOOM!} @@ -3377,7 +3513,7 @@ test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code*} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -level 99 -code 44 BANG} @@ -3392,7 +3528,7 @@ test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { rename foo {} set res } -result {{blocking rc* 0} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "blocking"*}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return BOGUS} @@ -3406,7 +3542,7 @@ test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glo rename foo {} set res } -result {{blocking rc* 0} 0 {}} \ - -constraints {testchannel testthread} + -constraints {testchannel thread} # --- === *** ########################### # method watch @@ -3422,7 +3558,7 @@ test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{watch rc* read} {watch rc* {}} {}} +} -constraints {testchannel thread} -result {{watch rc* read} {watch rc* {}} {}} test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code error BOOM!_IGNORED} @@ -3435,7 +3571,7 @@ test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body } c] rename foo {} set res -} -constraints {testchannel testthread} -result {{watch rc* write} {watch rc* {}} {} {}} +} -constraints {testchannel thread} -result {{watch rc* write} {watch rc* {}} {} {}} test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} @@ -3450,7 +3586,7 @@ test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {{watch rc* write} {watch rc* {read write}} {watch rc* read} {watch rc* {}} {} {} {} {}} test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -body { set res {} @@ -3465,7 +3601,7 @@ test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -b } c] rename foo {} set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {{watch rc* write} {watch rc* {read write}} {watch rc* write} {watch rc* {}} {} {} {}} # --- === *** ########################### @@ -3485,7 +3621,7 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {{can not find reflected channel named "rc*"}} # --- === *** ########################### @@ -3496,12 +3632,15 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body { test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { #puts <<$tcltest::mainThread>>main - set tida [testthread create];#puts <<$tida>> - set tidb [testthread create];#puts <<$tidb>> + set tida [thread::create -preserved];#puts <<$tida>> + thread::send $tida {load {} Tcltest} + + set tidb [thread::create -preserved];#puts <<$tidb>> + thread::send $tidb {load {} Tcltest} # Set up channel in thread - testthread send $tida $helperscript - set chan [testthread send $tida { + thread::send $tida $helperscript + set chan [thread::send $tida { proc foo {args} {oninit seek; onfinal; track; return} set chan [chan create {r w} foo] fconfigure $chan -buffering none @@ -3509,67 +3648,82 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { }] # Move channel to 2nd thread. - testthread send $tida [list testchannel cut $chan] - testthread send $tidb [list testchannel splice $chan] + thread::send $tida [list testchannel cut $chan] + thread::send $tidb [list testchannel splice $chan] # Kill origin thread, then access channel from 2nd thread. - testthread send -async $tida {testthread exit} - after 100 + thread::release $tida set res {} - lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg + lappend res [catch {thread::send $tidb [list puts $chan shoo]} msg] $msg - lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg - lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg - lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg - lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg - tcltest::threadReap + lappend res [catch {thread::send $tidb [list tell $chan]} msg] $msg + lappend res [catch {thread::send $tidb [list seek $chan 1]} msg] $msg + lappend res [catch {thread::send $tidb [list gets $chan]} msg] $msg + lappend res [catch {thread::send $tidb [list close $chan]} msg] $msg + thread::release $tidb set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread} \ -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} + +# 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 +# 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). +# +# 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 - set tida [testthread create];#puts <<$tida>> - set tidb [testthread create];#puts <<$tidb>> + set tida [thread::create -preserved];#puts <<$tida>> + thread::send $tida {load {} Tcltest} + set tidb [thread::create -preserved];#puts <<$tidb>> + thread::send $tidb {load {} Tcltest} # Set up channel in thread - set chan [testthread send $tida $helperscript] - set chan [testthread send $tida { + thread::send $tida $helperscript + set chan [thread::send $tida { proc foo {args} { oninit; onfinal; track; # destroy thread during channel access - testthread exit - return} + thread::exit + } set chan [chan create {r w} foo] fconfigure $chan -buffering none set chan }] # Move channel to 2nd thread. - testthread send $tida [list testchannel cut $chan] - testthread send $tidb [list testchannel splice $chan] + thread::send $tida [list testchannel cut $chan] + thread::send $tidb [list testchannel splice $chan] # Run access from thread B, wait for response from A (A is not # using event loop at this point, so the event pile up in the # queue. - testthread send $tidb [list set chan $chan] - testthread send $tidb [list set mid $tcltest::mainThread] - testthread send -async $tidb { + thread::send $tidb [list set chan $chan] + thread::send $tidb [list set mid [thread::id]] + thread::send -async $tidb { # wait a bit, give the main thread the time to start its event # loop to wait for the response from B after 2000 catch { puts $chan shoo } res - testthread send -async $mid [list set ::res $res] + thread::send -async $mid [list set ::res $res] } vwait ::res - tcltest::threadReap + catch {thread::release $tida} + thread::release $tidb set res -} -constraints {testchannel testthread} \ +} -constraints {testchannel thread notValgrind} \ -result {Owner lost} # ### ### ### ######### ######### ######### diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 8932874..5a8874c 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -10,29 +10,30 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: ioTrans.test,v 1.9 2010/08/04 16:49:02 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Custom constraints used in this file -testConstraint testchannel [llength [info commands testchannel]] -testConstraint testthread [llength [info commands testthread]] +testConstraint testchannel [llength [info commands testchannel]] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # testchannel cut|splice Both needed to test the reflection in threads. -# testthread send +# thread::send #---------------------------------------------------------------------- # ### ### ### ######### ######### ######### ## Testing the reflected transformation. -# Helper commands to record the arguments to handler methods. Stored -# in a script so that the tests needing this code do not need their -# own copy but can access this variable. +# Helper commands to record the arguments to handler methods. Stored in a +# script so that the tests needing this code do not need their own copy but +# can access this variable. set helperscript { if {[lsearch [namespace children] ::tcltest] == -1} { @@ -40,69 +41,61 @@ set helperscript { namespace import -force ::tcltest::* } - proc note {item} {global res; lappend res $item; return} - #proc note {item} {global res; lappend res $item; puts $item ; flush stdout ; return} - proc track {} {upvar args item; note $item; return} - proc notes {items} {foreach i $items {note $i}} - - # Use to prevent *'s in pattern to match beyond the expected end - # of the recording. - proc endnote {} {note |} - - # This forces the return options to be in the order that the test - # expects! - proc noteOpts opts {global res; lappend res [dict merge { + # This forces the return options to be in the order that the test expects! + variable optorder { -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! - } $opts]; return} + -errorstack !?! + } + proc noteOpts opts { + variable optorder + lappend ::res [dict merge $optorder $opts] + } # Helper command, canned result for 'initialize' method. Gets the - # optional methods as arguments. Use return features to post the - # result higher up. + # optional methods as arguments. Use return features to post the result + # higher up. - proc init {args} { - lappend args initialize finalize read write - return -code return $args - } - proc oninit {args} { + proc handle.initialize {args} { upvar args hargs - if {[lindex $hargs 0] ne "initialize"} {return} - lappend args initialize finalize read write - return -code return $args + if {[lindex $hargs 0] eq "initialize"} { + return -code return [list {*}$args initialize finalize read write] + } } - proc onfinal {} { + proc handle.finalize {} { upvar args hargs - if {[lindex $hargs 0] ne "finalize"} {return} - return -code return "" + if {[lindex $hargs 0] eq "finalize"} { + return -code return "" + } } - proc onread {} { + proc handle.read {} { upvar args hargs - if {[lindex $hargs 0] ne "read"} {return} - return -code return "@" + if {[lindex $hargs 0] eq "read"} { + return -code return "@" + } } - proc ondrain {} { + proc handle.drain {} { upvar args hargs - if {[lindex $hargs 0] ne "drain"} {return} - return -code return "<>" + if {[lindex $hargs 0] eq "drain"} { + return -code return "<>" + } } - proc onclear {} { + proc handle.clear {} { upvar args hargs - if {[lindex $hargs 0] ne "clear"} {return} - return -code return "" + if {[lindex $hargs 0] eq "clear"} { + return -code return "" + } } proc tempchan {{mode r+}} { - global tempchan - set tempchan [open [makeFile {test data} tempchanfile] $mode] - return $tempchan + global tempchan + return [set tempchan [open [makeFile {test data} tempchanfile] $mode]] } - proc tempdone {} { global tempchan catch {close $tempchan} removeFile tempchanfile return } - proc tempview {} { viewFile tempchanfile } } @@ -110,379 +103,456 @@ set helperscript { eval $helperscript #puts <<[file channels]>> - + # ### ### ### ######### ######### ######### -test iortrans-1.0 {chan, wrong#args} { - catch {chan} msg - set msg -} {wrong # args: should be "chan subcommand ?arg ...?"} -test iortrans-1.1 {chan, unknown method} -body { +test iortrans-1.0 {chan, wrong#args} -returnCodes error -body { + chan +} -result {wrong # args: should be "chan subcommand ?arg ...?"} +test iortrans-1.1 {chan, unknown method} -returnCodes error -body { chan foo -} -returnCodes error -match glob -result {unknown or ambiguous subcommand "foo": must be*} +} -match glob -result {unknown or ambiguous subcommand "foo": must be*} # --- --- --- --------- --------- --------- # chan push, and method "initalize" -test iortrans-2.0 {chan push, wrong#args, not enough} { - catch {chan push} msg - set msg -} {wrong # args: should be "chan push channel cmdprefix"} -test iortrans-2.1 {chan push, wrong#args, too many} { - catch {chan push a b c} msg - set msg -} {wrong # args: should be "chan push channel cmdprefix"} -test iortrans-2.2 {chan push, invalid channel} { +test iortrans-2.0 {chan push, wrong#args, not enough} -returnCodes error -body { + chan push +} -result {wrong # args: should be "chan push channel cmdprefix"} +test iortrans-2.1 {chan push, wrong#args, too many} -returnCodes error -body { + chan push a b c +} -result {wrong # args: should be "chan push channel cmdprefix"} +test iortrans-2.2 {chan push, invalid channel} -setup { proc foo {} {} - catch {chan push {} foo} msg +} -returnCodes error -body { + chan push {} foo +} -cleanup { rename foo {} - set msg -} {can not find channel named ""} -test iortrans-2.3 {chan push, bad handler, not a list} { - catch {chan push [tempchan] "foo \{"} msg +} -result {can not find channel named ""} +test iortrans-2.3 {chan push, bad handler, not a list} -body { + chan push [tempchan] "foo \{" +} -returnCodes error -cleanup { tempdone - set msg -} {unmatched open brace in list} -test iortrans-2.4 {chan push, bad handler, not a command} { - catch {chan push [tempchan] foo} msg +} -result {unmatched open brace in list} +test iortrans-2.4 {chan push, bad handler, not a command} -body { + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone - set msg -} {invalid command name "foo"} -test iortrans-2.5 {chan push, initialize failed, bad signature} { +} -result {invalid command name "foo"} +test iortrans-2.5 {chan push, initialize failed, bad signature} -body { proc foo {} {} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg -} {wrong # args: should be "foo"} -test iortrans-2.6 {chan push, initialize failed, bad signature} { +} -result {wrong # args: should be "foo"} +test iortrans-2.6 {chan push, initialize failed, bad signature} -body { proc foo {} {} - catch {chan push [tempchan] ::foo} msg + chan push [tempchan] ::foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg -} {wrong # args: should be "::foo"} +} -result {wrong # args: should be "::foo"} test iortrans-2.7 {chan push, initialize failed, bad result, not a list} -body { proc foo {args} {return "\{"} - catch {chan push [tempchan] foo} msg + catch {chan push [tempchan] foo} + return $::errorInfo +} -cleanup { tempdone rename foo {} - set ::errorInfo } -match glob -result {chan handler "foo initialize" returned non-list: *} test iortrans-2.8 {chan push, initialize failed, bad result, not a list} -body { proc foo {args} {return \{\{\}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {chan handler "foo initialize" returned non-list: *} test iortrans-2.9 {chan push, initialize failed, bad result, empty list} -body { proc foo {args} {} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*all required methods*} test iortrans-2.10 {chan push, initialize failed, bad result, bogus method name} -body { proc foo {args} {return 1} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*bad method "1": must be *} test iortrans-2.11 {chan push, initialize failed, bad result, bogus method name} -body { proc foo {args} {return {a b c}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*bad method "c": must be *} test iortrans-2.12 {chan push, initialize failed, bad result, required methods missing} -body { # Required: initialize, and finalize. proc foo {args} {return {initialize}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*all required methods*} test iortrans-2.13 {chan push, initialize failed, bad result, illegal method name} -body { proc foo {args} {return {initialize finalize BOGUS}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*returned bad method "BOGUS": must be clear, drain, finalize, flush, initialize, limit?, read, or write} test iortrans-2.14 {chan push, initialize failed, bad result, mode/handler mismatch} -body { proc foo {args} {return {initialize finalize}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg -} -match glob -result {*makes the channel inacessible} +} -match glob -result {*makes the channel inaccessible} # iortrans-2.15 event/watch methods elimimated, removed these tests. # iortrans-2.16 test iortrans-2.17 {chan push, initialize failed, bad result, drain/read mismatch} -body { proc foo {args} {return {initialize finalize drain write}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*supports "drain" but not "read"} test iortrans-2.18 {chan push, initialize failed, bad result, flush/write mismatch} -body { proc foo {args} {return {initialize finalize flush read}} - catch {chan push [tempchan] foo} msg + chan push [tempchan] foo +} -returnCodes error -cleanup { tempdone rename foo {} - set msg } -match glob -result {*supports "flush" but not "write"} -test iortrans-2.19 {chan push, initialize ok, creates channel} -match glob -body { +test iortrans-2.19 {chan push, initialize ok, creates channel} -setup { + set res {} +} -match glob -body { proc foo {args} { - global res + global res lappend res $args if {[lindex $args 0] ne "initialize"} {return} return {initialize finalize drain flush read write} } - set res {} lappend res [file channel rt*] lappend res [chan push [tempchan] foo] lappend res [close [lindex $res end]] lappend res [file channel rt*] +} -cleanup { tempdone rename foo {} - set res } -result {{} {initialize rt* {read write}} file* {drain rt*} {flush rt*} {finalize rt*} {} {}} -test iortrans-2.20 {chan push, init failure -> no channel, no finalize} -match glob -body { +test iortrans-2.20 {chan push, init failure -> no channel, no finalize} -setup { + set res {} +} -match glob -body { proc foo {args} { - global res + global res lappend res $args - return {} + return } - set res {} lappend res [file channel rt*] - lappend res [catch {chan push [tempchan] foo} msg] - lappend res $msg + lappend res [catch {chan push [tempchan] foo} msg] $msg lappend res [file channel rt*] +} -cleanup { tempdone rename foo {} - set res } -result {{} {initialize rt* {read write}} 1 {*all required methods*} {}} # --- --- --- --------- --------- --------- # method finalize (via close) -# General note: file channels rt* finds the transform channel, however -# the name reported will be that of the underlying base driver, fileXX -# here. This actually allows us to see if the whole channel is gone, -# or only the transformation, but not the base. +# General note: file channels rt* finds the transform channel, however the +# name reported will be that of the underlying base driver, fileXX here. This +# actually allows us to see if the whole channel is gone, or only the +# transformation, but not the base. -test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} -match glob -body { +test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} -setup { set res {} - proc foo {args} {track; oninit; return} - note [set c [chan push [tempchan] foo]] +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return + } + lappend res [set c [chan push [tempchan] foo]] rename foo {} - note [file channels file*] - note [file channels rt*] - note [catch {close $c} msg]; note $msg - note [file channels file*] - note [file channels rt*] - set res + lappend res [file channels file*] + lappend res [file channels rt*] + 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} -match glob -body { +test iortrans-3.2 {chan finalize, for close} -setup { set res {} - proc foo {args} {track; oninit; return {}} - note [set c [chan push [tempchan] foo]] +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return + } + lappend res [set c [chan push [tempchan] foo]] close $c # Close deleted the channel. - note [file channels rt*] + lappend res [file channels rt*] # Channel destruction does not kill handler command! - note [info command foo] + lappend res [info command foo] +} -cleanup { rename foo {} - set res + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} -test iortrans-3.3 {chan finalize, for close, error, close error} -match glob -body { +test iortrans-3.3 {chan finalize, for close, error, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code error 5} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code error 5 + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg] $msg # Channel is gone despite error. - note [file channels rt*] + lappend res [file channels rt*] +} -cleanup { rename foo {} - set res + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} -test iortrans-3.4 {chan finalize, for close, error, close error} -match glob -body { +test iortrans-3.4 {chan finalize, for close, error, close error} -setup { set res {} - proc foo {args} {track; oninit; error FOO} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg; note $::errorInfo +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + error FOO + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg] $msg $::errorInfo +} -cleanup { rename foo {} - set res + 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} -match glob -body { +test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -setup { set res {} - proc foo {args} {track; oninit; return SOMETHING} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return SOMETHING + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg] $msg +} -cleanup { rename foo {} - set res + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} -test iortrans-3.6 {chan finalize, for close, break, close error} -match glob -body { +test iortrans-3.6 {chan finalize, for close, break, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code 3} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code 3 + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg] $msg +} -cleanup { rename foo {} - set res + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} -test iortrans-3.7 {chan finalize, for close, continue, close error} -match glob -body { +test iortrans-3.7 {chan finalize, for close, continue, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code 4} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code 4 + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg] $msg +} -cleanup { rename foo {} - set res + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} -test iortrans-3.8 {chan finalize, for close, custom code, close error} -match glob -body { +test iortrans-3.8 {chan finalize, for close, custom code, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code 777 BANG} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg]; note $msg +} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code 777 BANG + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg] $msg +} -cleanup { rename foo {} - set res + tempdone } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} -test iortrans-3.9 {chan finalize, for close, ignore level, close error} -match glob -setup { +test iortrans-3.9 {chan finalize, for close, ignore level, close error} -setup { set res {} } -body { - proc foo {args} {track; oninit; return -level 5 -code 777 BANG} - note [set c [chan push [tempchan] foo]] - note [catch {close $c} msg opt]; note $msg; noteOpts $opt - return $res -} -cleanup { + proc foo {args} { + lappend ::res $args + handle.initialize + return -level 5 -code 777 BANG + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [catch {close $c} msg opt] $msg + 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"*}} # --- === *** ########################### # method read (via read) -test iortrans-4.1 {chan read, transform call and return} -match glob -body { +test iortrans-4.1 {chan read, transform call and return} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return snarf } set c [chan push [tempchan] foo] - note [read $c 10] + lappend res [read $c 10] +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} snarf} -test iortrans-4.2 {chan read, for non-readable channel} -match glob -body { +test iortrans-4.2 {chan read, for non-readable channel} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track; note MUST_NOT_HAPPEN + handle.initialize + handle.finalize + lappend ::res $args MUST_NOT_HAPPEN } set c [chan push [tempchan w] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {1 {channel "file*" wasn't opened for reading}} -test iortrans-4.3 {chan read, error return} -match glob -body { +test iortrans-4.3 {chan read, error return} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code error BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 BOOM!} -test iortrans-4.4 {chan read, break return is error} -match glob -body { +test iortrans-4.4 {chan read, break return is error} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code break BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 *bad code*} -test iortrans-4.5 {chan read, continue return is error} -match glob -body { +test iortrans-4.5 {chan read, continue return is error} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code continue BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 *bad code*} -test iortrans-4.6 {chan read, custom return is error} -match glob -body { +test iortrans-4.6 {chan read, custom return is error} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code 777 BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg]; note $msg + lappend res [catch {read $c 2} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 *bad code*} -test iortrans-4.7 {chan read, level is squashed} -match glob -body { +test iortrans-4.7 {chan read, level is squashed} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -level 55 -code 777 BOOM! } set c [chan push [tempchan] foo] - note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt + lappend res [catch {read $c 2} msg opt] $msg + noteOpts $opt +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} -test iortrans-4.8 {chan read, read, bug 2921116} -match glob -setup { +test iortrans-4.8 {chan read, read, bug 2921116} -setup { set res {} +} -match glob -body { proc foo {fd args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { - note [read $c] - #note [gets $c] - set res + lappend res [read $c] + #lappend res [gets $c] } -cleanup { tempdone rename foo {} } -result {{read rt* {test data }} file*} -test iortrans-4.9 {chan read, gets, bug 2921116} -match glob -setup { +test iortrans-4.9 {chan read, gets, bug 2921116} -setup { set res {} +} -match glob -body { proc foo {fd args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { - note [gets $c] - set res + lappend res [gets $c] } -cleanup { tempdone rename foo {} @@ -492,127 +562,207 @@ test iortrans-4.9 {chan read, gets, bug 2921116} -match glob -setup { # --- === *** ########################### # method write (via puts) -test iortrans-5.1 {chan write, regular write} -match glob -body { +test iortrans-5.1 {chan write, regular write} -setup { set res {} - proc foo {args} { oninit; onfinal; track ; return transformresult } +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return transformresult + } set c [chan push [tempchan] foo] - puts -nonewline $c snarf; flush $c + puts -nonewline $c snarf + flush $c close $c - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarf} transformresult} -test iortrans-5.2 {chan write, no write is ok, no change to file} -match glob -body { +test iortrans-5.2 {chan write, no write is ok, no change to file} -setup { set res {} - proc foo {args} { oninit; onfinal; track ; return {} } +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return + } set c [chan push [tempchan] foo] - puts -nonewline $c snarfsnarfsnarf; flush $c + puts -nonewline $c snarfsnarfsnarf + flush $c close $c - note [tempview];# This has to show the original data, as nothing was written + lappend res [tempview]; # This has to show the original data, as nothing was written +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} {test data}} -test iortrans-5.3 {chan write, failed write} -match glob -body { +test iortrans-5.3 {chan write, failed write} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code error FAIL!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code error FAIL! + } set c [chan push [tempchan] foo] puts -nonewline $c snarfsnarfsnarf - note [catch {flush $c} msg] ; note $msg + lappend res [catch {flush $c} msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 FAIL!} -test iortrans-5.4 {chan write, non-writable channel} -match glob -body { +test iortrans-5.4 {chan write, non-writable channel} -setup { set res {} - proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args MUST_NOT_HAPPEN + return + } set c [chan push [tempchan r] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]; note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { close $c tempdone rename foo {} - set res } -result {1 {channel "file*" wasn't opened for writing}} -test iortrans-5.5 {chan write, failed write, error return} -match glob -body { +test iortrans-5.5 {chan write, failed write, error return} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code error BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code error BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 BOOM!} -test iortrans-5.6 {chan write, failed write, error return} -match glob -body { +test iortrans-5.6 {chan write, failed write, error return} -setup { set res {} - proc foo {args} {oninit; onfinal; track; error BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + error BOOM! + } set c [chan push [tempchan] foo] - notes [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 BOOM!} -test iortrans-5.7 {chan write, failed write, break return is error} -match glob -body { +test iortrans-5.7 {chan write, failed write, break return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code break BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code break BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 *bad code*} -test iortrans-5.8 {chan write, failed write, continue return is error} -match glob -body { +test iortrans-5.8 {chan write, failed write, continue return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code continue BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 *bad code*} -test iortrans-5.9 {chan write, failed write, custom return is error} -match glob -body { +test iortrans-5.9 {chan write, failed write, custom return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code 777 BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg +} -cleanup { tempdone rename foo {} - set res } -result {{write rt* snarfsnarfsnarf} 1 *bad code*} -test iortrans-5.10 {chan write, failed write, level is ignored} -match glob -body { +test iortrans-5.10 {chan write, failed write, level is ignored} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} +} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -level 55 -code 777 BOOM! + } set c [chan push [tempchan] foo] - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt] - note $msg + lappend res [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg opt] $msg noteOpts $opt +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} +} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline * -errorinfo *bad code*subcommand "write"*}} test iortrans-5.11 {chan write, bug 2921116} -match glob -setup { set res {} set level 0 +} -body { proc foo {fd args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args # pop - invokes flush - invokes 'foo write' - infinite recursion - stop it global level - if {$level} { return "" } + if {$level} { + return + } incr level # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { - note [puts -nonewline $c abcdef] - note [flush $c] - set res + lappend res [puts -nonewline $c abcdef] + lappend res [flush $c] } -cleanup { tempdone rename foo {} @@ -621,85 +771,110 @@ test iortrans-5.11 {chan write, bug 2921116} -match glob -setup { # --- === *** ########################### # method limit?, drain (via read) -test iortrans-6.1 {chan read, read limits} -match glob -body { +test iortrans-6.1 {chan read, read limits} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit limit?; onfinal; track ; onread + handle.initialize limit? + handle.finalize + lappend ::res $args + handle.read return 6 } set c [chan push [tempchan] foo] - note [read $c 10] + lappend res [read $c 10] +} -cleanup { tempdone rename foo {} - set res } -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata }} {limit? rt*} @@} -test iortrans-6.2 {chan read, read transform drain on eof} -match glob -body { +test iortrans-6.2 {chan read, read transform drain on eof} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit drain; onfinal; track ; onread ; ondrain + handle.initialize drain + handle.finalize + lappend ::res $args + handle.read + handle.drain return } set c [chan push [tempchan] foo] - note [read $c] - note [close $c] + lappend res [read $c] + lappend res [close $c] +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data }} {drain rt*} @<> {}} # --- === *** ########################### # method clear (via puts, seek) -test iortrans-7.1 {chan write, write clears read buffers} -match glob -body { +test iortrans-7.1 {chan write, write clears read buffers} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit clear; onfinal; track ; onclear + handle.initialize clear + handle.finalize + lappend ::res $args + handle.clear return transformresult } set c [chan push [tempchan] foo] - puts -nonewline $c snarf; flush $c + puts -nonewline $c snarf + flush $c + return $res +} -cleanup { tempdone rename foo {} - set res } -result {{clear rt*} {write rt* snarf}} -test iortrans-7.2 {seek clears read buffers} -match glob -body { +test iortrans-7.2 {seek clears read buffers} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args return } set c [chan push [tempchan] foo] seek $c 2 + return $res +} -cleanup { tempdone rename foo {} - set res } -result {{clear rt*}} -test iortrans-7.3 {clear, any result is ignored} -match glob -body { +test iortrans-7.3 {clear, any result is ignored} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args return -code error "X" } set c [chan push [tempchan] foo] seek $c 2 + return $res +} -cleanup { tempdone rename foo {} - set res } -result {{clear rt*}} test iortrans-7.4 {chan clear, bug 2921116} -match glob -setup { set res {} +} -body { proc foo {fd args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { seek $c 2 - set res + return $res } -cleanup { tempdone rename foo {} @@ -708,47 +883,53 @@ test iortrans-7.4 {chan clear, bug 2921116} -match glob -setup { # --- === *** ########################### # method flush (via seek, close) -test iortrans-8.1 {seek flushes write buffers, ignores data} -match glob -body { +test iortrans-8.1 {seek flushes write buffers, ignores data} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit flush; onfinal; track + handle.initialize flush + handle.finalize + lappend ::res $args return X } set c [chan push [tempchan] foo] # Flush, no writing seek $c 2 # The close flushes again, this modifies the file! - note | ; note [close $c] ; note | - note [tempview] + lappend res | + lappend res [close $c] | [tempview] +} -cleanup { tempdone rename foo {} - set res } -result {{flush rt*} | {flush rt*} {} | {teXt data}} - -test iortrans-8.2 {close flushes write buffers, writes data} -match glob -body { +test iortrans-8.2 {close flushes write buffers, writes data} -setup { set res {} +} -match glob -body { proc foo {args} { - oninit flush; track ; onfinal + handle.initialize flush + lappend ::res $args + handle.finalize return .flushed. } set c [chan push [tempchan] foo] close $c - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res } -result {{flush rt*} {finalize rt*} .flushed.} - test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup { set res {} +} -body { proc foo {fd args} { - oninit flush; onfinal; track + handle.initialize flush + handle.finalize + lappend ::res $args # Kill and recreate transform while it is operating - chan pop $fd + chan pop $fd chan push $fd [list foo $fd] } set c [chan push [set c [tempchan]] [list foo $c]] -} -body { seek $c 2 set res } -cleanup { @@ -763,157 +944,132 @@ test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup { # method event - removed from TIP (rev 1.12+) # --- === *** ########################### -# 'Pull the rug' tests. Create channel in a interpreter A, move to -# other interpreter B, destroy the origin interpreter (A) before or -# during access from B. Must not crash, must return proper errors. - -test iortrans-11.0 {origin interpreter of moved transform gone} -match glob -body { - - set ida [interp create];#puts <<$ida>> - set idb [interp create];#puts <<$idb>> - +# 'Pull the rug' tests. Create channel in a interpreter A, move to other +# interpreter B, destroy the origin interpreter (A) before or during access +# from B. Must not crash, must return proper errors. +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 load {} Tcltest $ida load {} Tcltest $idb - +} -constraints {testchannel} -match glob -body { # Set up channel and transform in interpreter interp eval $ida $helperscript interp eval $ida [list ::variable tempchan [tempchan]] interp transfer {} $::tempchan $ida set chan [interp eval $ida { variable tempchan - proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; return} + proc foo {args} { + handle.initialize clear drain flush limit? read write + handle.finalize + lappend ::res $args + return + } set chan [chan push $tempchan foo] fconfigure $chan -buffering none set chan }] - # Move channel to 2nd interpreter, transform goes with it. - interp eval $ida [list testchannel cut $chan] + interp eval $ida [list testchannel cut $chan] interp eval $idb [list testchannel splice $chan] - # Kill origin interpreter, then access channel from 2nd interpreter. interp delete $ida - - set res {} - lappend res [catch {interp eval $idb [list puts $chan shoo]} msg] $msg - lappend res [catch {interp eval $idb [list tell $chan]} msg] $msg - lappend res [catch {interp eval $idb [list seek $chan 1]} msg] $msg - lappend res [catch {interp eval $idb [list gets $chan]} msg] $msg - lappend res [catch {interp eval $idb [list close $chan]} msg] $msg + set res {} + lappend res \ + [catch {interp eval $idb [list puts $chan shoo]} msg] $msg \ + [catch {interp eval $idb [list tell $chan]} msg] $msg \ + [catch {interp eval $idb [list seek $chan 1]} msg] $msg \ + [catch {interp eval $idb [list gets $chan]} msg] $msg \ + [catch {interp eval $idb [list close $chan]} msg] $msg #lappend res [interp eval $ida {set res}] # actions: clear|write|clear|write|clear|flush|limit?|drain|flush + # The 'tell' is ok, as it passed through the transform to the base channel + # without invoking the transform handler. +} -cleanup { tempdone - set res - # The 'tell' is ok, as it passed through the transform to the base - # channel without invoking the transform handler. -} -constraints {testchannel} \ - -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} -match glob -body { - - set ida [interp create];#puts <<$ida>> - set idb [interp create];#puts <<$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 load {} Tcltest $ida load {} Tcltest $idb - +} -constraints {testchannel impossible} -match glob -body { # Set up channel in thread set chan [interp eval $ida $helperscript] set chan [interp eval $ida { proc foo {args} { - oninit clear drain flush limit? read write; onfinal; track; - # destroy interpreter during channel access - # Actually not possible for an interp to destroy itself. + 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] fconfigure $chan -buffering none set chan }] - # Move channel to 2nd thread, transform goes with it. - interp eval $ida [list testchannel cut $chan] + interp eval $ida [list testchannel cut $chan] interp eval $idb [list testchannel splice $chan] - - # Run access from interpreter B, this will give us a synchronous - # response. - + # Run access from interpreter B, this will give us a synchronous response. interp eval $idb [list set chan $chan] interp eval $idb [list set mid $tcltest::mainThread] set res [interp eval $idb { - # wait a bit, give the main thread the time to start its event - # loop to wait for the response from B - after 2000 + # Wait a bit, give the main thread the time to start its event loop to + # wait for the response from B + after 50 catch { puts $chan shoo } res set res }] +} -cleanup { tempdone - set res -} -constraints {testchannel impossible} \ - -result {Owner lost} - - -test iortrans-11.2 {delete interp of reflected transform} -body { +} -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 - +} -constraints {testchannel} -body { # Get base channel into the slave set c [tempchan] testchannel cut $c interp eval slave [list testchannel splice $c] interp eval slave [list set c $c] - slave eval { - proc no-op args {} - proc driver {c sub args} {return {initialize finalize read write}} + proc no-op args {} + proc driver {c sub args} { + return {initialize finalize read write} + } set t [chan push $c [list driver $c]] - chan event $c readable no-op + chan event $c readable no-op } interp delete slave -} -result {} -constraints {testchannel} - +} -cleanup { + tempdone +} -result {} + # ### ### ### ######### ######### ######### -## Same tests as above, but exercising the code forwarding and -## receiving driver operations to the originator thread. +## Same tests as above, but exercising the code forwarding and receiving +## driver operations to the originator thread. -# -*- tcl -*- # ### ### ### ######### ######### ######### ## Testing the reflected channel (Thread forwarding). # -## The id numbers refer to the original test without thread -## forwarding, and gaps due to tests not applicable to forwarding are -## left to keep this association. - -# Duplicate of code in "thread.test", and "ioCmd.test". Find a better -# way of doing this without duplication. Maybe placement into a proc -# which transforms to nop after the first call, and placement of its -# defintion in a central location. - -if {[testConstraint testthread]} { - testthread errorproc ThreadError - - proc ThreadError {id info} { - global threadError - set threadError $info - } - proc ThreadNullError {id info} { - # ignore - } -} +## The id numbers refer to the original test without thread forwarding, and +## gaps due to tests not applicable to forwarding are left to keep this +## association. # ### ### ### ######### ######### ######### -## Helper command. Runs a script in a separate thread and returns the -## result. A channel is transfered into the thread as well, and a list -## of configuation variables +## Helper command. Runs a script in a separate thread and returns the result. +## A channel is transfered into the thread as well, and a list of configuation +## variables proc inthread {chan script args} { # Test thread. - - set tid [testthread create] + set tid [thread::create -preserved] + thread::send $tid {load {} Tcltest} # Init thread configuration. # - Listed variables @@ -922,491 +1078,619 @@ proc inthread {chan script args} { foreach v $args { upvar 1 $v x - testthread send $tid [list set $v $x] + thread::send $tid [list set $v $x] } - testthread send $tid [list set mid $tcltest::mainThread] - testthread send $tid { - proc note {item} {global notes; lappend notes $item} - proc notes {} {global notes; return $notes} - proc noteOpts opts {global notes; lappend notes [dict merge { - -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! - } $opts]} + thread::send $tid [list set mid [thread::id]] + thread::send $tid { + proc notes {} { + return $::notes + } + proc noteOpts opts { + lappend ::notes [dict merge { + -code !?! -level !?! -errorcode !?! -errorline !?! + -errorinfo !?! -errorstack !?! + } $opts] + } } - testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*) + thread::send $tid [list proc s {} [list uplevel 1 $script]]; # (*) # Transfer channel (cut/splice aka detach/attach) testchannel cut $chan - testthread send $tid [list testchannel splice $chan] + thread::send $tid [list testchannel splice $chan] - # Run test script, also run local event loop! - # The local event loop waits for the result to come back. - # It is also necessary for the execution of forwarded channel - # operations. + # Run test script, also run local event loop! The local event loop waits + # for the result to come back. It is also necessary for the execution of + # forwarded channel operations. set ::tres "" - testthread send -async $tid { - after 500 - catch {s} res; # This runs the script, 's' was defined at (*) - testthread send -async $mid [list set ::tres $res] + 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] } vwait ::tres # Remove test thread, and return the captured result. - tcltest::threadReap + thread::release $tid return $::tres } # ### ### ### ######### ######### ######### -# ### ### ### ######### ######### ######### - -test iortrans.tf-3.2 {chan finalize, for close} -match glob -body { +test iortrans.tf-3.2 {chan finalize, for close} -setup { set res {} - proc foo {args} {track; oninit; return {}} - note [set c [chan push [tempchan] foo]] - note [inthread $c { +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return {} + } + lappend res [set c [chan push [tempchan] foo]] + lappend res [inthread $c { close $c # Close the deleted the channel. file channels rt* } c] # Channel destruction does not kill handler command! - note [info command foo] + lappend res [info command foo] +} -cleanup { rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} -test iortrans.tf-3.3 {chan finalize, for close, error, close error} -match glob -body { - set res {} - proc foo {args} {track; oninit; return -code error 5} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} +test iortrans.tf-3.3 {chan finalize, for close, error, close error} -setup { + set res {} +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code error 5 + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg] $msg # Channel is gone despite error. - note [file channels rt*] + lappend notes [file channels rt*] notes } c] +} -cleanup { rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} -test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -match glob -body { - set res {} - proc foo {args} {track; oninit; error FOO} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} +test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -setup { + set res {} +} -constraints {testchannel thread} -body { + proc foo {args} { + lappend ::res $args + handle.initialize + error FOO + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg] $msg notes } c] +} -match glob -cleanup { rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO} -test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -match glob -body { - set res {} - proc foo {args} {track; oninit; return SOMETHING} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO} +test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -setup { + set res {} +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return SOMETHING + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg] $msg notes } c] +} -cleanup { rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} -test iortrans.tf-3.6 {chan finalize, for close, break, close error} -match glob -body { - set res {} - proc foo {args} {track; oninit; return -code 3} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} +test iortrans.tf-3.6 {chan finalize, for close, break, close error} -setup { + set res {} +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code 3 + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg] $msg notes } c] +} -cleanup { rename foo {} - set res -} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \ - -constraints {testchannel testthread} - - -test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -match glob -body { +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} +test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -setup { set res {} - proc foo {args} {track; oninit; return -code 4} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code 4 + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg] $msg notes } c] +} -cleanup { rename foo {} - set res -} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-3.8 {chan finalize, for close, custom code, close error} -match glob -body { - set res {} - proc foo {args} {track; oninit; return -code 777 BANG} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg]; note $msg +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} +test iortrans.tf-3.8 {chan finalize, for close, custom code, close error} -setup { + set res {} +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -code 777 BANG + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg] $msg notes } c] +} -cleanup { rename foo {} - set res -} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-3.9 {chan finalize, for close, ignore level, close error} -match glob -body { - set res {} - proc foo {args} {track; oninit; return -level 5 -code 777 BANG} - note [set c [chan push [tempchan] foo]] - notes [inthread $c { - note [catch {close $c} msg opt]; note $msg; noteOpts $opt +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} +test iortrans.tf-3.9 {chan finalize, for close, ignore level, close error} -setup { + set res {} +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + lappend ::res $args + handle.initialize + return -level 5 -code 777 BANG + } + lappend res [set c [chan push [tempchan] foo]] + lappend res {*}[inthread $c { + lappend notes [catch {close $c} msg opt] $msg + noteOpts $opt notes } c] +} -cleanup { rename foo {} - set res -} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \ - -constraints {testchannel testthread} +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} # --- === *** ########################### # method read -test iortrans.tf-4.1 {chan read, transform call and return} -match glob -body { +test iortrans.tf-4.1 {chan read, transform call and return} -setup { set res {} +} -constraints {testchannel thread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return snarf } set c [chan push [tempchan] foo] - notes [inthread $c { - note [read $c 10] + lappend res {*}[inthread $c { + lappend notes [read $c 10] close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} -result {{read rt* {test data +} -match glob -result {{read rt* {test data }} snarf} - -test iortrans.tf-4.2 {chan read, for non-readable channel} -match glob -body { +test iortrans.tf-4.2 {chan read, for non-readable channel} -setup { set res {} +} -constraints {testchannel thread} -body { proc foo {args} { - oninit; onfinal; track; note MUST_NOT_HAPPEN + handle.initialize + handle.finalize + lappend ::res $args MUST_NOT_HAPPEN } set c [chan push [tempchan w] foo] - notes [inthread $c { - note [catch {[read $c 2]} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {[read $c 2]} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} -result {1 {channel "file*" wasn't opened for reading}} -test iortrans.tf-4.3 {chan read, error return} -match glob -body { +} -match glob -result {1 {channel "file*" wasn't opened for reading}} +test iortrans.tf-4.3 {chan read, error return} -setup { set res {} +} -constraints {testchannel thread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code error BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 BOOM!} \ - -constraints {testchannel testthread} -test iortrans.tf-4.4 {chan read, break return is error} -match glob -body { +} -match glob -result {{read rt* {test data +}} 1 BOOM!} +test iortrans.tf-4.4 {chan read, break return is error} -setup { set res {} +} -constraints {testchannel thread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code break BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-4.5 {chan read, continue return is error} -match glob -body { +} -match glob -result {{read rt* {test data +}} 1 *bad code*} +test iortrans.tf-4.5 {chan read, continue return is error} -setup { set res {} +} -constraints {testchannel thread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code continue BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-4.6 {chan read, custom return is error} -match glob -body { +} -match glob -result {{read rt* {test data +}} 1 *bad code*} +test iortrans.tf-4.6 {chan read, custom return is error} -setup { set res {} +} -constraints {testchannel thread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -code 777 BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg]; note $msg + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 *bad code*} \ - -constraints {testchannel testthread} - -test iortrans.tf-4.7 {chan read, level is squashed} -match glob -body { +} -match glob -result {{read rt* {test data +}} 1 *bad code*} +test iortrans.tf-4.7 {chan read, level is squashed} -setup { set res {} +} -constraints {testchannel thread} -body { proc foo {args} { - oninit; onfinal; track + handle.initialize + handle.finalize + lappend ::res $args return -level 55 -code 777 BOOM! } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt + lappend res {*}[inthread $c { + lappend notes [catch {read $c 2} msg opt] $msg + noteOpts $opt close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{read rt* {test data -}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \ - -constraints {testchannel testthread} +} -match glob -result {{read rt* {test data +}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} # --- === *** ########################### # method write -test iortrans.tf-5.1 {chan write, regular write} -match glob -body { +test iortrans.tf-5.1 {chan write, regular write} -setup { set res {} - proc foo {args} { oninit; onfinal; track ; return transformresult } +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return transformresult + } set c [chan push [tempchan] foo] inthread $c { - puts -nonewline $c snarf; flush $c + puts -nonewline $c snarf + flush $c close $c } c - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} -result {{write rt* snarf} transformresult} -test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -match glob -body { +} -result {{write rt* snarf} transformresult} +test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -setup { set res {} - proc foo {args} { oninit; onfinal; track ; return {} } +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return + } set c [chan push [tempchan] foo] inthread $c { - puts -nonewline $c snarfsnarfsnarf; flush $c + puts -nonewline $c snarfsnarfsnarf + flush $c close $c } c - note [tempview];# This has to show the original data, as nothing was written + lappend res [tempview]; # This has to show the original data, as nothing was written +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{write rt* snarfsnarfsnarf} {test data}} -test iortrans.tf-5.3 {chan write, failed write} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} {test data}} +test iortrans.tf-5.3 {chan write, failed write} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code error FAIL!} +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code error FAIL! + } set c [chan push [tempchan] foo] - notes [inthread $c { + lappend res {*}[inthread $c { puts -nonewline $c snarfsnarfsnarf - note [catch {flush $c} msg] - note $msg + lappend notes [catch {flush $c} msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {{write rt* snarfsnarfsnarf} 1 FAIL!} -test iortrans.tf-5.4 {chan write, non-writable channel} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 FAIL!} +test iortrans.tf-5.4 {chan write, non-writable channel} -setup { set res {} - proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args MUST_NOT_HAPPEN + return + } set c [chan push [tempchan r] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -constraints {testchannel testthread} \ - -result {1 {channel "file*" wasn't opened for writing}} -test iortrans.tf-5.5 {chan write, failed write, error return} -match glob -body { +} -result {1 {channel "file*" wasn't opened for writing}} +test iortrans.tf-5.5 {chan write, failed write, error return} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code error BOOM!} +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code error BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \ - -constraints {testchannel testthread} -test iortrans.tf-5.6 {chan write, failed write, error return} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} +test iortrans.tf-5.6 {chan write, failed write, error return} -setup { set res {} - proc foo {args} {oninit; onfinal; track; error BOOM!} +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + error BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \ - -constraints {testchannel testthread} - - -test iortrans.tf-5.7 {chan write, failed write, break return is error} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} +test iortrans.tf-5.7 {chan write, failed write, break return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code break BOOM!} +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code break BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-5.8 {chan write, failed write, continue return is error} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} +test iortrans.tf-5.8 {chan write, failed write, continue return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code continue BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-5.9 {chan write, failed write, custom return is error} -match glob -body { +} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} +test iortrans.tf-5.9 {chan write, failed write, custom return is error} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} +} -constraints {testchannel thread} -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -code 777 BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg] $msg close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \ - -constraints {testchannel testthread} -test iortrans.tf-5.10 {chan write, failed write, level is ignored} -match glob -body { +} -match glob -result {{write rt* snarfsnarfsnarf} 1 *bad code*} +test iortrans.tf-5.10 {chan write, failed write, level is ignored} -setup { set res {} - proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} +} -constraints {testchannel thread} -match glob -body { + proc foo {args} { + handle.initialize + handle.finalize + lappend ::res $args + return -level 55 -code 777 BOOM! + } set c [chan push [tempchan] foo] - notes [inthread $c { - note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt] - note $msg + lappend res {*}[inthread $c { + lappend notes [catch { + puts -nonewline $c snarfsnarfsnarf + flush $c + } msg opt] $msg noteOpts $opt close $c notes } c] +} -cleanup { tempdone rename foo {} - set res -} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \ - -constraints {testchannel testthread} - +} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline * -errorinfo *bad code*subcommand "write"*}} # --- === *** ########################### # method limit?, drain (via read) -test iortrans.tf-6.1 {chan read, read limits} -match glob -body { +test iortrans.tf-6.1 {chan read, read limits} -setup { set res {} +} -constraints {testchannel thread} -match glob -body { proc foo {args} { - oninit limit?; onfinal; track ; onread + handle.initialize limit? + handle.finalize + lappend ::res $args + handle.read return 6 } set c [chan push [tempchan] foo] - notes [inthread $c { - note [read $c 10] + lappend res {*}[inthread $c { + lappend notes [read $c 10] close $c - set notes + notes } c] +} -cleanup { tempdone rename foo {} - set res } -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata -}} {limit? rt*} @@} -constraints {testchannel testthread} -test iortrans.tf-6.2 {chan read, read transform drain on eof} -match glob -body { +}} {limit? rt*} @@} +test iortrans.tf-6.2 {chan read, read transform drain on eof} -setup { set res {} +} -constraints {testchannel thread} -match glob -body { proc foo {args} { - oninit drain; onfinal; track ; onread ; ondrain + handle.initialize drain + handle.finalize + lappend ::res $args + handle.read + handle.drain return } set c [chan push [tempchan] foo] - notes [inthread $c { - note [read $c] - note [close $c] + lappend res {*}[inthread $c { + lappend notes [read $c] + lappend notes [close $c] } c] +} -cleanup { tempdone rename foo {} - set res } -result {{read rt* {test data -}} {drain rt*} @<> {}} -constraints {testchannel testthread} +}} {drain rt*} @<> {}} # --- === *** ########################### # method clear (via puts, seek) -test iortrans.tf-7.1 {chan write, write clears read buffers} -match glob -body { +test iortrans.tf-7.1 {chan write, write clears read buffers} -setup { set res {} +} -constraints {testchannel thread} -match glob -body { proc foo {args} { - oninit clear; onfinal; track ; onclear + handle.initialize clear + handle.finalize + lappend ::res $args + handle.clear return transformresult } set c [chan push [tempchan] foo] inthread $c { - puts -nonewline $c snarf; flush $c + puts -nonewline $c snarf + flush $c close $c } c + return $res +} -cleanup { tempdone rename foo {} - set res -} -result {{clear rt*} {write rt* snarf}} -constraints {testchannel testthread} -test iortrans.tf-7.2 {seek clears read buffers} -match glob -body { +} -result {{clear rt*} {write rt* snarf}} +test iortrans.tf-7.2 {seek clears read buffers} -setup { set res {} +} -constraints {testchannel thread} -match glob -body { proc foo {args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args return } set c [chan push [tempchan] foo] @@ -1414,14 +1698,18 @@ test iortrans.tf-7.2 {seek clears read buffers} -match glob -body { seek $c 2 close $c } c + return $res +} -cleanup { tempdone rename foo {} - set res -} -result {{clear rt*}} -constraints {testchannel testthread} -test iortrans.tf-7.3 {clear, any result is ignored} -match glob -body { +} -result {{clear rt*}} +test iortrans.tf-7.3 {clear, any result is ignored} -setup { set res {} +} -constraints {testchannel thread} -match glob -body { proc foo {args} { - oninit clear; onfinal; track + handle.initialize clear + handle.finalize + lappend ::res $args return -code error "X" } set c [chan push [tempchan] foo] @@ -1429,56 +1717,60 @@ test iortrans.tf-7.3 {clear, any result is ignored} -match glob -body { seek $c 2 close $c } c + return $res +} -cleanup { tempdone rename foo {} - set res -} -result {{clear rt*}} -constraints {testchannel testthread} +} -result {{clear rt*}} # --- === *** ########################### # method flush (via seek, close) -test iortrans.tf-8.1 {seek flushes write buffers, ignores data} -match glob -body { +test iortrans.tf-8.1 {seek flushes write buffers, ignores data} -setup { set res {} +} -constraints {testchannel thread} -match glob -body { proc foo {args} { - oninit flush; onfinal; track + handle.initialize flush + handle.finalize + lappend ::res $args return X } set c [chan push [tempchan] foo] - notes [inthread $c { + lappend res {*}[inthread $c { # Flush, no writing seek $c 2 # The close flushes again, this modifies the file! - note | ; note [close $c] ; note | - # NOTE: The flush generated by the close is recorded - # immediately, the other note's here are defered until after - # the thread is done. This changes the order of the result a - # bit from the non-threaded case (The first | moves one to the - # right). This is an artifact of the 'inthread' framework, not - # of the transformation itself. + lappend notes | [close $c] | + # NOTE: The flush generated by the close is recorded immediately, the + # other note's here are defered until after the thread is done. This + # changes the order of the result a bit from the non-threaded case + # (The first | moves one to the right). This is an artifact of the + # 'inthread' framework, not of the transformation itself. notes } c] - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res -} -result {{flush rt*} {flush rt*} | {} | {teXt data}} -constraints {testchannel testthread} - -test iortrans.tf-8.2 {close flushes write buffers, writes data} -match glob -body { +} -result {{flush rt*} {flush rt*} | {} | {teXt data}} +test iortrans.tf-8.2 {close flushes write buffers, writes data} -setup { set res {} +} -constraints {testchannel thread} -match glob -body { proc foo {args} { - oninit flush; track ; onfinal + handle.initialize flush + lappend ::res $args + handle.finalize return .flushed. } set c [chan push [tempchan] foo] inthread $c { close $c } c - note [tempview] + lappend res [tempview] +} -cleanup { tempdone rename foo {} - set res -} -result {{flush rt*} {finalize rt*} .flushed.} -constraints {testchannel testthread} - +} -result {{flush rt*} {finalize rt*} .flushed.} # --- === *** ########################### # method watch - removed from TIP (rev 1.12+) @@ -1487,97 +1779,101 @@ test iortrans.tf-8.2 {close flushes write buffers, writes data} -match glob -bod # method event - removed from TIP (rev 1.12+) # --- === *** ########################### -# 'Pull the rug' tests. Create channel in a thread A, move to other -# thread B, destroy the origin thread (A) before or during access from -# B. Must not crash, must return proper errors. - -test iortrans.tf-11.0 {origin thread of moved transform gone} -match glob -body { +# 'Pull the rug' tests. Create channel in a thread A, move to other thread B, +# destroy the origin thread (A) before or during access from B. Must not +# crash, must return proper errors. +test iortrans.tf-11.0 {origin thread of moved transform gone} -setup { #puts <<$tcltest::mainThread>>main - set tida [testthread create];#puts <<$tida>> - set tidb [testthread create];#puts <<$tidb>> - + set tida [thread::create -preserved]; #puts <<$tida>> + thread::send $tida {load {} Tcltest} + set tidb [thread::create -preserved]; #puts <<$tida>> + thread::send $tidb {load {} Tcltest} +} -constraints {testchannel thread} -match glob -body { # Set up channel in thread - testthread send $tida $helperscript - set chan [testthread send $tida { - proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; return} + thread::send $tida $helperscript + thread::send $tidb $helperscript + set chan [thread::send $tida { + proc foo {args} { + handle.initialize clear drain flush limit? read write + handle.finalize + lappend ::res $args + return + } set chan [chan push [tempchan] foo] fconfigure $chan -buffering none set chan }] # Move channel to 2nd thread, transform goes with it. - testthread send $tida [list testchannel cut $chan] - testthread send $tidb [list testchannel splice $chan] + thread::send $tida [list testchannel cut $chan] + thread::send $tidb [list testchannel splice $chan] # Kill origin thread, then access channel from 2nd thread. - testthread send -async $tida {testthread exit} - after 100 + thread::release -wait $tida - set res {} - lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg - lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg - lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg - lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg - lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg - tcltest::threadReap - tempdone - set res + set res {} + lappend res [catch {thread::send $tidb [list puts $chan shoo]} msg] $msg + lappend res [catch {thread::send $tidb [list tell $chan]} msg] $msg + lappend res [catch {thread::send $tidb [list seek $chan 1]} msg] $msg + lappend res [catch {thread::send $tidb [list gets $chan]} msg] $msg + lappend res [catch {thread::send $tidb [list close $chan]} msg] $msg # The 'tell' is ok, as it passed through the transform to the base # channel without invoking the transform handler. +} -cleanup { + thread::send $tidb tempdone + thread::release $tidb +} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} -} -constraints {testchannel testthread} \ - -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} - -test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -match glob -body { +testConstraint notValgrind [expr {![testConstraint valgrind]}] +test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -setup { #puts <<$tcltest::mainThread>>main - set tida [testthread create];#puts <<$tida>> - set tidb [testthread create];#puts <<$tidb>> - + set tida [thread::create -preserved]; #puts <<$tida>> + thread::send $tida {load {} Tcltest} + set tidb [thread::create -preserved]; #puts <<$tidb>> + thread::send $tidb {load {} Tcltest} +} -constraints {testchannel thread notValgrind} -match glob -body { # Set up channel in thread - set chan [testthread send $tida $helperscript] - set chan [testthread send $tida { + thread::send $tida $helperscript + thread::send $tidb $helperscript + set chan [thread::send $tida { proc foo {args} { - oninit clear drain flush limit? read write; onfinal; track; + handle.initialize clear drain flush limit? read write + handle.finalize + lappend ::res $args # destroy thread during channel access - testthread exit - return} + thread::exit + } set chan [chan push [tempchan] foo] fconfigure $chan -buffering none set chan }] # Move channel to 2nd thread, transform goes with it. - testthread send $tida [list testchannel cut $chan] - testthread send $tidb [list testchannel splice $chan] - - # Run access from thread B, wait for response from A (A is not - # using event loop at this point, so the event pile up in the - # queue. - - testthread send $tidb [list set chan $chan] - testthread send $tidb [list set mid $tcltest::mainThread] - testthread send -async $tidb { - # wait a bit, give the main thread the time to start its event - # loop to wait for the response from B - after 2000 + thread::send $tida [list testchannel cut $chan] + thread::send $tidb [list testchannel splice $chan] + + # Run access from thread B, wait for response from A (A is not using event + # loop at this point, so the event pile up in the queue. + thread::send $tidb [list set chan $chan] + thread::send $tidb [list set mid [thread::id]] + thread::send -async $tidb { + # Wait a bit, give the main thread the time to start its event loop to + # wait for the response from B + after 50 catch { puts $chan shoo } res catch { close $chan } - testthread send -async $mid [list set ::res $res] + thread::send -async $mid [list set ::res $res] } vwait ::res - - tcltest::threadReap - tempdone set res -} -constraints {testchannel testthread} \ - -result {Owner lost} - -# ### ### ### ######### ######### ######### - +} -cleanup { + thread::send $tidb tempdone + thread::release $tidb +} -result {Owner lost} + # ### ### ### ######### ######### ######### -rename track {} cleanupTests return diff --git a/tests/iogt.test b/tests/iogt.test index c45d97d..d4c31d2 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -3,19 +3,21 @@ # # This file contains a collection of tests for Giot # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# 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. # All rights reserved. -# -# RCS: @(#) $Id: iogt.test,v 1.16 2006/11/03 11:45:34 dkf Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." return } + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + namespace eval ::tcl::test::iogt { namespace import ::tcltest::* @@ -38,41 +40,38 @@ set path(__echo_srv__.tcl) [makeFile { # delay between blocks # blocksize ... -set port [lindex $argv 0] +set port [lindex $argv 0] set fdelay [lindex $argv 1] set idelay [lindex $argv 2] set bsizes [lrange $argv 3 end] -set c 0 +set c 0 proc newconn {sock rhost rport} { variable fdelay variable c - incr c - variable c$c + incr c + namespace upvar [namespace current] c$c conn #puts stdout "C $sock $rhost $rport / $fdelay" ; flush stdout - upvar 0 c$c conn set conn(after) {} set conn(state) 0 - set conn(size) 0 - set conn(data) "" + set conn(size) 0 + set conn(data) "" set conn(delay) $fdelay - fileevent $sock readable [list echoGet $c $sock] + fileevent $sock readable [list echoGet $c $sock] fconfigure $sock -translation binary -buffering none -blocking 0 } proc echoGet {c sock} { variable fdelay - variable c$c - upvar 0 c$c conn + namespace upvar [namespace current] c$c conn if {[eof $sock]} { # one-shot echo exit } - append conn(data) [read $sock] #puts stdout "G $c $sock $conn(data) <<$conn(data)>>" ; flush stdout @@ -86,8 +85,7 @@ proc echoPut {c sock} { variable idelay variable fdelay variable bsizes - variable c$c - upvar 0 c$c conn + namespace upvar [namespace current] c$c conn if {[string length $conn(data)] == 0} { #puts stdout "C $c $sock" ; flush stdout @@ -98,9 +96,7 @@ proc echoPut {c sock} { return } - set conn(delay) $idelay - set n [lindex $bsizes $conn(size)] #puts stdout "P $c $sock $n >>" ; flush stdout @@ -109,7 +105,6 @@ proc echoPut {c sock} { #parray conn #puts n=<$n> - if {[string length $conn(data)] >= $n} { puts -nonewline $sock [string range $conn(data) 0 $n] set conn(data) [string range $conn(data) [incr n] end] @@ -130,40 +125,33 @@ socket -server newconn -myaddr 127.0.0.1 $port vwait forever } __echo_srv__.tcl] - ######################################################################## proc fevent {fdelay idelay blocks script data} { - # start and initialize an echo server, prepare data - # transmission, then hand over to the test script. - # this has to start real transmission via 'flush'. - # The server is stopped after completion of the test. + # Start and initialize an echo server, prepare data transmission, then + # hand over to the test script. This has to start real transmission via + # 'flush'. The server is stopped after completion of the test. - # fixed port, not so good. lets hope for the best, for now. - set port 4000 + upvar 1 sock sk - exec tclsh __echo_srv__.tcl \ - $port $fdelay $idelay {*}$blocks >@stdout & + # Fixed port, not so good. Lets hope for the best, for now. + set port 4000 + exec tclsh __echo_srv__.tcl $port $fdelay $idelay {*}$blocks >@stdout & after 500 - #puts stdout "> $port" ; flush stdout - - set sk [socket localhost $port] - fconfigure $sk \ - -blocking 0 \ - -buffering full \ - -buffersize [expr {10+[llength $data]}] + #puts stdout "> $port"; flush stdout + set sk [socket localhost $port] + fconfigure $sk -blocking 0 -buffering full \ + -buffersize [expr {10+[llength $data]}] puts -nonewline $sk $data # The channel is prepared to go off. - #puts stdout ">>>>>" ; flush stdout - - uplevel #0 set sock $sk - set res [uplevel #0 $script] + #puts stdout ">>>>>"; flush stdout + set res [uplevel 1 $script] catch {close $sk} return $res } @@ -173,18 +161,15 @@ proc fevent {fdelay idelay blocks script data} { proc id {op data} { switch -- $op { - create/write - - create/read - - delete/write - - delete/read - - clear_read {;#ignore} - flush/write - - flush/read - - write - - read { + create/write - create/read - delete/write - delete/read - clear_read { + #ignore + } + flush/write - flush/read - write - read { return $data } - query/maxRead {return -1} + query/maxRead { + return -1 + } } } @@ -193,43 +178,34 @@ proc id_optrail {var op data} { upvar 0 $var trail lappend trail $op - switch -- $op { - create/write - create/read - - delete/write - delete/read - - flush/read - - clear/read { #ignore } - flush/write - - write - - read { + create/write - create/read - delete/write - delete/read - + flush/read - clear/read { + #ignore + } + flush/write - write - read { return $data } - query/maxRead { + query/maxRead { return -1 } - default { + default { lappend trail "error $op" error $op } } } - proc id_fulltrail {var op data} { - variable $var - upvar 0 $var trail + namespace upvar [namespace current] $var trail #puts stdout ">> $var $op $data" ; flush stdout switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read { + create/write - create/read - delete/write - delete/read - clear_read { set res *ignored* } - flush/write - flush/read - - write - - read { + flush/write - flush/read - write - read { set res $data } query/maxRead { @@ -245,18 +221,19 @@ proc id_fulltrail {var op data} { } proc counter {var op data} { - variable $var - upvar 0 $var n + namespace upvar [namespace current] $var n switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read {;#ignore} - flush/write - flush/read {return {}} + create/write - create/read - delete/write - delete/read - clear_read { + #ignore + } + flush/write - flush/read { + return {} + } write { return $data } - read { + read { if {$n > 0} { incr n -[string length $data] if {$n < 0} { @@ -271,25 +248,20 @@ proc counter {var op data} { } } - proc counter_audit {var vtrail op data} { - variable $var - variable $vtrail - upvar 0 $var n $vtrail trail + namespace upvar [namespace current] $var n $vtrail trail switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read { + create/write - create/read - delete/write - delete/read - clear_read { set res {} } - flush/write - flush/read { + flush/write - flush/read { set res {} } write { set res $data } - read { + read { if {$n > 0} { incr n -[string length $data] if {$n < 0} { @@ -307,36 +279,28 @@ proc counter_audit {var vtrail op data} { return $res } - proc rblocks {var vtrail n op data} { - variable $var - variable $vtrail - upvar 0 $var buf $vtrail trail + namespace upvar [namespace current] $var n $vtrail trail set res {} switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read { + create/write - create/read - delete/write - delete/read - clear_read { set buf {} } flush/write { } - flush/read { + flush/read { set res $buf set buf {} } - write { + write { set data } - read { + read { append buf $data - set b [expr {$n * ([string length $buf] / $n)}] - append op " $n [string length $buf] :- $b" - set res [string range $buf 0 [incr b -1]] set buf [string range $buf [incr b] end] #return $res @@ -350,36 +314,28 @@ proc rblocks {var vtrail n op data} { return $res } - # -------------------------------------------------------------- # ... and convenience procedures to stack them proc identity {-attach channel} { testchannel transform $channel -command [namespace code id] } - proc audit_ops {var -attach channel} { testchannel transform $channel -command [namespace code [list id_optrail $var]] } - proc audit_flow {var -attach channel} { testchannel transform $channel -command [namespace code [list id_fulltrail $var]] } - proc stopafter {var n -attach channel} { - variable $var - upvar 0 $var vn + namespace upvar [namespace current] $var vn set vn $n testchannel transform $channel -command [namespace code [list counter $var]] } - proc stopafter_audit {var trail n -attach channel} { - variable $var - upvar 0 $var vn + namespace upvar [namespace current] $var vn set vn $n testchannel transform $channel -command [namespace code [list counter_audit $var $trail]] } - proc rblocks_t {var trail n -attach channel} { testchannel transform $channel -command [namespace code [list rblocks $var $trail $n]] } @@ -389,36 +345,31 @@ proc rblocks_t {var trail n -attach channel} { proc array_sget {v} { upvar $v a - set res [list] foreach n [lsort [array names a]] { lappend res $n $a($n) } set res } - proc asort {alist} { # sort a list of key/value pairs by key, removes duplicates too. - - array set a $alist + array set a $alist array_sget a } - + ######################################################################## test iogt-1.1 {stack/unstack} testchannel { set fh [open $path(dummy) r] identity -attach $fh testchannel unstack $fh - close $fh + close $fh } {} - test iogt-1.2 {stack/close} testchannel { set fh [open $path(dummy) r] identity -attach $fh - close $fh + close $fh } {} - test iogt-1.3 {stack/unstack, configuration, options} testchannel { set fh [open $path(dummy) r] set ca [asort [fconfigure $fh]] @@ -427,79 +378,53 @@ test iogt-1.3 {stack/unstack, configuration, options} testchannel { testchannel unstack $fh set cc [asort [fconfigure $fh]] close $fh - - # With this system none of the buffering, translation and - # encoding option may change their values with channels - # stacked upon each other or not. - + # With this system none of the buffering, translation and encoding option + # may change their values with channels stacked upon each other or not. # cb == ca == cc - list [string equal $ca $cb] [string equal $cb $cc] [string equal $ca $cc] } {1 1 1} - -test iogt-1.4 {stack/unstack, configuration} testchannel { +test iogt-1.4 {stack/unstack, configuration} -setup { set fh [open $path(dummy) r] +} -constraints testchannel -body { set ca [asort [fconfigure $fh]] identity -attach $fh - fconfigure $fh \ - -buffering line \ - -translation cr \ - -encoding shiftjis + fconfigure $fh -buffering line -translation cr -encoding shiftjis testchannel unstack $fh set cc [asort [fconfigure $fh]] - - set res [list \ - [string equal $ca $cc] \ - [fconfigure $fh -buffering] \ - [fconfigure $fh -translation] \ - [fconfigure $fh -encoding] \ - ] - + list [string equal $ca $cc] [fconfigure $fh -buffering] \ + [fconfigure $fh -translation] [fconfigure $fh -encoding] +} -cleanup { close $fh - set res -} {0 line cr shiftjis} +} -result {0 line cr shiftjis} -test iogt-2.0 {basic I/O going through transform} testchannel { - set fin [open $path(dummy) r] +test iogt-2.0 {basic I/O going through transform} -setup { + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - +} -constraints testchannel -body { identity -attach $fin identity -attach $fout - fcopy $fin $fout - close $fin close $fout - - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) r] - - set res [string equal [set in [read $fin]] [set out [read $fout]]] - lappend res [string length $in] [string length $out] - + list [string equal [set in [read $fin]] [set out [read $fout]]] \ + [string length $in] [string length $out] +} -cleanup { close $fin close $fout - - set res -} {1 71 71} - - +} -result {1 71 71} test iogt-2.1 {basic I/O, operation trail} {testchannel unix} { - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - - set ain [list] ; set aout [list] - audit_ops ain -attach $fin + set ain [list]; set aout [list] + audit_ops ain -attach $fin audit_ops aout -attach $fout - - fconfigure $fin -buffersize 10 + fconfigure $fin -buffersize 10 fconfigure $fout -buffersize 10 - fcopy $fin $fout - close $fin close $fout - set res "[join $ain \n]\n--------\n[join $aout \n]" } {create/read query/maxRead @@ -533,23 +458,17 @@ write write flush/write delete/write} - test iogt-2.2 {basic I/O, data trail} {testchannel unix} { - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - - set ain [list] ; set aout [list] - audit_flow ain -attach $fin + set ain [list]; set aout [list] + audit_flow ain -attach $fin audit_flow aout -attach $fout - - fconfigure $fin -buffersize 10 + fconfigure $fin -buffersize 10 fconfigure $fout -buffersize 10 - fcopy $fin $fout - close $fin close $fout - set res "[join $ain \n]\n--------\n[join $aout \n]" } {create/read {} *ignored* query/maxRead {} -1 @@ -587,24 +506,17 @@ write { } flush/write {} {} delete/write {} *ignored*} - - test iogt-2.3 {basic I/O, mixed trail} {testchannel unix} { - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) w] - set trail [list] audit_flow trail -attach $fin audit_flow trail -attach $fout - - fconfigure $fin -buffersize 20 + fconfigure $fin -buffersize 20 fconfigure $fout -buffersize 10 - fcopy $fin $fout - close $fin close $fout - join $trail \n } {create/read {} *ignored* create/write {} *ignored* @@ -634,110 +546,80 @@ delete/read {} *ignored* flush/write {} {} delete/write {} *ignored*} - -test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} \ - {testchannel unknownFailure} { - # This test to check the validity of aquired Tcl_Channel references is - # not possible because even a backgrounded fcopy will immediately start - # to copy data, without waiting for the event loop. This is done only in - # case of an underflow on the read size!. So stacking transforms after the +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 + # 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 # fcopy will miss information, or are not used at all. # # I was able to circumvent this by using the echo.tcl server with a big # delay, causing the fcopy to underflow immediately. - - proc DoneCopy {n {err {}}} { - variable copy ; set copy 1 - } - - set fin [open $path(dummy) r] - + set fin [open $path(dummy) r] fevent 1000 500 {20 20 20 10 1 1} { close $fin - - set fout [open dummyout w] - - flush $sock ; # now, or fcopy will error us out - # But the 1 second delay should be enough to - # initialize everything else here. - + set fout [open dummyout w] + flush $sock; # now, or fcopy will error us out + # But the 1 second delay should be enough to initialize everything + # else here. fcopy $sock $fout -command [namespace code DoneCopy] - - # transform after fcopy got its handles ! - # They should be still valid for fcopy. - + # Transform after fcopy got its handles! They should be still valid + # for fcopy. set trail [list] audit_ops trail -attach $fout - vwait [namespace which -variable copy] - } [read $fin] ; # {} - + } [read $fin]; # {} close $fout - - rename DoneCopy {} - # Check result of copy. - - set fin [open $path(dummy) r] + set fin [open $path(dummy) r] set fout [open $path(dummyout) r] - set res [string equal [read $fin] [read $fout]] - close $fin close $fout - list $res $trail -} {1 {create/write create/read write flush/write flush/read delete/write delete/read}} - +} -cleanup { + rename DoneCopy {} +} -result {1 {create/write create/read write flush/write flush/read delete/write delete/read}} -test iogt-4.0 {fileevent readable, after transform} {testchannel unknownFailure} { - set fin [open $path(dummy) r] +test iogt-4.0 {fileevent readable, after transform} -setup { + set fin [open $path(dummy) r] set data [read $fin] close $fin - set trail [list] - set got [list] - + set got [list] proc Done {args} { - variable stop - set stop 1 + variable stop 1 } - - 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 hangs} -body { fevent 1000 500 {20 20 20 10 1} { - audit_flow trail -attach $sock - rblocks_t rbuf trail 23 -attach $sock - - fileevent $sock readable [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. - + 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 + } + }] + flush $sock; # Now, or fcopy will error us out + # But the 1 second delay should be enough to initialize everything + # else here. vwait [namespace which -variable stop] } $data - - - rename Done {} - rename Get {} - join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n -} {[[]] +} -cleanup { + rename Done {} +} -result {[[]] [[abcdefghijklmnopqrstuvw]] [[xyz0123456789,./?><;'\|]] [[]] @@ -818,35 +700,27 @@ rblock | delete/write {} {} | {} rblock | delete/read {} {} | {} flush/write {} {} delete/write {} *ignored* -delete/read {} *ignored*} ; # catch unescaped quote " - +delete/read {} *ignored*}; # catch unescaped quote " -test iogt-5.0 {EOF simulation} {testchannel unknownFailure} { - set fin [open $path(dummy) r] +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 { audit_flow trail -attach $fin - stopafter_audit d trail 20 -attach $fin + stopafter_audit d trail 20 -attach $fin audit_flow trail -attach $fout - - fconfigure $fin -buffersize 20 + fconfigure $fin -buffersize 20 fconfigure $fout -buffersize 10 - - fcopy $fin $fout + fcopy $fin $fout testchannel unstack $fin - # now copy the rest in the channel lappend trail {**after unstack**} - fcopy $fin $fout - close $fin close $fout - join $trail \n -} {create/read {} *ignored* +} -result {create/read {} *ignored* counter:create/read {} {} create/write {} *ignored* counter:query/maxRead {} 20 @@ -880,59 +754,48 @@ delete/write {} *ignored*} proc constX {op data} { # replace anything coming in with a same-length string of x'es. switch -- $op { - create/write - create/read - - delete/write - delete/read - - clear_read {;#ignore} - flush/write - flush/read - - write - - read { + create/write - create/read - delete/write - delete/read - clear_read { + #ignore + } + flush/write - flush/read - write - read { return [string repeat x [string length $data]] } - query/maxRead {return -1} + query/maxRead { + return -1 + } } } - proc constx {-attach channel} { testchannel transform $channel -command [namespace code constX] } -test iogt-6.0 {Push back} testchannel { +test iogt-6.0 {Push back} -constraints testchannel -body { set f [open $path(dummy) r] - # contents of dummy = "abcdefghi..." - read $f 3 ; # skip behind "abc" - + read $f 3; # skip behind "abc" constx -attach $f - - # expect to get "xxx" from the transform because - # of unread "def" input to transform which returns "xxx". + # expect to get "xxx" from the transform because of unread "def" input to + # transform which returns "xxx". # - # Actually the IO layer pre-read the whole file and will - # read "def" directly from the buffer without bothering - # to consult the newly stacked transformation. This is - # wrong. - - set res [read $f 3] + # Actually the IO layer pre-read the whole file and will read "def" + # directly from the buffer without bothering to consult the newly stacked + # transformation. This is wrong. + read $f 3 +} -cleanup { close $f - set res -} {xxx} - -test iogt-6.1 {Push back and up} {testchannel knownBug} { +} -result {xxx} +test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body { set f [open $path(dummy) r] - # contents of dummy = "abcdefghi..." - read $f 3 ; # skip behind "abc" - + read $f 3; # skip behind "abc" constx -attach $f set res [read $f 3] - testchannel unstack $f append res [read $f 3] +} -cleanup { close $f - set res -} {xxxghi} - - +} -result {xxxghi} + # cleanup foreach file [list dummy dummyout __echo_srv__.tcl] { removeFile $file diff --git a/tests/join.test b/tests/join.test index 0a6da27..4abe233 100644 --- a/tests/join.test +++ b/tests/join.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: join.test,v 1.7 2009/01/08 16:41:35 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -39,7 +37,7 @@ test join-2.2 {join errors} { } {1 {wrong # args: should be "join list ?joinString?"} {TCL WRONGARGS}} test join-2.3 {join errors} { list [catch {join "a \{ c" 111} msg] $msg $errorCode -} {1 {unmatched open brace in list} {TCL VALUE LIST}} +} {1 {unmatched open brace in list} {TCL VALUE LIST BRACE}} test join-3.1 {joinString is binary ok} { string length [join {a b c} a\0b] diff --git a/tests/lindex.test b/tests/lindex.test index 1621fda..b86e2e0 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -11,14 +11,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: lindex.test,v 1.18 2008/07/13 23:15:22 nijtmans Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + set minus - testConstraint testevalex [llength [info commands testevalex]] diff --git a/tests/link.test b/tests/link.test index 6b87ff5..00e490c 100644 --- a/tests/link.test +++ b/tests/link.test @@ -1,43 +1,48 @@ # Commands covered: none # -# This file contains a collection of tests for Tcl_LinkVar and related -# library procedures. 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 Tcl_LinkVar and related 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 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. -# -# RCS: @(#) $Id: link.test,v 1.17 2007/12/13 15:26:06 dgp Exp $ +# 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} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testlink [llength [info commands testlink]] foreach i {int real bool string} { - catch {unset $i} + unset -nocomplain $i } -test link-1.1 {reading C variables from Tcl} {testlink} { + +test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup { testlink delete +} -body { testlink set 43 1.23 4 - 12341234 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 $int $real $bool $string $wide -} {43 1.23 1 NULL 12341234} -test link-1.2 {reading C variables from Tcl} {testlink} { +} -result {43 1.23 1 NULL 12341234} +test link-1.2 {reading C variables from Tcl} -constraints {testlink} -setup { testlink delete +} -body { testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set -3 2 0 "A long string with spaces" 43214321 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 list $int $real $bool $string $wide $int $real $bool $string $wide -} {-3 2.0 0 {A long string with spaces} 43214321 -3 2.0 0 {A long string with spaces} 43214321} +} -result {-3 2.0 0 {A long string with spaces} 43214321 -3 2.0 0 {A long string with spaces} 43214321} -test link-2.1 {writing C variables from Tcl} {testlink} { +test link-2.1 {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 "0o0721" @@ -55,34 +60,39 @@ test link-2.1 {writing C variables from Tcl} {testlink} { set float 1.0987654321 set uwide 357357357357 concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide -} {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 357357357357 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 357357357357} -test link-2.2 {writing bad values into variables} {testlink} { +} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 357357357357 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 357357357357} +test link-2.2 {writing bad values into variables} -setup { testlink delete +} -constraints {testlink} -body { 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 int 09a} msg] $msg $int -} {1 {can't set "int": variable must have integer value} 43} -test link-2.3 {writing bad values into variables} {testlink} { +} -result {1 {can't set "int": variable must have integer value} 43} +test link-2.3 {writing bad values into variables} -setup { testlink delete +} -constraints {testlink} -body { 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 real 1.x3} msg] $msg $real -} {1 {can't set "real": variable must have real value} 1.23} -test link-2.4 {writing bad values into variables} {testlink} { +} -result {1 {can't set "real": variable must have real value} 1.23} +test link-2.4 {writing bad values into variables} -setup { testlink delete +} -constraints {testlink} -body { 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 bool gorp} msg] $msg $bool -} {1 {can't set "bool": variable must have boolean value} 1} -test link-2.5 {writing bad values into variables} {testlink} { +} -result {1 {can't set "bool": variable must have boolean value} 1} +test link-2.5 {writing bad values into variables} -setup { testlink delete +} -constraints {testlink} -body { 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 -} {1 {can't set "wide": variable must have integer value} 1} +} -result {1 {can't set "wide": variable must have integer value} 1} -test link-3.1 {read-only variables} {testlink} { +test link-3.1 {read-only variables} -constraints {testlink} -setup { testlink delete +} -body { testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 0 1 1 0 0 0 0 0 0 0 0 0 0 0 list [catch {set int 4} msg] $msg $int \ @@ -90,9 +100,10 @@ test link-3.1 {read-only variables} {testlink} { [catch {set bool no} msg] $msg $bool \ [catch {set string "new value"} msg] $msg $string \ [catch {set wide 12341234} msg] $msg $wide -} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL 1 {can't set "wide": linked variable is read-only} 56785678} -test link-3.2 {read-only variables} {testlink} { +} -result {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL 1 {can't set "wide": linked variable is read-only} 56785678} +test link-3.2 {read-only variables} -constraints {testlink} -setup { testlink delete +} -body { testlink set 43 1.23 4 - 56785678 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink create 1 0 0 1 1 0 0 0 0 0 0 0 0 0 list [catch {set int 4} msg] $msg $int \ @@ -100,19 +111,21 @@ test link-3.2 {read-only variables} {testlink} { [catch {set bool no} msg] $msg $bool \ [catch {set string "new value"} msg] $msg $string\ [catch {set wide 12341234} msg] $msg $wide -} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value} 0 12341234 12341234} +} -result {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value} 0 12341234 12341234} -test link-4.1 {unsetting linked variables} {testlink} { +test link-4.1 {unsetting linked variables} -constraints {testlink} -setup { testlink delete +} -body { testlink set -6 -2.5 0 stringValue 13579 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 unset int real bool string wide list [catch {set int} msg] $msg [catch {set real} msg] $msg \ [catch {set bool} msg] $msg [catch {set string} msg] $msg \ [catch {set wide} msg] $msg -} {0 -6 0 -2.5 0 0 0 stringValue 0 13579} -test link-4.2 {unsetting linked variables} {testlink} { +} -result {0 -6 0 -2.5 0 0 0 stringValue 0 13579} +test link-4.2 {unsetting linked variables} -constraints {testlink} -setup { testlink delete +} -body { testlink set -6 -2.1 0 stringValue 97531 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 unset int real bool string wide @@ -122,10 +135,11 @@ test link-4.2 {unsetting linked variables} {testlink} { set string newValue set wide 333555 lrange [testlink get] 0 4 -} {102 16.0 1 newValue 333555} +} -result {102 16.0 1 newValue 333555} -test link-5.1 {unlinking variables} {testlink} { +test link-5.1 {unlinking variables} -constraints {testlink} -setup { testlink delete +} -body { testlink set -6 -2.25 0 stringValue 13579 64 250 30000 60000 0xbeefbabe 12321 32123 3.25 1231231234 testlink delete set int xx1 @@ -143,98 +157,108 @@ test link-5.1 {unlinking variables} {testlink} { set float dskjfbjfd set uwide isdfsngs testlink get -} {-6 -2.25 0 stringValue 13579 64 250 30000 60000 -1091585346 12321 32123 3.25 1231231234} -test link-5.2 {unlinking variables} {testlink} { +} -result {-6 -2.25 0 stringValue 13579 64 250 30000 60000 -1091585346 12321 32123 3.25 1231231234} +test link-5.2 {unlinking variables} -constraints {testlink} -setup { testlink delete +} -body { testlink set -6 -2.25 0 stringValue 97531 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 testlink delete testlink set 25 14.7 7 - 999999 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 list $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide -} {-6 -2.25 0 stringValue 97531 64 250 30000 60000 3203381950 12321 32123 3.25 1231231234} +} -result {-6 -2.25 0 stringValue 97531 64 250 30000 60000 3203381950 12321 32123 3.25 1231231234} -test link-6.1 {errors in setting up link} {testlink} { +test link-6.1 {errors in setting up link} -setup { testlink delete - catch {unset int} + unset -nocomplain int +} -constraints {testlink} -body { set int(44) 1 - list [catch {testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1} msg] $msg -} {1 {can't set "int": variable is array}} -catch {unset int} + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 +} -cleanup { + unset -nocomplain int +} -returnCodes error -result {can't set "int": variable is array} -test link-7.1 {access to linked variables via upvar} {testlink} { +test link-7.1 {access to linked variables via upvar} -setup { + testlink delete +} -constraints {testlink} -body { proc x {} { upvar int y unset y } - testlink delete testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0 testlink set 14 {} {} {} {} {} {} {} {} {} {} {} {} {} x list [catch {set int} msg] $msg -} {0 14} -test link-7.2 {access to linked variables via upvar} {testlink} { +} -result {0 14} +test link-7.2 {access to linked variables via upvar} -setup { + testlink delete +} -constraints {testlink} -body { proc x {} { upvar int y return [set y] } - testlink delete testlink create 1 0 0 0 0 0 0 0 0 0 0 0 0 0 testlink set 0 {} {} {} {} {} {} {} {} {} {} {} {} {} set int testlink set 23 {} {} {} {} {} {} {} {} {} {} {} {} {} x list [x] $int -} {23 23} -test link-7.3 {access to linked variables via upvar} {testlink} { +} -result {23 23} +test link-7.3 {access to linked variables via upvar} -setup { + testlink delete +} -constraints {testlink} -body { proc x {} { upvar int y set y 44 } - testlink delete testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0 testlink set 11 {} {} {} {} {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $int -} {1 {can't set "y": linked variable is read-only} 11} -test link-7.4 {access to linked variables via upvar} {testlink} { +} -result {1 {can't set "y": linked variable is read-only} 11} +test link-7.4 {access to linked variables via upvar} -setup { + testlink delete +} -constraints {testlink} -body { proc x {} { upvar int y set y abc } - testlink delete testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set -4 {} {} {} {} {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $int -} {1 {can't set "y": variable must have integer value} -4} -test link-7.5 {access to linked variables via upvar} {testlink} { +} -result {1 {can't set "y": variable must have integer value} -4} +test link-7.5 {access to linked variables via upvar} -setup { + testlink delete +} -constraints {testlink} -body { proc x {} { upvar real y set y abc } - testlink delete testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set -4 16.75 {} {} {} {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $real -} {1 {can't set "y": variable must have real value} 16.75} -test link-7.6 {access to linked variables via upvar} {testlink} { +} -result {1 {can't set "y": variable must have real value} 16.75} +test link-7.6 {access to linked variables via upvar} -setup { + testlink delete +} -constraints {testlink} -body { proc x {} { upvar bool y set y abc } - testlink delete testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 testlink set -4 16.3 1 {} {} {} {} {} {} {} {} {} {} {} list [catch x msg] $msg $bool -} {1 {can't set "y": variable must have boolean value} 1} -test link-7.7 {access to linked variables via upvar} {testlink} { +} -result {1 {can't set "y": variable must have boolean value} 1} +test link-7.7 {access to linked variables via upvar} -setup { + testlink delete +} -constraints {testlink} -body { proc x {} { upvar wide y set y abc } - testlink delete 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 -} {1 {can't set "y": variable must have integer value} 778899} +} -result {1 {can't set "y": variable must have integer value} 778899} test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { @@ -247,7 +271,7 @@ test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} { trace var int w x testlink update 32 4.0 3 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 trace vdelete int w x - set x + return $x } {{int {} w} 32 -2.0 0 xyzzy 995511} test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { @@ -261,7 +285,7 @@ test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} { trace var int w x testlink update 32 4.0 6 abcd 113355 65 251 30001 60001 0xbabebeef 12322 32124 3.125 12312312340 trace vdelete int w x - set x + return $x } {} test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0 @@ -269,13 +293,18 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {} } msg] $msg $int } {0 {} 47} - + catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0} catch {testlink delete} foreach i {int real bool string wide} { - catch {unset $i} + unset -nocomplain $i } # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/linsert.test b/tests/linsert.test index e9c545a..4939e5c 100644 --- a/tests/linsert.test +++ b/tests/linsert.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: linsert.test,v 1.11 2008/09/29 15:38:32 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/list.test b/tests/list.test index 0dd2d73..dff5d50 100644 --- a/tests/list.test +++ b/tests/list.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: list.test,v 1.8 2010/02/12 03:21:32 mdejong Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -127,6 +125,10 @@ test list-3.1 {SetListFromAny and lrange/concat results} { slowsort {fred julie alex carol bill annie} } {alex annie bill carol fred julie} +test list-4.1 {Bug 3173086} { + string is list "{[list \\\\\}]}" +} 1 + # cleanup ::tcltest::cleanupTests return diff --git a/tests/listObj.test b/tests/listObj.test index 2e8ae17..8b24aa9 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -10,14 +10,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: listObj.test,v 1.9 2010/03/18 20:34:48 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testobj [llength [info commands testobj]] catch {unset x} @@ -201,4 +202,4 @@ return # Local Variables: # mode: tcl -# End:
\ No newline at end of file +# End: diff --git a/tests/llength.test b/tests/llength.test index 1f272f7..169c7ca 100644 --- a/tests/llength.test +++ b/tests/llength.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: llength.test,v 1.6 2004/05/19 12:23:58 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/lmap.test b/tests/lmap.test new file mode 100644 index 0000000..7baa77b --- /dev/null +++ b/tests/lmap.test @@ -0,0 +1,464 @@ +# 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 (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 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 + namespace import -force ::tcltest::* +} + +unset -nocomplain a 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} { + set x [lmap a [lrepeat 1000000 x] { set b y$a }] + list $b [llength $x] [string length $x] +} {yx 1000000 2999999} +test lmap-7.8 {huge list compiled} { + set x [apply {{times} { lmap a [lrepeat $times x] { set b y$a }}} 1000000] + list $b [llength $x] [string length $x] +} {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 711b919..cded85d 100644 --- a/tests/load.test +++ b/tests/load.test @@ -9,14 +9,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: load.test,v 1.21 2010/04/02 21:21:06 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Figure out what extension is used for shared libraries on this # platform. if {![info exists ext]} { @@ -46,32 +47,38 @@ testConstraint testsimplefilesystem \ test load-1.1 {basic errors} {} { list [catch {load} msg] $msg -} "1 {wrong \# args: should be \"load fileName ?packageName? ?interp?\"}" +} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? 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?\"}" +} "1 {wrong \# args: should be \"load ?-global? ?-lazy? ?--? 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 + list [catch {load -global {}} msg] $msg } {1 {must specify either file name or package name}} test load-1.5 {basic errors} {} { - list [catch {load {} {}} msg] $msg + list [catch {load -lazy {} {}} 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.7 {basic errors} {} { + list [catch {load -abc foo} msg] $msg +} "1 {bad option \"-abc\": must be -global, -lazy, or --}" +test load-1.8 {basic errors} {} { + list [catch {load -global} msg] $msg +} "1 {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"}} @@ -125,7 +132,7 @@ test load-5.1 {file name not specified and no static package: pick default} \ [list $dll $loaded] { catch {interp delete x} interp create x - load [file join $testDir pkga$ext] pkga + load -global [file join $testDir pkga$ext] pkga load {} pkga x set result [info loaded x] interp delete x @@ -181,7 +188,7 @@ test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] 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}] +} [list [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} \ @@ -199,7 +206,7 @@ test load-9.1 {Tcl_StaticPackage, load already-loaded package into another inter [child1 eval { info loaded {} }] \ [child2 eval { info loaded {} }] } \ - -result {{{{} Loadninepointone} {{} Tcltest}} {{{} Loadninepointone} {{} Tcltest}}} \ + -match glob -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} \ -cleanup { interp delete child1 ; interp delete child2 } test load-10.1 {load from vfs} \ diff --git a/tests/lrange.test b/tests/lrange.test index 6f8f88d..17a757e 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -10,14 +10,12 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: lrange.test,v 1.12 2009/02/22 17:45:21 ferrieux Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } - + test lrange-1.1 {range of list elements} { lrange {a b c d} 1 2 } {b c} @@ -63,9 +61,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 } {{[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"}} @@ -85,6 +85,16 @@ 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} +} {} + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/lrepeat.test b/tests/lrepeat.test index 7789e2f..788bb9b 100644 --- a/tests/lrepeat.test +++ b/tests/lrepeat.test @@ -8,8 +8,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: lrepeat.test,v 1.4 2008/09/28 20:39:08 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -65,7 +63,7 @@ test lrepeat-1.7 {Accept zero repetitions (TIP 323)} { } test lrepeat-1.8 {Do not build enormous lists - Bug 2130992} -body { lrepeat 0x10000000 a b c d e f g h -} -returnCodes error -result {too many elements in result list} +} -returnCodes error -match glob -result * ## Okay test lrepeat-2.1 {normal cases} { diff --git a/tests/lreplace.test b/tests/lreplace.test index 59934fb..5f675bc 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: lreplace.test,v 1.10 2008/07/21 22:22:28 nijtmans Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/lsearch.test b/tests/lsearch.test index 634adda..f36e987 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -1,23 +1,21 @@ # Commands covered: lsearch # -# 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-1993 The Regents of the University of California. # Copyright (c) 1994 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. -# -# RCS: @(#) $Id: lsearch.test,v 1.22 2008/09/29 12:25:21 dkf Exp $ +# 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 namespace import -force ::tcltest::* } - + set x {abcd bbcd 123 234 345} test lsearch-1.1 {lsearch command} { lsearch $x 123 @@ -47,9 +45,9 @@ test lsearch-2.4 {search modes} { test lsearch-2.5 {search modes} { lsearch -exact {foo bar cat} bar } 1 -test lsearch-2.6 {search modes} { - list [catch {lsearch -regexp {xyz bbcc *bc*} *bc*} msg] $msg -} {1 {couldn't compile regular expression pattern: quantifier operand invalid}} +test lsearch-2.6 {search modes} -returnCodes error -body { + lsearch -regexp {xyz bbcc *bc*} *bc* +} -result {couldn't compile regular expression pattern: quantifier operand invalid} test lsearch-2.7 {search modes} { lsearch -regexp {b.x ^bc xy bcx} ^bc } 3 @@ -59,9 +57,9 @@ test lsearch-2.8 {search modes} { test lsearch-2.9 {search modes} { lsearch -glob {b.x ^bc xy bcx} ^bc } 1 -test lsearch-2.10 {search modes} { - list [catch {lsearch -glib {b.x bx xy bcx} b.x} msg] $msg -} {1 {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} +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} test lsearch-2.11 {search modes with -nocase} { lsearch -exact -nocase {a b c A B C} A } 0 @@ -81,27 +79,27 @@ test lsearch-2.16 {search modes without -nocase} { lsearch -regexp {a b c A B C} ^A\$ } 3 -test lsearch-3.1 {lsearch errors} { - list [catch lsearch msg] $msg -} {1 {wrong # args: should be "lsearch ?-option value ...? list pattern"}} -test lsearch-3.2 {lsearch errors} { - list [catch {lsearch a} msg] $msg -} {1 {wrong # args: should be "lsearch ?-option value ...? list pattern"}} -test lsearch-3.3 {lsearch errors} { - list [catch {lsearch a b c} msg] $msg -} {1 {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} -test lsearch-3.4 {lsearch errors} { - list [catch {lsearch a b c d} msg] $msg -} {1 {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}} -test lsearch-3.5 {lsearch errors} { - list [catch {lsearch "\{" b} msg] $msg -} {1 {unmatched open brace in list}} -test lsearch-3.6 {lsearch errors} { - list [catch {lsearch -index a b} msg] $msg -} {1 {"-index" option must be followed by list index}} -test lsearch-3.7 {lsearch errors} { - list [catch {lsearch -subindices -exact a b} msg] $msg -} {1 {-subindices cannot be used without -index option}} +test lsearch-3.1 {lsearch errors} -returnCodes error -body { + lsearch +} -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} +test lsearch-3.2 {lsearch errors} -returnCodes error -body { + lsearch a +} -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} +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} +test lsearch-3.5 {lsearch errors} -returnCodes error -body { + lsearch "\{" b +} -result {unmatched open brace in list} +test lsearch-3.6 {lsearch errors} -returnCodes error -body { + lsearch -index a b +} -result {"-index" option must be followed by list index} +test lsearch-3.7 {lsearch errors} -returnCodes error -body { + lsearch -subindices -exact a b +} -result {-subindices cannot be used without -index option} test lsearch-4.1 {binary data} { lsearch -exact [list foo one\000two bar] bar @@ -300,12 +298,12 @@ test lsearch-10.2 {offset searching} { test lsearch-10.3 {offset searching} { lsearch -start end-4 {a b c a b c} a } 3 -test lsearch-10.4 {offset searching} { - list [catch {lsearch -start foobar {a b c a b c} a} msg] $msg -} {1 {bad index "foobar": must be integer?[+-]integer? or end?[+-]integer?}} -test lsearch-10.5 {offset searching} { - list [catch {lsearch -start 1 2} msg] $msg -} {1 {missing starting index}} +test lsearch-10.4 {offset searching} -returnCodes error -body { + lsearch -start foobar {a b c a b c} a +} -result {bad index "foobar": must be integer?[+-]integer? or end?[+-]integer?} +test lsearch-10.5 {offset searching} -returnCodes error -body { + lsearch -start 1 2 +} -result {missing starting index} test lsearch-10.6 {binary search with offset} { set res {} for {set i 0} {$i < 100} {incr i} { @@ -453,15 +451,15 @@ test lsearch-19.5 {lsearch -sunindices 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-20.1 {lsearch -index option, index larger than sublists} { - list [catch {lsearch -index 2 {{a c} {a b} {a a}} a} msg] $msg -} {1 {element 2 missing from sublist "a c"}} -test lsearch-20.2 {lsearch -index option, malformed index} { - list [catch {lsearch -index foo {{a c} {a b} {a a}} a} msg] $msg -} {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}} -test lsearch-20.3 {lsearch -index option, malformed index} { - list [catch {lsearch -index \{ {{a c} {a b} {a a}} a} msg] $msg -} {1 {unmatched open brace in list}} +test lsearch-20.1 {lsearch -index option, index larger than sublists} -body { + lsearch -index 2 {{a c} {a b} {a a}} a +} -returnCodes error -result {element 2 missing from sublist "a c"} +test lsearch-20.2 {lsearch -index option, malformed index} -body { + lsearch -index foo {{a c} {a b} {a a}} a +} -returnCodes error -result {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?} +test lsearch-20.3 {lsearch -index option, malformed index} -body { + lsearch -index \{ {{a c} {a b} {a a}} a +} -returnCodes error -result {unmatched open brace in list} test lsearch-21.1 {lsearch shimmering crash} { set x 0 @@ -511,7 +509,7 @@ 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} - + # cleanup catch {unset res} catch {unset increasingIntegers} diff --git a/tests/lset.test b/tests/lset.test index c10f433..1c1300b 100644 --- a/tests/lset.test +++ b/tests/lset.test @@ -10,14 +10,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id$ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + proc failTrace {name1 name2 op} { error "trace failed" } diff --git a/tests/lsetComp.test b/tests/lsetComp.test index bc08d78..6846cbf 100755 --- a/tests/lsetComp.test +++ b/tests/lsetComp.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id$ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index 5c87bab..071f11b 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -8,9 +8,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: macOSXFCmd.test,v 1.5 2006/08/18 07:45:31 das Exp $ -# if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/macOSXLoad.test b/tests/macOSXLoad.test index 6db695e..12c77e0 100644 --- a/tests/macOSXLoad.test +++ b/tests/macOSXLoad.test @@ -9,8 +9,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: macOSXLoad.test,v 1.1 2006/12/17 03:47:08 das Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 diff --git a/tests/main.test b/tests/main.test index 24d1fb5..f1dc7fd 100644 --- a/tests/main.test +++ b/tests/main.test @@ -1,6 +1,4 @@ # This file contains a collection of tests for generic/tclMain.c. -# -# RCS: @(#) $Id: main.test,v 1.22 2007/12/13 15:26:06 dgp Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." @@ -68,8 +66,6 @@ namespace eval ::tcl::test::main { } -result [list [interpreter] -script 0]\n test Tcl_Main-1.3 { - Tcl_Main: encoding of arguments: done by system encoding - Note the shortcoming explained in Tcl Feature Request 491789 } -constraints { stdio } -setup { @@ -84,10 +80,8 @@ namespace eval ::tcl::test::main { [encoding convertto [encoding system] \u00c0]]] 0]\n test Tcl_Main-1.4 { - Tcl_Main: encoding of arguments: done by system encoding - Note the shortcoming explained in Tcl Feature Request 491789 } -constraints { - stdio tempNotWin + stdio } -setup { makeFile {puts [list $argv0 $argv $tcl_interactive]} script catch {set f [open "|[list [interpreter] script \u20ac]" r]} @@ -100,8 +94,6 @@ namespace eval ::tcl::test::main { [encoding convertto [encoding system] \u20ac]]] 0]\n test Tcl_Main-1.5 { - Tcl_Main: encoding of script name: system encoding loss - Note the shortcoming explained in Tcl Feature Request 491789 } -constraints { stdio } -setup { @@ -116,10 +108,8 @@ namespace eval ::tcl::test::main { [encoding convertto [encoding system] \u00c0]]] {} 0]\n test Tcl_Main-1.6 { - Tcl_Main: encoding of script name: system encoding loss - Note the shortcoming explained in Tcl Feature Request 491789 } -constraints { - stdio tempNotWin + stdio } -setup { makeFile {puts [list $argv0 $argv $tcl_interactive]} \u20ac catch {set f [open "|[list [interpreter] \u20ac]" r]} diff --git a/tests/mathop.test b/tests/mathop.test index b7c4a04..f122b7b 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -9,8 +9,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: mathop.test,v 1.14 2010/07/02 20:37:10 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -1094,7 +1092,7 @@ test mathop-24.3 { binary ops, bad values } { } foreach op {in ni} { lappend res [TestOp $op 5 "a b \{ c"] - lappend exp "unmatched open brace in list TCL VALUE LIST" + lappend exp "unmatched open brace in list TCL VALUE LIST BRACE" } lappend res [TestOp % 5 0] lappend exp "divide by zero ARITH DIVZERO {divide by zero}" diff --git a/tests/misc.test b/tests/misc.test index 7015c52..6ddc718 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -11,14 +11,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: misc.test,v 1.11 2006/10/09 19:15:45 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testhashsystemhash [llength [info commands testhashsystemhash]] test misc-1.1 {error in variable ref. in command in array reference} { diff --git a/tests/msgcat.test b/tests/msgcat.test index 70dc384..1522354 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -11,16 +11,14 @@ # # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. -# -# RCS: @(#) $Id: msgcat.test,v 1.21 2008/05/31 23:34:46 das Exp $ package require Tcl 8.2 if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } -if {[catch {package require msgcat 1.4.2}]} { - puts stderr "Skipping tests in [info script]. No msgcat 1.4.2 found to test." +if {[catch {package require msgcat 1.5.0}]} { + puts stderr "Skipping tests in [info script]. No msgcat 1.5.0 found to test." return } @@ -58,6 +56,13 @@ namespace eval ::msgcat::test { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] } else { + if {([info sharedlibextension] == ".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 } } @@ -613,6 +618,45 @@ 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} l2.msg $msgdir3 + + # chained mcload + test msgcat-8.2 {mcflset} -setup { + variable locale [mclocale] + mclocale l2 + mcload $msgdir2 + } -cleanup { + mclocale $locale + } -body { + return [mc k2][mc k3] + } -result v2v3 + + removeFile l2.msg $msgdir2 + removeDirectory msgdir2 + removeDirectory msgdir3 + cleanupTests } namespace delete ::msgcat::test diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 804c233..1d8ba31 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -13,10 +13,8 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: namespace-old.test,v 1.14 2008/12/17 15:39:55 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.2 namespace import -force ::tcltest::* } @@ -496,8 +494,8 @@ test namespace-old-7.1 {define test namespace} { } } {} test namespace-old-7.2 {uplevel can access namespace call frame} { - list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] x]>=0}] \ - [expr {[lsearch -exact [test_ns_uplevel::test_uplevel 1] y]>=0}] + list [expr {"x" in [test_ns_uplevel::test_uplevel 1]}] \ + [expr {"y" in [test_ns_uplevel::test_uplevel 1]}] } {1 1} test namespace-old-7.3 {uplevel can go beyond namespace call frame} { lsort [test_ns_uplevel::test_uplevel 2] @@ -506,8 +504,8 @@ test namespace-old-7.4 {uplevel can go up to global context} { expr {[test_ns_uplevel::test_uplevel 3] == [info globals]} } {1} test namespace-old-7.5 {absolute call frame references work too} { - list [expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] x]>=0}] \ - [expr {[lsearch -exact [test_ns_uplevel::test_uplevel #2] y]>=0}] + list [expr {"x" in [test_ns_uplevel::test_uplevel #2]}] \ + [expr {"y" in [test_ns_uplevel::test_uplevel #2]}] } {1 1} test namespace-old-7.6 {absolute call frame references work too} { lsort [test_ns_uplevel::test_uplevel #1] diff --git a/tests/namespace.test b/tests/namespace.test index c1aef53..1d46bf0 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -1,25 +1,24 @@ # Functionality covered: this file contains a collection of tests for the -# procedures in tclNamesp.c that implement Tcl's basic support for -# namespaces. Other namespace-related tests appear in variable.test. +# procedures in tclNamesp.c and tclEnsemble.c that implement Tcl's basic +# support for namespaces. Other namespace-related tests appear in +# variable.test. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# 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. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: namespace.test,v 1.78 2010/01/10 16:51:25 dkf Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} +# 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::* testConstraint memory [llength [info commands memory]] +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # # REMARK: the tests for 'namespace upvar' are not done here. They are to be # found in the file 'upvar.test'. @@ -27,6 +26,12 @@ testConstraint memory [llength [info commands memory]] # Clear out any namespaces called test_ns_* catch {namespace delete {*}[namespace children :: test_ns_*]} + +proc fq {ns} { + if {[string match ::* $ns]} {return $ns} + set current [uplevel 1 {namespace current}] + return [string trimright $current :]::[string trimleft $ns :] +} test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} { namespace children :: test_ns_* @@ -47,7 +52,6 @@ test namespace-2.2 {Tcl_GetCurrentNamespace} { } } lappend l [namespace current] - set l } {:: ::test_ns_1 ::test_ns_1::foo ::} test namespace-3.1 {Tcl_GetGlobalNamespace} { @@ -594,9 +598,8 @@ test namespace-14.5 {TclGetNamespaceForQualName, relative ns names looked up onl namespace eval bar {} } namespace eval test_ns_1 { - set l [list [catch {namespace delete test_ns_2::bar} msg] $msg] + list [catch {namespace delete test_ns_2::bar} msg] $msg } - set l } {1 {unknown namespace "test_ns_2::bar" in namespace delete command}} test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { @@ -815,7 +818,7 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} { set a 0 namespace eval test_ns_1 set a 1 namespace delete test_ns_1 - set a + return $a } 1 catch {unset a} catch {unset x} @@ -837,7 +840,6 @@ 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] - set l } {{global foo} {foo in test_ns_1}} test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} { namespace eval test_ns_2 { @@ -858,7 +860,6 @@ test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shado } } lappend l [test_ns_1::trigger] - set l } {{foo in ::test_ns_2} {foo in ::test_ns_1::test_ns_2}} catch {unset l} catch {rename foo {}} @@ -890,7 +891,6 @@ 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] - set l } {{} ::test_ns_1::test_ns_2::test_ns_3} test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { @@ -899,7 +899,7 @@ test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { } {1 {wrong # args: should be "namespace subcommand ?arg ...?"}} test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} -body { namespace wombat {} -} -returnCodes error -match glob -result {bad option "wombat": must be *} +} -returnCodes error -match glob -result {unknown or ambiguous subcommand "wombat": must be *} test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} { namespace ch :: test_ns_* } {} @@ -937,9 +937,8 @@ test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} { } [lsort {::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] \ - [string trimright [namespace current] :]::test_ns_1 -} [string trimright [namespace current] :]::test_ns_1 + namespace children [namespace current] [fq test_ns_1] +} [fq test_ns_1] test namespace-22.1 {NamespaceCodeCmd, bad args} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -950,11 +949,11 @@ test namespace-22.2 {NamespaceCodeCmd, arg is already scoped value} { namespace eval test_ns_1 { proc cmd {} {return "test_ns_1::cmd"} } - namespace code {namespace inscope ::test_ns_1 cmd} -} {namespace inscope ::test_ns_1 cmd} + namespace code {::namespace inscope ::test_ns_1 cmd} +} {::namespace inscope ::test_ns_1 cmd} test namespace-22.3 {NamespaceCodeCmd, arg is already scoped value} { namespace code {namespace inscope ::test_ns_1 cmd} -} {namespace inscope ::test_ns_1 cmd} +} {::namespace inscope :: {namespace inscope ::test_ns_1 cmd}} test namespace-22.4 {NamespaceCodeCmd, in :: namespace} { namespace code unknown } {::namespace inscope :: unknown} @@ -974,6 +973,12 @@ test namespace-22.6 {NamespaceCodeCmd, in other namespace} { namespace code {set v} }] } {42} +test namespace-22.7 {NamespaceCodeCmd, Bug 3202171} { + namespace eval demo { + proc namespace args {puts $args} + ::namespace code {namespace inscope foo} + } +} [list ::namespace inscope [fq demo] {namespace inscope foo}] test namespace-23.1 {NamespaceCurrentCmd, bad args} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -1011,7 +1016,7 @@ test namespace-25.1 {NamespaceEvalCmd, bad args} { } {1 {wrong # args: should be "namespace eval name arg ?arg...?"}} test namespace-25.2 {NamespaceEvalCmd, bad args} -body { namespace test_ns_1 -} -returnCodes error -match glob -result {bad option "test_ns_1": must be *} +} -returnCodes error -match glob -result {unknown or ambiguous subcommand "test_ns_1": must be *} catch {unset v} test namespace-25.3 {NamespaceEvalCmd, new namespace} { set v 123 @@ -1420,16 +1425,17 @@ test namespace-39.3 {NamespaceExistsCmd error} { list [catch {namespace exists a b} msg] $msg } {1 {wrong # args: should be "namespace exists name"}} -test namespace-40.1 {Ignoring namespace proc "unknown"} { +test namespace-40.1 {Ignoring namespace proc "unknown"} -setup { rename unknown _unknown +} -body { proc unknown args {return global} namespace eval ns {proc unknown args {return local}} - set l [list [namespace eval ns aaa bbb] [namespace eval ns aaa]] + list [namespace eval ns aaa bbb] [namespace eval ns aaa] +} -cleanup { rename unknown {} rename _unknown unknown namespace delete ns - set l -} {global global} +} -result {global global} test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} { set res {} @@ -1447,7 +1453,6 @@ test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} { namespace delete ns set res } {0 1} - test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} { set res {} namespace eval ns {} @@ -1461,19 +1466,16 @@ test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} { namespace delete ns set res } {New proc is called} - test namespace-41.3 {Shadowing byte-compiled commands, Bugs: 231259, 729692} { set res {} namespace eval ns { variable b 0 } - proc ns::a {i} { variable b proc set args {return "New proc is called"} return [set b $i] } - set res [list [ns::a 1] $ns::b] namespace delete ns set res @@ -1512,18 +1514,18 @@ test namespace-42.3 {ensembles: basic} { namespace delete ns lappend result [info command ns::x1] } {1 2 1 {unknown or ambiguous subcommand "x": must be x1, or x2} ::ns::x1 {}} -test namespace-42.4 {ensembles: basic} { +test namespace-42.4 {ensembles: basic} -body { namespace eval ns { namespace export y* proc x1 {} {format 1} proc x2 {} {format 2} namespace ensemble create } - set result [list [catch {ns x} msg] $msg] + list [catch {ns x} msg] $msg +} -cleanup { namespace delete ns - set result -} {1 {unknown subcommand "x": namespace ::ns does not export any commands}} -test namespace-42.5 {ensembles: basic} { +} -result {1 {unknown subcommand "x": namespace ::ns does not export any commands}} +test namespace-42.5 {ensembles: basic} -body { namespace eval ns { namespace export x* proc x1 {} {format 1} @@ -1531,11 +1533,11 @@ test namespace-42.5 {ensembles: basic} { proc x3 {} {format 3} namespace ensemble create } - set result [list [catch {ns x} msg] $msg] + list [catch {ns x} msg] $msg +} -cleanup { namespace delete ns - set result -} {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}} -test namespace-42.6 {ensembles: nested} { +} -result {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}} +test namespace-42.6 {ensembles: nested} -body { namespace eval ns { namespace export x* namespace eval x0 { @@ -1548,11 +1550,11 @@ test namespace-42.6 {ensembles: nested} { proc x3 {} {format 3} namespace ensemble create } - set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]] + list [ns x0 z] [ns x1] [ns x2] [ns x3] +} -cleanup { namespace delete ns - set result -} {0 1 2 3} -test namespace-42.7 {ensembles: nested} { +} -result {0 1 2 3} +test namespace-42.7 {ensembles: nested} -body { namespace eval ns { namespace export x* namespace eval x0 { @@ -1565,10 +1567,10 @@ test namespace-42.7 {ensembles: nested} { proc x3 {} {format 3} namespace ensemble create } - set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]] + list [ns x0 z] [ns x1] [ns x2] [ns x3] +} -cleanup { namespace delete ns - set result -} {{1 ::ns::x0::z} 1 2 3} +} -result {{1 ::ns::x0::z} 1 2 3} test namespace-42.8 {ensembles: [Bug 1670091]} -setup { proc demo args {} variable target [list [namespace which demo] x] @@ -1595,7 +1597,7 @@ test namespace-43.1 {ensembles: dict-driven} { rename ns {} lappend result [namespace ensemble exists ns] } {1 {unknown or ambiguous subcommand "c": must be a, or b} 1 0} -test namespace-43.2 {ensembles: dict-driven} { +test namespace-43.2 {ensembles: dict-driven} -body { namespace eval ns { namespace export x* proc x1 {args} {list 1 $args} @@ -1604,10 +1606,10 @@ test namespace-43.2 {ensembles: dict-driven} { a ::ns::x1 b ::ns::x2 c {::ns::x1 .} d {::ns::x2 .} } } - set result [list [ns a] [ns b] [ns c] [ns c foo] [ns d] [ns d foo]] + list [ns a] [ns b] [ns c] [ns c foo] [ns d] [ns d foo] +} -cleanup { namespace delete ns - set result -} {{1 {}} {2 0} {1 .} {1 {. foo}} {2 1} {2 2}} +} -result {{1 {}} {2 0} {1 .} {1 {. foo}} {2 1} {2 2}} set SETUP { namespace eval ns { namespace export a b @@ -2481,7 +2483,7 @@ test namespace-51.16 {Bug 1566526} { test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup { set result {} catch {namespace delete ::a} -} -constraints knownBug -body { +} -body { namespace eval ::a { proc c {} {lappend ::result A} c @@ -2518,6 +2520,22 @@ test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup { catch {rename ::c {}} unset result } -result {A 1 . A A . B B . B B . B B . B B . G G} +test namespace-51.18 {Bug 3185407} -setup { + namespace eval ::test_ns_1 {} +} -body { + namespace eval ::test_ns_1 { + variable result {} + namespace eval ns {proc foo {} {}} + namespace eval ns2 {proc foo {} {}} + namespace path {ns ns2} + variable x foo + lappend result [namespace which $x] + proc foo {} {} + lappend result [namespace which $x] + } +} -cleanup { + namespace delete ::test_ns_1 +} -result {::test_ns_1::ns::foo ::test_ns_1::foo} # TIP 181 - namespace unknown tests test namespace-52.1 {unknown: default handler ::unknown} { @@ -2914,7 +2932,7 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ rename getbytes {} unset i ns start end } -result 0 - + # cleanup catch {rename cmd1 {}} catch {unset l} diff --git a/tests/notify.test b/tests/notify.test index 0d80132..d2b9123 100755 --- a/tests/notify.test +++ b/tests/notify.test @@ -12,14 +12,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: notify.test,v 1.3 2003/10/06 14:32:22 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testevent [llength [info commands testevent]] test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \ diff --git a/tests/nre.test b/tests/nre.test index dcc2180..b8ef2e0 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -8,14 +8,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: nre.test,v 1.12 2010/01/21 17:23:49 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testnrelevels [llength [info commands testnrelevels]] # @@ -62,7 +63,7 @@ if {[testConstraint testnrelevels]} { } namespace import testnre::* } - + test nre-1.1 {self-recursive procs} -setup { proc a i [makebody {a $i}] } -body { @@ -163,7 +164,7 @@ test nre-5.1 {[namespace eval] is not recursive} -setup { namespace delete ::foo } -constraints { testnrelevels -} -result {{0 2 2 2} 0} +} -result {{0 3 2 2} 0} test nre-5.2 {[namespace eval] is not recursive} -setup { namespace eval ::foo { @@ -176,7 +177,7 @@ test nre-5.2 {[namespace eval] is not recursive} -setup { namespace delete ::foo } -constraints { testnrelevels -} -result {{0 2 2 2} 0} +} -result {{0 3 2 2} 0} test nre-6.1 {[uplevel] is not recursive} -setup { proc a i [makebody {uplevel 1 [list a $i]}] @@ -304,7 +305,7 @@ test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { test nre-8.1 {nre and {*}} -body { # force an expansion that grows the evaluation stack, check that nre - # adapts the bottomPtr. This crashes on failure. + # adapts the TEBCdataPtr. This crashes on failure. proc inner {} { set long [lrepeat 1000000 1] @@ -413,23 +414,24 @@ test nre-oo.5 {really deep calls in oo - forwards} -setup { # NASTY BUG found by tcllib's interp package # -test nre-X.1 {eval in wrong interp} { +test nre-X.1 {eval in wrong interp} -setup { set i [interp create] - set res [$i eval { + $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}} +} -body { + $i eval { set x {namespace children ::} set y [list namespace children ::] - namespace delete {*}[{*}$y] + namespace delete {*}[filter [{*}$y]] set j [interp create] - $j eval {namespace delete {*}[namespace children ::]} + $j alias filter filter + $j eval {namespace delete {*}[filter [namespace children ::]]} namespace eval foo {} - set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]] - interp delete $j - set res - }] + list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]] + } +} -cleanup { interp delete $i - set res -} {::foo ::foo {} {}} - +} -result {::foo ::foo {} {}} + # cleanup ::tcltest::cleanupTests @@ -439,3 +441,8 @@ if {[testConstraint testnrelevels]} { } return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/obj.test b/tests/obj.test index f9c0a2d..71a39b4 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -10,14 +10,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: obj.test,v 1.21 2007/12/13 15:26:07 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testobj [llength [info commands testobj]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] diff --git a/tests/oo.test b/tests/oo.test index 50edb11..5d34077 100644 --- a/tests/oo.test +++ b/tests/oo.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 (c) 2006-2012 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.39 2010/03/24 13:21:11 dkf Exp $ -package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +package require TclOO 1.0 +package require tcltest 2 +if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } @@ -31,15 +29,9 @@ if {[testConstraint memory]} { return [expr {$end - $tmp}] } } - -proc initInterpreter name { - $name eval [list package ifneeded TclOO [package provide TclOO] \ - [package ifneeded TclOO [package provide TclOO]]] -} test oo-0.1 {basic test of OO's ability to clean up its initial state} { interp create t - initInterpreter t t eval { package require TclOO } @@ -47,11 +39,11 @@ test oo-0.1 {basic test of OO's ability to clean up its initial state} { } {} test oo-0.2 {basic test of OO's ability to clean up its initial state} { set i [interp create] - initInterpreter $i interp eval $i { package require TclOO namespace delete :: } + interp delete $i } {} test oo-0.3 {basic test of OO's ability to clean up its initial state} -body { leaktest { @@ -74,7 +66,6 @@ test oo-0.5 {testing literal leak on interp delete} memory { } 0 test oo-0.6 {cleaning the core class pair; way #1} -setup { interp create t - initInterpreter t } -body { t eval { package require TclOO @@ -86,7 +77,6 @@ test oo-0.6 {cleaning the core class pair; way #1} -setup { } -result {0 {} 1 {invalid command name "object"}} test oo-0.7 {cleaning the core class pair; way #2} -setup { interp create t - initInterpreter t } -body { t eval { package require TclOO @@ -96,6 +86,22 @@ test oo-0.7 {cleaning the core class pair; way #2} -setup { } -cleanup { interp delete t } -result {0 {} 1 {invalid command name "class"}} +test oo-0.8 {leak in variable management} -setup { + oo::class create foo +} -constraints memory -body { + oo::define foo { + constructor {} { + variable v 0 + } + } + leaktest {[foo new] destroy} +} -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-1.1 {basic test of OO functionality: no classes} { set result {} @@ -125,6 +131,13 @@ test oo-1.4 {basic test of OO functionality} -body { 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} +test oo-1.5.1 {basic test of OO functionality} -setup { + oo::object create aninstance +} -returnCodes error -body { + aninstance +} -cleanup { + rename aninstance {} +} -result {wrong # args: should be "aninstance method ?arg ...?"} test oo-1.6 {basic test of OO functionality} -setup { oo::object create aninstance } -body { @@ -262,7 +275,6 @@ 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 - initInterpreter subinterp subinterp eval { package require TclOO } @@ -325,12 +337,50 @@ test oo-2.6 {OO constructor and tailcall - Bug 2414858} -setup { } -cleanup { foo destroy } -result good +test oo-2.7 {construction, method calls and ensembles - Bug 3514761} -setup { + namespace eval k {} +} -body { + namespace eval k { + oo::class create s { + constructor {j} { + # nothing + } + } + namespace export s + namespace ensemble create + } + k s create X +} -returnCodes error -cleanup { + namespace delete k +} -result {wrong # args: should be "k s create X j"} +test oo-2.8 {construction, method calls and ensembles - Bug 3514761} -setup { + namespace eval k {} +} -body { + namespace eval k { + oo::class create s { + constructor {j} { + # nothing + } + } + oo::class create t { + superclass s + constructor args { + k next {*}$args + } + } + interp alias {} ::k::next {} ::oo::Helpers::next + namespace export t next + namespace ensemble create + } + k t create X +} -returnCodes error -cleanup { + namespace delete k +} -result {wrong # args: should be "k next j"} 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 - initInterpreter subinterp subinterp eval { package require TclOO } @@ -351,7 +401,6 @@ test oo-3.2 {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 - initInterpreter subinterp subinterp eval { package require TclOO } @@ -745,6 +794,148 @@ test oo-6.7 {OO: forward resolution scope is per-object} -setup { } -cleanup { fooClass destroy } -result 1 +test oo-6.8 {Bug 3400658: forwarding and wrongargs rewriting} -setup { + oo::class create fooClass +} -body { + oo::define fooClass { + forward test my handler + method handler {a b c} {} + } + fooClass create ::foo + foo test +} -returnCodes error -cleanup { + fooClass destroy +} -result {wrong # args: should be "foo test a b c"} +test oo-6.9 {Bug 3400658: forwarding and wrongargs rewriting} -setup { + oo::class create fooClass +} -body { + oo::define fooClass { + forward test my handler + method handler {a b c} {list $a,$b,$c} + } + fooClass create ::foo + foo test 1 2 3 +} -cleanup { + fooClass destroy +} -result 1,2,3 +test oo-6.10 {Bug 3400658: forwarding and wrongargs rewriting} -setup { + oo::class create fooClass +} -body { + oo::define fooClass { + forward test my handler + method handler {a b c} {list $a,$b,$c} + } + fooClass create ::foo + foo test 1 2 +} -returnCodes error -cleanup { + fooClass destroy +} -result {wrong # args: should be "foo test a b c"} +test oo-6.11 {Bug 3400658: forwarding and wrongargs rewriting} -setup { + oo::object create foo +} -body { + oo::objdefine foo { + forward test my handler + method handler {a b c} {} + } + foo test +} -returnCodes error -cleanup { + foo destroy +} -result {wrong # args: should be "foo test a b c"} +test oo-6.12 {Bug 3400658: forwarding and wrongargs rewriting} -setup { + oo::object create foo +} -body { + oo::objdefine foo { + forward test my handler + method handler {a b c} {list $a,$b,$c} + } + foo test 1 2 3 +} -cleanup { + foo destroy +} -result 1,2,3 +test oo-6.13 {Bug 3400658: forwarding and wrongargs rewriting} -setup { + oo::object create foo +} -body { + oo::objdefine foo { + forward test my handler + method handler {a b c} {list $a,$b,$c} + } + foo test 1 2 +} -returnCodes error -cleanup { + foo destroy +} -result {wrong # args: should be "foo test a b c"} +test oo-6.14 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup { + oo::class create fooClass +} -body { + oo::define fooClass { + forward test my handler1 p + forward handler1 my handler q + method handler {a b c} {} + } + fooClass create ::foo + foo test +} -returnCodes error -cleanup { + fooClass destroy +} -result {wrong # args: should be "foo test c"} +test oo-6.15 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup { + oo::class create fooClass +} -body { + oo::define fooClass { + forward test my handler1 p + forward handler1 my handler q + method handler {a b c} {list $a,$b,$c} + } + fooClass create ::foo + foo test 1 +} -cleanup { + fooClass destroy +} -result q,p,1 +test oo-6.16 {Bug 3400658: forwarding and wrongargs rewriting - via alias} -setup { + oo::class create fooClass +} -body { + oo::define fooClass { + forward test handler1 foo bar + forward handler2 my handler x + method handler {a b c d} {list $a,$b,$c,$d} + export eval + } + fooClass create ::foo + foo eval { + interp alias {} [namespace current]::handler1 \ + {} [namespace current]::my handler2 + } + foo test 1 2 3 +} -returnCodes error -cleanup { + fooClass destroy +} -result {wrong # args: should be "foo test d"} +test oo-6.17 {Bug 3400658: forwarding and wrongargs rewriting - via ensemble} -setup { + oo::class create fooClass +} -body { + oo::define fooClass { + forward test handler1 foo bar boo + forward handler2 my handler + method handler {a b c d} {list $a,$b,$c,$d} + export eval + } + fooClass create ::foo + foo eval { + namespace ensemble create \ + -command [namespace current]::handler1 -parameters {p q} \ + -map [list boo [list [namespace current]::my handler2]] + } + foo test 1 2 3 +} -returnCodes error -cleanup { + fooClass destroy +} -result {wrong # args: should be "foo test c d"} +test oo-6.18 {Bug 3408830: more forwarding cases} -setup { + oo::class create fooClass +} -body { + oo::define fooClass { + forward len string length + } + [fooClass create foo] len a b +} -returnCodes error -cleanup { + fooClass destroy +} -result {wrong # args: should be "::foo len string"} test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass @@ -1505,6 +1696,86 @@ test oo-15.3 {OO: class cloning} { bar destroy return $result } {::foo->::baseline ::foo->::baseline ::bar->::tester ::bar->::tester} +test oo-15.4 {OO: object cloning - Bug 3474460} -setup { + oo::class create ArbitraryClass +} -body { + ArbitraryClass create foo + oo::objdefine foo variable a b c + oo::copy foo bar + info object variable bar +} -cleanup { + ArbitraryClass destroy +} -result {a b c} +test oo-15.5 {OO: class cloning - Bug 3474460} -setup { + oo::class create ArbitraryClass +} -body { + oo::class create Foo { + superclass ArbitraryClass + variable a b c + } + oo::copy Foo Bar + info class variable Bar +} -cleanup { + ArbitraryClass destroy +} -result {a b c} +test oo-15.6 {OO: object cloning copies namespace contents} -setup { + oo::class create ArbitraryClass {export eval} +} -body { + ArbitraryClass create a + a eval {proc foo x { + variable y + return [string repeat $x [incr y]] + }} + set result [list [a eval {foo 2}] [a eval {foo 3}]] + oo::copy a b + a eval {rename foo bar} + lappend result [b eval {foo 2}] [b eval {foo 3}] [a eval {bar 4}] +} -cleanup { + ArbitraryClass destroy +} -result {2 33 222 3333 444} +test oo-15.7 {OO: classes can be cloned anonymously} -setup { + oo::class create ArbitraryClassA + oo::class create ArbitraryClassB {superclass ArbitraryClassA} +} -body { + info object isa class [oo::copy ArbitraryClassB] +} -cleanup { + ArbitraryClassA destroy +} -result 1 +test oo-15.8 {OO: intercept object cloning} -setup { + oo::class create Foo + set result {} +} -body { + oo::define Foo { + constructor {msg} { + variable v $msg + } + method <cloned> {from} { + next $from + lappend ::result cloned $from [self] + } + method check {} { + variable v + lappend ::result check [self] $v + } + } + Foo create foo ok + oo::copy foo bar + foo check + bar check +} -cleanup { + Foo destroy +} -result {cloned ::foo ::bar check ::foo ok check ::bar ok} +test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup { + oo::class create Foo +} -body { + oo::define Foo { + method <cloned> {a b} {} + } + interp alias {} Bar {} oo::copy [Foo create foo] + Bar bar +} -returnCodes error -cleanup { + Foo destroy +} -result {wrong # args: should be "::bar <cloned> a b"} test oo-16.1 {OO: object introspection} -body { info object @@ -1514,7 +1785,7 @@ test oo-16.2 {OO: object introspection} -body { } -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 class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, 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 @@ -1600,10 +1871,10 @@ test oo-16.11 {OO: object introspection} -setup { } -body { oo::define foo method spong {} {...} oo::objdefine bar method boo {a {b c} args} {the body} - list [info object methods bar -all] [info object methods bar -all -private] + list [lsort [info object methods bar -all]] [lsort [info object methods bar -all -private]] } -cleanup { foo destroy -} -result {{boo destroy spong} {boo destroy eval spong unknown variable varname}} +} -result {{boo destroy spong} {<cloned> boo destroy eval spong unknown variable varname}} test oo-16.12 {OO: object introspection} -setup { oo::object create foo } -cleanup { @@ -1636,7 +1907,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 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, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables} test oo-17.5 {OO: class introspection} -setup { oo::class create testClass } -body { @@ -1684,11 +1955,11 @@ test oo-17.9 {OO: class introspection} -setup { } } oo::define subfoo method boo {a {b c} args} {the body} - list [info class methods subfoo -all] \ - [info class methods subfoo -all -private] + list [lsort [info class methods subfoo -all]] \ + [lsort [info class methods subfoo -all -private]] } -cleanup { foo destroy -} -result {{bar boo destroy} {bar boo destroy eval unknown variable varname}} +} -result {{bar boo destroy} {<cloned> bar boo destroy eval unknown variable varname}} test oo-17.10 {OO: class introspection} -setup { oo::class create foo } -cleanup { @@ -1703,7 +1974,7 @@ test oo-18.1 {OO: define command support} { } {1 foo {foo while executing "error foo" - (in definition script for object "oo::object" line 1) + (in definition script for class "::oo::object" line 1) invoked from within "oo::define oo::object {error foo}"}} test oo-18.2 {OO: define command support} { @@ -1716,7 +1987,7 @@ test oo-18.3 {OO: define command support} { } {1 bar {bar while executing "error bar" - (in definition script for object "::foo" line 1) + (in definition script for class "::foo" line 1) invoked from within "oo::class create foo {error bar}"}} test oo-18.3a {OO: define command support} { @@ -1726,7 +1997,7 @@ test oo-18.3a {OO: define command support} { } {1 bar {bar while executing "error bar" - (in definition script for object "::foo" line 2) + (in definition script for class "::foo" line 2) invoked from within "oo::class create foo { error bar @@ -1744,7 +2015,7 @@ test oo-18.3b {OO: define command support} { ("eval" body line 1) invoked from within "eval eval error bar" - (in definition script for object "::foo" line 2) + (in definition script for class "::foo" line 2) invoked from within "oo::class create foo { eval eval error bar @@ -1799,6 +2070,106 @@ test oo-18.5 {OO: more error traces from the guts} -setup { (class "::cls" method "eval" line 1) invoked from within "obj eval {error bar}"}} +test oo-18.6 {class construction reference management and errors} -setup { + oo::class create super_abc +} -body { + catch { +oo::class create abc { + superclass super_abc + ::rename abc ::def + ::error foo +} + } msg opt + dict get $opt -errorinfo +} -cleanup { + super_abc destroy +} -result {foo + while executing +"::error foo" + (in definition script for class "::def" line 4) + invoked from within +"oo::class create abc { + superclass super_abc + ::rename abc ::def + ::error foo +}"} +test oo-18.7 {OO: objdefine command support} -setup { + oo::object create ::inst +} -body { + list [catch {oo::objdefine inst {rename ::inst ::INST;error foo}} msg] $msg $errorInfo +} -cleanup { + catch {::inst destroy} + catch {::INST destroy} +} -result {1 foo {foo + while executing +"error foo" + (in definition script for object "::INST" line 1) + 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} +} -body { + catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt + dict get $opt -errorinfo +} -cleanup { + master destroy +} -result {foobar + while executing +"error foobar" + (in definition script for class object "::bar" line 1) + invoked from within +"self {error foobar}" + (in definition script for class "::bar" line 1) + 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 + set c [oo::class create now_this_is_a_very_very_long_class_name_indeed { + superclass master + }] +} -body { + catch {oo::define $c {error err}} msg opt + dict get $opt -errorinfo +} -cleanup { + master destroy +} -result {err + while executing +"error err" + (in definition script for class "::now_this_is_a_very_very_long..." line 1) + 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} +} -body { + catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt + dict get $opt -errorinfo +} -cleanup { + master destroy +} -result {foobar + while executing +"error foobar" + (in definition script for class object "::foo" line 1) + invoked from within +"self {rename ::foo {}; error foobar}" + (in definition script for class "::foo" line 1) + 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} +} -body { + catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt + dict get $opt -errorinfo +} -cleanup { + master destroy +} -result {this command cannot be called when the object has been deleted + while executing +"self {error foobar}" + (in definition script for class "::foo" line 1) + invoked from within +"oo::define foo {rename ::foo {}; self {error foobar}}"} test oo-19.1 {OO: varname method} -setup { oo::object create inst @@ -2044,6 +2415,18 @@ test oo-20.15 {OO: variable method use in non-methods [Bug 2903811]} -setup { apply {{} {fooObj variable x; set x ok; return}} return [set [fooObj varname x]] } -result ok +test oo-20.16 {variable method: leak per instance} -setup { + oo::class create foo +} -constraints memory -body { + oo::define foo { + constructor {} { + set [my variable v] 0 + } + } + leaktest {[foo new] destroy} +} -cleanup { + foo destroy +} -result 0 test oo-21.1 {OO: inheritance ordering} -setup { oo::class create A @@ -2210,7 +2593,19 @@ test oo-22.1 {OO and info frame} -setup { list [i level] [i frames] [dict get [c frame] object] } -cleanup { c destroy -} -result {1 {{type source line * file * cmd {info frame 0} method frames class ::c level 0} {type source line * file * cmd {info frame 0} method frames object ::i level 0}} ::c} +} -result {1 {{* cmd {info frame 0} method frames class ::c level 0} {* cmd {info frame 0} method frames object ::i level 0}} ::c} +test oo-22.2 {OO and info frame: Bug 3001438} -setup { + oo::class create c +} -body { + oo::define c method test {{x 1}} { + if {$x} {my test 0} + lsort {q w e r t y u i o p}; # Overwrite the Tcl stack + info frame 0 + } + [c new] test +} -match glob -cleanup { + c destroy +} -result {* cmd {info frame 0} method test class ::c level 0} # Prove that the issue in [Bug 1865054] isn't an issue any more test oo-23.1 {Self-like derivation; complex case!} -setup { @@ -2269,6 +2664,16 @@ test oo-24.2 {unknown method method - Bug 1965063} -setup { } obj foo bar } -result {unknown method "foo": must be destroy, dummy, dummy2 or unknown} +test oo-24.3 {unknown method method - absent method name} -setup { + set o [oo::object new] +} -cleanup { + $o destroy +} -body { + oo::objdefine $o method unknown args { + return "unknown: >>$args<<" + } + list [$o] [$o foobar] [$o foo bar] +} -result {{unknown: >><<} {unknown: >>foobar<<} {unknown: >>foo bar<<}} # Probably need a better set of tests, but this is quite difficult to devise test oo-25.1 {call chain caching} -setup { @@ -2531,6 +2936,202 @@ test oo-27.11 {variables declaration - no instance var leaks with class resolver inst1 step list [inst1 value] [inst2 value] } -result {3 2} +test oo-27.12 {variables declaration: leak per instance} -setup { + oo::class create foo +} -constraints memory -body { + oo::define foo { + variable v + constructor {} { + set v 0 + } + } + leaktest {[foo new] destroy} +} -cleanup { + foo destroy +} -result 0 +# This test will actually (normally) crash if it fails! +test oo-27.13 {variables declaration: Bug 3185009: require refcount management} -setup { + oo::object create foo +} -body { + oo::objdefine foo { + variable x + method set v {set x $v} + method unset {} {unset x} + method exists {} {info exists x} + method get {} {return $x} + } + list [foo exists] [foo set 7] [foo exists] [foo get] [foo unset] \ + [foo exists] [catch {foo get} msg] $msg +} -cleanup { + 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 +} -cleanup { + master destroy +} -body { + oo::class create foo { + superclass master + variable x + variable y + method boo {} { + return [incr x],[incr y] + } + } + foo create bar + list [bar boo] [bar boo] +} -result {1,1 2,2} +test oo-27.15 {variables declaration - multiple use} -setup { + oo::class create master +} -cleanup { + master destroy +} -body { + oo::class create foo { + superclass master + variable + variable x y + method boo {} { + return [incr x],[incr y] + } + } + foo create bar + list [bar boo] [bar boo] +} -result {1,1 2,2} +test oo-27.16 {variables declaration - multiple use} -setup { + oo::class create master +} -cleanup { + master destroy +} -body { + oo::class create foo { + superclass master + variable x + variable -clear + variable y + method boo {} { + return [incr x],[incr y] + } + } + foo create bar + list [bar boo] [bar boo] +} -result {1,1 1,2} +test oo-27.17 {variables declaration - multiple use} -setup { + oo::class create master +} -cleanup { + master destroy +} -body { + oo::class create foo { + superclass master + variable x + variable -set y + method boo {} { + return [incr x],[incr y] + } + } + foo create bar + list [bar boo] [bar boo] +} -result {1,1 1,2} +test oo-27.18 {variables declaration - multiple use} -setup { + oo::class create master +} -cleanup { + master destroy +} -body { + oo::class create foo { + superclass master + variable x + variable -? y + method boo {} { + return [incr x],[incr y] + } + } + foo create bar + list [bar boo] [bar boo] +} -returnCodes error -match glob -result {unknown method "-?": must be *} +test oo-27.19 {variables declaration and [info vars]: Bug 2712377} -setup { + oo::class create Foo + set result {} +} -body { + # This is really a test of problems to do with Tcl's introspection when a + # variable resolver is present... + oo::define Foo { + variable foo bar + method setvars {f b} { + set foo $f + set bar $b + } + method dump1 {} { + lappend ::result <1> + foreach v [lsort [info vars *]] { + lappend ::result $v=[set $v] + } + lappend ::result [info locals] [info locals *] + } + method dump2 {} { + lappend ::result <2> + foreach v [lsort [info vars *]] { + lappend ::result $v=[set $v] + } + lappend ::result | foo=$foo [info locals] [info locals *] + } + } + Foo create stuff + stuff setvars what ever + stuff dump1 + stuff dump2 + return $result +} -cleanup { + Foo destroy +} -result {<1> bar=ever foo=what v v <2> bar=ever foo=what | foo=what v v} +test oo-27.20 {variables declaration and [info vars]: Bug 2712377} -setup { + oo::class create Foo + set result {} +} -body { + # This is really a test of problems to do with Tcl's introspection when a + # variable resolver is present... + oo::define Foo { + variable foo bar + method setvars {f b} { + set foo $f + set bar $b + } + method dump1 {} { + lappend ::result <1> + foreach v [lsort [info vars *o]] { + lappend ::result $v=[set $v] + } + lappend ::result [info locals] [info locals *] + } + method dump2 {} { + lappend ::result <2> + foreach v [lsort [info vars *o]] { + lappend ::result $v=[set $v] + } + lappend ::result | foo=$foo [info locals] [info locals *] + } + } + Foo create stuff + stuff setvars what ever + stuff dump1 + stuff dump2 + return $result +} -cleanup { + Foo destroy +} -result {<1> foo=what v v <2> foo=what | foo=what v v} +test oo-27.21 {variables declaration uniqueifies: Bug 3396896} -setup { + oo::class create Foo +} -body { + oo::define Foo variable v v v t t v t + info class variable Foo +} -cleanup { + Foo destroy +} -result {v t} +test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup { + oo::object create foo +} -body { + oo::objdefine foo variable v v v t t v t + info object variable foo +} -cleanup { + foo destroy +} -result {v t} # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... @@ -2578,6 +3179,182 @@ test oo-30.2 {Bug 2903011: deleting an object in a constructor} -setup { } -returnCodes error -cleanup { cls destroy } -result {object deleted in constructor} + +test oo-31.1 {Bug 3111059: when objects and coroutines entangle} -setup { + oo::class create cls +} -constraints memory -body { + oo::define cls { + method justyield {} { + yield + } + constructor {} { + coroutine coro my justyield + } + } + list [leaktest {[cls new] destroy}] [info class instances cls] +} -cleanup { + cls destroy +} -result {0 {}} +test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup { + oo::class create cls +} -constraints memory -body { + oo::define cls { + method justyield {} { + yield + } + constructor {} { + coroutine coro my justyield + } + destructor { + rename coro {} + } + } + list [leaktest {[cls new] destroy}] [info class instances cls] +} -cleanup { + 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 + } +} + +test oo-32.1 {TIP 380: slots - class test} -setup { + SampleSlot create sampleSlot +} -body { + list [info level] [sampleSlot contents] [sampleSlot ops] +} -cleanup { + rename sampleSlot {} +} -result {0 {a b c} {}} +test oo-32.2 {TIP 380: slots - class test} -setup { + SampleSlot create sampleSlot +} -body { + list [info level] [sampleSlot -clear] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup { + rename sampleSlot {} +} -result {0 {} {} {1 Set {}}} +test oo-32.3 {TIP 380: slots - class test} -setup { + SampleSlot create sampleSlot +} -body { + list [info level] [sampleSlot -append g h i] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup { + 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 { + SampleSlot create sampleSlot +} -body { + list [info level] [sampleSlot -set d e f] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup { + rename sampleSlot {} +} -result {0 {} {d e f} {1 Set {d e f}}} +test oo-32.5 {TIP 380: slots - class test} -setup { + SampleSlot create sampleSlot +} -body { + list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup { + 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}}} + +test oo-33.1 {TIP 380: slots - defaulting} -setup { + set s [SampleSlot new] +} -body { + list [$s x y] [$s contents] +} -cleanup { + rename $s {} +} -result {{} {a b c x y}} +test oo-33.2 {TIP 380: slots - defaulting} -setup { + set s [SampleSlot new] +} -body { + list [$s destroy; $s unknown] [$s contents] +} -cleanup { + rename $s {} +} -result {{} {a b c destroy unknown}} +test oo-33.3 {TIP 380: slots - defaulting} -setup { + set s [SampleSlot new] +} -body { + oo::objdefine $s forward --default-operation my -set + list [$s destroy; $s unknown] [$s contents] [$s ops] +} -cleanup { + rename $s {} +} -result {{} unknown {1 Set destroy 1 Set unknown}} +test oo-33.4 {TIP 380: slots - errors} -setup { + set s [SampleSlot new] +} -body { + # Method names beginning with "-" are special to slots + $s -grill q +} -returnCodes error -cleanup { + rename $s {} +} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops} + +SampleSlot destroy + +test oo-34.1 {TIP 380: slots - presence} -setup { + set obj [oo::object new] + set result {} +} -body { + oo::define oo::object { + ::lappend ::result [::info object class filter] + ::lappend ::result [::info object class mixin] + ::lappend ::result [::info object class superclass] + ::lappend ::result [::info object class variable] + } + oo::objdefine $obj { + ::lappend ::result [::info object class filter] + ::lappend ::result [::info object class mixin] + ::lappend ::result [::info object class variable] + } + return $result +} -cleanup { + $obj destroy +} -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot} +test oo-34.2 {TIP 380: slots - presence} { + lsort [info class instances oo::Slot] +} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} +proc getMethods obj { + list [lsort [info object methods $obj -all]] \ + [lsort [info object methods $obj -private]] +} +test oo-34.3 {TIP 380: slots - presence} { + getMethods oo::define::filter +} {{-append -clear -set} {Get Set}} +test oo-34.4 {TIP 380: slots - presence} { + getMethods oo::define::mixin +} {{-append -clear -set} {--default-operation Get Set}} +test oo-34.5 {TIP 380: slots - presence} { + getMethods oo::define::superclass +} {{-append -clear -set} {--default-operation Get Set}} +test oo-34.6 {TIP 380: slots - presence} { + getMethods oo::define::variable +} {{-append -clear -set} {Get Set}} +test oo-34.7 {TIP 380: slots - presence} { + getMethods oo::objdefine::filter +} {{-append -clear -set} {Get Set}} +test oo-34.8 {TIP 380: slots - presence} { + getMethods oo::objdefine::mixin +} {{-append -clear -set} {--default-operation Get Set}} +test oo-34.9 {TIP 380: slots - presence} { + getMethods oo::objdefine::variable +} {{-append -clear -set} {Get Set}} cleanupTests return diff --git a/tests/ooNext2.test b/tests/ooNext2.test new file mode 100644 index 0000000..d77e8d1 --- /dev/null +++ b/tests/ooNext2.test @@ -0,0 +1,788 @@ +# This file contains a collection of tests for Tcl's built-in object system. +# 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 +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require TclOO 1.0 +package require tcltest 2 +if {"::tcltest" in [namespace children]} { + namespace import -force ::tcltest::* +} + +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 oo-nextto-1.1 {basic nextto functionality} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x args { + lappend ::result ==A== $args + } + } + oo::class create B { + superclass A + method x args { + lappend ::result ==B== $args + nextto A B -> A {*}$args + } + } + oo::class create C { + superclass A + method x args { + lappend ::result ==C== $args + nextto A C -> A {*}$args + } + } + oo::class create D { + superclass B C + method x args { + lappend ::result ==D== $args + next foo + nextto C bar + } + } + set ::result {} + [D new] x + return $::result +} -cleanup { + root destroy +} -result {==D== {} ==B== foo ==A== {B -> A foo} ==C== bar ==A== {C -> A bar}} +test oo-nextto-1.2 {basic nextto functionality} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x args { + lappend ::result ==A== $args + } + } + oo::class create B { + superclass A + method x args { + lappend ::result ==B== $args + nextto A B -> A {*}$args + } + } + oo::class create C { + superclass A + method x args { + lappend ::result ==C== $args + nextto A C -> A {*}$args + } + } + oo::class create D { + superclass B C + method x args { + lappend ::result ==D== $args + nextto B foo {*}$args + nextto C bar {*}$args + } + } + set ::result {} + [D new] x 123 + return $::result +} -cleanup { + root destroy +} -result {==D== 123 ==B== {foo 123} ==A== {B -> A foo 123} ==C== {bar 123} ==A== {C -> A bar 123}} +test oo-nextto-1.3 {basic nextto functionality: constructors} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + variable result + constructor {a c} { + lappend result ==A== a=$a,c=$c + } + } + oo::class create B { + superclass root + variable result + constructor {b} { + lappend result ==B== b=$b + } + } + oo::class create C { + superclass A B + variable result + constructor {p q r} { + lappend result ==C== p=$p,q=$q,r=$r + # Route arguments to superclasses, in non-trival pattern + nextto B $q + nextto A $p $r + } + method result {} {return $result} + } + [C new x y z] result +} -cleanup { + root destroy +} -result {==C== p=x,q=y,r=z ==B== b=y ==A== a=x,c=z} +test oo-nextto-1.4 {basic nextto functionality: destructors} -setup { + oo::class create root {destructor return} +} -body { + oo::class create A { + superclass root + destructor { + lappend ::result ==A== + next + } + } + oo::class create B { + superclass root + destructor { + lappend ::result ==B== + next + } + } + oo::class create C { + superclass A B + destructor { + lappend ::result ==C== + lappend ::result | + nextto B + lappend ::result | + nextto A + lappend ::result | + next + } + } + set ::result "" + [C new] destroy + return $::result +} -cleanup { + root destroy +} -result {==C== | ==B== | ==A== ==B== | ==A== ==B==} + +test oo-nextto-2.1 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {error $y} + } + oo::class create B { + superclass A + method x y {nextto A $y} + } + [B new] x boom +} -cleanup { + root destroy +} -result boom -returnCodes error +test oo-nextto-2.2 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {error $y} + } + oo::class create B { + superclass root + method x y {nextto A $y} + } + [B new] x boom +} -returnCodes error -cleanup { + root destroy +} -result {method has no non-filter implementation by "A"} +test oo-nextto-2.3 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + method x y {nextto A $y} + } + [B new] x B +} -returnCodes error -cleanup { + root destroy +} -result {method implementation by "B" not reachable from here} +test oo-nextto-2.4 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + method x y {nextto} + } + [B new] x B +} -returnCodes error -cleanup { + root destroy +} -result {wrong # args: should be "nextto class ?arg...?"} +test oo-nextto-2.5 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + method x y {nextto $y $y $y} + } + [B new] x A +} -cleanup { + root destroy +} -result {wrong # args: should be "nextto A y"} -returnCodes error +test oo-nextto-2.6 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + method x y {nextto $y $y $y} + } + [B new] x [root create notAClass] +} -cleanup { + root destroy +} -result {"::notAClass" is not a class} -returnCodes error +test oo-nextto-2.7 {errors in nextto} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x y {nextto $y} + } + oo::class create B { + superclass A + filter Y + method Y args {next {*}$args} + } + oo::class create C { + superclass B + method x y {nextto $y $y $y} + } + [C new] x B +} -returnCodes error -cleanup { + root destroy +} -result {method has no non-filter implementation by "B"} + +test oo-call-1.1 {object call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + A create y + info object call y x +} -cleanup { + root destroy +} -result {{method x ::A method}} +test oo-call-1.2 {object call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{method x ::B method} {method x ::A method}} +test oo-call-1.3 {object call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + A create y + oo::objdefine y method x {} {} + info object call y x +} -cleanup { + root destroy +} -result {{method x object method} {method x ::A method}} +test oo-call-1.4 {object object call introspection - unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + A create y + info object call y z +} -cleanup { + root destroy +} -result {{unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-1.5 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + A create y + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {method x ::A method}} +test oo-call-1.6 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method x {} {} + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {method x ::B method} {method x ::A method}} +test oo-call-1.7 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}} +test oo-call-1.8 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + method z {} {} + filter z + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}} +test oo-call-1.9 {object call introspection - filters} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + method z {} {} + filter z + } + B create y + info object call y y +} -cleanup { + root destroy +} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method y ::B method} {method y ::A method}} +test oo-call-1.10 {object call introspection - filters + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + filter y + } + oo::class create ::B { + superclass A + method y {} {} + method unknown {} {} + } + B create y + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::B method} {filter y ::A method} {unknown unknown ::B method} {unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-1.11 {object call introspection - filters + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + filter y + } + A create y + oo::objdefine y method unknown {} {} + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-1.12 {object call introspection - filters + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + } + A create y + oo::objdefine y { + method unknown {} {} + filter y + } + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-1.13 {object call introspection - filters + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method y {} {} + } + A create y + oo::objdefine y { + method unknown {} {} + method x {} {} + filter y + } + info object call y x +} -cleanup { + root destroy +} -result {{filter y ::A method} {method x object method}} +test oo-call-1.14 {object call introspection - errors} -body { + info object call +} -returnCodes error -result {wrong # args: should be "info object call objName methodName"} +test oo-call-1.15 {object call introspection - errors} -body { + info object call a +} -returnCodes error -result {wrong # args: should be "info object call objName methodName"} +test oo-call-1.16 {object call introspection - errors} -body { + info object call a b c +} -returnCodes error -result {wrong # args: should be "info object call objName methodName"} +test oo-call-1.17 {object call introspection - errors} -body { + info object call notanobject x +} -returnCodes error -result {notanobject does not refer to an object} +test oo-call-1.18 {object call introspection - memory leaks} -body { + leaktest { + info object call oo::object destroy + } +} -constraints memory -result 0 +test oo-call-1.19 {object call introspection - memory leaks} -setup { + oo::class create leaktester { method foo {} {dummy} } +} -body { + leaktest { + set lt [leaktester new] + oo::objdefine $lt method foobar {} {dummy} + list [info object call $lt destroy] \ + [info object call $lt foo] \ + [info object call $lt bar] \ + [info object call $lt foobar] \ + [$lt destroy] + } +} -cleanup { + leaktester destroy +} -constraints memory -result 0 + +test oo-call-2.1 {class call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + info class call A x +} -cleanup { + root destroy +} -result {{method x ::A method}} +test oo-call-2.2 {class call introspection} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + } + list [info class call A x] [info class call B x] +} -cleanup { + root destroy +} -result {{{method x ::A method}} {{method x ::B method} {method x ::A method}}} +test oo-call-2.3 {class call introspection} -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 A + method x {} {} + } + oo::class create ::D { + superclass C B + method x {} {} + } + info class call D x +} -cleanup { + root destroy +} -result {{method x ::D method} {method x ::C method} {method x ::B method} {method x ::A method}} +test oo-call-2.4 {class call introspection - mixin} -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 A + method x {} {} + } + oo::class create ::D { + superclass C + mixin B + method x {} {} + } + info class call D x +} -cleanup { + root destroy +} -result {{method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}} +test oo-call-2.5 {class call introspection - mixin + filter} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + filter y + } + oo::class create ::C { + superclass A + method x {} {} + method y {} {} + } + oo::class create ::D { + superclass C + mixin B + method x {} {} + } + info class call D x +} -cleanup { + root destroy +} -result {{filter y ::B method} {filter y ::C method} {method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}} +test oo-call-2.6 {class call introspection - mixin + filter + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + method unknown {} {} + } + oo::class create ::B { + superclass A + method x {} {} + method y {} {} + filter y + } + oo::class create ::C { + superclass A + method x {} {} + method y {} {} + } + oo::class create ::D { + superclass C + mixin B + method x {} {} + method unknown {} {} + } + info class call D z +} -cleanup { + root destroy +} -result {{filter y ::B method} {filter y ::C method} {unknown unknown ::D method} {unknown unknown ::A method} {unknown unknown ::oo::object {core method: "unknown"}}} +test oo-call-2.7 {class call introspection - mixin + filter + unknown} -setup { + oo::class create root +} -body { + oo::class create ::A { + superclass root + method x {} {} + } + oo::class create ::B { + superclass A + method x {} {} + filter x + } + info class call B x +} -cleanup { + root destroy +} -result {{filter x ::B method} {filter x ::A method} {method x ::B method} {method x ::A method}} +test oo-call-2.8 {class call introspection - errors} -body { + info class call +} -returnCodes error -result {wrong # args: should be "info class call className methodName"} +test oo-call-2.9 {class call introspection - errors} -body { + info class call a +} -returnCodes error -result {wrong # args: should be "info class call className methodName"} +test oo-call-2.10 {class call introspection - errors} -body { + info class call a b c +} -returnCodes error -result {wrong # args: should be "info class call className methodName"} +test oo-call-2.11 {class call introspection - errors} -body { + info class call notaclass x +} -returnCodes error -result {notaclass does not refer to an object} +test oo-call-2.12 {class call introspection - errors} -setup { + oo::class create root +} -body { + root create notaclass + info class call notaclass x +} -returnCodes error -cleanup { + root destroy +} -result {"notaclass" is not a class} +test oo-call-2.13 {class call introspection - memory leaks} -body { + leaktest { + info class call oo::class destroy + } +} -constraints memory -result 0 +test oo-call-2.14 {class call introspection - memory leaks} -body { + leaktest { + oo::class create leaktester { method foo {} {dummy} } + [leaktester new] destroy + list [info class call leaktester destroy] \ + [info class call leaktester foo] \ + [info class call leaktester bar] \ + [leaktester destroy] + } +} -constraints memory -result 0 + +test oo-call-3.1 {current call introspection} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + method x {} {lappend ::result [self call]} + } + oo::class create B { + superclass A + method x {} {lappend ::result [self call];next} + } + B create y + oo::objdefine y method x {} {lappend ::result [self call];next} + set ::result {} + y x +} -cleanup { + root destroy +} -result {{{{method x object method} {method x ::B method} {method x ::A method}} 0} {{{method x object method} {method x ::B method} {method x ::A method}} 1} {{{method x object method} {method x ::B method} {method x ::A method}} 2}} +test oo-call-3.2 {current call introspection} -setup { + oo::class create root +} -constraints memory -body { + oo::class create A { + superclass root + method x {} {self call} + } + oo::class create B { + superclass A + method x {} {self call;next} + } + B create y + oo::objdefine y method x {} {self call;next} + leaktest { + y x + } +} -cleanup { + root destroy +} -result 0 +test oo-call-3.3 {current call introspection: in constructors} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + constructor {} {lappend ::result [self call]} + } + oo::class create B { + superclass A + constructor {} {lappend ::result [self call]; next} + } + set ::result {} + [B new] destroy + return $::result +} -cleanup { + root destroy +} -result {{{{method <constructor> ::B method} {method <constructor> ::A method}} 0} {{{method <constructor> ::B method} {method <constructor> ::A method}} 1}} +test oo-call-3.4 {current call introspection: in destructors} -setup { + oo::class create root +} -body { + oo::class create A { + superclass root + destructor {lappend ::result [self call]} + } + oo::class create B { + superclass A + destructor {lappend ::result [self call]; next} + } + set ::result {} + [B new] destroy + return $::result +} -cleanup { + root destroy +} -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}} + +cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/opt.test b/tests/opt.test index 53e6711..2732d40 100644 --- a/tests/opt.test +++ b/tests/opt.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: opt.test,v 1.11 2010/05/27 09:18:12 nijtmans Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/package.test b/tests/package.test index eb24e99..da778f1 100644 --- a/tests/package.test +++ b/tests/package.test @@ -1,38 +1,51 @@ -# This file contains tests for the ::package::* commands. +# This file contains tests for the package and ::pkg::* commands. # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# 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. -# All rights reserved. +# Copyright (c) 2011 Donal K. Fellows # -# RCS: @(#) $Id: package.test,v 1.3 2000/04/10 17:19:02 ericm Exp $ +# 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.3.3 namespace import -force ::tcltest::* } -test package-1.1 {pkg::create gives error on insufficient args} { - catch {::pkg::create} -} 1 -test package-1.2 {pkg::create gives error on bad args} { - catch {::pkg::create -foo bar -bar baz -baz boo} -} 1 -test package-1.3 {pkg::create gives error on no value given} { - catch {::pkg::create -name foo -version 1.0 -source test.tcl -load} -} 1 -test package-1.4 {pkg::create gives error on no name given} { - catch {::pkg::create -version 1.0 -source test.tcl -load foo.so} -} 1 -test package-1.5 {pkg::create gives error on no version given} { - catch {::pkg::create -name foo -source test.tcl -load foo.so} -} 1 -test package-1.6 {pkg::create gives error on no source or load options} { - catch {::pkg::create -name foo -version 1.0 -version 2.0} -} 1 +# Do all this in a slave interp to avoid garbaging the package list +set i [interp create] +tcltest::loadIntoSlaveInterpreter $i {*}$argv +interp eval $i { +namespace import -force ::tcltest::* +package forget {*}[package names] +set oldPkgUnknown [package unknown] +package unknown {} +set oldPath $auto_path +set auto_path "" + +test package-1.1 {pkg::create gives error on insufficient args} -body { + ::pkg::create +} -returnCodes error -match glob -result {wrong # args: should be "*"} +test package-1.2 {pkg::create gives error on bad args} -body { + ::pkg::create -foo bar -bar baz -baz boo +} -returnCodes error -match glob -result {unknown option "bar": *} +test package-1.3 {pkg::create gives error on no value given} -body { + ::pkg::create -name foo -version 1.0 -source test.tcl -load +} -returnCodes error -match glob -result {value for "-load" missing: *} +test package-1.4 {pkg::create gives error on no name given} -body { + ::pkg::create -version 1.0 -source test.tcl -load foo.so +} -returnCodes error -match glob -result {value for "-name" missing: *} +test package-1.5 {pkg::create gives error on no version given} -body { + ::pkg::create -name foo -source test.tcl -load foo.so +} -returnCodes error -match glob -result {value for "-version" missing: *} +test package-1.6 {pkg::create gives error on no source or load options} -body { + ::pkg::create -name foo -version 1.0 -version 2.0 +} -returnCodes error -result {at least one of -load and -source must be given} test package-1.7 {pkg::create gives correct output for 1 direct source} { ::pkg::create -name foo -version 1.0 -source test.tcl } {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]} @@ -67,5 +80,1200 @@ test package-1.16 {pkg::create gives correct output for 1 direct, 1 lazy} { -source {test2.tcl {foo bar}} } {package ifneeded foo 1.0 [list source [file join $dir test.tcl]]\n[list tclPkgSetup $dir foo 1.0 {{test2.tcl source {foo bar}}}]} +test package-2.1 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3 +} {} +test package-2.2 {Tcl_PkgProvide procedure} -returnCodes error -setup { + package forget t +} -body { + package provide t 2.3 + package provide t 2.2 +} -result {conflicting versions provided for package "t": 2.3, then 2.2} +test package-2.3 {Tcl_PkgProvide procedure} -returnCodes error -setup { + package forget t +} -body { + package provide t 2.3 + package provide t 2.4 +} -result {conflicting versions provided for package "t": 2.3, then 2.4} +test package-2.4 {Tcl_PkgProvide procedure} -returnCodes error -setup { + package forget t +} -body { + package provide t 2.3 + package provide t 3.3 +} -result {conflicting versions provided for package "t": 2.3, then 3.3} +test package-2.5 {Tcl_PkgProvide procedure} -setup { + package forget t +} -body { + package provide t 2.3 + package provide t 2.3 +} -result {} +test package-2.6 {Tcl_PkgProvide procedure} { + package forget t + package provide t 2.3a1 +} {} + +set n 0 +foreach v { + 2.3k1 2a3a2 2ab3 2.a4 2.b4 2b.4 2a.4 2ba4 2a4b1 + 2b4a1 2b3b2 +} { + test package-2.7.$n {Tcl_PkgProvide procedure} -setup { + package forget t + } -returnCodes error -body " + package provide t $v + " -result "expected version number but got \"$v\"" + incr n +} + +test package-3.1 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {3.4} +test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {3.5} +test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {3.5 2.1 2.3} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t 2.2 + return $x +} -result {2.3} +test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require -exact t 2.3 + return $x +} -result {2.3} +test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t 2.1 + return $x +} -result {2.4} +test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup { + package forget t +} -returnCodes error -body { + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package require t 2.5 +} -result {can't find package t 2.5} +test package-3.7 {Tcl_PkgRequire procedure, can't find suitable version} -setup { + package forget t +} -returnCodes error -body { + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package require t 4.1 +} -result {can't find package t 4.1} +test package-3.8 {Tcl_PkgRequire procedure, can't find suitable version} -setup { + package forget t +} -returnCodes error -body { + package unknown {} + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package require -exact t 1.3 +} -result {can't find package t exactly 1.3} +test package-3.9 {Tcl_PkgRequire procedure, can't find suitable version} -setup { + package forget t +} -returnCodes error -body { + package unknown {} + package require t +} -result {can't find package t} +test package-3.10 {Tcl_PkgRequire procedure, error in ifneeded script} -setup { + package forget t +} -body { + package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"} + list [catch {package require t 2.1} msg] $msg $::errorInfo +} -match glob -result {1 {ifneeded test} {ifneeded test + while executing +"error "ifneeded test"" + ("package ifneeded*" script) + invoked from within +"package require t 2.1"}} +test package-3.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} -setup { + package forget t + set x xxx +} -body { + package ifneeded t 2.1 "set x invoked" + list [catch {package require t 2.1} msg] $msg $x +} -match glob -result {1 * invoked} +test package-3.12 {Tcl_PkgRequire procedure, self-deleting script} -setup { + package forget t + set x xxx +} -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 +} -result {1.2} +test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { + package forget t + set x xxx +} -body { + proc pkgUnknown args { + # args = name requirement + # requirement = v-v (for exact version) + global x + set x $args + package provide [lindex $args 0] [lindex [split [lindex $args 1] -] 0] + } + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + package require -exact t 1.5 + return $x +} -cleanup { + package unknown {} +} -result {t 1.5-1.5} +test package-3.14 {Tcl_PkgRequire procedure, "package unknown" support} -setup { + package forget t + set x xxx +} -body { + proc pkgUnknown args { + package ifneeded t 1.2 "set x loaded; package provide t 1.2" + } + package unknown pkgUnknown + list [package require t] $x +} -cleanup { + package unknown {} +} -result {1.2 loaded} +test package-3.15 {Tcl_PkgRequire procedure, "package unknown" support} -setup { + package forget {a b} + package unknown pkgUnknown + set x xxx +} -body { + proc pkgUnknown args { + global x + set x $args + package provide [lindex $args 0] 2.0 + } + package require {a b} + return $x +} -cleanup { + package unknown {} +} -result {{a b} 0-} +test package-3.16 {Tcl_PkgRequire procedure, "package unknown" error} -setup { + package forget t +} -body { + proc pkgUnknown args { + error "testing package unknown" + } + package unknown pkgUnknown + list [catch {package require t} msg] $msg $::errorInfo +} -cleanup { + package unknown {} +} -result {1 {testing package unknown} {testing package unknown + while executing +"error "testing package unknown"" + (procedure "pkgUnknown" line 2) + invoked from within +"pkgUnknown t 0-" + ("package unknown" script) + invoked from within +"package require t"}} +test package-3.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} -setup { + package forget t + set x xxx +} -body { + proc pkgUnknown args { + global x + set x $args + } + foreach i {1.4 3.4 2.3 2.4 2.2} { + package ifneeded t $i "set x $i" + } + package unknown pkgUnknown + list [catch {package require -exact t 1.5} msg] $msg $x +} -cleanup { + package unknown {} +} -result {1 {can't find package t exactly 1.5} {t 1.5-1.5}} +test package-3.18 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -body { + package provide t 2.3 + package require t +} -result {2.3} +test package-3.19 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -body { + package provide t 2.3 + package require t 2.1 +} -result {2.3} +test package-3.20 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -body { + package provide t 2.3 + package require t 2.3 +} -result {2.3} +test package-3.21 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.3 + package require t 2.4 +} -result {version conflict for package "t": have 2.3, need 2.4} +test package-3.22 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.3 + package require t 1.2 +} -result {version conflict for package "t": have 2.3, need 1.2} +test package-3.23 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -body { + package provide t 2.3 + package require -exact t 2.3 +} -result {2.3} +test package-3.24 {Tcl_PkgRequire procedure, version checks} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.3 + package require -exact t 2.2 +} -result {version conflict for package "t": have 2.3, need exactly 2.2} +test package-3.25 {Tcl_PkgRequire procedure, error in ifneeded script} -setup { + package forget t +} -body { + package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI} + list [catch {package require t 2.1} msg] $msg $::errorInfo +} -match glob -result {1 {ifneeded test} {EI + ("package ifneeded*" script) + invoked from within +"package require t 2.1"}} +test package-3.26 {Tcl_PkgRequire procedure, error in ifneeded script} -setup { + package forget t +} -body { + package ifneeded t 2.1 {package provide t 2.1; foreach x 1 {error "ifneeded test" EI}} + list [catch {package require t 2.1} msg] $msg $::errorInfo +} -match glob -result {1 {ifneeded test} {EI + ("foreach" body line 1) + invoked from within +"foreach x 1 {error "ifneeded test" EI}" + ("package ifneeded*" script) + invoked from within +"package require t 2.1"}} +test package-3.27 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package require foo 1} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {circular package dependency:*} +test package-3.28 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package require foo 2} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {circular package dependency:*} +test package-3.29 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo + package forget bar +} -body { + package ifneeded foo 1 {package require bar 1; package provide foo 1} + package ifneeded bar 1 {package require foo 1; package provide bar 1} + package require foo 1 +} -cleanup { + package forget foo + package forget bar +} -returnCodes error -match glob -result {circular package dependency:*} +test package-3.30 {Tcl_PkgRequire: circular dependency} -setup { + package forget foo + package forget bar +} -body { + package ifneeded foo 1 {package require bar 1; package provide foo 1} + package ifneeded foo 2 {package provide foo 2} + package ifneeded bar 1 {package require foo 2; package provide bar 1} + package require foo 1 +} -cleanup { + package forget foo + package forget bar +} -returnCodes error -match glob -result {circular package dependency:*} +test package-3.31 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 1; error foo} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result foo +test package-3.32 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 1; error foo} + catch {package require foo 1} + package provide foo +} -cleanup { + package forget foo +} -result {} +test package-3.33 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 2} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.34 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {package provide foo 1.1} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.34.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1.1 {package provide foo 1} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.34.2 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1.1 {package provide foo 1} + package require foo 1.1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.35 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob -result {attempt to provide package * failed:*} +test package-3.35.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {break} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test package-3.36 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {continue} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test package-3.37 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {return} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test package-3.38 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo +} -body { + package ifneeded foo 1 {return -level 0 -code 10} + package require foo 1 +} -cleanup { + package forget foo +} -returnCodes error -match glob \ +-result {attempt to provide package * failed: bad return code:*} +test package-3.39 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {package provide foo 2 ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result * +test package-3.40 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {break ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test package-3.41 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {continue ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test package-3.42 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {return ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test package-3.43 {Tcl_PkgRequire: consistent return values (1162286)} -setup { + package forget foo + set saveUnknown [package unknown] + package unknown {return -level 0 -code 10 ;#} +} -body { + package require foo 1 +} -cleanup { + package forget foo + package unknown $saveUnknown +} -returnCodes error -match glob -result {bad return code:*} +test package-3.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { + package provide demo 1.2.3 +} -body { + package require -exact demo 1.2 +} -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 { + package forget t + set x xxx +} -body { + 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 +} -result {3.4} +test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.2b1 1.2 1.3a2 1.3} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {1.3} +test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup { + package forget t + set x xxx +} -body { + foreach i {1.2b1 1.2 1.3 1.3a2} { + package ifneeded t $i "set x $i; package provide t $i" + } + package require t + return $x +} -result {1.3} + +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} { + package forget {*}[package names] + package names +} {} +test package-4.3 {Tcl_PackageCmd procedure, "forget" option} { + package forget {*}[package names] + package forget foo +} {} +test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup { + package forget {*}[package names] + set result {} +} -body { + 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] +} -result {{t x} {1.1 2.3} x {}} +test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { + package forget {*}[package names] +} -body { + package ifneeded a 1.1 {first script} + package ifneeded b 2.3 {second script} + package ifneeded c 1.4 {third script} + package forget + set result [list [lsort [package names]]] + package forget a c + lappend result [lsort [package names]] +} -result {{a b c} b} +test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body { + # Test for Bug 415273 + package ifneeded a 1 "I should have been forgotten" + package forget no-such-package a + package ifneeded a 1 +} -cleanup { + package forget a +} -result {} +test package-4.6 {Tcl_PackageCmd procedure, "ifneeded" option} -body { + package ifneeded a +} -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"} +test package-4.7 {Tcl_PackageCmd procedure, "ifneeded" option} -body { + package ifneeded a b c d +} -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"} +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} { + package forget {*}[package names] + list [package ifneeded foo 1.1] [package names] +} {{} {}} +test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + package forget t +} -body { + package ifneeded t 1.4 "script for t 1.4" + list [package names] [package ifneeded t 1.4] [package versions t] +} -result {t {script for t 1.4} 1.4} +test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + package forget t +} -body { + package ifneeded t 1.4 "script for t 1.4" + list [package ifneeded t 1.5] [package names] [package versions t] +} -result {{} t 1.4} +test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + package forget t +} -body { + 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] +} -result {{second script for t 1.4} t 1.4} +test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + package forget t +} -body { + package ifneeded t 1.4 "script for t 1.4" + package ifneeded t 1.2 "second script" + package ifneeded t 3.1 "last script" + list [package ifneeded t 1.2] [package versions t] +} -result {{second script} {1.4 1.2 3.1}} +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} { + package forget {*}[package names] + package names +} {} +test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup { + package forget {*}[package names] +} -body { + 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] +} -result {x y} +test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body { + package provide +} -returnCodes error -result {wrong # args: should be "package provide package ?version?"} +test package-4.18 {Tcl_PackageCmd procedure, "provide" option} -body { + package provide a b c +} -returnCodes error -result {wrong # args: should be "package provide package ?version?"} +test package-4.19 {Tcl_PackageCmd procedure, "provide" option} -setup { + package forget t +} -body { + package provide t +} -result {} +test package-4.20 {Tcl_PackageCmd procedure, "provide" option} -setup { + package forget t +} -body { + package provide t 2.3 + package provide t +} -result {2.3} +test package-4.21 {Tcl_PackageCmd procedure, "provide" option} -setup { + package forget t +} -returnCodes error -body { + package provide t a.b +} -result {expected version number but got "a.b"} +test package-4.22 {Tcl_PackageCmd procedure, "require" option} -returnCodes error -body { + package require +} -result {wrong # args: should be "package require ?-exact? package ?requirement ...?"} +test package-4.24 {Tcl_PackageCmd procedure, "require" option} -body { + package require -exact a b c + # Exact syntax: -exact name version + # name ?requirement ...? +} -returnCodes error -result {wrong # args: should be "package require ?-exact? package ?requirement ...?"} +test package-4.26 {Tcl_PackageCmd procedure, "require" option} -body { + package require x a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-4.27 {Tcl_PackageCmd procedure, "require" option} -body { + package require -exact x a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-4.28 {Tcl_PackageCmd procedure, "require" option} -body { + package require -exact x +} -returnCodes error -result {wrong # args: should be "package require ?-exact? package ?requirement ...?"} +test package-4.29 {Tcl_PackageCmd procedure, "require" option} -body { + package require -exact +} -returnCodes error -result {wrong # args: should be "package require ?-exact? package ?requirement ...?"} +test package-4.30 {Tcl_PackageCmd procedure, "require" option} -setup { + package forget t +} -body { + package provide t 2.3 + package require t 2.1 +} -result {2.3} +test package-4.31 {Tcl_PackageCmd procedure, "require" option} -setup { + package forget t +} -body { + package require t +} -returnCodes error -result {can't find package t} +test package-4.32 {Tcl_PackageCmd procedure, "require" option} -setup { + package forget t +} -body { + package ifneeded t 2.3 "error {synthetic error}" + package require t 2.3 +} -returnCodes error -result {synthetic error} +test package-4.33 {Tcl_PackageCmd procedure, "unknown" option} -body { + package unknown a b +} -returnCodes error -result {wrong # args: should be "package unknown ?command?"} +test package-4.34 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown +} {test script} +test package-4.35 {Tcl_PackageCmd procedure, "unknown" option} { + package unknown "test script" + package unknown {} + package unknown +} {} +test package-4.36 {Tcl_PackageCmd procedure, "vcompare" option} -body { + package vcompare a +} -returnCodes error -result {wrong # args: should be "package vcompare version1 version2"} +test package-4.37 {Tcl_PackageCmd procedure, "vcompare" option} -body { + package vcompare a b c +} -returnCodes error -result {wrong # args: should be "package vcompare version1 version2"} +test package-4.38 {Tcl_PackageCmd procedure, "vcompare" option} -body { + package vcompare x.y 3.4 +} -returnCodes error -result {expected version number but got "x.y"} +test package-4.39 {Tcl_PackageCmd procedure, "vcompare" option} -body { + package vcompare 2.1 a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-4.40 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.1 2.3 +} {-1} +test package-4.41 {Tcl_PackageCmd procedure, "vcompare" option} { + package vc 2.2.4 2.2.4 +} {0} +test package-4.42 {Tcl_PackageCmd procedure, "versions" option} -body { + package versions +} -returnCodes error -result {wrong # args: should be "package versions package"} +test package-4.43 {Tcl_PackageCmd procedure, "versions" option} -body { + package versions a b +} -returnCodes error -result {wrong # args: should be "package versions package"} +test package-4.44 {Tcl_PackageCmd procedure, "versions" option} -body { + package forget t + package versions t +} -result {} +test package-4.45 {Tcl_PackageCmd procedure, "versions" option} -setup { + package forget t +} -body { + package provide t 2.3 + package versions t +} -result {} +test package-4.46 {Tcl_PackageCmd procedure, "versions" option} -setup { + package forget t +} -body { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package versions t +} -result {2.3 2.4} +test package-4.47 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies a +} -returnCodes error -result {wrong # args: should be "package vsatisfies version ?requirement ...?"} +test package-4.49 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies x.y 3.4 +} -returnCodes error -result {expected version number but got "x.y"} +test package-4.50 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vcompare 2.1 a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-4.51 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 2.1 +} {1} +test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { + package vs 2.3 1.2 +} {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} +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"} +test package-4.55 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies 2.1 3.2-x.y +} -returnCodes error -result {expected version number but got "x.y"} +test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { + package vsatisfies 2.1 x.y-3.2 +} -returnCodes error -result {expected version number but got "x.y"} + +# No tests for FindPackage; can't think up anything detectable errors. + +test package-5.1 {TclFreePackageInfo procedure} { + interp create slave + slave 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 +} {} +test package-5.2 {TclFreePackageInfo procedure} -body { + interp create foo + foo eval { + package ifneeded t 2.3 x + package ifneeded t 2.4 y + package ifneeded x 3.1 z + package provide q 4.3 + } + foo alias z kill + proc kill {} { + interp delete foo + } + foo eval package require x 3.1 +} -returnCodes error -match glob -result * + +test package-6.1 {CheckVersion procedure} { + package vcompare 1 2.1 +} -1 +test package-6.2 {CheckVersion procedure} -body { + package vcompare .1 2.1 +} -returnCodes error -result {expected version number but got ".1"} +test package-6.3 {CheckVersion procedure} -body { + package vcompare 111.2a.3 2.1 +} -returnCodes error -result {expected version number but got "111.2a.3"} +test package-6.4 {CheckVersion procedure} -body { + package vcompare 1.2.3. 2.1 +} -returnCodes error -result {expected version number but got "1.2.3."} +test package-6.5 {CheckVersion procedure} -body { + package vcompare 1.2..3 2.1 +} -returnCodes error -result {expected version number but got "1.2..3"} + +test package-7.1 {ComparePkgVersions procedure} { + package vcompare 1.23 1.22 +} {1} +test package-7.2 {ComparePkgVersions procedure} { + package vcompare 1.22.1.2.3 1.22.1.2.3 +} {0} +test package-7.3 {ComparePkgVersions procedure} { + package vcompare 1.21 1.22 +} {-1} +test package-7.4 {ComparePkgVersions procedure} { + package vcompare 1.21 1.21.2 +} {-1} +test package-7.5 {ComparePkgVersions procedure} { + package vcompare 1.21.1 1.21 +} {1} +test package-7.6 {ComparePkgVersions procedure} { + package vsatisfies 1.21.1 1.21 +} {1} +test package-7.7 {ComparePkgVersions procedure} { + package vsatisfies 2.22.3 1.21 +} {0} +test package-7.8 {ComparePkgVersions procedure} { + package vsatisfies 1 1 +} {1} +test package-7.9 {ComparePkgVersions procedure} { + package vsatisfies 2 1 +} {0} + +test package-8.1 {Tcl_PkgPresent procedure, any version} -setup { + package forget t +} -body { + package provide t 2.4 + package present t +} -result {2.4} +test package-8.2 {Tcl_PkgPresent procedure, correct version} -setup { + package forget t +} -body { + package provide t 2.4 + package present t 2.4 +} -result {2.4} +test package-8.3 {Tcl_PkgPresent procedure, satisfying version} -setup { + package forget t +} -body { + package provide t 2.4 + package present t 2.0 +} -result {2.4} +test package-8.4 {Tcl_PkgPresent procedure, not satisfying version} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.4 + package present t 2.6 +} -result {version conflict for package "t": have 2.4, need 2.6} +test package-8.5 {Tcl_PkgPresent procedure, not satisfying version} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.4 + package present t 1.0 +} -result {version conflict for package "t": have 2.4, need 1.0} +test package-8.6 {Tcl_PkgPresent procedure, exact version} -setup { + package forget t +} -body { + package provide t 2.4 + package present -exact t 2.4 +} -result {2.4} +test package-8.7 {Tcl_PkgPresent procedure, not exact version} -setup { + package forget t +} -returnCodes error -body { + package provide t 2.4 + package present -exact t 2.3 +} -result {version conflict for package "t": have 2.4, need exactly 2.3} +test package-8.8 {Tcl_PkgPresent procedure, unknown package} -body { + package forget t + package present t +} -returnCodes error -result {package t is not present} +test package-8.9 {Tcl_PkgPresent procedure, unknown package} -body { + package forget t + package present t 2.4 +} -returnCodes error -result {package t 2.4 is not present} +test package-8.10 {Tcl_PkgPresent procedure, unknown package} -body { + package forget t + package present -exact t 2.4 +} -returnCodes error -result {package t 2.4 is not present} +test package-8.11 {Tcl_PackageCmd procedure, "present" option} -body { + package present +} -returnCodes error -result {wrong # args: should be "package present ?-exact? package ?requirement ...?"} +test package-8.12 {Tcl_PackageCmd procedure, "present" option} -body { + package present a b c +} -returnCodes error -result {expected version number but got "b"} +test package-8.13 {Tcl_PackageCmd procedure, "present" option} -body { + package present -exact a b c +} -returnCodes error -result {wrong # args: should be "package present ?-exact? package ?requirement ...?"} +test package-8.14 {Tcl_PackageCmd procedure, "present" option} -body { + package present -bs a b +} -returnCodes error -result {expected version number but got "a"} +test package-8.15 {Tcl_PackageCmd procedure, "present" option} -body { + package present x a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-8.16 {Tcl_PackageCmd procedure, "present" option} -body { + package present -exact x a.b +} -returnCodes error -result {expected version number but got "a.b"} +test package-8.17 {Tcl_PackageCmd procedure, "present" option} -body { + package present -exact x +} -returnCodes error -result {wrong # args: should be "package present ?-exact? package ?requirement ...?"} +test package-8.18 {Tcl_PackageCmd procedure, "present" option} -body { + package present -exact +} -returnCodes error -result {wrong # args: should be "package present ?-exact? package ?requirement ...?"} + +set n 0 +foreach {r p vs vc} { + 8.5a0 8.5a5 1 -1 + 8.5a0 8.5b1 1 -1 + 8.5a0 8.5.1 1 -1 + 8.5a0 8.6a0 1 -1 + 8.5a0 8.6b0 1 -1 + 8.5a0 8.6.0 1 -1 + 8.5a6 8.5a5 0 1 + 8.5a6 8.5b1 1 -1 + 8.5a6 8.5.1 1 -1 + 8.5a6 8.6a0 1 -1 + 8.5a6 8.6b0 1 -1 + 8.5a6 8.6.0 1 -1 + 8.5b0 8.5a5 0 1 + 8.5b0 8.5b1 1 -1 + 8.5b0 8.5.1 1 -1 + 8.5b0 8.6a0 1 -1 + 8.5b0 8.6b0 1 -1 + 8.5b0 8.6.0 1 -1 + 8.5b2 8.5a5 0 1 + 8.5b2 8.5b1 0 1 + 8.5b2 8.5.1 1 -1 + 8.5b2 8.6a0 1 -1 + 8.5b2 8.6b0 1 -1 + 8.5b2 8.6.0 1 -1 + 8.5 8.5a5 1 1 + 8.5 8.5b1 1 1 + 8.5 8.5.1 1 -1 + 8.5 8.6a0 1 -1 + 8.5 8.6b0 1 -1 + 8.5 8.6.0 1 -1 + 8.5.0 8.5a5 0 1 + 8.5.0 8.5b1 0 1 + 8.5.0 8.5.1 1 -1 + 8.5.0 8.6a0 1 -1 + 8.5.0 8.6b0 1 -1 + 8.5.0 8.6.0 1 -1 + 10 8 0 1 + 8 10 0 -1 + 0.0.1.2 0.1.2 1 -1 +} { + test package-9.$n {package vsatisfies} { + package vsatisfies $p $r + } $vs + test package-10.$n {package vcompare} { + package vcompare $r $p + } $vc + incr n +} + +test package-11.0.0 {package vcompare at 32bit boundary} { + package vcompare [expr {1<<31}] [expr {(1<<31)-1}] +} 1 + +# Note: It is correct that the result of the very first test, i.e. "5.0 5.0a0" +# is 1, i.e. that version 5.0a0 satisfies a 5.0 requirement. + +# The requirement "5.0" internally translates first to "5.0-6", and then to +# its final form of "5.0a0-6a0". These translations are explicitly specified +# by the TIP (Search for "padded/extended internally with 'a0'"). This was +# done intentionally for exactly the tested case, that an alpha package can +# satisfy a requirement for the regular package. An example would be a package +# FOO requiring Tcl 8.X for its operation. It can be used with Tcl 8.Xa0. +# Without our translation that would not be possible. + +set n 0 +foreach {required provided satisfied} { + 5.0 5.0a0 1 + 5.0a0 5.0 1 + + 8.5a0- 8.5a5 1 + 8.5a0- 8.5b1 1 + 8.5a0- 8.5.1 1 + 8.5a0- 8.6a0 1 + 8.5a0- 8.6b0 1 + 8.5a0- 8.6.0 1 + 8.5a6- 8.5a5 0 + 8.5a6- 8.5b1 1 + 8.5a6- 8.5.1 1 + 8.5a6- 8.6a0 1 + 8.5a6- 8.6b0 1 + 8.5a6- 8.6.0 1 + 8.5b0- 8.5a5 0 + 8.5b0- 8.5b1 1 + 8.5b0- 8.5.1 1 + 8.5b0- 8.6a0 1 + 8.5b0- 8.6b0 1 + 8.5b0- 8.6.0 1 + 8.5b2- 8.5a5 0 + 8.5b2- 8.5b1 0 + 8.5b2- 8.5.1 1 + 8.5b2- 8.6a0 1 + 8.5b2- 8.6b0 1 + 8.5b2- 8.6.0 1 + 8.5- 8.5a5 1 + 8.5- 8.5b1 1 + 8.5- 8.5.1 1 + 8.5- 8.6a0 1 + 8.5- 8.6b0 1 + 8.5- 8.6.0 1 + 8.5.0- 8.5a5 0 + 8.5.0- 8.5b1 0 + 8.5.0- 8.5.1 1 + 8.5.0- 8.6a0 1 + 8.5.0- 8.6b0 1 + 8.5.0- 8.6.0 1 + 8.5a0-7 8.5a5 0 + 8.5a0-7 8.5b1 0 + 8.5a0-7 8.5.1 0 + 8.5a0-7 8.6a0 0 + 8.5a0-7 8.6b0 0 + 8.5a0-7 8.6.0 0 + 8.5a6-7 8.5a5 0 + 8.5a6-7 8.5b1 0 + 8.5a6-7 8.5.1 0 + 8.5a6-7 8.6a0 0 + 8.5a6-7 8.6b0 0 + 8.5a6-7 8.6.0 0 + 8.5b0-7 8.5a5 0 + 8.5b0-7 8.5b1 0 + 8.5b0-7 8.5.1 0 + 8.5b0-7 8.6a0 0 + 8.5b0-7 8.6b0 0 + 8.5b0-7 8.6.0 0 + 8.5b2-7 8.5a5 0 + 8.5b2-7 8.5b1 0 + 8.5b2-7 8.5.1 0 + 8.5b2-7 8.6a0 0 + 8.5b2-7 8.6b0 0 + 8.5b2-7 8.6.0 0 + 8.5-7 8.5a5 0 + 8.5-7 8.5b1 0 + 8.5-7 8.5.1 0 + 8.5-7 8.6a0 0 + 8.5-7 8.6b0 0 + 8.5-7 8.6.0 0 + 8.5.0-7 8.5a5 0 + 8.5.0-7 8.5b1 0 + 8.5.0-7 8.5.1 0 + 8.5.0-7 8.6a0 0 + 8.5.0-7 8.6b0 0 + 8.5.0-7 8.6.0 0 + 8.5a0-8.6.1 8.5a5 1 + 8.5a0-8.6.1 8.5b1 1 + 8.5a0-8.6.1 8.5.1 1 + 8.5a0-8.6.1 8.6a0 1 + 8.5a0-8.6.1 8.6b0 1 + 8.5a0-8.6.1 8.6.0 1 + 8.5a6-8.6.1 8.5a5 0 + 8.5a6-8.6.1 8.5b1 1 + 8.5a6-8.6.1 8.5.1 1 + 8.5a6-8.6.1 8.6a0 1 + 8.5a6-8.6.1 8.6b0 1 + 8.5a6-8.6.1 8.6.0 1 + 8.5b0-8.6.1 8.5a5 0 + 8.5b0-8.6.1 8.5b1 1 + 8.5b0-8.6.1 8.5.1 1 + 8.5b0-8.6.1 8.6a0 1 + 8.5b0-8.6.1 8.6b0 1 + 8.5b0-8.6.1 8.6.0 1 + 8.5b2-8.6.1 8.5a5 0 + 8.5b2-8.6.1 8.5b1 0 + 8.5b2-8.6.1 8.5.1 1 + 8.5b2-8.6.1 8.6a0 1 + 8.5b2-8.6.1 8.6b0 1 + 8.5b2-8.6.1 8.6.0 1 + 8.5-8.6.1 8.5a5 1 + 8.5-8.6.1 8.5b1 1 + 8.5-8.6.1 8.5.1 1 + 8.5-8.6.1 8.6a0 1 + 8.5-8.6.1 8.6b0 1 + 8.5-8.6.1 8.6.0 1 + 8.5.0-8.6.1 8.5a5 0 + 8.5.0-8.6.1 8.5b1 0 + 8.5.0-8.6.1 8.5.1 1 + 8.5.0-8.6.1 8.6a0 1 + 8.5.0-8.6.1 8.6b0 1 + 8.5.0-8.6.1 8.6.0 1 + 8.5a0-8.5a0 8.5a0 1 + 8.5a0-8.5a0 8.5b1 0 + 8.5a0-8.5a0 8.4 0 + 8.5b0-8.5b0 8.5a5 0 + 8.5b0-8.5b0 8.5b0 1 + 8.5b0-8.5b0 8.5.1 0 + 8.5-8.5 8.5a5 0 + 8.5-8.5 8.5b1 0 + 8.5-8.5 8.5 1 + 8.5-8.5 8.5.1 0 + 8.5.0-8.5.0 8.5a5 0 + 8.5.0-8.5.0 8.5b1 0 + 8.5.0-8.5.0 8.5.0 1 + 8.5.0-8.5.0 8.5.1 0 + 8.5.0-8.5.0 8.6a0 0 + 8.5.0-8.5.0 8.6b0 0 + 8.5.0-8.5.0 8.6.0 0 + 8.2 9 0 + 8.2- 9 1 + 8.2-8.5 9 0 + 8.2-9.1 9 1 + + 8.5-8.5 8.5b1 0 + 8.5a0-8.5 8.5b1 0 + 8.5a0-8.5.1 8.5b1 1 + + 8.5-8.5 8.5 1 + 8.5.0-8.5.0 8.5 1 + 8.5a0-8.5.0 8.5 0 +} { + test package-11.$n "package vsatisfies $provided $required" { + package vsatisfies $provided $required + } $satisfied + incr n +} + +test package-12.0 "package vsatisfies multiple" { + # yes no + package vsatisfies 8.4 8.4 7.3 +} 1 +test package-12.1 "package vsatisfies multiple" { + # no yes + package vsatisfies 8.4 7.3 8.4 +} 1 +test package-12.2 "package vsatisfies multiple" { + # yes yes + package vsatisfies 8.4.2 8.4 8.4.1 +} 1 +test package-12.3 "package vsatisfies multiple" { + # no no + package vsatisfies 8.4 7.3 6.1 +} 0 + +proc prefer {args} { + set ip [interp create] + try { + lappend res [$ip eval {package prefer}] + foreach mode $args { + lappend res [$ip eval [list package prefer $mode]] + } + return $res + } finally { + interp delete $ip + } +} + +test package-13.0 {package prefer defaults} { + prefer +} stable +test package-13.1 {package prefer defaults} -body { + set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! + prefer +} -cleanup { + unset -nocomplain ::env(TCL_PKG_PREFER_LATEST) +} -result latest + +test package-14.0 {wrong\#args} -returnCodes error -body { + package prefer foo bar +} -result {wrong # args: should be "package prefer ?latest|stable?"} +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} + +rename prefer {} + +set auto_path $oldPath +package unknown $oldPkgUnknown + +cleanupTests +} + +# cleanup +interp delete $i ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/parse.test b/tests/parse.test index b83d20e..0f76d64 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -7,8 +7,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: parse.test,v 1.39 2009/09/17 17:58:10 dgp Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." @@ -18,6 +16,9 @@ if {[catch {package require tcltest 2.0.2}]} { namespace eval ::tcl::test::parse { namespace import ::tcltest::* +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testparser [llength [info commands testparser]] testConstraint testevalobjv [llength [info commands testevalobjv]] testConstraint testevalex [llength [info commands testevalex]] @@ -235,6 +236,12 @@ test parse-5.28 {Tcl_ParseCommand: {*} parsing, expanded literals} testparser { test parse-5.29 {Tcl_ParseCommand: {*} parsing, expanded literals, naked backslashes} testparser { testparser {{*}{a \n b}} 0 } {- {{*}{a \n b}} 1 expand {{*}{a \n b}} 1 text {a \n b} 0 {}} +test parse-5.30 {Tcl_ParseCommand: {*} parsing, expanded literals} testparser { + testparser {{*}"a b"} 0 +} {- {{*}"a b"} 2 simple a 1 text a 0 simple b 1 text b 0 {}} +test parse-5.31 {Tcl_ParseCommand: {*} parsing, expanded literals, naked backslashes} testparser { + testparser {{*}"a \n b"} 0 +} {- {{*}"a \n b"} 1 expand {{*}"a \n b"} 3 text {a } 0 backslash {\n} 0 text { b} 0 {}} test parse-6.1 {ParseTokens procedure, empty word} testparser { testparser {""} 0 @@ -1045,6 +1052,44 @@ test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} emptyTest { # Test no longer valid in Tcl 8.6 } {} +test parse-20.1 {TclParseBackslash: truncated escape} testparser { + testparser {\u12345} 1 +} {- \\ 1 simple \\ 1 text \\ 0 u12345} +test parse-20.2 {TclParseBackslash: truncated escape} testparser { + testparser {\u12345} 2 +} {- {\u} 1 word {\u} 1 backslash {\u} 0 12345} +test parse-20.3 {TclParseBackslash: truncated escape} testparser { + testparser {\u12345} 3 +} {- {\u1} 1 word {\u1} 1 backslash {\u1} 0 2345} +test parse-20.4 {TclParseBackslash: truncated escape} testparser { + testparser {\u12345} 4 +} {- {\u12} 1 word {\u12} 1 backslash {\u12} 0 345} +test parse-20.5 {TclParseBackslash: truncated escape} testparser { + testparser {\u12345} 5 +} {- {\u123} 1 word {\u123} 1 backslash {\u123} 0 45} +test parse-20.6 {TclParseBackslash: truncated escape} testparser { + testparser {\u12345} 6 +} {- {\u1234} 1 word {\u1234} 1 backslash {\u1234} 0 5} +test parse-20.7 {TclParseBackslash: truncated escape} testparser { + testparser {\u12345} 7 +} {- {\u12345} 1 word {\u12345} 2 backslash {\u1234} 0 text 5 0 {}} + +test parse-20.8 {TclParseBackslash: truncated escape} testparser { + testparser {\x12X} 1 +} {- \\ 1 simple \\ 1 text \\ 0 x12X} +test parse-20.9 {TclParseBackslash: truncated escape} testparser { + testparser {\x12X} 2 +} {- {\x} 1 word {\x} 1 backslash {\x} 0 12X} +test parse-20.10 {TclParseBackslash: truncated escape} testparser { + testparser {\x12X} 3 +} {- {\x1} 1 word {\x1} 1 backslash {\x1} 0 2X} +test parse-20.11 {TclParseBackslash: truncated escape} testparser { + testparser {\x12X} 4 +} {- {\x12} 1 word {\x12} 1 backslash {\x12} 0 X} +test parse-20.12 {TclParseBackslash: truncated escape} testparser { + testparser {\x12X} 5 +} {- {\x12X} 1 word {\x12X} 2 backslash {\x12} 0 text X 0 {}} + cleanupTests } diff --git a/tests/parseExpr.test b/tests/parseExpr.test index 0f62b91..7910974 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -7,14 +7,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: parseExpr.test,v 1.29 2007/12/13 15:26:07 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [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, # for example, that a math function actually exists, or that the operands @@ -999,6 +1000,72 @@ test parseExpr-21.63 {error message} -body { } -returnCodes error -result "missing close-brace in expression \"...12345678901234567890*\[\{abcdefghijklmnopqrstuv...\"" +test parseExpr-22.1 {Bug 3401704} -constraints testexprparser -body { + testexprparser 2a() 1 +} -result {- {} 0 subexpr 2 1 text 2 0 {}} +test parseExpr-22.2 {Bug 3401704} -constraints testexprparser -body { + testexprparser nana() 3 +} -result {- {} 0 subexpr nan 1 text nan 0 {}} +test parseExpr-22.3 {Bug 3401704} -constraints testexprparser -body { + testexprparser 2a() -1 +} -result {- {} 0 subexpr 2a() 1 operator 2a 0 {}} +test parseExpr-22.4 {Bug 3401704} -constraints testexprparser -body { + testexprparser nana() -1 +} -result {- {} 0 subexpr nana() 1 operator nana 0 {}} +test parseExpr-22.5 {Bug 3401704} -constraints testexprparser -body { + testexprparser nan9() -1 +} -result {- {} 0 subexpr nan9() 1 operator nan9 0 {}} +test parseExpr-22.6 {Bug 3401704} -constraints testexprparser -body { + testexprparser 2_() -1 +} -result {- {} 0 subexpr 2_() 1 operator 2_ 0 {}} +test parseExpr-22.7 {Bug 3401704} -constraints testexprparser -body { + testexprparser nan_() -1 +} -result {- {} 0 subexpr nan_() 1 operator nan_ 0 {}} +test parseExpr-22.8 {Bug 3401704} -constraints testexprparser -body { + catch {testexprparser nan!() -1} m o + dict get $o -errorcode +} -result {TCL PARSE EXPR MISSING} +test parseExpr-22.9 {Bug 3401704} -constraints testexprparser -body { + testexprparser 1e3_() -1 +} -result {- {} 0 subexpr 1e3_() 1 operator 1e3_ 0 {}} +test parseExpr-22.10 {Bug 3401704} -constraints testexprparser -body { + catch {testexprparser 1.3_() -1} m o + dict get $o -errorcode +} -result {TCL PARSE EXPR BADCHAR} +test parseExpr-22.11 {Bug 3401704} -constraints testexprparser -body { + catch {testexprparser 1e-3_() -1} m o + dict get $o -errorcode +} -result {TCL PARSE EXPR BADCHAR} +test parseExpr-22.12 {Bug 3401704} -constraints testexprparser -body { + catch {testexprparser naneq() -1} m o + dict get $o -errorcode +} -result {TCL PARSE EXPR EMPTY} +test parseExpr-22.13 {Bug 3401704} -constraints testexprparser -body { + testexprparser naner() -1 +} -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} +test parseExpr-22.15 {Bug 3401704} -constraints testexprparser -body { + catch {testexprparser 0o8 -1} m o + dict get $o -errorcode +} -result {TCL PARSE EXPR BADNUMBER OCTAL} +test parseExpr-22.16 {Bug 3401704} -constraints testexprparser -body { + catch {testexprparser 0o08 -1} m o + dict get $o -errorcode +} -result {TCL PARSE EXPR BADNUMBER OCTAL} +test parseExpr-22.17 {Bug 3401704} -constraints testexprparser -body { + catch {testexprparser 0b2 -1} m o + dict get $o -errorcode +} -result {TCL PARSE EXPR BADNUMBER BINARY} +test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body { + catch {testexprparser 0b02 -1} m o + dict get $o -errorcode +} -result {TCL PARSE EXPR BADNUMBER BINARY} + + # cleanup ::tcltest::cleanupTests return diff --git a/tests/parseOld.test b/tests/parseOld.test index 9cc90fe..0edcbf0 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -12,14 +12,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: parseOld.test,v 1.14 2006/10/09 19:15:45 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testwordend [llength [info commands testwordend]] # Save the argv value for restoration later diff --git a/tests/pid.test b/tests/pid.test index 9734d51..d21dbaa 100644 --- a/tests/pid.test +++ b/tests/pid.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: pid.test,v 1.12 2004/05/19 22:06:07 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 diff --git a/tests/pkg.test b/tests/pkg.test deleted file mode 100644 index 4f92d4c..0000000 --- a/tests/pkg.test +++ /dev/null @@ -1,1222 +0,0 @@ -# -*- tcl -*- -# Commands covered: pkg -# -# 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) 1995-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. -# -# RCS: @(#) $Id: pkg.test,v 1.31 2008/07/19 22:50:39 nijtmans Exp $ - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 - namespace import -force ::tcltest::* -} - -# Do all this in a slave interp to avoid garbaging the -# package list -set i [interp create] -interp eval $i [list set argv $argv] -interp eval $i [list package require tcltest 2] -interp eval $i [list namespace import -force ::tcltest::*] -interp eval $i { - -package forget {*}[package names] -set oldPkgUnknown [package unknown] -package unknown {} -set oldPath $auto_path -set auto_path "" - -test pkg-1.1 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 -} {} -test pkg-1.2 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 - list [catch {package provide t 2.2} msg] $msg -} {1 {conflicting versions provided for package "t": 2.3, then 2.2}} -test pkg-1.3 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 - list [catch {package provide t 2.4} msg] $msg -} {1 {conflicting versions provided for package "t": 2.3, then 2.4}} -test pkg-1.4 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 - list [catch {package provide t 3.3} msg] $msg -} {1 {conflicting versions provided for package "t": 2.3, then 3.3}} -test pkg-1.5 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3 - package provide t 2.3 -} {} - -test pkg-1.6 {Tcl_PkgProvide procedure} { - package forget t - package provide t 2.3a1 -} {} - -set n 0 -foreach v { - 2.3k1 2a3a2 2ab3 2.a4 2.b4 2b.4 2a.4 2ba4 2a4b1 - 2b4a1 2b3b2 -} { - test pkg-1.7.$n {Tcl_PkgProvide procedure} { - package forget t - list [catch {package provide t $v} msg] $msg - } [list 1 "expected version number but got \"$v\""] - incr n -} - -test pkg-2.1 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {3.4} -test pkg-2.2 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2 3.5 3.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {3.5} -test pkg-2.3 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {3.5 2.1 2.3} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t 2.2 - set x -} {2.3} -test pkg-2.4 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require -exact t 2.3 - set x -} {2.3} -test pkg-2.5 {Tcl_PkgRequire procedure, picking best version} { - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t 2.1 - set x -} {2.4} -test pkg-2.6 {Tcl_PkgRequire procedure, can't find suitable version} { - package forget t - package unknown {} - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - list [catch {package require t 2.5} msg] $msg -} {1 {can't find package t 2.5}} -test pkg-2.7 {Tcl_PkgRequire procedure, can't find suitable version} { - package forget t - package unknown {} - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - list [catch {package require t 4.1} msg] $msg -} {1 {can't find package t 4.1}} -test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} { - package forget t - package unknown {} - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - list [catch {package require -exact t 1.3} msg] $msg -} {1 {can't find package t exactly 1.3}} -test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} { - package forget t - package unknown {} - list [catch {package require t} msg] $msg -} {1 {can't find package t}} -test pkg-2.10 {Tcl_PkgRequire procedure, error in ifneeded script} -body { - package forget t - package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"} - list [catch {package require t 2.1} msg] $msg $::errorInfo -} -match glob -result {1 {ifneeded test} {ifneeded test - while executing -"error "ifneeded test"" - ("package ifneeded*" script) - invoked from within -"package require t 2.1"}} -test pkg-2.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} -body { - package forget t - package ifneeded t 2.1 "set x invoked" - set x xxx - list [catch {package require t 2.1} msg] $msg $x -} -match glob -result {1 * invoked} -test pkg-2.12 {Tcl_PkgRequire procedure, self-deleting script} { - package forget t - package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" - set x xxx - package require t 1.2 - set x -} {1.2} -test pkg-2.13 {Tcl_PkgRequire procedure, "package unknown" support} { - proc pkgUnknown args { - # args = name requirement - # requirement = v-v (for exact version) - global x - set x $args - package provide [lindex $args 0] [lindex [split [lindex $args 1] -] 0] - } - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - package unknown pkgUnknown - set x xxx - package require -exact t 1.5 - package unknown {} - set x -} {t 1.5-1.5} -test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} { - proc pkgUnknown args { - package ifneeded t 1.2 "set x loaded; package provide t 1.2" - } - package forget t - package unknown pkgUnknown - set x xxx - set result [list [package require t] $x] - package unknown {} - set result -} {1.2 loaded} -test pkg-2.15 {Tcl_PkgRequire procedure, "package unknown" support} { - proc pkgUnknown args { - global x - set x $args - package provide [lindex $args 0] 2.0 - } - package forget {a b} - package unknown pkgUnknown - set x xxx - package require {a b} - package unknown {} - set x -} {{a b} 0-} -test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} { - proc pkgUnknown args { - error "testing package unknown" - } - package forget t - package unknown pkgUnknown - set result [list [catch {package require t} msg] $msg $::errorInfo] - package unknown {} - set result -} {1 {testing package unknown} {testing package unknown - while executing -"error "testing package unknown"" - (procedure "pkgUnknown" line 2) - invoked from within -"pkgUnknown t 0-" - ("package unknown" script) - invoked from within -"package require t"}} -test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} { - proc pkgUnknown args { - global x - set x $args - } - package forget t - foreach i {1.4 3.4 2.3 2.4 2.2} { - package ifneeded t $i "set x $i" - } - package unknown pkgUnknown - set x xxx - set result [list [catch {package require -exact t 1.5} msg] $msg $x] - package unknown {} - set result -} {1 {can't find package t exactly 1.5} {t 1.5-1.5}} -test pkg-2.18 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - package require t -} {2.3} -test pkg-2.19 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - package require t 2.1 -} {2.3} -test pkg-2.20 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - package require t 2.3 -} {2.3} -test pkg-2.21 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - list [catch {package require t 2.4} msg] $msg -} {1 {version conflict for package "t": have 2.3, need 2.4}} -test pkg-2.22 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - list [catch {package require t 1.2} msg] $msg -} {1 {version conflict for package "t": have 2.3, need 1.2}} -test pkg-2.23 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - package require -exact t 2.3 -} {2.3} -test pkg-2.24 {Tcl_PkgRequire procedure, version checks} { - package forget t - package provide t 2.3 - list [catch {package require -exact t 2.2} msg] $msg -} {1 {version conflict for package "t": have 2.3, need exactly 2.2}} -test pkg-2.25 {Tcl_PkgRequire procedure, error in ifneeded script} -body { - package forget t - package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI} - list [catch {package require t 2.1} msg] $msg $::errorInfo -} -match glob -result {1 {ifneeded test} {EI - ("package ifneeded*" script) - invoked from within -"package require t 2.1"}} -test pkg-2.26 {Tcl_PkgRequire procedure, error in ifneeded script} -body { - package forget t - package ifneeded t 2.1 {package provide t 2.1; foreach x 1 {error "ifneeded test" EI}} - list [catch {package require t 2.1} msg] $msg $::errorInfo -} -match glob -result {1 {ifneeded test} {EI - ("foreach" body line 1) - invoked from within -"foreach x 1 {error "ifneeded test" EI}" - ("package ifneeded*" script) - invoked from within -"package require t 2.1"}} -test pkg-2.27 {Tcl_PkgRequire: circular dependency} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package require foo 1} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {circular package dependency:*} -test pkg-2.28 {Tcl_PkgRequire: circular dependency} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package require foo 2} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {circular package dependency:*} -test pkg-2.29 {Tcl_PkgRequire: circular dependency} -setup { - package forget foo - package forget bar -} -body { - package ifneeded foo 1 {package require bar 1; package provide foo 1} - package ifneeded bar 1 {package require foo 1; package provide bar 1} - package require foo 1 -} -cleanup { - package forget foo - package forget bar -} -returnCodes error -match glob -result {circular package dependency:*} -test pkg-2.30 {Tcl_PkgRequire: circular dependency} -setup { - package forget foo - package forget bar -} -body { - package ifneeded foo 1 {package require bar 1; package provide foo 1} - package ifneeded foo 2 {package provide foo 2} - package ifneeded bar 1 {package require foo 2; package provide bar 1} - package require foo 1 -} -cleanup { - package forget foo - package forget bar -} -returnCodes error -match glob -result {circular package dependency:*} -test pkg-2.31 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package provide foo 1; error foo} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result foo -test pkg-2.32 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package provide foo 1; error foo} - catch {package require foo 1} - package provide foo -} -cleanup { - package forget foo -} -result {} -test pkg-2.33 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package provide foo 2} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.34 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {package provide foo 1.1} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.34.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1.1 {package provide foo 1} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.34.2 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1.1 {package provide foo 1} - package require foo 1.1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.35 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob -result {attempt to provide package * failed:*} -test pkg-2.35.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {break} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob \ --result {attempt to provide package * failed: bad return code:*} -test pkg-2.36 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {continue} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob \ --result {attempt to provide package * failed: bad return code:*} -test pkg-2.37 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {return} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob \ --result {attempt to provide package * failed: bad return code:*} -test pkg-2.38 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo -} -body { - package ifneeded foo 1 {return -level 0 -code 10} - package require foo 1 -} -cleanup { - package forget foo -} -returnCodes error -match glob \ --result {attempt to provide package * failed: bad return code:*} -test pkg-2.39 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {package provide foo 2 ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result * -test pkg-2.40 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {break ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result {bad return code:*} -test pkg-2.41 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {continue ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result {bad return code:*} -test pkg-2.42 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {return ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result {bad return code:*} -test pkg-2.43 {Tcl_PkgRequire: consistent return values (1162286)} -setup { - package forget foo - set saveUnknown [package unknown] - package unknown {return -level 0 -code 10 ;#} -} -body { - package require foo 1 -} -cleanup { - package forget foo - package unknown $saveUnknown -} -returnCodes error -match glob -result {bad return code:*} -test pkg-2.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { - package provide demo 1.2.3 -} -body { - package require -exact demo 1.2 -} -cleanup { - package forget demo -} -returnCodes error -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} - - -test pkg-2.50 {Tcl_PkgRequire procedure, picking best stable version} { - package forget t - 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" - } - set x xxx - package require t - set x -} {3.4} - -test pkg-2.51 {Tcl_PkgRequire procedure, picking best stable version} { - package forget t - foreach i {1.2b1 1.2 1.3a2 1.3} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {1.3} - -test pkg-2.52 {Tcl_PkgRequire procedure, picking best stable version} { - package forget t - foreach i {1.2b1 1.2 1.3 1.3a2} { - package ifneeded t $i "set x $i; package provide t $i" - } - set x xxx - package require t - set x -} {1.3} - - - -test pkg-3.1 {Tcl_PackageCmd procedure} { - list [catch {package} msg] $msg -} {1 {wrong # args: should be "package option ?arg ...?"}} -test pkg-3.2 {Tcl_PackageCmd procedure, "forget" option} { - foreach i [package names] { - package forget $i - } - package names -} {} -test pkg-3.3 {Tcl_PackageCmd procedure, "forget" option} { - foreach i [package names] { - package forget $i - } - package forget foo -} {} -test pkg-3.4 {Tcl_PackageCmd procedure, "forget" option} { - foreach i [package names] { - package forget $i - } - package ifneeded t 1.1 {first script} - package ifneeded t 2.3 {second script} - package ifneeded x 1.4 {x's script} - set result {} - lappend result [lsort [package names]] [package versions t] - package forget t - lappend result [lsort [package names]] [package versions t] -} {{t x} {1.1 2.3} x {}} -test pkg-3.5 {Tcl_PackageCmd procedure, "forget" option} { - foreach i [package names] { - package forget $i - } - package ifneeded a 1.1 {first script} - package ifneeded b 2.3 {second script} - package ifneeded c 1.4 {third script} - package forget - set result [list [lsort [package names]]] - package forget a c - lappend result [lsort [package names]] -} {{a b c} b} -test pkg-3.5.1 {Tcl_PackageCmd procedure, "forget" option} { - # Test for Bug 415273 - package ifneeded a 1 "I should have been forgotten" - package forget no-such-package a - set x [package ifneeded a 1] - package forget a - set x -} {} -test pkg-3.6 {Tcl_PackageCmd procedure, "ifneeded" option} { - list [catch {package ifneeded a} msg] $msg -} {1 {wrong # args: should be "package ifneeded package version ?script?"}} -test pkg-3.7 {Tcl_PackageCmd procedure, "ifneeded" option} { - list [catch {package ifneeded a b c d} msg] $msg -} {1 {wrong # args: should be "package ifneeded package version ?script?"}} -test pkg-3.8 {Tcl_PackageCmd procedure, "ifneeded" option} { - list [catch {package ifneeded t xyz} msg] $msg -} {1 {expected version number but got "xyz"}} -test pkg-3.9 {Tcl_PackageCmd procedure, "ifneeded" option} { - foreach i [package names] { - package forget $i - } - list [package ifneeded foo 1.1] [package names] -} {{} {}} -test pkg-3.10 {Tcl_PackageCmd procedure, "ifneeded" option} { - package forget t - package ifneeded t 1.4 "script for t 1.4" - list [package names] [package ifneeded t 1.4] [package versions t] -} {t {script for t 1.4} 1.4} -test pkg-3.11 {Tcl_PackageCmd procedure, "ifneeded" option} { - package forget t - package ifneeded t 1.4 "script for t 1.4" - list [package ifneeded t 1.5] [package names] [package versions t] -} {{} t 1.4} -test pkg-3.12 {Tcl_PackageCmd procedure, "ifneeded" option} { - package forget t - 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] -} {{second script for t 1.4} t 1.4} -test pkg-3.13 {Tcl_PackageCmd procedure, "ifneeded" option} { - package forget t - package ifneeded t 1.4 "script for t 1.4" - package ifneeded t 1.2 "second script" - package ifneeded t 3.1 "last script" - list [package ifneeded t 1.2] [package versions t] -} {{second script} {1.4 1.2 3.1}} -test pkg-3.14 {Tcl_PackageCmd procedure, "names" option} { - list [catch {package names a} msg] $msg -} {1 {wrong # args: should be "package names"}} -test pkg-3.15 {Tcl_PackageCmd procedure, "names" option} { - foreach i [package names] { - package forget $i - } - package names -} {} -test pkg-3.16 {Tcl_PackageCmd procedure, "names" option} { - foreach i [package names] { - package forget $i - } - 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] -} {x y} -test pkg-3.17 {Tcl_PackageCmd procedure, "provide" option} { - list [catch {package provide} msg] $msg -} {1 {wrong # args: should be "package provide package ?version?"}} -test pkg-3.18 {Tcl_PackageCmd procedure, "provide" option} { - list [catch {package provide a b c} msg] $msg -} {1 {wrong # args: should be "package provide package ?version?"}} -test pkg-3.19 {Tcl_PackageCmd procedure, "provide" option} { - package forget t - package provide t -} {} -test pkg-3.20 {Tcl_PackageCmd procedure, "provide" option} { - package forget t - package provide t 2.3 - package provide t -} {2.3} -test pkg-3.21 {Tcl_PackageCmd procedure, "provide" option} { - package forget t - list [catch {package provide t a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require} msg] $msg -} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} - -test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require -exact a b c} msg] $msg - # Exact syntax: -exact name version - # name ?requirement ...? -} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} - -test pkg-3.26 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require x a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.27 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require -exact x a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require -exact x} msg] $msg -} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} -test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} { - list [catch {package require -exact} msg] $msg -} {1 {wrong # args: should be "package require ?-exact? package ?requirement ...?"}} -test pkg-3.30 {Tcl_PackageCmd procedure, "require" option} { - package forget t - package provide t 2.3 - package require t 2.1 -} {2.3} -test pkg-3.31 {Tcl_PackageCmd procedure, "require" option} { - package forget t - list [catch {package require t} msg] $msg -} {1 {can't find package t}} -test pkg-3.32 {Tcl_PackageCmd procedure, "require" option} { - package forget t - package ifneeded t 2.3 "error {synthetic error}" - list [catch {package require t 2.3} msg] $msg -} {1 {synthetic error}} -test pkg-3.33 {Tcl_PackageCmd procedure, "unknown" option} { - list [catch {package unknown a b} msg] $msg -} {1 {wrong # args: should be "package unknown ?command?"}} -test pkg-3.34 {Tcl_PackageCmd procedure, "unknown" option} { - package unknown "test script" - package unknown -} {test script} -test pkg-3.35 {Tcl_PackageCmd procedure, "unknown" option} { - package unknown "test script" - package unknown {} - package unknown -} {} -test pkg-3.36 {Tcl_PackageCmd procedure, "vcompare" option} { - list [catch {package vcompare a} msg] $msg -} {1 {wrong # args: should be "package vcompare version1 version2"}} -test pkg-3.37 {Tcl_PackageCmd procedure, "vcompare" option} { - list [catch {package vcompare a b c} msg] $msg -} {1 {wrong # args: should be "package vcompare version1 version2"}} -test pkg-3.38 {Tcl_PackageCmd procedure, "vcompare" option} { - list [catch {package vcompare x.y 3.4} msg] $msg -} {1 {expected version number but got "x.y"}} -test pkg-3.39 {Tcl_PackageCmd procedure, "vcompare" option} { - list [catch {package vcompare 2.1 a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.40 {Tcl_PackageCmd procedure, "vcompare" option} { - package vc 2.1 2.3 -} {-1} -test pkg-3.41 {Tcl_PackageCmd procedure, "vcompare" option} { - package vc 2.2.4 2.2.4 -} {0} -test pkg-3.42 {Tcl_PackageCmd procedure, "versions" option} { - list [catch {package versions} msg] $msg -} {1 {wrong # args: should be "package versions package"}} -test pkg-3.43 {Tcl_PackageCmd procedure, "versions" option} { - list [catch {package versions a b} msg] $msg -} {1 {wrong # args: should be "package versions package"}} -test pkg-3.44 {Tcl_PackageCmd procedure, "versions" option} { - package forget t - package versions t -} {} -test pkg-3.45 {Tcl_PackageCmd procedure, "versions" option} { - package forget t - package provide t 2.3 - package versions t -} {} -test pkg-3.46 {Tcl_PackageCmd procedure, "versions" option} { - package forget t - package ifneeded t 2.3 x - package ifneeded t 2.4 y - package versions t -} {2.3 2.4} -test pkg-3.47 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies a} msg] $msg -} {1 {wrong # args: should be "package vsatisfies version ?requirement ...?"}} - -test pkg-3.49 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies x.y 3.4} msg] $msg -} {1 {expected version number but got "x.y"}} -test pkg-3.50 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vcompare 2.1 a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-3.51 {Tcl_PackageCmd procedure, "vsatisfies" option} { - package vs 2.3 2.1 -} {1} -test pkg-3.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { - package vs 2.3 1.2 -} {0} -test pkg-3.53 {Tcl_PackageCmd procedure, "versions" option} { - list [catch {package foo} msg] $msg -} {1 {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies}} - -test pkg-3.54 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies 2.1 2.1-3.2-4.5} msg] $msg -} {1 {expected versionMin-versionMax but got "2.1-3.2-4.5"}} - -test pkg-3.55 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies 2.1 3.2-x.y} msg] $msg -} {1 {expected version number but got "x.y"}} - -test pkg-3.56 {Tcl_PackageCmd procedure, "vsatisfies" option} { - list [catch {package vsatisfies 2.1 x.y-3.2} msg] $msg -} {1 {expected version number but got "x.y"}} - - -# No tests for FindPackage; can't think up anything detectable -# errors. - -test pkg-4.1 {TclFreePackageInfo procedure} { - interp create foo - foo 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 foo -} {} -test pkg-4.2 {TclFreePackageInfo procedure} -body { - interp create foo - foo eval { - package ifneeded t 2.3 x - package ifneeded t 2.4 y - package ifneeded x 3.1 z - package provide q 4.3 - } - foo alias z kill - proc kill {} { - interp delete foo - } - foo eval package require x 3.1 -} -returnCodes error -match glob -result * - -test pkg-5.1 {CheckVersion procedure} { - list [catch {package vcompare 1 2.1} msg] $msg -} {0 -1} -test pkg-5.2 {CheckVersion procedure} { - list [catch {package vcompare .1 2.1} msg] $msg -} {1 {expected version number but got ".1"}} -test pkg-5.3 {CheckVersion procedure} { - list [catch {package vcompare 111.2a.3 2.1} msg] $msg -} {1 {expected version number but got "111.2a.3"}} -test pkg-5.4 {CheckVersion procedure} { - list [catch {package vcompare 1.2.3. 2.1} msg] $msg -} {1 {expected version number but got "1.2.3."}} -test pkg-5.5 {CheckVersion procedure} { - list [catch {package vcompare 1.2..3 2.1} msg] $msg -} {1 {expected version number but got "1.2..3"}} - -test pkg-6.1 {ComparePkgVersions procedure} { - package vcompare 1.23 1.22 -} {1} -test pkg-6.2 {ComparePkgVersions procedure} { - package vcompare 1.22.1.2.3 1.22.1.2.3 -} {0} -test pkg-6.3 {ComparePkgVersions procedure} { - package vcompare 1.21 1.22 -} {-1} -test pkg-6.4 {ComparePkgVersions procedure} { - package vcompare 1.21 1.21.2 -} {-1} -test pkg-6.5 {ComparePkgVersions procedure} { - package vcompare 1.21.1 1.21 -} {1} -test pkg-6.6 {ComparePkgVersions procedure} { - package vsatisfies 1.21.1 1.21 -} {1} -test pkg-6.7 {ComparePkgVersions procedure} { - package vsatisfies 2.22.3 1.21 -} {0} -test pkg-6.8 {ComparePkgVersions procedure} { - package vsatisfies 1 1 -} {1} -test pkg-6.9 {ComparePkgVersions procedure} { - package vsatisfies 2 1 -} {0} - -test pkg-7.1 {Tcl_PkgPresent procedure, any version} { - package forget t - package provide t 2.4 - package present t -} {2.4} -test pkg-7.2 {Tcl_PkgPresent procedure, correct version} { - package forget t - package provide t 2.4 - package present t 2.4 -} {2.4} -test pkg-7.3 {Tcl_PkgPresent procedure, satisfying version} { - package forget t - package provide t 2.4 - package present t 2.0 -} {2.4} -test pkg-7.4 {Tcl_PkgPresent procedure, not satisfying version} { - package forget t - package provide t 2.4 - list [catch {package present t 2.6} msg] $msg -} {1 {version conflict for package "t": have 2.4, need 2.6}} -test pkg-7.5 {Tcl_PkgPresent procedure, not satisfying version} { - package forget t - package provide t 2.4 - list [catch {package present t 1.0} msg] $msg -} {1 {version conflict for package "t": have 2.4, need 1.0}} -test pkg-7.6 {Tcl_PkgPresent procedure, exact version} { - package forget t - package provide t 2.4 - package present -exact t 2.4 -} {2.4} -test pkg-7.7 {Tcl_PkgPresent procedure, not exact version} { - package forget t - package provide t 2.4 - list [catch {package present -exact t 2.3} msg] $msg -} {1 {version conflict for package "t": have 2.4, need exactly 2.3}} -test pkg-7.8 {Tcl_PkgPresent procedure, unknown package} { - package forget t - list [catch {package present t} msg] $msg -} {1 {package t is not present}} -test pkg-7.9 {Tcl_PkgPresent procedure, unknown package} { - package forget t - list [catch {package present t 2.4} msg] $msg -} {1 {package t 2.4 is not present}} -test pkg-7.10 {Tcl_PkgPresent procedure, unknown package} { - package forget t - list [catch {package present -exact t 2.4} msg] $msg -} {1 {package t 2.4 is not present}} -test pkg-7.11 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} -test pkg-7.12 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present a b c} msg] $msg -} {1 {expected version number but got "b"}} -test pkg-7.13 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -exact a b c} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} -test pkg-7.14 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -bs a b} msg] $msg -} {1 {expected version number but got "a"}} -test pkg-7.15 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present x a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-7.16 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -exact x a.b} msg] $msg -} {1 {expected version number but got "a.b"}} -test pkg-7.17 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -exact x} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} -test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} { - list [catch {package present -exact} msg] $msg -} {1 {wrong # args: should be "package present ?-exact? package ?requirement ...?"}} - - - - -set n 0 -foreach {r p vs vc} { - 8.5a0 8.5a5 1 -1 - 8.5a0 8.5b1 1 -1 - 8.5a0 8.5.1 1 -1 - 8.5a0 8.6a0 1 -1 - 8.5a0 8.6b0 1 -1 - 8.5a0 8.6.0 1 -1 - 8.5a6 8.5a5 0 1 - 8.5a6 8.5b1 1 -1 - 8.5a6 8.5.1 1 -1 - 8.5a6 8.6a0 1 -1 - 8.5a6 8.6b0 1 -1 - 8.5a6 8.6.0 1 -1 - 8.5b0 8.5a5 0 1 - 8.5b0 8.5b1 1 -1 - 8.5b0 8.5.1 1 -1 - 8.5b0 8.6a0 1 -1 - 8.5b0 8.6b0 1 -1 - 8.5b0 8.6.0 1 -1 - 8.5b2 8.5a5 0 1 - 8.5b2 8.5b1 0 1 - 8.5b2 8.5.1 1 -1 - 8.5b2 8.6a0 1 -1 - 8.5b2 8.6b0 1 -1 - 8.5b2 8.6.0 1 -1 - 8.5 8.5a5 1 1 - 8.5 8.5b1 1 1 - 8.5 8.5.1 1 -1 - 8.5 8.6a0 1 -1 - 8.5 8.6b0 1 -1 - 8.5 8.6.0 1 -1 - 8.5.0 8.5a5 0 1 - 8.5.0 8.5b1 0 1 - 8.5.0 8.5.1 1 -1 - 8.5.0 8.6a0 1 -1 - 8.5.0 8.6b0 1 -1 - 8.5.0 8.6.0 1 -1 - 10 8 0 1 - 8 10 0 -1 - 0.0.1.2 0.1.2 1 -1 -} { - test package-vsatisfies-1.$n {package vsatisfies} { - package vsatisfies $p $r - } $vs - - test package-vcompare-1.$n {package vcompare} { - package vcompare $r $p - } $vc - - incr n -} - -test package-vcompare-2.0 {package vcompare at 32bit boundary} { - package vcompare [expr {1<<31}] [expr {(1<<31)-1}] -} 1 - -# Note: It is correct that the result of the very first test, -# i.e. "5.0 5.0a0" is 1, i.e. that version 5.0a0 satisfies a 5.0 -# requirement. - -# The requirement "5.0" internally translates first to "5.0-6", and -# then to its final form of "5.0a0-6a0". These translations are -# explicitly specified by the TIP (Search for "padded/extended -# internally with 'a0'"). This was done intentionally for exactly the -# tested case, that an alpha package can satisfy a requirement for the -# regular package. An example would be a package FOO requiring Tcl 8.X -# for its operation. It can be used with Tcl 8.Xa0. Without our -# translation that would not be possible. - -set n 0 -foreach {required provided satisfied} { - 5.0 5.0a0 1 - 5.0a0 5.0 1 - - 8.5a0- 8.5a5 1 - 8.5a0- 8.5b1 1 - 8.5a0- 8.5.1 1 - 8.5a0- 8.6a0 1 - 8.5a0- 8.6b0 1 - 8.5a0- 8.6.0 1 - 8.5a6- 8.5a5 0 - 8.5a6- 8.5b1 1 - 8.5a6- 8.5.1 1 - 8.5a6- 8.6a0 1 - 8.5a6- 8.6b0 1 - 8.5a6- 8.6.0 1 - 8.5b0- 8.5a5 0 - 8.5b0- 8.5b1 1 - 8.5b0- 8.5.1 1 - 8.5b0- 8.6a0 1 - 8.5b0- 8.6b0 1 - 8.5b0- 8.6.0 1 - 8.5b2- 8.5a5 0 - 8.5b2- 8.5b1 0 - 8.5b2- 8.5.1 1 - 8.5b2- 8.6a0 1 - 8.5b2- 8.6b0 1 - 8.5b2- 8.6.0 1 - 8.5- 8.5a5 1 - 8.5- 8.5b1 1 - 8.5- 8.5.1 1 - 8.5- 8.6a0 1 - 8.5- 8.6b0 1 - 8.5- 8.6.0 1 - 8.5.0- 8.5a5 0 - 8.5.0- 8.5b1 0 - 8.5.0- 8.5.1 1 - 8.5.0- 8.6a0 1 - 8.5.0- 8.6b0 1 - 8.5.0- 8.6.0 1 - 8.5a0-7 8.5a5 0 - 8.5a0-7 8.5b1 0 - 8.5a0-7 8.5.1 0 - 8.5a0-7 8.6a0 0 - 8.5a0-7 8.6b0 0 - 8.5a0-7 8.6.0 0 - 8.5a6-7 8.5a5 0 - 8.5a6-7 8.5b1 0 - 8.5a6-7 8.5.1 0 - 8.5a6-7 8.6a0 0 - 8.5a6-7 8.6b0 0 - 8.5a6-7 8.6.0 0 - 8.5b0-7 8.5a5 0 - 8.5b0-7 8.5b1 0 - 8.5b0-7 8.5.1 0 - 8.5b0-7 8.6a0 0 - 8.5b0-7 8.6b0 0 - 8.5b0-7 8.6.0 0 - 8.5b2-7 8.5a5 0 - 8.5b2-7 8.5b1 0 - 8.5b2-7 8.5.1 0 - 8.5b2-7 8.6a0 0 - 8.5b2-7 8.6b0 0 - 8.5b2-7 8.6.0 0 - 8.5-7 8.5a5 0 - 8.5-7 8.5b1 0 - 8.5-7 8.5.1 0 - 8.5-7 8.6a0 0 - 8.5-7 8.6b0 0 - 8.5-7 8.6.0 0 - 8.5.0-7 8.5a5 0 - 8.5.0-7 8.5b1 0 - 8.5.0-7 8.5.1 0 - 8.5.0-7 8.6a0 0 - 8.5.0-7 8.6b0 0 - 8.5.0-7 8.6.0 0 - 8.5a0-8.6.1 8.5a5 1 - 8.5a0-8.6.1 8.5b1 1 - 8.5a0-8.6.1 8.5.1 1 - 8.5a0-8.6.1 8.6a0 1 - 8.5a0-8.6.1 8.6b0 1 - 8.5a0-8.6.1 8.6.0 1 - 8.5a6-8.6.1 8.5a5 0 - 8.5a6-8.6.1 8.5b1 1 - 8.5a6-8.6.1 8.5.1 1 - 8.5a6-8.6.1 8.6a0 1 - 8.5a6-8.6.1 8.6b0 1 - 8.5a6-8.6.1 8.6.0 1 - 8.5b0-8.6.1 8.5a5 0 - 8.5b0-8.6.1 8.5b1 1 - 8.5b0-8.6.1 8.5.1 1 - 8.5b0-8.6.1 8.6a0 1 - 8.5b0-8.6.1 8.6b0 1 - 8.5b0-8.6.1 8.6.0 1 - 8.5b2-8.6.1 8.5a5 0 - 8.5b2-8.6.1 8.5b1 0 - 8.5b2-8.6.1 8.5.1 1 - 8.5b2-8.6.1 8.6a0 1 - 8.5b2-8.6.1 8.6b0 1 - 8.5b2-8.6.1 8.6.0 1 - 8.5-8.6.1 8.5a5 1 - 8.5-8.6.1 8.5b1 1 - 8.5-8.6.1 8.5.1 1 - 8.5-8.6.1 8.6a0 1 - 8.5-8.6.1 8.6b0 1 - 8.5-8.6.1 8.6.0 1 - 8.5.0-8.6.1 8.5a5 0 - 8.5.0-8.6.1 8.5b1 0 - 8.5.0-8.6.1 8.5.1 1 - 8.5.0-8.6.1 8.6a0 1 - 8.5.0-8.6.1 8.6b0 1 - 8.5.0-8.6.1 8.6.0 1 - 8.5a0-8.5a0 8.5a0 1 - 8.5a0-8.5a0 8.5b1 0 - 8.5a0-8.5a0 8.4 0 - 8.5b0-8.5b0 8.5a5 0 - 8.5b0-8.5b0 8.5b0 1 - 8.5b0-8.5b0 8.5.1 0 - 8.5-8.5 8.5a5 0 - 8.5-8.5 8.5b1 0 - 8.5-8.5 8.5 1 - 8.5-8.5 8.5.1 0 - 8.5.0-8.5.0 8.5a5 0 - 8.5.0-8.5.0 8.5b1 0 - 8.5.0-8.5.0 8.5.0 1 - 8.5.0-8.5.0 8.5.1 0 - 8.5.0-8.5.0 8.6a0 0 - 8.5.0-8.5.0 8.6b0 0 - 8.5.0-8.5.0 8.6.0 0 - 8.2 9 0 - 8.2- 9 1 - 8.2-8.5 9 0 - 8.2-9.1 9 1 - - 8.5-8.5 8.5b1 0 - 8.5a0-8.5 8.5b1 0 - 8.5a0-8.5.1 8.5b1 1 - - 8.5-8.5 8.5 1 - 8.5.0-8.5.0 8.5 1 - 8.5a0-8.5.0 8.5 0 - -} { - test package-vsatisfies-2.$n "package vsatisfies $provided $required" { - package vsatisfies $provided $required - } $satisfied - incr n -} - -test package-vsatisfies-3.0 "package vsatisfies multiple" { - # yes no - package vsatisfies 8.4 8.4 7.3 -} 1 - -test package-vsatisfies-3.1 "package vsatisfies multiple" { - # no yes - package vsatisfies 8.4 7.3 8.4 -} 1 - -test package-vsatisfies-3.2 "package vsatisfies multiple" { - # yes yes - package vsatisfies 8.4.2 8.4 8.4.1 -} 1 - -test package-vsatisfies-3.3 "package vsatisfies multiple" { - # no no - package vsatisfies 8.4 7.3 6.1 -} 0 - - -proc prefer {args} { - set ip [interp create] - lappend res [$ip eval {package prefer}] - foreach mode $args { - lappend res [$ip eval [list package prefer $mode]] - } - interp delete $ip - return $res -} - -test package-prefer-1.0 {default} { - prefer -} stable - -test package-prefer-1.1 {default} { - set ::env(TCL_PKG_PREFER_LATEST) stable ; # value not relevant! - set res [prefer] - unset ::env(TCL_PKG_PREFER_LATEST) - set res -} latest - -test package-prefer-2.0 {wrong\#args} { - catch {package prefer foo bar} msg - set msg -} {wrong # args: should be "package prefer ?latest|stable?"} - -test package-prefer-2.1 {bogus argument} { - catch {package prefer foo} msg - set msg -} {bad preference "foo": must be latest or stable} - -test package-prefer-3.0 {set, keep} { - package prefer stable -} stable - -test package-prefer-3.1 {set stable, keep} { - prefer stable -} {stable stable} - -test package-prefer-3.2 {set latest, change} { - prefer latest -} {stable latest} - -test package-prefer-3.3 {set latest, keep} { - prefer latest latest -} {stable latest latest} - -test package-prefer-3.4 {set stable, rejected} { - prefer latest stable -} {stable latest latest} - -rename prefer {} - - -set auto_path $oldPath -package unknown $oldPkgUnknown -concat - -cleanupTests -} - -# cleanup -interp delete $i -::tcltest::cleanupTests -return diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 0db6533..0fe394e 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -2,13 +2,11 @@ # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# 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. # All rights reserved. -# -# RCS: @(#) $Id: pkgMkIndex.test,v 1.29 2006/11/03 00:34:53 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -17,7 +15,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} { set fullPkgPath [makeDirectory pkg] - namespace eval pkgtest { # Namespace for procs we can discard } @@ -27,8 +24,8 @@ namespace eval pkgtest { # Parse an argument list. # # Arguments: -# <flags> (optional) arguments starting with a dash are collected -# as options to pkg_mkIndex and passed to pkg_mkIndex. +# <flags> (optional) arguments starting with a dash are collected as +# options to pkg_mkIndex and passed to pkg_mkIndex. # dirPath the directory to index # pattern0 pattern to index # ... pattern to index @@ -130,13 +127,13 @@ proc pkgtest::parseIndex { filePath } { # pkgtest::createIndex -- # -# Runs pkg_mkIndex for the given directory and set of patterns. -# This procedure deletes any pkgIndex.tcl file in the target directory, -# then runs pkg_mkIndex. +# Runs pkg_mkIndex for the given directory and set of patterns. This +# procedure deletes any pkgIndex.tcl file in the target directory, then runs +# pkg_mkIndex. # # Arguments: -# <flags> (optional) arguments starting with a dash are collected -# as options to pkg_mkIndex and passed to pkg_mkIndex. +# <flags> (optional) arguments starting with a dash are collected as +# options to pkg_mkIndex and passed to pkg_mkIndex. # dirPath the directory to index # pattern0 pattern to index # ... pattern to index @@ -194,11 +191,9 @@ proc makePkgList { inList } { lappend l $s } } - source { set l $v } - default { error "can't handle $k $v" } @@ -215,8 +210,8 @@ proc makePkgList { inList } { # Runs pkg_mkIndex, parses the generated index file. # # Arguments: -# <flags> (optional) arguments starting with a dash are collected -# as options to pkg_mkIndex and passed to pkg_mkIndex. +# <flags> (optional) arguments starting with a dash are collected as +# options to pkg_mkIndex and passed to pkg_mkIndex. # dirPath the directory to index # pattern0 pattern to index # ... pattern to index @@ -226,8 +221,7 @@ proc makePkgList { inList } { # Returns a two element list: # 0: 1 if the procedure encountered an error, 0 otherwise. # 1: if no error, this is the parsed generated index file, in the format -# returned by pkgtest::parseIndex. -# If error, this is the error result. +# returned by pkgtest::parseIndex. If error, this is the error result. proc pkgtest::runCreatedIndex {rv args} { if {[lindex $rv 0] == 0} { @@ -251,9 +245,9 @@ proc pkgtest::runIndex { args } { set rv [createIndex {*}$args] return [runCreatedIndex $rv {*}$args] } - -# If there is no match to the patterns, make sure the directory hasn't -# changed on us + +# If there is no match to the patterns, make sure the directory hasn't changed +# on us test pkgMkIndex-1.1 {nothing matches pattern - current dir is the same} { list [pkgtest::runIndex -lazy $fullPkgPath nomatch.tcl] [pwd] @@ -314,8 +308,8 @@ removeFile [file join pkg global.tcl] makeFile { # This package is required by pkg1. -# This package is split into two files, to test packages that are split -# over multiple files. +# This package is split into two files, to test packages that are split over +# multiple files. package provide pkg2 1.0 namespace eval pkg2 { namespace export p2-1 @@ -327,8 +321,8 @@ proc pkg2::p2-1 { num } { makeFile { # This package is required by pkg1. -# This package is split into two files, to test packages that are split -# over multiple files. +# This package is split into two files, to test packages that are split over +# multiple files. package provide pkg2 1.0 namespace eval pkg2 { namespace export p2-2 @@ -347,8 +341,8 @@ test pkgMkIndex-4.2 {split package - direct loading} { } "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]] [list source [file join $fullPkgPath pkg2_b.tcl]]}}}" -# Add the direct1 directory to auto_path, so that the direct1 package -# can be found. +# Add the direct1 directory to auto_path, so that the direct1 package can be +# found. set direct1 [makeDirectory direct1] lappend auto_path $direct1 makeFile { @@ -367,9 +361,9 @@ proc direct1::pd2 { stg } { pkg_mkIndex -direct $direct1 direct1.tcl makeFile { -# Does a package require of direct1, whose pkgIndex.tcl entry -# is created above with option -direct. This tests that pkg_mkIndex -# can handle code that is sourced in pkgIndex.tcl files. +# Does a package require of direct1, whose pkgIndex.tcl entry is created +# above with option -direct. This tests that pkg_mkIndex can handle code +# that is sourced in pkgIndex.tcl files. package require direct1 package provide std 1.0 namespace eval std { @@ -393,9 +387,9 @@ removeDirectory direct1 removeFile [file join pkg std.tcl] makeFile { -# This package requires pkg3, but it does -# not use any of pkg3's procs in the code that is executed by the file -# (i.e. references to pkg3's procs are in the proc bodies only). +# This package requires pkg3, but it does not use any of pkg3's procs in the +# code that is executed by the file (i.e. references to pkg3's procs are in +# the proc bodies only). package require pkg3 1.0 package provide pkg1 1.0 namespace eval pkg1 { @@ -433,8 +427,8 @@ test pkgMkIndex-6.2 {pkg1 requires pkg3 - use -direct} { removeFile [file join pkg pkg1.tcl] makeFile { -# This package requires pkg3, and it calls -# a pkg3 proc in the code that is executed by the file +# This package requires pkg3, and it calls a pkg3 proc in the code that is +# executed by the file package require pkg3 1.0 package provide pkg4 1.0 namespace eval pkg4 { @@ -462,9 +456,8 @@ removeFile [file join pkg pkg4.tcl] removeFile [file join pkg pkg3.tcl] makeFile { -# This package requires pkg2, and it calls -# a pkg2 proc in the code that is executed by the file. -# Pkg2 is a split package. +# This package requires pkg2, and it calls a pkg2 proc in the code that is +# executed by the file. Pkg2 is a split package. package require pkg2 1.0 package provide pkg5 1.0 namespace eval pkg5 { @@ -496,9 +489,9 @@ removeFile [file join pkg pkg2_a.tcl] removeFile [file join pkg pkg2_b.tcl] makeFile { -# This package requires circ2, and circ2 -# requires circ3, which in turn requires circ1. -# In case of cirularities, pkg_mkIndex should give up when it gets stuck. +# This package requires circ2, and circ2 requires circ3, which in turn +# requires circ1. In case of cirularities, pkg_mkIndex should give up when +# it gets stuck. package require circ2 1.0 package provide circ1 1.0 namespace eval circ1 { @@ -519,8 +512,8 @@ proc circ1::c1-4 {} { } [file join pkg circ1.tcl] makeFile { -# This package is required by circ1, and -# requires circ3. Circ3, in turn, requires circ1 to give us a circularity. +# This package is required by circ1, and requires circ3. Circ3, in turn, +# requires circ1 to give us a circularity. package require circ3 1.0 package provide circ2 1.0 namespace eval circ2 { @@ -535,8 +528,8 @@ proc circ2::c2-2 { num } { } [file join pkg circ2.tcl] makeFile { -# This package is required by circ2, and in -# turn requires circ1. This closes the circularity. +# This package is required by circ2, and in turn requires circ1. This closes +# the circularity. package require circ1 1.0 package provide circ3 1.0 namespace eval circ3 { @@ -577,22 +570,23 @@ proc pkga_neq { x } { testConstraint exec [llength [info commands ::exec]] test pkgMkIndex-10.1 {package in DLL and script} [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 it. + # 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 + # it. 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}}}}" 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 it. + # 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 + # it. # # This test depends on context from prior test, so repeat it. - set script "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]\n" - append script \ - "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]" + set script \ + "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]" + append script \n \ + "[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]" exec [interpreter] << $script pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension] } {0 {}} @@ -625,9 +619,8 @@ test pkgMkIndex-11.1 {conflicting namespace imports} { removeFile [file join pkg import.tcl] -# Verify that the auto load list generated is correct even when there -# is a proc name conflict between two namespaces (ie, ::foo::baz and -# ::bar::baz) +# Verify that the auto load list generated is correct even when there is a +# proc name conflict between two namespaces (ie, ::foo::baz and ::bar::baz) makeFile { package provide football 1.0 @@ -692,7 +685,7 @@ test pkgMkIndex-14.5 {tcl::Pkg::CompareExtension} {unix} { test pkgMkIndex-14.6 {tcl::Pkg::CompareExtension} {unix} { tcl::Pkg::CompareExtension foo.so.1.2.bar .so } 0 - + # cleanup removeDirectory pkg @@ -701,3 +694,7 @@ namespace delete pkgtest ::tcltest::cleanupTests return +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/platform.test b/tests/platform.test index fd9ed66..aab7c78 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -8,15 +8,16 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -testConstraint testWinCPUID [llength [info commands testwincpuid]] +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +testConstraint testCPUID [llength [info commands testcpuid]] test platform-1.1 {TclpSetVariables: tcl_platform} { interp create i @@ -38,12 +39,12 @@ test platform-2.1 {tcl_platform(wordSize) indicates size of native word} { list [expr {$result < 0}] [expr {$result ^ int($result - 1)}] } {1 -1} -# On Windows, test that the CPU ID works +# On Windows/UNIX, test that the CPU ID works -test platform-3.1 {CPU ID on Windows } \ - -constraints testWinCPUID \ +test platform-3.1 {CPU ID on Windows/UNIX} \ + -constraints testCPUID \ -body { - set cpudata [testwincpuid 0] + set cpudata [testcpuid 0] binary format iii \ [lindex $cpudata 1] \ [lindex $cpudata 3] \ diff --git a/tests/proc-old.test b/tests/proc-old.test index 6a95528..e45cf5c 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -13,8 +13,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: proc-old.test,v 1.18 2010/03/31 10:29:22 nijtmans Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/proc.test b/tests/proc.test index 789c671..e06720e 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -1,40 +1,34 @@ -# This file contains tests for the tclProc.c source file. Tests appear in -# the same order as the C code that they test. The set of tests is -# currently incomplete since it includes only new tests, in particular -# tests for code changed for the addition of Tcl namespaces. Other -# procedure-related tests appear in other test files such as proc-old.test. +# This file contains tests for the tclProc.c source file. Tests appear in the +# same order as the C code that they test. The set of tests is currently +# incomplete since it includes only new tests, in particular tests for code +# changed for the addition of Tcl namespaces. Other procedure-related tests +# appear in other test files such as proc-old.test. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# 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. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: proc.test,v 1.21 2009/10/29 17:21:48 dgp Exp $ +# 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 namespace import -force ::tcltest::* } -if {[catch {package require procbodytest}]} { - testConstraint procbodytest 0 -} else { - testConstraint procbodytest 1 -} - -testConstraint memory [llength [info commands memory]] +testConstraint procbodytest [expr {![catch {package require procbodytest}]}] +testConstraint memory [llength [info commands memory]] catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename {} ""} catch {unset msg} - -test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} { + +test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace eval baz {} } @@ -44,23 +38,26 @@ test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} list [test_ns_1::baz::p] \ [namespace eval test_ns_1 {baz::p}] \ [info commands test_ns_1::baz::*] -} {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p} -test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} { +} -result {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p} +test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} - list [catch {proc test_ns_1::baz::p {} {}} msg] $msg -} {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}} -test proc-1.3 {Tcl_ProcObjCmd, empty proc name} { +} -returnCodes error -body { + proc test_ns_1::baz::p {} {} +} -result {can't create procedure "test_ns_1::baz::p": unknown namespace} +test proc-1.3 {Tcl_ProcObjCmd, empty proc name} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { proc :: {} { return "empty called" } list [::] \ [info body {}] -} {{empty called} { +} -result {{empty called} { return "empty called" }} -test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} { +test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace eval baz { proc p {} { @@ -70,9 +67,10 @@ test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} { } list [test_ns_1::baz::p] \ [info commands test_ns_1::baz::*] -} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p} -test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} { +} -result {{p in ::test_ns_1::baz} ::test_ns_1::baz::p} +test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::baz {} namespace eval test_ns_1 { proc baz::p {} { @@ -82,9 +80,10 @@ test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace list [test_ns_1::baz::p] \ [info commands test_ns_1::baz::*] \ [namespace eval test_ns_1::baz {namespace which p}] -} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p} -test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} { +} -result {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p} +test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { proc q: {} {return "q:"} proc value:at: {} {return "value:at:"} @@ -96,88 +95,102 @@ test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or e [lsort [info commands test_ns_1::*]] \ [namespace eval test_ns_1 {namespace which q:}] \ [namespace eval test_ns_1 {namespace which value:at:}] -} {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:} -test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} { +} -result {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:} +test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} -setup { catch {rename p ""} - list [catch {proc p {a(1) a(2)} { - set z [expr $a(1)+$a(2)] - puts "$z=z, $a(1)=$a(1)" - }} msg] $msg -} {1 {formal parameter "a(1)" is an array element}} -test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} { +} -returnCodes error -body { + 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 ""} - list [catch {proc p {b:a b::a} { - }} msg] $msg -} {1 {formal parameter "b::a" is not a simple name}} +} -body { + proc p {b:a b::a} { + } +} -returnCodes error -result {formal parameter "b::a" is not a simple name} -test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} { +test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} +} -body { proc p {} {return "p in [namespace current]"} info body p -} {return "p in [namespace current]"} -test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} { +} -result {return "p in [namespace current]"} +test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace eval baz { proc p {} {return "p in [namespace current]"} } } namespace eval test_ns_1::baz {info body p} -} {return "p in [namespace current]"} -test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} { +} -result {return "p in [namespace current]"} +test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::baz {} namespace eval test_ns_1 { proc baz::p {} {return "p in [namespace current]"} } namespace eval test_ns_1 {info body baz::p} -} {return "p in [namespace current]"} -test proc-2.4 {TclFindProc, global proc and executing in namespace} { +} -result {return "p in [namespace current]"} +test proc-2.4 {TclFindProc, global proc and executing in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} +} -body { proc p {} {return "global p"} namespace eval test_ns_1::baz {info body p} -} {return "global p"} +} -result {return "global p"} -test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} { +test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { proc p {} {return "p in [namespace current]"} p -} {p in ::} -test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} { +} -result {p in ::} +test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::baz { proc p {} {return "p in [namespace current]"} p } -} {p in ::test_ns_1::baz} -test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} { +} -result {p in ::test_ns_1::baz} +test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} +} -body { proc p {} {return "p in [namespace current]"} namespace eval test_ns_1::baz { p } -} {p in ::} -test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} { +} -result {p in ::} +test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} +} -body { namespace eval test_ns_1::baz { proc p {} {return "p in [namespace current]"} rename ::test_ns_1::baz::p ::p list [p] [namespace which p] } -} {{p in ::} ::p} -test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} { +} -result {{p in ::} ::p} +test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} -body { proc p {x} {info commands 3m} - list [catch {p} msg] $msg -} {1 {wrong # args: should be "p x"}} - -test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} { + p +} -returnCodes error -result {wrong # args: should be "p x"} +test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} -body { proc {a b c} {x} {info commands 3m} - list [catch {{a b c}} msg] $msg -} {1 {wrong # args: should be "{a b c} x"}} + {a b c} +} -returnCodes error -result {wrong # args: should be "{a b c} x"} + +test proc-3.7 {TclObjInterpProc, wrong num args, Bug 3366265} { + proc {} {x} {} + list [catch {{}} msg] $msg +} {1 {wrong # args: should be "{} x"}} catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} @@ -189,116 +202,95 @@ 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 executed, so that the Proc struct is populated correctly (CompiledLocals -# are added at compile time). +# procbody objects must be executed before the 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} procbodytest { - catch { - proc p x {return "$x:$x"} - set rv [p P] - procbodytest::proc t x p - lappend rv [t T] - set rv - } result +test proc-4.1 {TclCreateProc, procbody obj} -constraints procbodytest -body { + proc p x {return "$x:$x"} + set rv [p P] + procbodytest::proc t x p + lappend rv [t T] +} -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {P:P T:T} -test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} procbodytest { - catch { - proc p x { - set y [string tolower $x] - return "$x:$y" - } - set rv [p P] - procbodytest::proc t x p - lappend rv [t T] - set rv - } result +} -result {P:P T:T} +test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} -body { + proc p x { + set y [string tolower $x] + return "$x:$y" + } + set rv [p P] + procbodytest::proc t x p + lappend rv [t T] +} -constraints procbodytest -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {P:p T:t} -test proc-4.3 {TclCreateProc, procbody obj, too many args} procbodytest { - catch { - proc p x { - set y [string tolower $x] - return "$x:$y" - } - set rv [p P] - procbodytest::proc t {x x1 x2} p - lappend rv [t T] - set rv - } result +} -result {P:p T:t} +test proc-4.3 {TclCreateProc, procbody obj, too many args} -body { + proc p x { + set y [string tolower $x] + return "$x:$y" + } + set rv [p P] + procbodytest::proc t {x x1 x2} p + lappend rv [t T] +} -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": arg list contains 3 entries, precompiled header expects 1} -test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} procbodytest { - catch { - proc p {x y z} { - set v [join [list $x $y $z]] - set w [string tolower $v] - return "$v:$w" - } - set rv [p P Q R] - procbodytest::proc t {x x1 z} p - lappend rv [t S T U] - set rv - } result +} -result {procedure "t": arg list contains 3 entries, precompiled header expects 1} +test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} -body { + proc p {x y z} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x x1 z} p + lappend rv [t S T U] +} -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": formal parameter 1 is inconsistent with precompiled body} -test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} procbodytest { - catch { - proc p {x y {z Z}} { - set v [join [list $x $y $z]] - set w [string tolower $v] - return "$v:$w" - } - set rv [p P Q R] - procbodytest::proc t {x y z} p - lappend rv [t S T U] - set rv - } result +} -result {procedure "t": formal parameter 1 is inconsistent with precompiled body} +test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} -body { + proc p {x y {z Z}} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x y z} p + lappend rv [t S T U] +} -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": formal parameter 2 is inconsistent with precompiled body} -test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} procbodytest { - catch { - proc p {x y z} { - set v [join [list $x $y $z]] - set w [string tolower $v] - return "$v:$w" - } - set rv [p P Q R] - procbodytest::proc t {x y {z Z}} p - lappend rv [t S T U] - set rv - } result +} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} +test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} -body { + proc p {x y z} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x y {z Z}} p + lappend rv [t S T U] +} -returnCodes error -constraints procbodytest -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": formal parameter 2 is inconsistent with precompiled body} -test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} procbodytest { - catch { - proc p {x y {z Z}} { - set v [join [list $x $y $z]] - set w [string tolower $v] - return "$v:$w" - } - set rv [p P Q R] - procbodytest::proc t {x y {z ZZ}} p - lappend rv [t S T U] - set rv - } result +} -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} +test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} -body { + proc p {x y {z Z}} { + set v [join [list $x $y $z]] + set w [string tolower $v] + return "$v:$w" + } + set rv [p P Q R] + procbodytest::proc t {x y {z ZZ}} p + lappend rv [t S T U] +} -constraints procbodytest -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} +} -result {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -setup { proc getbytes {} { set lines [split [memory info] "\n"] @@ -310,12 +302,9 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set } px x } -constraints {procbodytest memory} -body { - set end [getbytes] for {set i 0} {$i < 5} {incr i} { - procbodytest::proc tx x px - set tmp $end set end [getbytes] } @@ -325,7 +314,7 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set unset -nocomplain end i tmp leakedBytes } -result 0 -test proc-5.1 {Bytecompiling noop; test for correct argument substitution} { +test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body { proc p args {} ; # this will be bytecompiled into t proc t {} { set res {} @@ -336,20 +325,20 @@ test proc-5.1 {Bytecompiling noop; test for correct argument substitution} { p $a ccccccw {bfe} {$a} [incr b] [incr a] {[incr b]} {$a} hello set res } - set result [t] + t +} -cleanup { catch {rename p ""} catch {rename t ""} - set result -} {aba} +} -result {aba} -test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} { +test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} -body { proc a {} {return -code -5} proc b {} a - set result [catch b] + catch b +} -cleanup { rename a {} rename b {} - set result -} -5 +} -result -5 test proc-7.1 {Redefining a compiled cmd: Bug 729692} { proc bar args {} @@ -359,19 +348,17 @@ test proc-7.1 {Redefining a compiled cmd: Bug 729692} { } foo } bar - -test proc-7.2 {Shadowing a compiled cmd: Bug 729692} { +test proc-7.2 {Shadowing a compiled cmd: Bug 729692} -body { namespace eval ugly {} proc ugly::foo {} { proc set args {return bar} set x 1 } - set res [list [catch {ugly::foo} msg] $msg] + ugly::foo +} -cleanup { namespace delete ugly - set res -} {0 bar} - -test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} { +} -result bar +test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} -body { namespace eval ugly {} proc ugly::foo {} { set i 0 @@ -383,15 +370,27 @@ test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} { } return $i } - set res [list [catch {ugly::foo} msg] $msg] + ugly::foo +} -cleanup { namespace delete ugly - set res -} {0 4} - - +} -result 4 +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 + unset lambda +} {} + # cleanup catch {rename p ""} catch {rename t ""} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/pwd.test b/tests/pwd.test index 1592680..175c852 100644 --- a/tests/pwd.test +++ b/tests/pwd.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: pwd.test,v 1.7 2004/05/19 13:00:13 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 diff --git a/tests/reg.test b/tests/reg.test index 46b5e64..a0ea850 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -8,13 +8,14 @@ # to read this file, ignoring the Tcl-isms.) # # Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. -# -# RCS: @(#) $Id: reg.test,v 1.26 2009/10/29 17:21:48 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # All tests require the testregexp command, return if this # command doesn't exist @@ -176,14 +177,32 @@ namespace eval RETest { return $ret } + # Share the generation of the list of test constraints so it is + # done the same on all routes. + proc TestConstraints {flags} { + set constraints [list testregexp] + + variable regBug + if {$regBug} { + # This will trigger registration as a skipped test + lappend constraints knownBug + } + + # Tcl locale stuff doesn't do the ch/xy test fakery yet + if {[string match *+* $flags]} { + # This will trigger registration as a skipped test + lappend constraints localeRegexp + } + + return $constraints + } + # match expected, internal routine that does the work # parameters like the "real" routines except they don't have "opts", # which is a possibly-empty list of switches for the regexp match attempt # The ! flag is used to indicate expected match failure (for REG_EXPECT, # which wants argument testing even in the event of failure). proc MatchExpected {opts testid flags re target args} { - variable regBug - # if &, test as both BRE and ARE if {[string match *&* $flags]} { set f [string map {& {}} $flags] @@ -192,18 +211,7 @@ namespace eval RETest { return } - set constraints [list testregexp] - - if {$regBug} { - # This will register as a skipped test - lappend constraints knownBug - } - - # Tcl locale stuff doesn't do the ch/xy test fakery yet - if {[string match *+* $flags]} { - # This will register as a skipped test - lappend constraints localeRegexp - } + set constraints [TestConstraints $flags] set f [TestFlags $flags] set infoflags [TestInfoFlags $flags] @@ -254,13 +262,7 @@ namespace eval RETest { return } - set constraints [list testregexp] - - # Tcl locale stuff doesn't do the ch/xy test fakery yet - if {[string match *+* $flags]} { - # This will register as a skipped test - lappend constraints localeRegexp - } + set constraints [TestConstraints $flags] set cmd [list testregexp -about {*}[TestFlags $flags] $re] ::tcltest::test [TestNum $testid error] [TestDesc $testid error] \ @@ -270,6 +272,7 @@ namespace eval RETest { # match failure expected proc expectNomatch {testid flags re target args} { + variable regBug # if &, test as both ARE and BRE if {[string match *&* $flags]} { set f [string map {& {}} $flags] @@ -278,13 +281,7 @@ namespace eval RETest { return } - set constraints [list testregexp] - - # Tcl locale stuff doesn't do the ch/xy test fakery yet - if {[string match *+* $flags]} { - # This will register as a skipped test - lappend constraints localeRegexp - } + set constraints [TestConstraints $flags] set f [TestFlags $flags] set infoflags [TestInfoFlags $flags] @@ -333,7 +330,7 @@ namespace eval RETest { } } namespace import RETest::* - + ######## the tests themselves ######## # support functions and preliminary misc. @@ -628,16 +625,24 @@ expectMatch 13.13 P "a\\nb" "a\nb" "a\nb" 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" -expectError 13.17 - {a\u008x} EESCAPE +expectMatch 13.17 P {a\u008x} "a\bx" "a\bx" expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x" expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx" -expectError 13.20 - {a\U0000008x} EESCAPE +expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx" expectMatch 13.21 P "a\\vb" "a\vb" "a\vb" expectMatch 13.22 MP "a\\x08x" "a\bx" "a\bx" expectError 13.23 - {a\xq} EESCAPE -expectMatch 13.24 MP "a\\x0008x" "a\bx" "a\bx" +expectMatch 13.24 MP "a\\x08x" "a\bx" "a\bx" expectError 13.25 - {a\z} EESCAPE expectMatch 13.26 MP "a\\010b" "a\bb" "a\bb" +expectMatch 13.27 P "a\\U00001234x" "a\u1234x" "a\u1234x" +expectMatch 13.28 P {a\U00001234x} "a\u1234x" "a\u1234x" +expectMatch 13.29 P "a\\U0001234x" "a\u1234x" "a\u1234x" +expectMatch 13.30 P {a\U0001234x} "a\u1234x" "a\u1234x" +expectMatch 13.31 P "a\\U000012345x" "a\u12345x" "a\u12345x" +expectMatch 13.32 P {a\U000012345x} "a\u12345x" "a\u12345x" +expectMatch 13.33 P "a\\U1000000x" "a\ufffd0x" "a\ufffd0x" +expectMatch 13.34 P {a\U1000000x} "a\ufffd0x" "a\ufffd0x" doing 14 "back references" @@ -662,6 +667,9 @@ expectMatch 14.17 RP {a([bc])(\1*)} ab ab b "" expectError 14.18 - {a((b)\1)} ESUBREG 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 doing 15 "octal escapes vs back references" @@ -684,6 +692,7 @@ expectError 15.9 - {a((((((((((b\10))))))))))c} ESUBREG expectMatch 15.10 MP "a\\12b" "a\nb" "a\nb" expectError 15.11 b {a\12b} ESUBREG expectMatch 15.12 eAS {a\12b} a12b a12b +expectMatch 15.13 MP {a\701b} a\u00381b a\u00381b doing 16 "expanded syntax" @@ -1071,7 +1080,11 @@ 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 - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/regexp.test b/tests/regexp.test index e2282eb..7cafd1b 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -10,15 +10,13 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: regexp.test,v 1.36 2010/02/21 18:55:41 mdejong Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } -catch {unset foo} +unset -nocomplain foo testConstraint exec [llength [info commands exec]] @@ -198,7 +196,7 @@ set x $x$x$x$x$x$x$x$x$x$x$x$x test regexp-4.4 {case conversion in regexp} { list [regexp -nocase $x $x foo] $foo } "1 $x" -catch {unset x} +unset -nocomplain x test regexp-5.1 {exercise cache of compiled expressions} { regexp .*a b @@ -262,11 +260,12 @@ test regexp-6.6 {regexp errors} { test regexp-6.7 {regexp errors} { list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg } {0 0} -test regexp-6.8 {regexp errors} { - catch {unset f1} +test regexp-6.8 {regexp errors} -setup { + unset -nocomplain f1 +} -body { set f1 44 - list [catch {regexp abc abc f1(f2)} msg] $msg -} {1 {couldn't set variable "f1(f2)"}} + regexp abc abc f1(f2) +} -returnCodes error -result {can't set "f1(f2)": variable isn't array} test regexp-6.9 {regexp errors, -start bad int check} { list [catch {regexp -start bogus {^$} {}} msg] $msg } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} @@ -458,11 +457,12 @@ test regexp-11.5 {regsub errors} { 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}} -test regexp-11.7 {regsub errors} { - catch {unset f1} +test regexp-11.7 {regsub errors} -setup { + unset -nocomplain f1 +} -body { set f1 44 - list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg -} {1 {couldn't set variable "f1(f2)"}} + regsub -nocase aaa aaa xxx f1(f2) +} -returnCodes error -result {can't set "f1(f2)": variable isn't array} test regexp-11.8 {regsub errors, -start bad int check} { list [catch {regsub -start bogus pattern string rep var} msg] $msg } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} @@ -529,23 +529,23 @@ test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -co } -result 1 test regexp-15.1 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start -10 {\d} 1abc2de3 x] $x } {1 1} test regexp-15.2 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 2 {\d} 1abc2de3 x] $x } {1 2} test regexp-15.3 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 4 {\d} 1abc2de3 x] $x } {1 2} test regexp-15.4 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 5 {\d} 1abc2de3 x] $x } {1 3} test regexp-15.5 {regexp -start, over end of string} { - catch {unset x} + 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} { @@ -558,11 +558,11 @@ test regexp-15.8 {regexp -start, double option} { regexp -start 0 -start 2 a abc } 0 test regexp-15.9 {regexp -start, end relative index} { - catch {unset x} + unset -nocomplain x list [regexp -start end {\d} 1abc2de3 x] [info exists x] } {0 0} test regexp-15.10 {regexp -start, end relative index} { - catch {unset x} + 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} { @@ -571,15 +571,15 @@ test regexp-15.11 {regexp -start, over end of string} { } {1 {}} test regexp-16.1 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x } {4 a1b/2c/3d/4e/5} test regexp-16.2 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start -25 {z} hello {/&} x] $x } {0 hello} test regexp-16.3 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start 3 {z} hello {/&} x] $x } {0 hello} test regexp-16.4 {regsub -start, \A behavior} { @@ -1067,3 +1067,6 @@ test regexp-26.13 {regexp without -line option} { ::tcltest::cleanupTests return +# Local Variables: +# mode: tcl +# End: diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 4f05bc3..94fb90e 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id$ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -31,7 +29,8 @@ proc evalInProc { script } { #return [list $status $result] } -catch {unset foo} +unset -nocomplain foo + test regexpComp-1.1 {basic regexp operation} { evalInProc { regexp ab*c abbbc @@ -260,7 +259,7 @@ test regexpComp-4.4 {case conversion in regexp} { list [regexp -nocase $::x $::x foo] $foo } } "1 $x" -catch {unset ::x} +unset -nocomplain ::x test regexpComp-5.1 {exercise cache of compiled expressions} { evalInProc { @@ -350,11 +349,11 @@ test regexpComp-6.7 {regexp errors} { } {0 0} test regexpComp-6.8 {regexp errors} { evalInProc { - catch {unset f1} + unset -nocomplain f1 set f1 44 list [catch {regexp abc abc f1(f2)} msg] $msg } -} {1 {couldn't set variable "f1(f2)"}} +} {1 {can't set "f1(f2)": variable isn't array}} test regexpComp-6.9 {regexp errors, -start bad int check} { evalInProc { list [catch {regexp -start bogus {^$} {}} msg] $msg @@ -591,11 +590,11 @@ test regexpComp-11.6 {regsub errors} { } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} test regexpComp-11.7 {regsub errors} { evalInProc { - catch {unset f1} + unset -nocomplain f1 set f1 44 list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg } -} {1 {couldn't set variable "f1(f2)"}} +} {1 {can't set "f1(f2)": variable isn't array}} test regexpComp-11.8 {regsub errors, -start bad int check} { evalInProc { list [catch {regsub -start bogus pattern string rep var} msg] $msg @@ -662,23 +661,23 @@ test regexpComp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} } -result 1 test regexpComp-15.1 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start -10 {\d} 1abc2de3 x] $x } {1 1} test regexpComp-15.2 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 2 {\d} 1abc2de3 x] $x } {1 2} test regexpComp-15.3 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 4 {\d} 1abc2de3 x] $x } {1 2} test regexpComp-15.4 {regexp -start} { - catch {unset x} + unset -nocomplain x list [regexp -start 5 {\d} 1abc2de3 x] $x } {1 3} test regexpComp-15.5 {regexp -start, over end of string} { - catch {unset x} + 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} { @@ -686,15 +685,15 @@ test regexpComp-15.6 {regexp -start, loss of ^$ behavior} { } {0} test regexpComp-16.1 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x } {4 a1b/2c/3d/4e/5} test regexpComp-16.2 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start -25 {z} hello {/&} x] $x } {0 hello} test regexpComp-16.3 {regsub -start} { - catch {unset x} + unset -nocomplain x list [regsub -all -start 3 {z} hello {/&} x] $x } {0 hello} test regexpComp-16.4 {regsub -start, \A behavior} { @@ -983,7 +982,11 @@ test regexpComp-24.11 {regexp command compiling tests} { regexp -- $re $text } } 1 - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/registry.test b/tests/registry.test index 02866f3..77588e3 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -9,8 +9,6 @@ # # Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. # Copyright (c) 1998-1999 by Scriptics Corporation. -# -# RCS: @(#) $Id: registry.test,v 1.26 2010/04/02 19:27:44 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -19,13 +17,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { testConstraint reg 0 if {[testConstraint win]} { - catch { - # Is the registry extension already static to this shell? - if [catch {load {} Registry; set ::reglib {}}] { - # try the location given to use on the commandline to tcltest + if {![catch { ::tcltest::loadTestedCommands - load $::reglib Registry - } + set ::regver [package require registry 1.3.0] + }]} { testConstraint reg 1 } } @@ -36,6 +31,9 @@ testConstraint english [expr { && [string match "English*" [testlocale all ""]] }] +test registry-1.0 {check if we are testing the right dll} {win reg} { + set ::regver +} {1.3.0} 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 ...?"}} @@ -507,6 +505,12 @@ 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} { + 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 + set result +} [string repeat x 16383] test registry-7.1 {GetValueNames: bad key} -constraints {win reg english} -setup { registry delete HKEY_CURRENT_USER\\TclFoobar diff --git a/tests/remote.tcl b/tests/remote.tcl index 005f2df..097e41f 100644 --- a/tests/remote.tcl +++ b/tests/remote.tcl @@ -8,8 +8,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: remote.tcl,v 1.3 1999/04/16 00:47:33 stanton Exp $ # Initialize message delimitor @@ -32,11 +30,9 @@ proc __doCommands__ {l s} { puts "---" } set callerSocket $s - if {[catch {uplevel #0 $l} msg]} { - list error $msg - } else { - list success $msg - } + set ::errorInfo "" + set code [catch {uplevel "#0" $l} msg] + return [list $code $::errorInfo $msg] } proc __readAndExecute__ {s} { @@ -44,10 +40,9 @@ proc __readAndExecute__ {s} { set l [gets $s] if {[string compare $l "--Marker--Marker--Marker--"] == 0} { - if {[info exists command($s)]} { - puts $s [list error incomplete_command] - } + puts $s [__doCommands__ $command($s) $s] puts $s "--Marker--Marker--Marker--" + set command($s) "" return } if {[string compare $l ""] == 0} { @@ -59,28 +54,26 @@ proc __readAndExecute__ {s} { } return } - append command($s) $l "\n" - if {[info complete $command($s)]} { - set cmds $command($s) - unset command($s) - puts $s [__doCommands__ $cmds $s] - } if {[eof $s]} { if {$VERBOSE} { puts "Server closing $s, eof from client" } close $s + unset command($s) + return } + append command($s) $l "\n" } proc __accept__ {s a p} { - global VERBOSE + global command VERBOSE if {$VERBOSE} { puts "Server accepts new connection from $a:$p on $s" } - fileevent $s readable [list __readAndExecute__ $s] + set command($s) "" fconfigure $s -buffering line -translation crlf + fileevent $s readable [list __readAndExecute__ $s] } set serverIsSilent 0 @@ -153,20 +146,14 @@ if {$serverIsSilent == 0} { flush stdout } +proc getPort sock { + lindex [fconfigure $sock -sockname] 2 +} + if {[catch {set serverSocket \ [socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} { puts "Server on $serverAddress:$serverPort cannot start: $msg" } else { + puts ready vwait __server_wait_variable__ } - - - - - - - - - - - diff --git a/tests/rename.test b/tests/rename.test index 3a3a47f..1fa0441 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -10,14 +10,15 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: rename.test,v 1.13 2009/01/08 16:41:35 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testdel [llength [info commands testdel]] # Must eliminate the "unknown" command while the test is running, especially diff --git a/tests/resolver.test b/tests/resolver.test new file mode 100644 index 0000000..e73ea50 --- /dev/null +++ b/tests/resolver.test @@ -0,0 +1,203 @@ +# This test collection covers some unwanted interactions between command +# literal sharing and the use of command resolvers (per-interp) which cause +# command literals to be re-used with their command references being invalid +# 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> +# +# 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]} { + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +testConstraint testinterpresolver [llength [info commands testinterpresolver]] + +test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup { + testinterpresolver up + namespace eval ::ns1 { + proc z {} { return Z } + namespace export z + } + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + # 1) Have the proc body compiled: During compilation or, alternatively, + # the first evaluation of the compiled body, the InterpCmdResolver (see + # tclTest.c) maps the cmd token "z" to "::y"; this mapping is saved in the + # resulting CmdName Tcl_Obj with the print string "z". The CmdName Tcl_Obj + # is turned into a command literal shared for a given (here: the global) + # namespace. + set r0 [x]; # --> The result of [x] is "Y" + # 2) After having requested cmd resolution above, we can now use the + # globally shared CmdName Tcl_Obj "z", now bound to cmd ::y. This is + # certainly questionable, but defensible + set r1 [z]; # --> The result of [z] is "Y" + # 3) We import from the namespace ns1 another z. [namespace import] takes + # care "shadowed" cmd references, however, till now cmd literals have not + # been touched. This is, however, necessary since the BC compiler (used in + # the [namespace eval]) seems to be eager to reuse CmdName Tcl_Objs as cmd + # literals for a given NS scope. We expect, that r2 is "Z", the result of + # the namespace imported cmd. + namespace eval :: { + namespace import ::ns1::z + set r2 [z] + } + list $r0 $r1 $::r2 +} -cleanup { + testinterpresolver down + rename ::x "" + rename ::y "" + namespace delete ::ns1 +} -result {Y Y Z} +test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup { + testinterpresolver up + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + set r0 [x] + set r1 [z] + proc ::foo {} { + proc ::z {} { return Z } + return [z] + } + list $r0 $r1 [::foo] +} -cleanup { + testinterpresolver down + rename ::x "" + rename ::y "" + rename ::foo "" + rename ::z "" +} -result {Y Y Z} +test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup { + testinterpresolver up + proc ::Z {} { return Z } + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + set r0 [x] + set r1 [z] + namespace eval :: { + rename ::Z ::z + set r2 [z] + } + list $r0 $r1 $r2 +} -cleanup { + testinterpresolver down + rename ::x "" + rename ::y "" + rename ::z "" +} -result {Y Y Z} +test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup { + testinterpresolver up + proc ::Z {} { return Z } + interp hide {} Z + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + set r0 [x] + set r1 [z] + interp expose {} Z z + namespace eval :: { + set r2 [z] + } + list $r0 $r1 $r2 +} -cleanup { + testinterpresolver down + rename ::x "" + rename ::y "" + rename ::z "" +} -result {Y Y Z} +test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -setup { + testinterpresolver up + namespace eval ::ns1 { + proc z {} { return Z } + namespace export z + } + proc ::y {} { return Y } + namespace eval ::ns2 { + proc x {} { + z + } + } +} -constraints testinterpresolver -body { + set r0 [namespace eval ::ns2 {x}] + set r1 [namespace eval ::ns2 {z}] + namespace eval ::ns2 { + namespace import ::ns1::z + set r2 [z] + } + list $r0 $r1 $r2 +} -cleanup { + testinterpresolver down + namespace delete ::ns2 + namespace delete ::ns1 +} -result {Y Y Z} +test resolver-1.6 {cmdNameObj sharing vs. cmd resolver: interp alias} -setup { + testinterpresolver up + proc ::Z {} { return Z } + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + set r0 [x] + set r1 [z] + namespace eval :: { + interp alias {} ::z {} ::Z + set r2 [z] + } + list $r0 $r1 $r2 +} -cleanup { + testinterpresolver down + rename ::x "" + rename ::y "" + rename ::Z "" +} -result {Y Y Z} + +test resolver-2.1 {compiled var resolver: Bug #3383616} -setup { + testinterpresolver up + # The compiled var resolver fetches just variables starting with a capital + # "T" and stores some test information in the resolver-specific resolver + # var info. + proc ::x {} { + set T1 100 + return $T1 + } +} -constraints testinterpresolver -body { + # Call "x" the first time, causing a byte code compilation of the body. + # 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; + # During later calls, the cached variable is reused. + x + # When the proc is freed, the resolver-specific resolver var info is + # freed. This did not happen before fix #3383616. + rename ::x "" +} -cleanup { + testinterpresolver down +} -result {} + +cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/result.test b/tests/result.test index 8bde7ef..3391ce1 100644 --- a/tests/result.test +++ b/tests/result.test @@ -9,14 +9,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# SCCS: @(#) result.test 1.4 97/12/08 15:07:49 if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Some tests require the testsaveresult command testConstraint testsaveresult [llength [info commands testsaveresult]] @@ -135,14 +136,14 @@ test result-6.3 {Bug 2383005} { catch {return -code error -errorcode {{}a} eek} m set m } {bad -errorcode value: expected a list but got "{}a"} -test result-6.4 {non-list -errorstack} { +test result-6.4 {non-list -errorstack} -body { catch {return -code error -errorstack {{}a} eek} m o list $m [dict get $o -errorcode] [dict get $o -errorstack] -} {{bad -errorstack value: expected a list but got "{}a"} {TCL RESULT NONLIST_ERRORSTACK} {UP 1}} -test result-6.5 {odd-sized-list -errorstack} { +} -match glob -result {{bad -errorstack value: expected a list but got "{}a"} {TCL RESULT NONLIST_ERRORSTACK} {INNER * UP 1}} +test result-6.5 {odd-sized-list -errorstack} -body { catch {return -code error -errorstack a eek} m o list $m [dict get $o -errorcode] [dict get $o -errorstack] -} {{forbidden odd-sized list for -errorstack: "a"} {TCL RESULT ODDSIZEDLIST_ERRORSTACK} {UP 1}} +} -match glob -result {{forbidden odd-sized list for -errorstack: "a"} {TCL RESULT ODDSIZEDLIST_ERRORSTACK} {INNER * UP 1}} # cleanup cleanupTests return diff --git a/tests/safe.test b/tests/safe.test index c22cf6e..4a2792e 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -9,8 +9,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: safe.test,v 1.34 2010/08/18 13:31:55 dkf Exp $ package require Tcl 8.5 @@ -30,7 +28,10 @@ set ::auto_path [info library] # thus un-autoindexed) APIs in this test result arguments: catch {safe::interpConfigure} -proc equiv {x} {return $x} +# 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) + +testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body { safe::interpConfigure @@ -91,7 +92,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} -setup { lsort [a aliases] } -cleanup { safe::interpDelete a -} -result {::tcl::info::nameofexecutable clock encoding exit file glob load source} +} -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} test safe-3.3 {calling safe::interpCreate on trusted interp} -setup { catch {safe::interpDelete a} } -body { @@ -166,27 +167,24 @@ test safe-6.2 {test safe interpreters knowledge of the world} { SafeEval {info script} } {} test safe-6.3 {test safe interpreters knowledge of the world} { - set r [lsort [SafeEval {array names tcl_platform}]] + set r [SafeEval {array names tcl_platform}] # If running a windows-debug shell, remove the "debug" element from r. - if {[testConstraint win] && ("debug" in $r)} { - set r [lreplace $r 1 1] + if {[testConstraint win]} { + set r [lsearch -all -inline -not -exact $r "debug"] } - set threaded [lsearch $r "threaded"] - if {$threaded != -1} { - set r [lreplace $r $threaded $threaded] - } - set r + set r [lsearch -all -inline -not -exact $r "threaded"] + lsort $r } {byteOrder pathSeparator platform pointerSize wordSize} -# more test should be added to check that hostname, nameofexecutable, -# aren't leaking infos, but they still do... +# 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} { set i [safe::interpCreate] # no error shall occur: - # (because the default access_path shall include 1st level sub dirs - # so package require in a slave works like in the master) + # (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}] # no error shall occur: interp eval $i {http_config} @@ -205,7 +203,12 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { [catch {interp eval $i {package require http 1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] -} -match glob -result "{\$p(:0:)} {\$p(:[expr 1+[llength [tcl::tm::list]]]:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library * /dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" +} -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 {}} {}" +test safe-7.3 {check that safe subinterpreters work} { + 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} # test source control on file name test safe-8.1 {safe source control on file} -setup { @@ -331,6 +334,20 @@ test safe-8.9 {safe source and return} -setup { catch {safe::interpDelete $i} removeFile $returnScript } -result ok +test safe-8.10 {safe source and return} -setup { + set returnScript [makeFile {return -level 2 "ok"} return.tcl] + catch {safe::interpDelete $i} +} -body { + safe::interpCreate $i + set token [safe::interpAddToAccessPath $i [file dirname $returnScript]] + $i eval [list apply {filename { + source $filename + error boom + }} $token/[file tail $returnScript]] +} -cleanup { + catch {safe::interpDelete $i} + removeFile $returnScript +} -result ok test safe-9.1 {safe interps' deleteHook} -setup { set i "a" @@ -400,17 +417,7 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { 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}} -# testing that nested and statics do what is advertised (we use a static -# package : Tcltest) -try { - package require Tcltest - testConstraint TcltestPackage 1 - # we use the Tcltest package , which has no Safe_Init -} on error {} { - testConstraint TcltestPackage 0 -} - -teststaticpkg Safepkg1 0 0 +catch {teststaticpkg Safepkg1 0 0} test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] } -body { @@ -548,9 +555,214 @@ test safe-12.7 {glob is restricted} -setup { set i [safe::interpCreate] } -body { $i eval glob * +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {permission denied} + +proc buildEnvironment {filename} { + upvar 1 testdir testdir testdir2 testdir2 testfile testfile + set testdir [makeDirectory deletethisdir] + set testdir2 [makeDirectory deletemetoo $testdir] + set testfile [makeFile {} $filename $testdir2] +} +#### New tests for Safe base glob, with patches @ Bug 2964715 +test safe-13.1 {glob is restricted [Bug 2964715]} -setup { + set i [safe::interpCreate] +} -body { + $i eval glob * +} -returnCodes error -cleanup { + safe::interpDelete $i +} -result {permission denied} +test safe-13.2 {mimic the valid glob call by ::tcl::tm::UnknownHandler [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment deleteme.tm +} -body { + ::safe::interpAddToAccessPath $i $testdir2 + set result [$i eval glob -nocomplain -directory $testdir2 *.tm] + if {$result eq [list $testfile]} { + return "glob match" + } else { + return "no match: $result" + } +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {glob match} +test safe-13.3 {cf 13.2 but test glob failure when -directory is outside access path [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment deleteme.tm +} -body { + $i eval glob -directory $testdir2 *.tm +} -returnCodes error -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {permission denied} +test safe-13.4 {another valid glob call [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment deleteme.tm +} -body { + ::safe::interpAddToAccessPath $i $testdir + ::safe::interpAddToAccessPath $i $testdir2 + set result [$i eval \ + glob -nocomplain -directory $testdir [file join deletemetoo *.tm]] + if {$result eq [list $testfile]} { + return "glob match" + } else { + return "no match: $result" + } } -cleanup { safe::interpDelete $i -} -match glob -result * + removeDirectory $testdir +} -result {glob match} +test safe-13.5 {as 13.4 but test glob failure when -directory is outside access path [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment deleteme.tm +} -body { + ::safe::interpAddToAccessPath $i $testdir2 + $i eval \ + glob -directory $testdir [file join deletemetoo *.tm] +} -returnCodes error -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {permission denied} +test safe-13.6 {as 13.4 but test silent failure when result is outside access_path [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment deleteme.tm +} -body { + ::safe::interpAddToAccessPath $i $testdir + $i eval \ + glob -nocomplain -directory $testdir [file join deletemetoo *.tm] +} -cleanup { + 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 { + 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 \ + 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 { + set i [safe::interpCreate] + buildEnvironment notIndex.tcl +} -body { + set safeTD [::safe::interpAddToAccessPath $i $testdir] + ::safe::interpAddToAccessPath $i $testdir2 + $i eval [list glob -directory $safeTD -join -nocomplain * notIndex.tcl] +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {} +test safe-13.9 {as 13.8 but test glob failure when -directory is outside access path [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment notIndex.tcl +} -body { + ::safe::interpAddToAccessPath $i $testdir2 + set result [$i eval \ + glob -directory $testdir -join -nocomplain * notIndex.tcl] + if {$result eq [list $testfile]} { + return {glob match} + } else { + return "no match: $result" + } +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {no match: } +test safe-13.10 {as 13.8 but test silent failure when result is outside access_path [Bug 2964715]} -setup { + set i [safe::interpCreate] + buildEnvironment notIndex.tcl +} -body { + ::safe::interpAddToAccessPath $i $testdir + $i eval glob -directory $testdir -join -nocomplain * notIndex.tcl +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {} +rename buildEnvironment {} + +#### Test for the module path +test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup { + set i [safe::interpCreate] +} -body { + set tm {} + foreach token [$i eval ::tcl::tm::path list] { + lappend tm [dict get [set ::safe::S${i}(access_path,map)] $token] + } + return $tm +} -cleanup { + safe::interpDelete $i +} -result [::tcl::tm::path list] + +test safe-15.1 {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] $msg +} -cleanup { + 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}} + +### ~ should have no special meaning in paths in safe interpreters +test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { + set savedHOME $env(HOME) + set env(HOME) /foo/bar + set i [safe::interpCreate] +} -body { + $i eval { + set d [format %c 126] + list [file join [file dirname $d] [file tail $d]] + } +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME +} -result {./~} +test safe-16.2 {Bug 3529949: defang ~user in paths} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -body { + string map [list $user USER] [$i eval \ + "file join \[file dirname ~$user\] \[file tail ~$user\]"] +} -cleanup { + safe::interpDelete $i +} -result {./~USER} +test safe-16.3 {Bug 3529949: defang ~ in globs} -setup { + set syntheticHOME [makeDirectory foo] + makeFile {} bar $syntheticHOME + set savedHOME $env(HOME) + set env(HOME) $syntheticHOME + set i [safe::interpCreate] +} -body { + ::safe::interpAddToAccessPath $i $syntheticHOME + $i eval {glob -nocomplain ~/*} +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME + removeDirectory $syntheticHOME +} -result {} +test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { + set i [safe::interpCreate] +} -body { + ::safe::interpAddToAccessPath $i $~$tcl_platform(user) + $i eval [list glob -nocomplain ~$tcl_platform(user)/*] +} -cleanup { + safe::interpDelete $i +} -result {} set ::auto_path $saveAutoPath # cleanup diff --git a/tests/scan.test b/tests/scan.test index 4296366..97ad5eb 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: scan.test,v 1.23 2008/12/10 18:21:47 ferrieux Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -330,7 +328,7 @@ test scan-4.60 {Tcl_ScanObjCmd, set errors} { $msg $x $y] unset z set result -} {1 {couldn't set variable "z"} abc ghi} +} {1 {can't set "z": variable is array} abc ghi} test scan-4.61 {Tcl_ScanObjCmd, set errors} { set x {} catch {unset y}; array set y {} @@ -340,7 +338,7 @@ test scan-4.61 {Tcl_ScanObjCmd, set errors} { unset y unset z set result -} {1 {couldn't set variable "z"couldn't set variable "y"} abc} +} {1 {can't set "z": variable is array} abc} # procedure that returns the range of integers @@ -547,27 +545,27 @@ test scan-8.12 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %d a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.13 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %c a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.14 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %s a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.15 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %f a} msg] $msg -} {1 {couldn't set variable "a"}} +} {1 {can't set "a": variable is array}} test scan-8.16 {error conditions} { catch {unset a} set a(0) 44 list [catch {scan 44 %f a} msg] $msg -} {1 {couldn't set variable "a"}} +} {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 @@ -755,11 +753,11 @@ testConstraint ieeeFloatingPoint [testIEEE] # scan infinities - not working -test scan-14.1 {infinity} ieeeFloatingPoint { +test scan-14.1 {infinity} { scan Inf %g d set d } Inf -test scan-14.2 {infinity} ieeeFloatingPoint { +test scan-14.2 {infinity} { scan -Inf %g d set d } -Inf diff --git a/tests/security.test b/tests/security.test index 2549a4a..eeabc9c 100644 --- a/tests/security.test +++ b/tests/security.test @@ -1,18 +1,16 @@ # security.test -- # -# Functionality covered: this file contains a collection of tests for the -# auto loading and namespaces. +# Functionality covered: this file contains a collection of tests for the auto +# loading and namespaces. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# 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. # All rights reserved. -# -# RCS: @(#) $Id: security.test,v 1.6 2004/05/19 13:02:10 dkf Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -41,3 +39,7 @@ test security-1.1 {tcl_endOfPreviousWord} { # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/set-old.test b/tests/set-old.test index de16d60..52dc0ff 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -12,8 +12,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: set-old.test,v 1.24 2010/02/04 13:49:55 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/set.test b/tests/set.test index 76eab79..1d88553 100644 --- a/tests/set.test +++ b/tests/set.test @@ -9,14 +9,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: set.test,v 1.15 2008/02/13 20:35:03 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testset2 [llength [info commands testset2]] catch {unset x} diff --git a/tests/socket.test b/tests/socket.test index 99ce29f..5542c09 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -9,8 +9,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: socket.test,v 1.43 2010/06/25 15:20:06 rmax Exp $ # Running socket tests with a remote server: # ------------------------------------------ @@ -65,10 +63,32 @@ package require tcltest 2 namespace import -force ::tcltest::* -# Some tests require the testthread and exec commands -testConstraint testthread [llength [info commands testthread]] +# Some tests require the Thread package or exec command +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] testConstraint exec [llength [info commands exec]] +# Produce a random port number in the Dynamic/Private range +# from 49152 through 65535. +proc randport {} { expr {int(rand()*16383+49152)} } + +# 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 +# up to 200ms for a packet sent to localhost to arrive. We're measuring this +# here, so that OSes that don't have this problem can run the tests at full +# speed. +set server [socket -server {apply {{s a p} {set ::s1 $s}}} 0] +set s2 [socket localhost [lindex [fconfigure $server -sockname] 2]] +vwait s1; close $server +fconfigure $s1 -buffering line +fconfigure $s2 -buffering line +set t1 [clock milliseconds] +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 + # If remoteServerIP or remoteServerPort are not set, check in the environment # variables for externally set values. # @@ -79,7 +99,7 @@ if {![info exists remoteServerIP]} { } } if {![info exists remoteServerPort]} { - if {[info exists env(remoteServerIP)]} { + if {[info exists env(remoteServerPort)]} { set remoteServerPort $env(remoteServerPort) } else { if {[info exists remoteServerIP]} { @@ -88,16 +108,47 @@ if {![info exists remoteServerPort]} { } } +if 0 { + # activate this to time the tests + proc test {args} { + set name [lindex $args 0] + puts "[lindex [time {uplevel [linsert $args 0 tcltest::test]}] 0] @@@ $name" + } +} + +foreach {af localhost} { + inet 127.0.0.1 + inet6 ::1 +} { + # Check if the family is supported and set the constraint accordingly + 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] +close $sock +testConstraint localhost_v4 [expr {"127.0.0.1" in $sockname}] +testConstraint localhost_v6 [expr {"::1" in $sockname}] + + +foreach {af localhost} { + any 127.0.0.1 + inet 127.0.0.1 + inet6 ::1 +} { + set ::tcl::unsupported::socketAF $af # # Check if we're supposed to do tests against the remote server # set doTestsWithRemoteServer 1 if {![info exists remoteServerIP]} { - set remoteServerIP 127.0.0.1 + set remoteServerIP $localhost } if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { - set remoteServerPort 2048 + set remoteServerPort [randport] } # Attempt to connect to a remote server if one is already running. If it is @@ -119,7 +170,7 @@ if {$doTestsWithRemoteServer} { set noRemoteTestReason "can't exec" set doTestsWithRemoteServer 0 } else { - set remoteServerIP 127.0.0.1 + set remoteServerIP $localhost # Be *extra* careful in case this file is sourced from # a directory other than the current one... set remoteFile [file join [pwd] [file dirname [info script]] \ @@ -129,7 +180,7 @@ if {$doTestsWithRemoteServer} { [interpreter] $remoteFile -serverIsSilent \ -port $remoteServerPort -address $remoteServerIP]" w+] } msg]} then { - after 1000 + gets $remoteProcChan if {[catch { set commandSocket [socket $remoteServerIP $remoteServerPort] } msg] == 0} then { @@ -173,73 +224,73 @@ if {[testConstraint doTestsWithRemoteServer]} { error "remote server disappeared: $msg" } - set resp "" while {1} { set line [gets $commandSocket] if {[eof $commandSocket]} { error "remote server disappaered" } - if {[string compare $line "--Marker--Marker--Marker--"] == 0} { - if {[string compare [lindex $resp 0] error] == 0} { - error [lindex $resp 1] - } else { - return [lindex $resp 1] - } - } else { - append resp $line "\n" + if {$line eq "--Marker--Marker--Marker--"} { + lassign $result code info value + return -code $code -errorinfo $info $value } + append result $line "\n" } } } + +proc getPort sock { + lindex [fconfigure $sock -sockname] 2 +} + # ---------------------------------------------------------------------- -test socket-1.1 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server } -returnCodes error -result {no argument given for -server option} -test socket-1.2 {arg parsing for socket command} -constraints socket -body { +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"} -test socket-1.3 {arg parsing for socket command} -constraints socket -body { +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-1.4 {arg parsing for socket command} -constraints socket -body { - socket -myaddr 127.0.0.1 +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"} -test socket-1.5 {arg parsing for socket command} -constraints socket -body { +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} -test socket-1.6 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport xxxx } -returnCodes error -result {expected integer but got "xxxx"} -test socket-1.7 {arg parsing for socket command} -constraints socket -body { +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"} -test socket-1.8 {arg parsing for socket command} -constraints socket -body { +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} -test socket-1.9 {arg parsing for socket command} -constraints socket -body { +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-1.10 {arg parsing for socket command} -constraints socket -body { +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"} -test socket-1.11 {arg parsing for socket command} -constraints socket -body { +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"} -test socket-1.12 {arg parsing for socket command} -constraints socket -body { +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"} -test socket-1.13 {arg parsing for socket command} -constraints socket -body { +test socket_$af-1.13 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -async -server } -returnCodes error -result {cannot set -async option for server sockets} -test socket-1.14 {arg parsing for socket command} -constraints socket -body { +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} set path(script) [makeFile {} script] -test socket-2.1 {tcp connection} -constraints {socket stdio} -setup { +test socket_$af-2.1 {tcp connection} -constraints [list socket supported_$af stdio] -setup { file delete $path(script) set f [open $path(script) w] puts $f { @@ -263,19 +314,15 @@ test socket-2.1 {tcp connection} -constraints {socket stdio} -setup { gets $f listen } -body { # $x == "ready" at this point - set sock [socket 127.0.0.1 $listen] + set sock [socket $localhost $listen] lappend x [gets $f] close $sock lappend x [gets $f] } -cleanup { close $f } -result {ready done {}} -if {[info exists port]} { - incr port -} else { - set port [expr {2048 + [pid]%1024}] -} -test socket-2.2 {tcp connection with client port specified} -setup { +test socket_$af-2.2 {tcp connection with client port specified} -setup { + set port [randport] file delete $path(script) set f [open $path(script) w] puts $f { @@ -297,31 +344,31 @@ test socket-2.2 {tcp connection with client port specified} -setup { set f [open "|[list [interpreter] $path(script)]" r] gets $f x gets $f listen -} -constraints {socket stdio} -body { +} -constraints [list socket supported_$af stdio] -body { # $x == "ready" at this point - global port - set sock [socket -myport $port 127.0.0.1 $listen] + set sock [socket -myport $port $localhost $listen] puts $sock hello flush $sock - lappend x [gets $f] + lappend x [expr {[gets $f] eq "hello $port"}] close $sock return $x } -cleanup { - catch {close [socket 127.0.0.1 $listen]} + catch {close [socket $localhost $listen]} close $f -} -result [list ready "hello $port"] -test socket-2.3 {tcp connection with client interface specified} -setup { +} -result {ready 1} +test socket_$af-2.3 {tcp connection with client interface specified} -setup { file delete $path(script) set f [open $path(script) w] puts $f { set timer [after 2000 "set x done"] - set f [socket -server accept 2830] + set f [socket -server accept 0] proc accept {file addr port} { global x puts "[gets $file] $addr" close $file set x done } + puts [lindex [fconfigure $f -sockname] 2] puts ready vwait x after cancel $timer @@ -329,10 +376,11 @@ test socket-2.3 {tcp connection with client interface specified} -setup { } close $f set f [open "|[list [interpreter] $path(script)]" r] + gets $f listen gets $f x -} -constraints {socket stdio} -body { +} -constraints [list socket supported_$af stdio] -body { # $x == "ready" at this point - set sock [socket -myaddr 127.0.0.1 127.0.0.1 2830] + set sock [socket -myaddr $localhost $localhost $listen] puts $sock hello flush $sock lappend x [gets $f] @@ -340,13 +388,14 @@ test socket-2.3 {tcp connection with client interface specified} -setup { return $x } -cleanup { close $f -} -result {ready {hello 127.0.0.1}} -test socket-2.4 {tcp connection with server interface specified} -setup { +} -result [list ready [list hello $localhost]] +test socket_$af-2.4 {tcp connection with server interface specified} -setup { file delete $path(script) set f [open $path(script) w] + puts $f [list set localhost $localhost] puts $f { set timer [after 2000 "set x done"] - set f [socket -server accept -myaddr 127.0.0.1 0] + set f [socket -server accept -myaddr $localhost 0] proc accept {file addr port} { global x puts "[gets $file]" @@ -363,9 +412,9 @@ test socket-2.4 {tcp connection with server interface specified} -setup { set f [open "|[list [interpreter] $path(script)]" r] gets $f x gets $f listen -} -constraints {socket stdio} -body { +} -constraints [list socket supported_$af stdio] -body { # $x == "ready" at this point - set sock [socket 127.0.0.1 $listen] + set sock [socket $localhost $listen] puts $sock hello flush $sock lappend x [gets $f] @@ -374,7 +423,7 @@ test socket-2.4 {tcp connection with server interface specified} -setup { } -cleanup { close $f } -result {ready hello} -test socket-2.5 {tcp connection with redundant server port} -setup { +test socket_$af-2.5 {tcp connection with redundant server port} -setup { file delete $path(script) set f [open $path(script) w] puts $f { @@ -396,9 +445,9 @@ test socket-2.5 {tcp connection with redundant server port} -setup { set f [open "|[list [interpreter] $path(script)]" r] gets $f x gets $f listen -} -constraints {socket stdio} -body { +} -constraints [list socket supported_$af stdio] -body { # $x == "ready" at this point - set sock [socket 127.0.0.1 $listen] + set sock [socket $localhost $listen] puts $sock hello flush $sock lappend x [gets $f] @@ -407,9 +456,9 @@ test socket-2.5 {tcp connection with redundant server port} -setup { } -cleanup { close $f } -result {ready hello} -test socket-2.6 {tcp connection} -constraints socket -body { +test socket_$af-2.6 {tcp connection} -constraints [list socket supported_$af] -body { set status ok - if {![catch {set sock [socket 127.0.0.1 2833]}]} { + if {![catch {set sock [socket $localhost [randport]]}]} { if {![catch {gets $sock}]} { set status broken } @@ -417,7 +466,7 @@ test socket-2.6 {tcp connection} -constraints socket -body { } set status } -result ok -test socket-2.7 {echo server, one line} -constraints {socket stdio} -setup { +test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_$af stdio] -setup { file delete $path(script) set f [open $path(script) w] puts $f { @@ -449,10 +498,9 @@ test socket-2.7 {echo server, one line} -constraints {socket stdio} -setup { gets $f gets $f listen } -body { - set s [socket 127.0.0.1 $listen] + set s [socket $localhost $listen] fconfigure $s -buffering line -translation lf puts $s "hello abcdefghijklmnop" - after 1000 set x [gets $s] close $s list $x [gets $f] @@ -460,7 +508,7 @@ test socket-2.7 {echo server, one line} -constraints {socket stdio} -setup { close $f } -result {{hello abcdefghijklmnop} done} removeFile script -test socket-2.8 {echo server, loop 50 times, single connection} -setup { +test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup { set path(script) [makeFile { set f [socket -server accept 0] proc accept {s a p} { @@ -491,8 +539,8 @@ test socket-2.8 {echo server, loop 50 times, single connection} -setup { set f [open "|[list [interpreter] $path(script)]" r] gets $f gets $f listen -} -constraints {socket stdio} -body { - set s [socket 127.0.0.1 $listen] +} -constraints [list socket supported_$af stdio] -body { + set s [socket $localhost $listen] fconfigure $s -buffering line catch { for {set x 0} {$x < 50} {incr x} { @@ -508,11 +556,12 @@ test socket-2.8 {echo server, loop 50 times, single connection} -setup { removeFile script } -result {done 50} set path(script) [makeFile {} script] -test socket-2.9 {socket conflict} -constraints {socket stdio} -body { +test socket_$af-2.9 {socket conflict} -constraints [list socket supported_$af stdio] -body { set s [socket -server accept 0] file delete $path(script) set f [open $path(script) w] - puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]" + puts $f [list set ::tcl::unsupported::socketAF $::tcl::unsupported::socketAF] + puts $f "socket -server accept [lindex [fconfigure $s -sockname] 2]" close $f set f [open "|[list [interpreter] $path(script)]" r] gets $f @@ -521,10 +570,10 @@ test socket-2.9 {socket conflict} -constraints {socket stdio} -body { } -returnCodes error -cleanup { close $s } -match glob -result {couldn't open socket: address already in use*} -test socket-2.10 {close on accept, accepted socket lives} -setup { +test socket_$af-2.10 {close on accept, accepted socket lives} -setup { set done 0 set timer [after 20000 "set done timed_out"] -} -constraints socket -body { +} -constraints [list socket supported_$af] -body { set ss [socket -server accept 0] proc accept {s a p} { global ss @@ -538,7 +587,7 @@ test socket-2.10 {close on accept, accepted socket lives} -setup { close $s set done 1 } - set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]] + set cs [socket $localhost [lindex [fconfigure $ss -sockname] 2]] puts $cs hello close $cs vwait done @@ -546,7 +595,7 @@ test socket-2.10 {close on accept, accepted socket lives} -setup { } -cleanup { after cancel $timer } -result 1 -test socket-2.11 {detecting new data} -constraints socket -setup { +test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$af] -setup { proc accept {s a p} { global sock set sock $s @@ -554,18 +603,20 @@ test socket-2.11 {detecting new data} -constraints socket -setup { set s [socket -server accept 0] set sock "" } -body { - set s2 [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]] vwait sock puts $s2 one flush $s2 - after 500 + after idle {set x 1} + vwait x fconfigure $sock -blocking 0 set result a:[gets $sock] lappend result b:[gets $sock] fconfigure $sock -blocking 1 puts $s2 two flush $s2 - after 500 + after $latency {set x 1}; # NetBSD fails here if we do [after idle] + vwait x fconfigure $sock -blocking 0 lappend result c:[gets $sock] } -cleanup { @@ -575,11 +626,12 @@ test socket-2.11 {detecting new data} -constraints socket -setup { close $sock } -result {a:one b: c:two} -test socket-3.1 {socket conflict} -constraints {socket stdio} -setup { +test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af stdio] -setup { file delete $path(script) set f [open $path(script) w] + puts $f [list set localhost $localhost] puts $f { - set f [socket -server accept -myaddr 127.0.0.1 0] + set f [socket -server accept -myaddr $localhost 0] puts ready puts [lindex [fconfigure $f -sockname] 2] gets stdin @@ -590,20 +642,21 @@ test socket-3.1 {socket conflict} -constraints {socket stdio} -setup { gets $f gets $f listen } -body { - socket -server accept -myaddr 127.0.0.1 $listen + socket -server accept -myaddr $localhost $listen } -cleanup { puts $f bye close $f } -returnCodes error -result {couldn't open socket: address already in use} -test socket-3.2 {server with several clients} -setup { +test socket_$af-3.2 {server with several clients} -setup { file delete $path(script) set f [open $path(script) w] + puts $f [list set localhost $localhost] puts $f { set t1 [after 30000 "set x timed_out"] set t2 [after 31000 "set x timed_out"] set t3 [after 32000 "set x timed_out"] set counter 0 - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -buffering line @@ -633,13 +686,13 @@ test socket-3.2 {server with several clients} -setup { set f [open "|[list [interpreter] $path(script)]" r+] set x [gets $f] gets $f listen -} -constraints {socket stdio} -body { +} -constraints [list socket supported_$af stdio] -body { # $x == "ready" here - set s1 [socket 127.0.0.1 $listen] + set s1 [socket $localhost $listen] fconfigure $s1 -buffering line - set s2 [socket 127.0.0.1 $listen] + set s2 [socket $localhost $listen] fconfigure $s2 -buffering line - set s3 [socket 127.0.0.1 $listen] + set s3 [socket $localhost $listen] fconfigure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { puts $s1 hello,s1 @@ -657,12 +710,13 @@ test socket-3.2 {server with several clients} -setup { close $f } -result {ready done} -test socket-4.1 {server with several clients} -setup { +test socket_$af-4.1 {server with several clients} -setup { file delete $path(script) set f [open $path(script) w] + puts $f [list set localhost $localhost] puts $f { set port [gets stdin] - set s [socket 127.0.0.1 $port] + set s [socket $localhost $port] fconfigure $s -buffering line for {set i 0} {$i < 100} {incr i} { puts $s hello @@ -679,7 +733,7 @@ test socket-4.1 {server with several clients} -setup { fconfigure $p2 -buffering line set p3 [open "|[list [interpreter] $path(script)]" r+] fconfigure $p3 -buffering line -} -constraints {socket stdio} -body { +} -constraints [list socket supported_$af stdio] -body { proc accept {s a p} { fconfigure $s -buffering line fileevent $s readable [list echo $s] @@ -697,7 +751,7 @@ test socket-4.1 {server with several clients} -setup { set t1 [after 30000 "set x timed_out"] set t2 [after 31000 "set x timed_out"] set t3 [after 32000 "set x timed_out"] - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] set listen [lindex [fconfigure $s -sockname] 2] puts $p1 $listen puts $p2 $listen @@ -721,34 +775,34 @@ test socket-4.1 {server with several clients} -setup { close $p2 close $p3 } -result {{p1 bye done} {p2 bye done} {p3 bye done}} -test socket-4.2 {byte order problems, socket numbers, htons} -body { - close [socket -server dodo -myaddr 127.0.0.1 0x3000] +test socket_$af-4.2 {byte order problems, socket numbers, htons} -body { + close [socket -server dodo -myaddr $localhost 0x3000] return ok -} -constraints socket -result ok +} -constraints [list socket supported_$af] -result ok -test socket-5.1 {byte order problems, socket numbers, htons} -body { +test socket_$af-5.1 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 0x1} msg]} { close $msg return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} -} -constraints {socket unix notRoot} -result {couldn't open socket: not owner} -test socket-5.2 {byte order problems, socket numbers, htons} -body { +} -constraints [list socket supported_$af unix notRoot] -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 return {port resolution problem, should be disallowed} } return {couldn't open socket: port number too high} -} -constraints socket -result {couldn't open socket: port number too high} -test socket-5.3 {byte order problems, socket numbers, htons} -body { +} -constraints [list socket supported_$af] -result {couldn't open socket: port number too high} +test socket_$af-5.3 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 21} msg]} { close $msg return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} -} -constraints {socket unix notRoot} -result {couldn't open socket: not owner} +} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner} -test socket-6.1 {accept callback error} -constraints {socket stdio} -setup { +test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup { proc myHandler {msg options} { variable x $msg } @@ -757,14 +811,15 @@ test socket-6.1 {accept callback error} -constraints {socket stdio} -setup { file delete $path(script) } -body { set f [open $path(script) w] + puts $f [list set localhost $localhost] puts $f { gets stdin port - socket 127.0.0.1 $port + socket $localhost $port } close $f set f [open "|[list [interpreter] $path(script)]" r+] proc accept {s a p} {expr 10 / 0} - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] puts $f [lindex [fconfigure $s -sockname] 2] close $f set timer [after 10000 "set x timed_out"] @@ -776,7 +831,25 @@ test socket-6.1 {accept callback error} -constraints {socket stdio} -setup { interp bgerror {} $handler } -result {divide by zero} -test socket-7.1 {testing socket specific options} -setup { +test socket_$af-6.2 { + readable fileevent on server socket +} -setup { + set sock [socket -server dummy 0] +} -constraints [list socket supported_$af] -body { + fileevent $sock readable dummy +} -cleanup { + close $sock +} -returnCodes 1 -result "channel is not readable" + +test socket_$af-6.3 {writable fileevent on server socket} -setup { + set sock [socket -server dummy 0] +} -constraints [list socket supported_$af] -body { + fileevent $sock writable dummy +} -cleanup { + close $sock +} -returnCodes 1 -result "channel is not writable" + +test socket_$af-7.1 {testing socket specific options} -setup { file delete $path(script) set f [open $path(script) w] puts $f { @@ -796,21 +869,22 @@ test socket-7.1 {testing socket specific options} -setup { gets $f gets $f listen set l "" -} -constraints {socket stdio} -body { - set s [socket 127.0.0.1 $listen] +} -constraints [list socket supported_$af stdio] -body { + set s [socket $localhost $listen] set p [fconfigure $s -peername] close $s - lappend l [string compare [lindex $p 0] 127.0.0.1] + lappend l [string compare [lindex $p 0] $localhost] lappend l [string compare [lindex $p 2] $listen] lappend l [llength $p] } -cleanup { close $f } -result {0 0 3} -test socket-7.2 {testing socket specific options} -setup { +test socket_$af-7.2 {testing socket specific options} -setup { file delete $path(script) set f [open $path(script) w] + puts $f [list set ::tcl::unsupported::socketAF $::tcl::unsupported::socketAF] puts $f { - set ss [socket -server accept 2821] + set ss [socket -server accept 0] proc accept args { global x set x done @@ -825,35 +899,35 @@ test socket-7.2 {testing socket specific options} -setup { set f [open "|[list [interpreter] $path(script)]" r] gets $f gets $f listen -} -constraints {socket stdio} -body { - set s [socket 127.0.0.1 $listen] +} -constraints [list socket supported_$af stdio] -body { + set s [socket $localhost $listen] set p [fconfigure $s -sockname] close $s list [llength $p] \ - [regexp {^(127\.0\.0\.1|0\.0\.0\.0)$} [lindex $p 0]] \ + [regexp {^(127\.0\.0\.1|0\.0\.0\.0|::1)$} [lindex $p 0]] \ [expr {[lindex $p 2] == $listen}] } -cleanup { close $f } -result {3 1 0} -test socket-7.3 {testing socket specific options} -constraints socket -body { - set s [socket -server accept -myaddr 127.0.0.1 0] +test socket_$af-7.3 {testing socket specific options} -constraints [list socket supported_$af] -body { + set s [socket -server accept -myaddr $localhost 0] set l [fconfigure $s] close $s update llength $l } -result 14 -test socket-7.4 {testing socket specific options} -constraints socket -setup { +test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup { set timer [after 10000 "set x timed_out"] set l "" } -body { - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} { global x set x [fconfigure $s -sockname] close $s } set listen [lindex [fconfigure $s -sockname] 2] - set s1 [socket 127.0.0.1 $listen] + set s1 [socket $localhost $listen] vwait x lappend l [expr {[lindex $x 2] == $listen}] [llength $x] } -cleanup { @@ -861,10 +935,10 @@ test socket-7.4 {testing socket specific options} -constraints socket -setup { close $s close $s1 } -result {1 3} -test socket-7.5 {testing socket specific options} -setup { +test socket_$af-7.5 {testing socket specific options} -setup { set timer [after 10000 "set x timed_out"] set l "" -} -constraints {socket unixOrPc} -body { +} -constraints [list socket supported_$af unixOrPc] -body { set s [socket -server accept 0] proc accept {s a p} { global x @@ -872,16 +946,16 @@ test socket-7.5 {testing socket specific options} -setup { close $s } set listen [lindex [fconfigure $s -sockname] 2] - set s1 [socket 127.0.0.1 $listen] + set s1 [socket $localhost $listen] vwait x lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x] } -cleanup { after cancel $timer close $s close $s1 -} -result {127.0.0.1 1 3} +} -result [list $localhost 1 3] -test socket-8.1 {testing -async flag on sockets} -constraints socket -body { +test socket_$af-8.1 {testing -async flag on sockets} -constraints [list socket supported_$af] -body { # NOTE: This test may fail on some Solaris 2.4 systems. If it does, check # that you have these patches installed (using showrev -p): # @@ -896,14 +970,14 @@ test socket-8.1 {testing -async flag on sockets} -constraints socket -body { # please email jyl@eng.sun.com. We have not observed this failure on # Solaris 2.5, so another option (instead of installing these patches) is # to upgrade to Solaris 2.5. - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} { global x puts $s bye close $s set x done } - set s1 [socket -async 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + set s1 [socket -async $localhost [lindex [fconfigure $s -sockname] 2]] vwait x gets $s1 } -cleanup { @@ -911,7 +985,7 @@ test socket-8.1 {testing -async flag on sockets} -constraints socket -body { close $s1 } -result bye -test socket-9.1 {testing spurious events} -constraints socket -setup { +test socket_$af-9.1 {testing spurious events} -constraints [list socket supported_$af] -setup { set len 0 set spurious 0 set done 0 @@ -935,8 +1009,8 @@ test socket-9.1 {testing spurious events} -constraints socket -setup { fconfigure $s -buffering none -blocking off fileevent $s readable [list readlittle $s] } - set s [socket -server accept -myaddr 127.0.0.1 0] - set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + set s [socket -server accept -myaddr $localhost 0] + set c [socket $localhost [lindex [fconfigure $s -sockname] 2]] puts -nonewline $c 01234567890123456789012345678901234567890123456789 close $c vwait done @@ -945,7 +1019,7 @@ test socket-9.1 {testing spurious events} -constraints socket -setup { } -cleanup { after cancel $timer } -result {0 50} -test socket-9.2 {testing async write, fileevents, flush on close} -constraints socket -setup { +test socket_$af-9.2 {testing async write, fileevents, flush on close} -constraints [list socket supported_$af] -setup { set firstblock "" for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"} set secondblock "" @@ -953,7 +1027,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} -constraints s set secondblock "b$secondblock$secondblock" } set timer [after 10000 "set done timed_out"] - set l [socket -server accept -myaddr 127.0.0.1 0] + set l [socket -server accept -myaddr $localhost 0] proc accept {s a p} { fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ -buffering line @@ -962,12 +1036,12 @@ test socket-9.2 {testing async write, fileevents, flush on close} -constraints s proc readable {s} { set l [gets $s] fileevent $s readable {} - after 1000 respond $s + after idle respond $s } proc respond {s} { global firstblock puts -nonewline $s $firstblock - after 1000 writedata $s + after idle writedata $s } proc writedata {s} { global secondblock @@ -975,7 +1049,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} -constraints s close $s } } -body { - set s [socket 127.0.0.1 [lindex [fconfigure $l -sockname] 2]] + set s [socket $localhost [lindex [fconfigure $l -sockname] 2]] fconfigure $s -blocking 0 -trans lf -buffering line set count 0 puts $s hello @@ -995,7 +1069,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} -constraints s close $l after cancel $timer } -result 65566 -test socket-9.3 {testing EOF stickyness} -constraints socket -setup { +test socket_$af-9.3 {testing EOF stickyness} -constraints [list socket supported_$af] -setup { set count 0 set done false proc write_then_close {s} { @@ -1006,7 +1080,7 @@ test socket-9.3 {testing EOF stickyness} -constraints socket -setup { fconfigure $s -buffering line -translation lf fileevent $s writable "write_then_close $s" } - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] } -body { proc count_to_eof {s} { global count done @@ -1026,7 +1100,7 @@ test socket-9.3 {testing EOF stickyness} -constraints socket -setup { set count {timer went off, eof is not sticky} close $s } - set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + set c [socket $localhost [lindex [fconfigure $s -sockname] 2]] fconfigure $c -blocking off -buffering line -translation lf fileevent $c readable "count_to_eof $c" set timer [after 1000 timerproc $c] @@ -1039,9 +1113,8 @@ test socket-9.3 {testing EOF stickyness} -constraints socket -setup { removeFile script -test socket-10.1 {testing socket accept callback error handling} -constraints { - socket -} -setup { +test socket_$af-10.1 {testing socket accept callback error handling} \ + -constraints [list socket supported_$af] -setup { variable goterror 0 proc myHandler {msg options} { variable goterror 1 @@ -1049,9 +1122,9 @@ test socket-10.1 {testing socket accept callback error handling} -constraints { set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] } -body { - set s [socket -server accept -myaddr 127.0.0.1 0] + set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} {close $s; error} - set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + set c [socket $localhost [lindex [fconfigure $s -sockname] 2]] vwait goterror close $s close $c @@ -1060,55 +1133,53 @@ test socket-10.1 {testing socket accept callback error handling} -constraints { interp bgerror {} $handler } -result 1 -test socket-11.1 {tcp connection} -setup { - sendCommand { - set socket9_1_test_server [socket -server accept 2834] +test socket_$af-11.1 {tcp connection} -setup { + set port [sendCommand { + set server [socket -server accept 0] proc accept {s a p} { puts $s done close $s } - } -} -constraints {socket doTestsWithRemoteServer} -body { - set s [socket $remoteServerIP 2834] + getPort $server + }] +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { + set s [socket $remoteServerIP $port] gets $s } -cleanup { close $s - sendCommand {close $socket9_1_test_server} + sendCommand {close $server} } -result done -test socket-11.2 {client specifies its port} -setup { - if {[info exists port]} { - incr port - } else { - set port [expr 2048 + [pid]%1024] - } - sendCommand { - set socket9_2_test_server [socket -server accept 2835] +test socket_$af-11.2 {client specifies its port} -setup { + set lport [randport] + set rport [sendCommand { + set server [socket -server accept 0] proc accept {s a p} { puts $s $p close $s } - } -} -constraints {socket doTestsWithRemoteServer} -body { - set s [socket -myport $port $remoteServerIP 2835] + getPort $server + }] +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { + set s [socket -myport $lport $remoteServerIP $rport] set r [gets $s] - expr {$r==$port ? "ok" : "broken: $r != $port"} + expr {$r==$lport ? "ok" : "broken: $r != $port"} } -cleanup { close $s - sendCommand {close $socket9_2_test_server} + sendCommand {close $server} } -result ok -test socket-11.3 {trying to connect, no server} -body { +test socket_$af-11.3 {trying to connect, no server} -body { set status ok - if {![catch {set s [socket $remoteServerIp 2836]}]} { + if {![catch {set s [socket $remoteServerIp [randport]]}]} { if {![catch {gets $s}]} { set status broken } close $s } return $status -} -constraints {socket doTestsWithRemoteServer} -result ok -test socket-11.4 {remote echo, one line} -setup { - sendCommand { - set socket10_6_test_server [socket -server accept 2836] +} -constraints [list socket supported_$af doTestsWithRemoteServer] -result ok +test socket_$af-11.4 {remote echo, one line} -setup { + set port [sendCommand { + set server [socket -server accept 0] proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -buffering line -translation crlf @@ -1121,19 +1192,20 @@ test socket-11.4 {remote echo, one line} -setup { puts $s $l } } - } -} -constraints {socket doTestsWithRemoteServer} -body { - set f [socket $remoteServerIP 2836] + getPort $server + }] +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { + set f [socket $remoteServerIP $port] fconfigure $f -translation crlf -buffering line puts $f hello gets $f } -cleanup { catch {close $f} - sendCommand {close $socket10_6_test_server} + sendCommand {close $server} } -result hello -test socket-11.5 {remote echo, 50 lines} -setup { - sendCommand { - set socket10_7_test_server [socket -server accept 2836] +test socket_$af-11.5 {remote echo, 50 lines} -setup { + set port [sendCommand { + set server [socket -server accept 0] proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -buffering line -translation crlf @@ -1146,9 +1218,10 @@ test socket-11.5 {remote echo, 50 lines} -setup { puts $s $l } } - } -} -constraints {socket doTestsWithRemoteServer} -body { - set f [socket $remoteServerIP 2836] + getPort $server + }] +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { + set f [socket $remoteServerIP $port] fconfigure $f -translation crlf -buffering line for {set cnt 0} {$cnt < 50} {incr cnt} { puts $f "hello, $cnt" @@ -1159,19 +1232,19 @@ test socket-11.5 {remote echo, 50 lines} -setup { return $cnt } -cleanup { close $f - sendCommand {close $socket10_7_test_server} + sendCommand {close $server} } -result 50 -test socket-11.6 {socket conflict} -setup { - set s1 [socket -server accept -myaddr 127.0.0.1 2836] -} -constraints {socket doTestsWithRemoteServer} -body { - set s2 [socket -server accept -myaddr 127.0.0.1 2836] - list [lindex [fconfigure $s2 -sockname] 2] [close $s2] +test socket_$af-11.6 {socket conflict} -setup { + set s1 [socket -server accept -myaddr $localhost 0] +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { + set s2 [socket -server accept -myaddr $localhost [getPort $s1]] + list [getPort $s2] [close $s2] } -cleanup { close $s1 } -returnCodes error -result {couldn't open socket: address already in use} -test socket-11.7 {server with several clients} -setup { - sendCommand { - set socket10_9_test_server [socket -server accept 2836] +test socket_$af-11.7 {server with several clients} -setup { + set port [sendCommand { + set server [socket -server accept 0] proc accept {s a p} { fconfigure $s -buffering line fileevent $s readable [list echo $s] @@ -1184,13 +1257,14 @@ test socket-11.7 {server with several clients} -setup { puts $s $l } } - } -} -constraints {socket doTestsWithRemoteServer} -body { - set s1 [socket $remoteServerIP 2836] + getPort $server + }] +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { + set s1 [socket $remoteServerIP $port] fconfigure $s1 -buffering line - set s2 [socket $remoteServerIP 2836] + set s2 [socket $remoteServerIP $port] fconfigure $s2 -buffering line - set s3 [socket $remoteServerIP 2836] + set s3 [socket $remoteServerIP $port] fconfigure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { puts $s1 hello,s1 @@ -1205,22 +1279,23 @@ test socket-11.7 {server with several clients} -setup { close $s1 close $s2 close $s3 - sendCommand {close $socket10_9_test_server} + sendCommand {close $server} } -result 100 -test socket-11.8 {client with several servers} -setup { - sendCommand { - set s1 [socket -server "accept 4003" 4003] - set s2 [socket -server "accept 4004" 4004] - set s3 [socket -server "accept 4005" 4005] +test socket_$af-11.8 {client with several servers} -setup { + lassign [sendCommand { + set s1 [socket -server "accept server1" 0] + set s2 [socket -server "accept server2" 0] + set s3 [socket -server "accept server3" 0] proc accept {mp s a p} { puts $s $mp close $s } - } -} -constraints {socket doTestsWithRemoteServer} -body { - set s1 [socket $remoteServerIP 4003] - set s2 [socket $remoteServerIP 4004] - set s3 [socket $remoteServerIP 4005] + list [getPort $s1] [getPort $s2] [getPort $s3] + }] p1 p2 p3 +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { + set s1 [socket $remoteServerIP $p1] + set s2 [socket $remoteServerIP $p2] + set s3 [socket $remoteServerIP $p3] list [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \ [gets $s3] [gets $s3] [eof $s3] } -cleanup { @@ -1232,10 +1307,8 @@ test socket-11.8 {client with several servers} -setup { close $s2 close $s3 } -} -result {4003 {} 1 4004 {} 1 4005 {} 1} -test socket-11.9 {accept callback error} -constraints { - socket doTestsWithRemoteServer -} -setup { +} -result {server1 {} 1 server2 {} 1 server3 {} 1} +test socket_$af-11.9 {accept callback error} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup { proc myHandler {msg options} { variable x $msg } @@ -1243,12 +1316,13 @@ test socket-11.9 {accept callback error} -constraints { interp bgerror {} [namespace which myHandler] set timer [after 10000 "set x timed_out"] } -body { - set s [socket -server accept 2836] - proc accept {s a p} {expr 10 / 0} + set s [socket -server accept 0] + proc accept {s a p} {expr {10 / 0}} + sendCommand "set port [getPort $s]" if {[catch { sendCommand { set peername [fconfigure $callerSocket -peername] - set s [socket [lindex $peername 0] 2836] + set s [socket [lindex $peername 0] $port] close $s } } msg]} then { @@ -1262,26 +1336,27 @@ test socket-11.9 {accept callback error} -constraints { after cancel $timer interp bgerror {} $handler } -result {divide by zero} -test socket-11.10 {testing socket specific options} -setup { - sendCommand { - set socket10_12_test_server [socket -server accept 2836] +test socket_$af-11.10 {testing socket specific options} -setup { + set port [sendCommand { + set server [socket -server accept 0] proc accept {s a p} {close $s} - } -} -constraints {socket doTestsWithRemoteServer} -body { - set s [socket $remoteServerIP 2836] + getPort $server + }] +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { + set s [socket $remoteServerIP $port] set p [fconfigure $s -peername] set n [fconfigure $s -sockname] - list [lindex $p 2] [llength $p] [llength $n] + list [expr {[lindex $p 2] == $port}] [llength $p] [llength $n] } -cleanup { close $s - sendCommand {close $socket10_12_test_server} -} -result {2836 3 3} -test socket-11.11 {testing spurious events} -setup { - sendCommand { - set socket10_13_test_server [socket -server accept 2836] + sendCommand {close $server} +} -result {1 3 3} +test socket_$af-11.11 {testing spurious events} -setup { + set port [sendCommand { + set server [socket -server accept 0] proc accept {s a p} { fconfigure $s -translation "auto lf" - after 100 writesome $s + after idle writesome $s } proc writesome {s} { for {set i 0} {$i < 100} {incr i} { @@ -1289,12 +1364,13 @@ test socket-11.11 {testing spurious events} -setup { } close $s } - } + getPort $server + }] set len 0 set spurious 0 set done 0 set timer [after 40000 "set done timed_out"] -} -constraints {socket doTestsWithRemoteServer} -body { +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { proc readlittle {s} { global spurious done len set l [read $s 1] @@ -1309,23 +1385,24 @@ test socket-11.11 {testing spurious events} -setup { incr len [string length $l] } } - set c [socket $remoteServerIP 2836] + set c [socket $remoteServerIP $port] fileevent $c readable "readlittle $c" vwait done list $spurious $len $done } -cleanup { after cancel $timer - sendCommand {close $socket10_13_test_server} + sendCommand {close $server} } -result {0 2690 1} -test socket-11.12 {testing EOF stickyness} -constraints {socket doTestsWithRemoteServer} -setup { +test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup { set counter 0 set done 0 - sendCommand { - set socket10_14_test_server [socket -server accept 2836] + set port [sendCommand { + set server [socket -server accept 0] proc accept {s a p} { - after 100 close $s + after idle close $s } - } + getPort $server + }] proc timed_out {} { global c done set done {timed_out, EOF is not sticky} @@ -1344,16 +1421,16 @@ test socket-11.12 {testing EOF stickyness} -constraints {socket doTestsWithRemot } } } - set c [socket $remoteServerIP 2836] + set c [socket $remoteServerIP $port] fileevent $c readable [list count_up $c] vwait done return $done } -cleanup { after cancel $after_id - sendCommand {close $socket10_14_test_server} + sendCommand {close $server} } -result {EOF is sticky} -test socket-11.13 {testing async write, async flush, async close} -setup { - sendCommand { +test socket_$af-11.13 {testing async write, async flush, async close} -setup { + set port [sendCommand { set firstblock "" for {set i 0} {$i < 5} {incr i} { set firstblock "a$firstblock$firstblock" @@ -1362,7 +1439,7 @@ test socket-11.13 {testing async write, async flush, async close} -setup { for {set i 0} {$i < 16} {incr i} { set secondblock "b$secondblock$secondblock" } - set l [socket -server accept 2845] + set l [socket -server accept 0] proc accept {s a p} { fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ -buffering line @@ -1371,21 +1448,22 @@ test socket-11.13 {testing async write, async flush, async close} -setup { proc readable {s} { set l [gets $s] fileevent $s readable {} - after 1000 respond $s + after idle respond $s } proc respond {s} { global firstblock puts -nonewline $s $firstblock - after 1000 writedata $s + after idle writedata $s } proc writedata {s} { global secondblock puts -nonewline $s $secondblock close $s } - } + getPort $l + }] set timer [after 10000 "set done timed_out"] -} -constraints {socket doTestsWithRemoteServer} -body { +} -constraints [list socket supported_$af doTestsWithRemoteServer] -body { proc readit {s} { global count done set l [read $s] @@ -1395,7 +1473,7 @@ test socket-11.13 {testing async write, async flush, async close} -setup { set done 1 } } - set s [socket $remoteServerIP 2845] + set s [socket $remoteServerIP $port] fconfigure $s -blocking 0 -trans lf -buffering line set count 0 puts $s hello @@ -1410,57 +1488,56 @@ test socket-11.13 {testing async write, async flush, async close} -setup { set path(script1) [makeFile {} script1] set path(script2) [makeFile {} script2] -test socket-12.1 {testing inheritance of server sockets} -setup { +test socket_$af-12.1 {testing inheritance of server sockets} -setup { file delete $path(script1) file delete $path(script2) # Script1 is just a 10 second delay. If the server socket is inherited, it # will be held open for 10 seconds set f [open $path(script1) w] puts $f { + fileevent stdin readable exit after 10000 exit vwait forever } close $f - # Script2 creates the server socket, launches script1, waits a second, and - # exits. The server socket will now be closed unless script1 inherited it. + # Script2 creates the server socket, launches script1, and exits. + # The server socket will now be closed unless script1 inherited it. set f [open $path(script2) w] puts $f [list set tcltest [interpreter]] puts $f [list set delay $path(script1)] + puts $f [list set localhost $localhost] puts $f { - set f [socket -server accept -myaddr 127.0.0.1 0] - puts [lindex [fconfigure $f -sockname] 2] + set f [socket -server accept -myaddr $localhost 0] proc accept { file addr port } { close $file } exec $tcltest $delay & + puts [lindex [fconfigure $f -sockname] 2] close $f - after 1000 exit - vwait forever + exit } close $f -} -constraints {socket stdio exec} -body { +} -constraints [list socket supported_$af stdio exec] -body { # Launch script2 and wait 5 seconds ### exec [interpreter] script2 & set p [open "|[list [interpreter] $path(script2)]" r] - gets $p listen - after 5000 { set ok_to_proceed 1 } - vwait ok_to_proceed # If we can still connect to the server, the socket got inherited. - if {[catch {close [socket 127.0.0.1 $listen]}]} { + if {[catch {close [socket $localhost $listen]}]} { return {server socket was not inherited} } else { return {server socket was inherited} } } -cleanup { - close $p + catch {close $p} } -result {server socket was not inherited} -test socket-12.2 {testing inheritance of client sockets} -setup { +test socket_$af-12.2 {testing inheritance of client sockets} -setup { file delete $path(script1) file delete $path(script2) # Script1 is just a 20 second delay. If the server socket is inherited, it # will be held open for 20 seconds set f [open $path(script1) w] puts $f { + fileevent stdin readable exit after 20000 exit vwait forever } @@ -1471,23 +1548,23 @@ test socket-12.2 {testing inheritance of client sockets} -setup { set f [open $path(script2) w] puts $f [list set tcltest [interpreter]] puts $f [list set delay $path(script1)] + puts $f [list set localhost $localhost] puts $f { gets stdin port - set f [socket 127.0.0.1 $port] + set f [socket $localhost $port] exec $tcltest $delay & puts $f testing flush $f - after 1000 exit - vwait forever + exit } 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 - after 10000 [list set failed 1] -} -constraints {socket stdio exec} -body { + set after [after 10000 [list set failed 1]] +} -constraints [list socket supported_$af stdio exec] -body { # Create the server socket - set server [socket -server accept -myaddr 127.0.0.1 0] + set server [socket -server accept -myaddr $localhost 0] proc accept { file host port } { # When the client connects, establish the read handler global server @@ -1523,16 +1600,15 @@ test socket-12.2 {testing inheritance of client sockets} -setup { vwait x return $x } -cleanup { - if {!$failed} { - vwait failed - } + after cancel $after close $p } -result {client socket was not inherited} -test socket-12.3 {testing inheritance of accepted sockets} -setup { +test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { file delete $path(script1) file delete $path(script2) set f [open $path(script1) w] puts $f { + fileevent stdin readable exit after 10000 exit vwait forever } @@ -1540,33 +1616,32 @@ test socket-12.3 {testing inheritance of accepted sockets} -setup { set f [open $path(script2) w] puts $f [list set tcltest [interpreter]] puts $f [list set delay $path(script1)] + puts $f [list set localhost $localhost] puts $f { - set server [socket -server accept -myaddr 127.0.0.1 0] - puts stdout [lindex [fconfigure $server -sockname] 2] + set server [socket -server accept -myaddr $localhost 0] proc accept { file host port } { global tcltest delay puts $file {test data on socket} exec $tcltest $delay & - after 1000 exit + after idle exit } + puts stdout [lindex [fconfigure $server -sockname] 2] vwait forever } close $f -} -constraints {socket stdio exec} -body { +} -constraints [list socket supported_$af stdio exec] -body { # Launch the script2 process and connect to it. See how long the socket # stays open ## exec [interpreter] script2 & set p [open "|[list [interpreter] $path(script2)]" r] gets $p listen - after 1000 set ok_to_proceed 1 - vwait ok_to_proceed - set f [socket 127.0.0.1 $listen] + set f [socket $localhost $listen] fconfigure $f -buffering full -blocking 0 fileevent $f readable [list getdata $f] # If the socket is still open after 5 seconds, the script1 process must # have inherited the accepted socket. set failed 0 - after 5000 set failed 1 + set after [after 5000 [list set failed 1]] proc getdata { file } { # Read handler on the client socket. global x @@ -1593,13 +1668,14 @@ test socket-12.3 {testing inheritance of accepted sockets} -setup { vwait x return $x } -cleanup { + after cancel $after catch {close $p} } -result {accepted socket was not inherited} -test socket-13.1 {Testing use of shared socket between two threads} -setup { - threadReap - set path(script) [makeFile { - set f [socket -server accept -myaddr 127.0.0.1 0] +test socket_$af-13.1 {Testing use of shared socket between two threads} -body { + # create a thread + set serverthread [thread::create -preserved [string map [list @localhost@ $localhost] { + set f [socket -server accept -myaddr @localhost@ 0] set listen [lindex [fconfigure $f -sockname] 2] proc accept {s a p} { fileevent $s readable [list echo $s] @@ -1620,29 +1696,19 @@ test socket-13.1 {Testing use of shared socket between two threads} -setup { set i 0 vwait x close $f - # thread cleans itself up. - testthread exit - } script] -} -constraints {socket testthread} -body { - # create a thread - set serverthread [testthread create [list source $path(script) ] ] - update - set port [testthread send $serverthread {set listen}] - update - after 1000 - set s [socket 127.0.0.1 $port] + thread::wait + }]] + set port [thread::send $serverthread {set listen}] + set s [socket $localhost $port] fconfigure $s -buffering line catch { puts $s "hello" gets $s result } close $s - update - after 2000 - append result " " [threadReap] -} -cleanup { - removeFile script -} -result {hello 1} + thread::release $serverthread + append result " " [llength [thread::names]] +} -result {hello 1} -constraints [list socket supported_$af thread] # ---------------------------------------------------------------------- @@ -1650,11 +1716,140 @@ removeFile script1 removeFile script2 # cleanup -if {[string match sock* $commandSocket] == 1} { +if {$remoteProcChan ne ""} { catch {sendCommand exit} } 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] \ + -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] + } -body { + set client [socket -async localhost $port] + set after [after 1000 {set x [fconfigure $client -error]}] + vwait x + set x + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result ok +test socket-14.1 {[socket -async] fileevent while still connecting} \ + -constraints [list socket supported_any] \ + -setup { + proc accept {s a p} { + global x + puts $s bye + close $s + lappend x ok + } + set server [socket -server accept -myaddr localhost 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } -body { + set client [socket -async localhost $port] + fileevent $client writable { + lappend x [fconfigure $client -error] + fileevent $client writable {} + } + set after [after 1000 {lappend x timeout}] + while {[llength $x] < 2 && "timeout" ni $x} { + vwait x + } + lsort $x; # we only want to see both events, the order doesn't matter + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result {{} ok} +test socket-14.2 {[socket -async] fileevent connection refused} \ + -constraints [list socket supported_any] \ + -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 + } -cleanup { + unset x + } -result "connection refused" +test socket-14.3 {[socket -async] when server only listens on IPv6} \ + -constraints [list socket supported_any 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 1000 {set x [fconfigure $client -error]}] + vwait x + set x + } -cleanup { + after cancel $after + close $server + close $client + unset x + } -result ok +test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ + -constraints [list socket supported_any] \ + -setup { + proc accept {s a p} { + puts $s bye + close $s + } + set server [socket -server accept -myaddr localhost 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } -body { + set client [socket -async localhost $port] + fileevent $client writable { + lappend x [fconfigure $client -error] + fileevent $client writable {} + } + fileevent $client readable {lappend x [gets $client]} + set after [after 1000 {lappend x timeout}] + while {[llength $x] < 2 && "timeout" ni $x} { + vwait x + } + lsort $x + } -cleanup { + after cancel $after + close $client + close $server + } -result {{} bye} +test socket-14.5 {[socket -async] which fails before any connect() can be made} \ + -constraints [list socket supported_any] \ + -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} ::tcltest::cleanupTests flush stdout return diff --git a/tests/source.test b/tests/source.test index f358042..d71212d 100644 --- a/tests/source.test +++ b/tests/source.test @@ -11,8 +11,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: source.test,v 1.14 2009/01/05 11:27:41 dkf Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -109,6 +107,19 @@ test source-2.6 {source error conditions} -setup { } -match listGlob -result [list 1 \ {couldn't read file "*_non_existent_": no such file or directory} \ {POSIX ENOENT {no such file or directory}}] +test source-2.7 {utf-8 with BOM} -setup { + set sourcefile [makeFile {} source.file] +} -body { + set out [open $sourcefile w] + fconfigure $out -encoding utf-8 + puts $out "\ufeffset y new-y" + close $out + set y old-y + source -encoding utf-8 $sourcefile + return $y +} -cleanup { + removeFile $sourcefile +} -result {new-y} test source-3.1 {return in middle of source file} -setup { set sourcefile [makeFile { @@ -288,4 +299,4 @@ return # Local Variables: # mode: tcl -# End:
\ No newline at end of file +# End: diff --git a/tests/split.test b/tests/split.test index 1cc13b7..778131f 100644 --- a/tests/split.test +++ b/tests/split.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: split.test,v 1.10 2009/01/08 16:41:35 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/stack.test b/tests/stack.test index da587b5..873cb08 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -8,8 +8,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: stack.test,v 1.25 2008/10/03 19:20:24 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 diff --git a/tests/string.test b/tests/string.test index 39b12ff..f558d30 100644 --- a/tests/string.test +++ b/tests/string.test @@ -11,14 +11,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: string.test,v 1.78 2010/03/01 23:25:43 ferrieux Exp $ 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] != {}}] @@ -314,10 +315,10 @@ test string-6.4 {string is, too many args} { } {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, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} +} {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, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} +} {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 @@ -594,7 +595,7 @@ test string-6.90 {string is integer, bad integers} { foreach num $numbers { lappend result [string is int -strict $num] } - set result + return $result } {1 1 0 0 0 1 0 0} test string-6.91 {string is double, bad doubles} { set result "" @@ -602,20 +603,20 @@ test string-6.91 {string is double, bad doubles} { foreach num $numbers { lappend result [string is double -strict $num] } - set result + return $result } {1 1 0 0 0 1 0 0} -test string-6.92 {string is double, 32-bit overflow} { +test string-6.92 {string is integer, 32-bit overflow} { # Bug 718878 set x 0x100000000 list [string is integer -failindex var $x] $var } {0 -1} -test string-6.93 {string is double, 32-bit overflow} { +test string-6.93 {string is integer, 32-bit overflow} { # Bug 718878 set x 0x100000000 append x "" list [string is integer -failindex var $x] $var } {0 -1} -test string-6.94 {string is double, 32-bit overflow} { +test string-6.94 {string is integer, 32-bit overflow} { # Bug 718878 set x 0x100000000 list [string is integer -failindex var [expr {$x}]] $var @@ -666,7 +667,7 @@ test string-6.107 {string is integer, bad integers} { foreach num $numbers { lappend result [string is wideinteger -strict $num] } - set result + return $result } {1 1 0 0 0 1 0 0} test string-6.108 {string is double, Bug 1382287} { set x 2turtledoves @@ -676,6 +677,78 @@ test string-6.108 {string is double, Bug 1382287} { test string-6.109 {string is double, Bug 1360532} { string is double 1\u00a0 } 0 +test string-6.110 {string is entier, true} { + string is entier +1234567890 +} 1 +test string-6.111 {string is entier, true on type} { + string is entier [expr wide(50.0)] +} 1 +test string-6.112 {string is entier, true} { + string is entier [list -10] +} 1 +test string-6.113 {string is entier, true as hex} { + string is entier 0xabcdef +} 1 +test string-6.114 {string is entier, true as octal} { + string is entier 0123456 +} 1 +test string-6.115 {string is entier, true with whitespace} { + string is entier " \n1234\v" +} 1 +test string-6.116 {string is entier, false} { + list [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 +} {0 84} +test string-6.118 {string is entier, false} { + list [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 +} {0 0} +test string-6.120 {string is entier, false on bad octal} { + list [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 +} {0 4} +test string-6.122 {string is entier, false on bad hex} { + list [string is entier -fail var 0X345XYZ] $var +} {0 5} +test string-6.123 {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] + } + return $result +} {1 1 0 0 0 1 0 0} +test string-6.124 {string is entier, true} { + string is entier +1234567890123456789012345678901234567890 +} 1 +test string-6.125 {string is entier, true} { + string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000] +} 1 +test string-6.126 {string is entier, true as hex} { + string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef +} 1 +test string-6.127 {string is entier, true as octal} { + string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456 +} 1 +test string-6.128 {string is entier, true with whitespace} { + 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 +} {0 87} +test string-6.130.1 {string is entier, false on bad octal} { + list [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 +} {0 88} catch {rename largest_int {}} @@ -1411,8 +1484,8 @@ 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 + string trim \ufeff\x00\u0085\u00a0\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 @@ -1421,8 +1494,8 @@ test string-19.2 {string trimleft} { string trimleft " XYZ " } {XYZ } test string-19.3 {string trimleft, unicode default} { - string trimleft \u1361\u1680\u3000ABC -} ABC + string trimleft \ufeff\u0085\u00a0\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 @@ -1440,8 +1513,8 @@ test string-20.5 {string trimright} { string trimright "" } {} test string-20.6 {string trimright, unicode default} { - string trimright ABC\u1361\u1680\u3000 -} ABC + string trimright ABC\u1361\u0085\x00\u00a0\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000 +} ABC\u1361 test string-21.1 {string wordend} { list [catch {string wordend a} msg] $msg @@ -1620,6 +1693,22 @@ test string-24.11 {string reverse command - corner case} { 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 + set x +} 030201 +test string-24.15 {string reverse command - pure bytearray} { + binary scan [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} @@ -1687,10 +1776,10 @@ test string-26.3.1 {tcl::prefix, bad args} -body { } -returnCodes 1 -result {error options must have an even number of elements} test string-26.3.2 {tcl::prefix, bad args} -body { tcl::prefix match -error str1 str2 -} -returnCodes 1 -result {missing error options} +} -returnCodes 1 -result {missing value for -error} test string-26.4 {tcl::prefix, bad args} -body { tcl::prefix match -message str1 str2 -} -returnCodes 1 -result {missing message} +} -returnCodes 1 -result {missing value for -message} test string-26.5 {tcl::prefix} { tcl::prefix match {apa bepa cepa depa} cepa } cepa diff --git a/tests/stringComp.test b/tests/stringComp.test index 6ef94ee..9e00ce7 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -14,18 +14,19 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: stringComp.test,v 1.18 2010/09/25 02:25:54 hobbs Exp $ 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 @@ -676,7 +677,11 @@ test stringComp-11.54 {string match, failure} { } {0 1 1 1 0 0} ## string range -## not yet bc +test stringComp-12.1 {Bug 3588366: end-offsets before start} { + apply {s { + string range $s 0 end-5 + }} 12345 +} {} ## string repeat ## not yet bc @@ -698,8 +703,12 @@ test stringComp-11.54 {string match, failure} { ## string word* ## not yet bc - + # cleanup catch {rename foo {}} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/stringObj.test b/tests/stringObj.test index 921deef..6f331d3 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -11,14 +11,15 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: stringObj.test,v 1.22 2009/03/21 02:55:49 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testobj [llength [info commands testobj]] testConstraint testdstring [llength [info commands testdstring]] @@ -446,35 +447,35 @@ test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} testobj { teststringobj get 1 } {bar} -test stringObj-15.1 {Tcl_Append*ToObj: self appends} { +test stringObj-15.1 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 0 } foofoo -test stringObj-15.2 {Tcl_Append*ToObj: self appends} { +test stringObj-15.2 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 1 } foooo -test stringObj-15.3 {Tcl_Append*ToObj: self appends} { +test stringObj-15.3 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 2 } fooo -test stringObj-15.4 {Tcl_Append*ToObj: self appends} { +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} { +test stringObj-15.5 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 0 } foofoo -test stringObj-15.6 {Tcl_Append*ToObj: self appends} { +test stringObj-15.6 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 1 } foooo -test stringObj-15.7 {Tcl_Append*ToObj: self appends} { +test stringObj-15.7 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 2 } fooo -test stringObj-15.8 {Tcl_Append*ToObj: self appends} { +test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 3 } foo diff --git a/tests/subst.test b/tests/subst.test index 1b9ccf6..4be4798 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: subst.test,v 1.20 2010/04/08 13:26:25 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -271,6 +269,30 @@ test subst-12.7 {nasty case with compilation} { set y unset list [eval [list subst {[set x 1;continue;incr x][set y $x]}]] $x $y } {1 1 1} + +test subst-13.1 {Bug 3081065} -setup { + set script [makeFile { + proc demo {string} { + subst $string + } + demo name2 + } subst13.tcl] +} -body { + interp create slave + slave eval [list source $script] + interp delete slave + interp create slave + slave eval { + set count 400 + while {[incr count -1]} { + lappend bloat [expr {rand()}] + } + } + slave eval [list source $script] + interp delete slave +} -cleanup { + removeFile subst13.tcl +} # cleanup ::tcltest::cleanupTests diff --git a/tests/switch.test b/tests/switch.test index 738565f..a03948b 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -10,14 +10,12 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: switch.test,v 1.25 2009/07/14 16:52:28 kennykb Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } - + test switch-1.1 {simple patterns} { switch a a {subst 1} b {subst 2} c {subst 3} default {subst 4} } 1 @@ -538,7 +536,7 @@ test switch-11.6 {-matchvar unwritable} { test switch-12.1 {regexp matching with -indexvar} { switch -regexp -indexvar x -- abc {.(.). {set x}} -} {{0 3} {1 2}} +} {{0 2} {1 1}} test switch-12.2 {regexp matching with -indexvar} { set x GOOD switch -regexp -indexvar x -- abc {.(.).. {list $x z}} @@ -546,7 +544,7 @@ test switch-12.2 {regexp matching with -indexvar} { } GOOD test switch-12.3 {regexp matching with -indexvar} { switch -regexp -indexvar x -- "a b c" {.(.). {set x}} -} {{0 3} {1 2}} +} {{0 2} {1 1}} test switch-12.4 {regexp matching with -indexvar} { set x BAD switch -regexp -indexvar x -- "a b c" { @@ -562,22 +560,32 @@ test switch-12.6 {-indexvar unwritable} { set x {} list [catch {switch -regexp -indexvar x(x) -- abc . {set x}} msg] $x $msg } {1 {} {can't set "x(x)": variable isn't array}} +test switch-12.7 {[Bug 3106532] -indexvar should be directly usable with [string range]} { + set str abcdef + switch -regexp -indexvar x -- $str ^... {string range $str {*}[lindex $x 0]} +} abc +test switch-12.8 {-indexvar and matched empty strings} { + switch -regexp -indexvar x -- abcdef ^...(x?) {return $x} +} {{0 2} {3 2}} +test switch-12.9 {-indexvar and unmatched strings} { + switch -regexp -indexvar x -- abcdef ^...(x)? {return $x} +} {{0 2} {-1 -1}} test switch-13.1 {-indexvar -matchvar combinations} { switch -regexp -indexvar x -matchvar y abc { . {list $x $y} } -} {{{0 1}} a} +} {{{0 0}} a} test switch-13.2 {-indexvar -matchvar combinations} { switch -regexp -indexvar x -matchvar y abc { .$ {list $x $y} } -} {{{2 3}} c} +} {{{2 2}} c} test switch-13.3 {-indexvar -matchvar combinations} { switch -regexp -indexvar x -matchvar y abc { (.)(.)(.) {list $x $y} } -} {{{0 3} {0 1} {1 2} {2 3}} {abc a b c}} +} {{{0 2} {0 0} {1 1} {2 2}} {abc a b c}} test switch-13.4 {-indexvar -matchvar combinations} { set x - set y - @@ -599,7 +607,7 @@ test switch-13.6 {-indexvar -matchvar combinations} { list [catch { switch -regexp -indexvar x -matchvar y(y) abc {. {list $x $y}} } msg] $x $y $msg -} {1 {{0 1}} - {can't set "y(y)": variable isn't array}} +} {1 {{0 0}} - {can't set "y(y)": variable isn't array}} test switch-14.1 {-regexp -- compilation [Bug 1854399]} { switch -regexp -- 0 { @@ -753,7 +761,7 @@ test switch-15.1 {coroutine safety of non-bytecoded switch} {*}{ rename coro {} } } - + # cleanup catch {rename foo {}} ::tcltest::cleanupTests diff --git a/tests/tailcall.test b/tests/tailcall.test index 46e2471..2d04f82 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -8,14 +8,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: tailcall.test,v 1.14 2010/08/30 14:02:10 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testnrelevels [llength [info commands testnrelevels]] # diff --git a/tests/tcltest.test b/tests/tcltest.test index f235fac..86aca6f 100755 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -5,8 +5,6 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. -# -# RCS: @(#) $Id: tcltest.test,v 1.56 2009/10/30 11:13:21 patthoyts Exp $ # Note that there are several places where the value of # tcltest::currentFailure is stored/reset in the -setup/-cleanup diff --git a/tests/thread.test b/tests/thread.test index 15988bd..d79f693 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -10,278 +10,275 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: thread.test,v 1.21 2009/10/18 08:00:40 mistachkin Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2.2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # 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-}]}] + +# Some tests may not work under valgrind + +testConstraint notValgrind [expr {![testConstraint valgrind]}] + +set threadSuperKillScript { + rename catch "" + rename while "" + rename unknown "" + rename update "" + thread::release +} + +proc getThreadErrorFromInfo { info } { + set list [split $info \n] + set idx [lsearch -glob $list "*eval*unwound*"] + if {$idx != -1} then { + return [lindex $list $idx] + } + set idx [lsearch -glob $list "*eval*canceled*"] + if {$idx != -1} then { + return [lindex $list $idx] + } + return ""; # some other error we do not care about. +} + +proc findThreadError { info } { + foreach error [lreverse $info] { + set error [getThreadErrorFromInfo $error] + if {[string length $error] > 0} then { + return $error + } + } + return ""; # some other error we do not care about. +} + +proc ThreadError {id info} { + global threadSawError + if {[string length [getThreadErrorFromInfo $info]] > 0} then { + global threadId threadError + set threadId $id + lappend threadError($id) $info + } + set threadSawError($id) true; # signal main thread to exit [vwait]. +} + +if {[testConstraint thread]} { + thread::errorproc ThreadError +} + if {[testConstraint testthread]} { + proc drainEventQueue {} { + while {[set x [testthread event]]} { + #puts "WARNING: drained $x event(s) on main thread" + } + } + testthread errorproc ThreadError - proc ThreadError {id info} { - global threadId threadError - set threadId $id - set threadError $info - } + 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 -test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} { - list [catch {testthread} msg] $msg -} {1 {wrong # args: should be "testthread option ?arg ...?"}} -test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} { - list [catch {testthread foo} msg] $msg -} {1 {bad option "foo": must be cancel, create, event, exit, id, join, names, send, wait, or errorproc}} -test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {testthread} { - list [threadReap] [llength [testthread names]] -} {1 1} -test thread-1.4 {Tcl_ThreadObjCmd: thread create } {testthread} { - threadReap - set serverthread [testthread create] - update - set numthreads [llength [testthread names]] - threadReap +testConstraint drainEventQueue [expr {[info commands drainEventQueue] != {}}] + +test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} { + llength [thread::names] +} 1 +test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} { + set serverthread [thread::create -preserved] + set numthreads [llength [thread::names]] + thread::release $serverthread set numthreads } {2} -test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {testthread} { - threadReap - testthread create {set x 5} +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 [testthread names]] + set l [llength [thread::names]] if {$l == 1} { break } } - threadReap set l } {1} -test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {testthread} { - threadReap - testthread create {testthread exit} +test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { + thread::create {{*}{}} update after 10 - set result [llength [testthread names]] - threadReap - set result + llength [thread::names] } {1} -test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} { - set x [catch {testthread id x} msg] - list $x $msg -} {1 {wrong # args: should be "testthread id"}} -test thread-1.8 {Tcl_ThreadObjCmd: thread id} {testthread} { - string compare [testthread id] $::tcltest::mainThread -} {0} -test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {testthread} { - set x [catch {testthread names x} msg] - list $x $msg -} {1 {wrong # args: should be "testthread names"}} -test thread-1.10 {Tcl_ThreadObjCmd: thread id} {testthread} { - string compare [testthread names] $::tcltest::mainThread -} {0} -test thread-1.11 {Tcl_ThreadObjCmd: send args} {testthread} { - set x [catch {testthread send} msg] - list $x $msg -} {1 {wrong # args: should be "testthread send ?-async? id script"}} -test thread-1.12 {Tcl_ThreadObjCmd: send nonint} {testthread} { - set x [catch {testthread send abc command} msg] - list $x $msg -} {1 {expected integer but got "abc"}} -test thread-1.13 {Tcl_ThreadObjCmd: send args} {testthread} { - threadReap - set serverthread [testthread create] - set five [testthread send $serverthread {set x 5}] - threadReap +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 set five } 5 -test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} { - set tid [expr $::tcltest::mainThread + 10] - set x [catch {testthread send $tid {set x 5}} msg] - list $x $msg -} {1 {invalid thread id}} -test thread-1.15 {Tcl_ThreadObjCmd: wait} {testthread} { - threadReap - set serverthread [testthread create {set z 5 ; testthread wait}] - set five [testthread send $serverthread {set z}] - threadReap +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 set five } 5 -test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} {testthread} { - set x [catch {testthread errorproc foo bar} msg] - list $x $msg -} {1 {wrong # args: should be "testthread errorproc proc"}} -test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {testthread} { - testthread errorproc foo - testthread errorproc ThreadError -} {} # The tests above also cover: # TclCreateThread, except when pthread_create fails # NewThread, safe and regular # ThreadErrorProc, except for printing to standard error -test thread-2.1 {ListUpdateInner and ListRemove} {testthread} { - threadReap +test thread-2.1 {ListUpdateInner and ListRemove} {thread} { catch {unset tid} foreach t {0 1 2} { upvar #0 t$t tid - set tid [testthread create] + set tid [thread::create -preserved] + } + foreach t {0 1 2} { + upvar #0 t$t tid + thread::release $tid } - threadReap + llength [thread::names] } 1 -test thread-3.1 {TclThreadList} {testthread} { - threadReap +test thread-3.1 {TclThreadList} {thread} { catch {unset tid} - set len [llength [testthread names]] + set len [llength [thread::names]] set l1 {} foreach t {0 1 2} { - lappend l1 [testthread create] + lappend l1 [thread::create -preserved] + } + set l2 [thread::names] + set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]] + foreach t $l1 { + thread::release $t } - set l2 [testthread names] - list $l1 $l2 - set c [string compare \ - [lsort -integer [concat $::tcltest::mainThread $l1]] \ - [lsort -integer $l2]] - threadReap list $len $c } {1 0} -test thread-4.1 {TclThreadSend to self} {testthread} { +test thread-4.1 {TclThreadSend to self} {thread} { catch {unset x} - testthread send [testthread id] { + thread::send [thread::id] { set x 4 } set x } {4} -test thread-4.2 {TclThreadSend -async} {testthread} { - threadReap - set len [llength [testthread names]] - set serverthread [testthread create] - testthread send -async $serverthread { - after 1000 - testthread exit +test thread-4.2 {TclThreadSend -async} {thread} { + set len [llength [thread::names]] + set serverthread [thread::create -preserved] + thread::send -async $serverthread { + after 1 {thread::release} } - set two [llength [testthread names]] - after 1500 {set done 1} + set two [llength [thread::names]] + after 100 {set done 1} vwait done - threadReap - list $len [llength [testthread names]] $two + list $len [llength [thread::names]] $two } {1 1 2} -test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} { - threadReap - set len [llength [testthread names]] - set serverthread [testthread create] - set x [catch {testthread send $serverthread {set undef}} msg] +test thread-4.3 {TclThreadSend preserve errorInfo} {thread} { + set len [llength [thread::names]] + set serverthread [thread::create -preserved] + set x [catch {thread::send $serverthread {set undef}} msg] set savedErrorInfo $::errorInfo - threadReap + thread::release $serverthread list $len $x $msg $savedErrorInfo } {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable while executing "set undef" invoked from within -"testthread send $serverthread {set undef}"}} -test thread-4.4 {TclThreadSend preserve code} {testthread} { - threadReap - set len [llength [testthread names]] - set serverthread [testthread create] +"thread::send $serverthread {set undef}"}} +test thread-4.4 {TclThreadSend preserve code} {thread} { + set len [llength [thread::names]] + set serverthread [thread::create -preserved] set ::errorInfo {} - set x [catch {testthread send $serverthread {set ::errorInfo {}; break}} msg] + set x [catch {thread::send $serverthread {set ::errorInfo {}; break}} msg] set savedErrorInfo $::errorInfo - threadReap + thread::release $serverthread list $len $x $msg $savedErrorInfo } {1 3 {} {}} -test thread-4.5 {TclThreadSend preserve errorCode} {testthread} { - threadReap - set ::tcltest::mainThread [testthread names] - set serverthread [testthread create] - set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg] +test thread-4.5 {TclThreadSend preserve errorCode} {thread} { + set serverthread [thread::create] + set x [catch {thread::send $serverthread {error ERR INFO CODE}} msg] set savedErrorCode $::errorCode - threadReap + thread::release $serverthread list $x $msg $savedErrorCode } {1 ERR CODE} -test thread-5.0 {Joining threads} {testthread} { - threadReap - set serverthread [testthread create -joinable] - testthread send -async $serverthread {after 1000 ; testthread exit} - set res [testthread join $serverthread] - threadReap - set res +test thread-5.0 {Joining threads} {thread} { + set serverthread [thread::create -joinable -preserved] + thread::send -async $serverthread {after 1000 ; thread::release} + thread::join $serverthread } {0} -test thread-5.1 {Joining threads after the fact} {testthread} { - threadReap - set serverthread [testthread create -joinable] - testthread send -async $serverthread {testthread exit} +test thread-5.1 {Joining threads after the fact} {thread} { + set serverthread [thread::create -joinable -preserved] + thread::send -async $serverthread {thread::release} after 2000 - set res [testthread join $serverthread] - threadReap - set res + thread::join $serverthread } {0} -test thread-5.2 {Try to join a detached thread} {testthread} { - threadReap - set serverthread [testthread create] - testthread send -async $serverthread {after 1000 ; testthread exit} - catch {set res [testthread join $serverthread]} msg - threadReap +test thread-5.2 {Try to join a detached thread} {thread} { + set serverthread [thread::create -preserved] + thread::send -async $serverthread {after 1000 ; thread::release} + catch {set res [thread::join $serverthread]} msg + while {[llength [thread::names]] > 1} { + after 20 + } lrange $msg 0 2 } {cannot join thread} -test thread-6.1 {freeing very large object trees in a thread} testthread { +test thread-6.1 {freeing very large object trees in a thread} thread { # conceptual duplicate of obj-32.1 - threadReap - set serverthread [testthread create -joinable] - testthread send -async $serverthread { + set serverthread [thread::create -preserved] + thread::send -async $serverthread { set x {} for {set i 0} {$i<100000} {incr i} { set x [list $x {}] } unset x - testthread exit } - catch {set res [testthread join $serverthread]} msg - threadReap - set res -} {0} + thread::release -wait $serverthread +} 0 # TIP #285: Script cancellation support -test thread-7.1 {cancel: args} {testthread} { - set x [catch {testthread cancel} msg] - list $x $msg -} {1 {wrong # args: should be "testthread cancel ?-unwind? id ?result?"}} -test thread-7.2 {cancel: nonint} {testthread} { - set x [catch {testthread cancel abc} msg] - list $x $msg -} {1 {expected integer but got "abc"}} -test thread-7.3 {cancel: bad id} {testthread} { - set tid [expr $::tcltest::mainThread + 10] - set x [catch {testthread cancel $tid} msg] - list $x $msg -} {1 {invalid thread id}} -test thread-7.4 {cancel: pure bytecode loop} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +test thread-7.4 {cancel: pure bytecode loop} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } while {1} { @@ -289,30 +286,30 @@ test thread-7.4 {cancel: pure bytecode loop} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.5 {cancel: pure inside-command loop} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.5 {cancel: pure inside-command loop} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } set while while @@ -321,30 +318,30 @@ test thread-7.5 {cancel: pure inside-command loop} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.6 {cancel: pure bytecode loop -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.6 {cancel: pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } while {1} { @@ -352,30 +349,30 @@ test thread-7.6 {cancel: pure bytecode loop -unwind} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.7 {cancel: pure inside-command loop -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { - proc foobar {} { + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.7 {cancel: pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } set while while @@ -384,30 +381,30 @@ test thread-7.7 {cancel: pure inside-command loop -unwind} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.8 {cancel: pure bytecode loop custom result} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.8 {cancel: pure bytecode loop custom result} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } while {1} { @@ -415,30 +412,33 @@ test thread-7.8 {cancel: pure bytecode loop custom result} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread "the eval was canceled"] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {the eval was canceled}} -test thread-7.9 {cancel: pure inside-command loop custom result} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { - proc foobar {} { + vwait ::threadIdStarted + set res [thread::cancel $serverthread "the eval was canceled"] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {the eval was canceled}} +test thread-7.9 {cancel: pure inside-command loop custom result} -constraints { + thread + drainEventQueue +} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } set while while @@ -447,30 +447,33 @@ test thread-7.9 {cancel: pure inside-command loop custom result} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread "the eval was canceled"] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {the eval was canceled}} -test thread-7.10 {cancel: pure bytecode loop custom result -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel $serverthread "the eval was canceled"] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {the eval was canceled}} +test thread-7.10 {cancel: pure bytecode loop custom result -unwind} -constraints { + thread + drainEventQueue +} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } while {1} { @@ -478,30 +481,33 @@ test thread-7.10 {cancel: pure bytecode loop custom result -unwind} {testthread} } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread "the eval was unwound"] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {the eval was unwound}} -test thread-7.11 {cancel: pure inside-command loop custom result -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { - proc foobar {} { + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread "the eval was unwound"] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {the eval was unwound}} +test thread-7.11 {cancel: pure inside-command loop custom result -unwind} -constraints { + thread + drainEventQueue +} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + proc foobar {} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } set while while @@ -510,383 +516,379 @@ test thread-7.11 {cancel: pure inside-command loop custom result -unwind} {testt } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread "the eval was unwound"] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {the eval was unwound}} -test thread-7.12 {cancel: after} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread "the eval was unwound"] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {the eval was unwound}} +test thread-7.12 {cancel: after} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [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). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } after 30000 - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.13 {cancel: after -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.13 {cancel: after -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [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). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } after 30000 - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.14 {cancel: vwait} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +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]] { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } vwait forever - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.15 {cancel: vwait -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.15 {cancel: vwait -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [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). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } vwait forever - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.16 {cancel: expr} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +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]] { set i [interp create] - interp alias $i testthread {} testthread + $i eval "package require -exact Thread [package present Thread]" $i eval { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } expr {[while {1} {incr x}]} } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.17 {cancel: expr -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.17 {cancel: expr -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { set i [interp create] - interp alias $i testthread {} testthread + $i eval "package require -exact Thread [package present Thread]" $i eval { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } expr {[while {1} {incr x}]} } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.18 {cancel: expr bignum} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { - set i [interp create] - interp alias $i testthread {} testthread - $i eval { - if {![info exists foo]} then { - # signal the primary thread that we are ready - # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] - set foo 1 - } - # - # TODO: This will not cancel because libtommath - # does not check Tcl_Canceled. - # - expr {2**99999} - } - }] + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.18 {cancel: expr bignum} {thread drainEventQueue knownBug} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create] + $i eval "package require -exact Thread [package present Thread]" + $i eval { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + # + # BUGBUG: This will not cancel because libtommath + # does not check Tcl_Canceled. + # + expr {2**99999} + } + }]] # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread); # WARNING: Never returns (see above). + thread::join $serverthread; drainEventQueue; # WARNING: Never returns (see above). list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] + $::threadIdStarted == $serverthread : 0}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] } {{} 1 0 {}} -test thread-7.19 {cancel: expr bignum -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { - set i [interp create] - interp alias $i testthread {} testthread - $i eval { - if {![info exists foo]} then { - # signal the primary thread that we are ready - # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] - set foo 1 - } - # - # TODO: This will not cancel because libtommath - # does not check Tcl_Canceled. - # - expr {2**99999} - } - }] +test thread-7.19 {cancel: expr bignum -unwind} {thread drainEventQueue knownBug} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create] + $i eval "package require -exact Thread [package present Thread]" + $i eval { + if {![info exists foo]} then { + # signal the primary thread that we are ready + # to be canceled now (we are running). + thread::send %ID% [list set ::threadIdStarted [thread::id]] + set foo 1 + } + # + # BUGBUG: This will not cancel because libtommath + # does not check Tcl_Canceled. + # + expr {2**99999} + } + }]] # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread); # WARNING: Never returns (see above). + thread::join $serverthread; drainEventQueue; # WARNING: Never returns (see above). list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] + $::threadIdStarted == $serverthread : 0}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] } {{} 1 0 {}} -test thread-7.20 {cancel: subst} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +test thread-7.20 {cancel: subst} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { set i [interp create] - interp alias $i testthread {} testthread + $i eval "package require -exact Thread [package present Thread]" $i eval { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } subst {[while {1} {incr x}]} } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.21 {cancel: subst -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.21 {cancel: subst -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { set i [interp create] - interp alias $i testthread {} testthread + $i eval "package require -exact Thread [package present Thread]" $i eval { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } subst {[while {1} {incr x}]} } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.22 {cancel: slave interp} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { set i [interp create] - interp alias $i testthread {} testthread + $i eval "package require -exact Thread [package present Thread]" $i eval { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } while {1} {} } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.23 {cancel: slave interp -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.23 {cancel: slave interp -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { set i [interp create] - interp alias $i testthread {} testthread + $i eval "package require -exact Thread [package present Thread]" $i eval { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } set while while; $while {1} {} } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.24 {cancel: nested catch inside pure bytecode loop} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } catch { @@ -903,25 +905,24 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {testthread} { } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - after 1000; # wait for ThreadErrorProc to be called. - while {[testthread event]} {}; # force events to service - catch {testthread send $serverthread {testthread exit}} - threadReap + set res [thread::cancel $serverthread] + thread::send $serverthread $::threadSuperKillScript + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ $::threadIdStarted == $serverthread : 0}] \ [expr {[info exists ::threadId] ? \ $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] } {{} 1 0 {}} -test thread-7.25 {cancel: nested catch inside pure inside-command loop} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { set catch catch set while while @@ -929,8 +930,7 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {testthr if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } $catch { @@ -947,61 +947,59 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {testthr } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 - set res [testthread cancel $serverthread] - after 1000; # wait for ThreadErrorProc to be called. - while {[testthread event]} {}; # force events to service - catch {testthread send $serverthread {testthread exit}} - threadReap + set res [thread::cancel $serverthread] + thread::send $serverthread $::threadSuperKillScript + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ $::threadIdStarted == $serverthread : 0}] \ [expr {[info exists ::threadId] ? \ $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] } {{} 1 0 {}} -test thread-7.26 {cancel: send async cancel bad interp path} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { +test thread-7.26 {cancel: send async cancel bad interp path} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } update } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - catch {testthread send $serverthread {interp cancel -- bad}} msg - threadReap - list [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - $msg + vwait ::threadIdStarted + catch {thread::send $serverthread {interp cancel -- bad}} msg + thread::send -async $serverthread {interp cancel -unwind} + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list [expr {$::threadIdStarted == $serverthread}] $msg } {1 {could not find interpreter "bad"}} -test thread-7.27 {cancel: send async cancel -- switch} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { - interp create -- -unwind - interp alias -unwind testthread {} testthread - interp eval -unwind { +test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { + set i [interp create -- -unwind] + $i eval "package require -exact Thread [package present Thread]" + $i eval { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } update @@ -1009,31 +1007,30 @@ test thread-7.27 {cancel: send async cancel -- switch} {testthread} { } foobar } - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {interp cancel -- -unwind}] - after 1000; # wait for ThreadErrorProc to be called. - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval canceled}} -test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::send -async $serverthread {interp cancel -- -unwind}] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval canceled}} +test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } catch { @@ -1050,25 +1047,24 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {interp cancel}] - after 1000; # wait for ThreadErrorProc to be called. - while {[testthread event]} {}; # force events to service - catch {testthread send $serverthread {testthread exit}} - threadReap + set res [thread::send -async $serverthread {interp cancel}] + thread::send $serverthread $::threadSuperKillScript + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ $::threadIdStarted == $serverthread : 0}] \ [expr {[info exists ::threadId] ? \ $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 0 {}} -test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} {{} 1 1 {eval canceled}} +test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { set catch catch set while while @@ -1076,8 +1072,7 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } $catch { @@ -1094,32 +1089,30 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {interp cancel}] - after 1000; # wait for ThreadErrorProc to be called. - while {[testthread event]} {}; # force events to service - catch {testthread send $serverthread {testthread exit}} - threadReap + set res [thread::send -async $serverthread {interp cancel}] + thread::send $serverthread $::threadSuperKillScript + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ $::threadIdStarted == $serverthread : 0}] \ [expr {[info exists ::threadId] ? \ $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 0 {}} -test thread-7.30 {cancel: send async testthread cancel nested catch inside pure bytecode loop} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} {{} 1 1 {eval canceled}} +test thread-7.30 {cancel: send async thread cancel nested catch inside pure bytecode loop} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } catch { @@ -1136,25 +1129,24 @@ test thread-7.30 {cancel: send async testthread cancel nested catch inside pure } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {testthread cancel [testthread id]}] - after 1000; # wait for ThreadErrorProc to be called. - while {[testthread event]} {}; # force events to service - catch {testthread send $serverthread {testthread exit}} - threadReap + set res [thread::send -async $serverthread {thread::cancel [thread::id]}] + thread::send $serverthread $::threadSuperKillScript + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ $::threadIdStarted == $serverthread : 0}] \ [expr {[info exists ::threadId] ? \ $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 0 {}} -test thread-7.31 {cancel: send async testthread cancel nested catch pure inside-command loop} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} {{} 1 1 {eval canceled}} +test thread-7.31 {cancel: send async thread cancel nested catch pure inside-command loop} {thread drainEventQueue} { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { set catch catch set while while @@ -1162,8 +1154,7 @@ test thread-7.31 {cancel: send async testthread cancel nested catch pure inside- if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } $catch { @@ -1180,32 +1171,31 @@ test thread-7.31 {cancel: send async testthread cancel nested catch pure inside- } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {testthread cancel [testthread id]}] - after 1000; # wait for ThreadErrorProc to be called. - while {[testthread event]} {}; # force events to service - catch {testthread send $serverthread {testthread exit}} - threadReap + set res [thread::send -async $serverthread {thread::cancel [thread::id]}] + thread::send $serverthread $::threadSuperKillScript + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ $::threadIdStarted == $serverthread : 0}] \ [expr {[info exists ::threadId] ? \ $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 0 {}} -test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} {{} 1 1 {eval canceled}} +test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } catch { @@ -1220,24 +1210,25 @@ test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} {testt } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { set catch catch set while while @@ -1245,8 +1236,7 @@ test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } $catch { @@ -1261,31 +1251,31 @@ test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread cancel -unwind $serverthread] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::cancel -unwind $serverthread] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } catch { @@ -1302,24 +1292,25 @@ test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode lo } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {interp cancel -unwind}] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::send -async $serverthread {interp cancel -unwind}] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { set catch catch set while while @@ -1327,8 +1318,7 @@ test thread-7.35 {cancel: send async cancel nested catch inside pure inside-comm if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } $catch { @@ -1345,31 +1335,31 @@ test thread-7.35 {cancel: send async cancel nested catch inside pure inside-comm } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {interp cancel -unwind}] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.36 {cancel: send async testthread cancel nested catch inside pure bytecode loop -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::send -async $serverthread {interp cancel -unwind}] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.36 {cancel: send async thread cancel nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID% [thread::id]] { proc foobar {} { while {1} { if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } catch { @@ -1386,24 +1376,25 @@ test thread-7.36 {cancel: send async testthread cancel nested catch inside pure } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {testthread cancel -unwind [testthread id]}] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} -test thread-7.37 {cancel: send async testthread cancel nested catch inside pure inside-command loop -unwind} {testthread} { - threadReap - unset -nocomplain ::threadError ::threadId ::threadIdStarted - set serverthread [testthread create -joinable { + vwait ::threadIdStarted + set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} +test thread-7.37 {cancel: send async thread cancel nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -body { + set serverthread [thread::create -joinable \ + [string map [list %ID [thread::id]] { proc foobar {} { set catch catch set while while @@ -1411,8 +1402,7 @@ test thread-7.37 {cancel: send async testthread cancel nested catch inside pure if {![info exists foo]} then { # signal the primary thread that we are ready # to be canceled now (we are running). - testthread send [testthread id -main] \ - [list set ::threadIdStarted [testthread id]] + thread::send %ID% [list set ::threadIdStarted [thread::id]] set foo 1 } $catch { @@ -1429,20 +1419,20 @@ test thread-7.37 {cancel: send async testthread cancel nested catch inside pure } } foobar - }] + }]] # wait for other thread to signal "ready to cancel" - vwait ::threadIdStarted; after 1000 - set res [testthread send -async $serverthread {testthread cancel -unwind [testthread id]}] - testthread join $serverthread - while {[testthread event]} {}; # force events to service - threadReap - list $res [expr {[info exists ::threadIdStarted] ? \ - $::threadIdStarted == $serverthread : 0}] \ - [expr {[info exists ::threadId] ? \ - $::threadId == $serverthread : 0}] \ - [expr {[info exists ::threadError] ? \ - [lindex [split $::threadError \n] 0] : "" }] -} {{} 1 1 {eval unwound}} + vwait ::threadIdStarted + set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}] + vwait ::threadSawError($serverthread) + thread::join $serverthread; drainEventQueue + list $res [expr {$::threadIdStarted == $serverthread}] \ + [expr {[info exists ::threadId] ? \ + $::threadId == $serverthread : 0}] \ + [expr {[info exists ::threadError($serverthread)] ? \ + [findThreadError $::threadError($serverthread)] : ""}] +} -cleanup { + unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted +} -result {{} 1 1 {eval unwound}} # cleanup ::tcltest::cleanupTests diff --git a/tests/timer.test b/tests/timer.test index 76be883..ab6efc9 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -12,8 +12,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: timer.test,v 1.14 2008/07/19 22:50:39 nijtmans Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 diff --git a/tests/tm.test b/tests/tm.test index 72bcc72..149a65d 100644 --- a/tests/tm.test +++ b/tests/tm.test @@ -5,8 +5,6 @@ # # Copyright (c) 2004 by Donal K. Fellows. # All rights reserved. -# -# RCS: @(#) $Id: tm.test,v 1.8 2008/09/26 19:54:59 dgp Exp $ package require Tcl 8.5 if {"::tcltest" ni [namespace children]} { diff --git a/tests/trace.test b/tests/trace.test index 4d924e2..0f48dcf 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -10,14 +10,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: trace.test,v 1.62 2008/07/19 22:50:38 nijtmans Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testevalobjv [llength [info commands testevalobjv]] @@ -2560,8 +2561,69 @@ set base { } runbase {{- *} {-* *} {- *} {- *}} $base +test trace-39 {bug #3484621: tracing Bc'ed commands} -setup { + set ::traceLog 0 + set ::traceCalls 0 + set ::bar [list 0 1 2 3] + set res {} + proc dotrace args { + incr ::traceLog + } + proc foo {} { + incr ::traceCalls + # choose a BC'ed command that is 'unlikely' to interfere with tcltest's + # internals + lset ::bar 1 2 + } +} -body { + foo + lappend res $::traceLog + + trace add execution lset enter dotrace + foo + lappend res $::traceLog + + trace remove execution lset enter dotrace + foo + lappend res $::traceLog + + list $::traceCalls | {*}$res +} -cleanup { + unset ::traceLog ::traceCalls ::bar res + 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 + set res {} + proc dotrace args { + incr ::traceLog + } + proc foo {} { + incr ::traceCalls + string equal zip zap + } +} -body { + foo + lappend res $::traceLog + + trace add execution ::tcl::string::equal enter dotrace + foo + lappend res $::traceLog + trace remove execution tcl::string::equal enter dotrace + foo + lappend res $::traceLog + list $::traceCalls | {*}$res +} -cleanup { + unset ::traceLog ::traceCalls res + rename dotrace {} + rename foo {} +} -result {3 | 0 1 1} + # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). catch {rename foobar {}} diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 43dcf1a..2453e01 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -8,14 +8,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: unixFCmd.test,v 1.26 2008/04/11 14:55:10 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testchmod [llength [info commands testchmod]] # These tests really need to be run from a writable directory, which diff --git a/tests/unixFile.test b/tests/unixFile.test index 8e37b5d..8147f48 100644 --- a/tests/unixFile.test +++ b/tests/unixFile.test @@ -8,14 +8,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: unixFile.test,v 1.9 2004/06/23 15:36:58 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testfindexecutable [llength [info commands testfindexecutable]] set oldpwd [pwd] diff --git a/tests/unixInit.test b/tests/unixInit.test index 1f4dc7a..9ba9c11 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -1,23 +1,21 @@ # The file tests the functions in the tclUnixInit.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. +# 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) 1997 by 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. -# -# RCS: @(#) $Id: unixInit.test,v 1.50 2006/11/03 11:45:35 dkf Exp $ +# 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::* unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C - + test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { set x {} # Watch out for a race condition here. If tcltest is too slow to start @@ -36,13 +34,13 @@ test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { lappend x [catch {close $f}] set x } {0 1} -# This test is really a test of code in tclUnixChan.c, but the -# channels are set up as part of initialisation of the interpreter so -# the test seems to me to fit here as well as anywhere else. +# This test is really a test of code in tclUnixChan.c, but the channels are +# set up as part of initialisation of the interpreter so the test seems to me +# to fit here as well as anywhere else. test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} { - # pipe1 is a connection to a server that reports what port it - # starts on, and delivers a constant string to the first client to - # connect to that port before exiting. + # pipe1 is a connection to a server that reports what port it starts on, + # and delivers a constant string to the first client to connect to that + # port before exiting. set pipe1 [open "|[list [interpreter]]" r+] puts $pipe1 { proc accept {channel host port} { @@ -53,16 +51,16 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} puts [fconfigure [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 string is read before an [exit] can happen... + # Note the backslash above; this is important to make sure that the whole + # string is read before an [exit] can happen... flush $pipe1 set port [lindex [gets $pipe1] 2] set sock [socket localhost $port] - # pipe2 is a connection to a Tcl interpreter that takes its orders - # from the socket we hand it (i.e. the server we create above.) - # These orders will tell it to print out the details about the - # socket it is taking instructions from, hopefully identifying it - # as a socket. Which is what this test is all about. + # pipe2 is a connection to a Tcl interpreter that takes its orders from + # the socket we hand it (i.e. the server we create above.) These orders + # will tell it to print out the details about the socket it is taking + # instructions from, hopefully identifying it as a socket. Which is what + # this test is all about. set pipe2 [open "|[list [interpreter] <@$sock]" r] set result [gets $pipe2] # Clear any pending data; stops certain kinds of (non-important) errors @@ -75,8 +73,7 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} # Can't use normal comparison, as hostname varies due to some # installations having a messed up /etc/hosts file. if { - [string equal 127.0.0.1 [lindex $result 0]] && - [string equal $port [lindex $result 2]] + "127.0.0.1" eq [lindex $result 0] && $port == [lindex $result 2] } then { subst "OK" } else { @@ -85,8 +82,8 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} } {OK} # The unixInit-2.* tests were written to test the internal routine, -# TclpInitLibraryPath. That routine no longer does the things it used -# to do so those tests are obsolete. Skip them. +# TclpInitLibraryPath. That routine no longer does the things it used to do +# so those tests are obsolete. Skip them. skip [concat [skip] unixInit-2.*] @@ -108,16 +105,14 @@ test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup set installLib lib/tcl[info tclversion] set developLib tcl[info patchlevel]/library set prefix [file dirname [file dirname [interpreter]]] - set x {} - lappend x [string compare [lindex $path 0] $prefix/$installLib] - lappend x [string compare [lindex $path 4] [file dirname $prefix]/$developLib] - set x + list [string equal [lindex $path 0] $prefix/$installLib] \ + [string equal [lindex $path 4] [file dirname $prefix]/$developLib] } -cleanup { if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } -} -result {0 0} +} -result {1 1} test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { @@ -126,10 +121,9 @@ test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup { } -body { # ((str != NULL) && (str[0] != '\0')) set env(TCL_LIBRARY) sparkly - set path [getlibpath] - unset env(TCL_LIBRARY) - lindex $path 0 + lindex [getlibpath] 0 } -cleanup { + unset -nocomplain env(TCL_LIBRARY) if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary @@ -143,10 +137,9 @@ test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -setup { } -body { # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0)) set env(TCL_LIBRARY) /a/b/tcl1.7 - set path [getlibpath] - unset env(TCL_LIBRARY) - lrange $path 0 1 + lrange [getlibpath] 0 1 } -cleanup { + unset -nocomplain env(TCL_LIBRARY) if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary @@ -159,11 +152,9 @@ test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup { } -body { # Child process translates env variable from native encoding. set env(TCL_LIBRARY) "\xa7" - set x [lindex [getlibpath] 0] - unset env(TCL_LIBRARY) - unset env(LANG) - set x + lindex [getlibpath] 0 } -cleanup { + unset -nocomplain env(TCL_LIBRARY) env(LANG) if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary @@ -207,10 +198,9 @@ test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} { # [lindex $auto_path end] } {} # -# The following two tests write to the directory /tmp/sparkly instead -# of to [temporaryDirectory]. This is because the failures tested by -# these tests need paths near the "root" of the file system to present -# themselves. +# The following two tests write to the directory /tmp/sparkly instead of to +# [temporaryDirectory]. This is because the failures tested by these tests +# need paths near the "root" of the file system to present themselves. # test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { unset -nocomplain oldlibrary @@ -219,20 +209,20 @@ test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { } set env(TCL_LIBRARY) [info library] # Checking for Bug 219416 - # When a program that embeds the Tcl library, like tcltest, is - # installed near the "root" of the file system, there was a problem - # constructing directories relative to the executable. When a - # relative ".." went past the root, relative path names were created - # rather than absolute pathnames. In some cases, accessing past the - # root caused memory access violations too. + # When a program that embeds the Tcl library, like tcltest, is installed + # near the "root" of the file system, there was a problem constructing + # directories relative to the executable. When a relative ".." went past + # the root, relative path names were created rather than absolute + # pathnames. In some cases, accessing past the root caused memory access + # violations too. # - # The bug is now fixed, but here we check for it by making sure that - # the directories constructed relative to the executable are all - # absolute pathnames, even when the executable is installed near - # the root of the filesystem. + # The bug is now fixed, but here we check for it by making sure that the + # directories constructed relative to the executable are all absolute + # pathnames, even when the executable is installed near the root of the + # filesystem. # - # The only directory near the root we are likely to have write access - # to is /tmp. + # The only directory near the root we are likely to have write access to + # is /tmp. file delete -force /tmp/sparkly file delete -force /tmp/lib/tcl[info tclversion] file mkdir /tmp/sparkly @@ -318,21 +308,15 @@ test unixInit-2.10 {TclpInitLibraryPath: executable relative} -setup { set y } -cleanup { cd $saveDir - unset saveDir removeFile init.tcl $scriptDir - unset scriptDir removeDirectory tcl[info tclversion] $libDir - unset libDir file delete $execPath - unset execPath removeDirectory bin $sparklyDir removeDirectory lib $sparklyDir - unset sparklyDir removeDirectory sparkly $tmpDir - unset tmpDir removeDirectory tmp - unset x p y - unset env(TCL_LIBRARY) + unset -nocomplain saveDir scriptDir libDir execPath sparklyDir tmpDir + unset -nocomplain x p y env(TCL_LIBRARY) if {[info exists oldlibrary]} { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary @@ -349,31 +333,32 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints { puts $f {puts [encoding system]; exit} set enc [gets $f] close $f - unset env(LANG) - set enc + return $enc +} -cleanup { + unset -nocomplain env(LANG) } -match regexp -result [expr { ($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}] -test unixInit-3.2 {TclpSetInitialEncodings} {unix stdio} { - set env(LANG) japanese +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 puts $f {puts [encoding system]; exit} set enc [gets $f] close $f - unset env(LANG) - unset env(LC_ALL) - catch {set env(LC_ALL) $oldlc_all} set validEncodings [list euc-jp] if {[string match HP-UX $tcl_platform(os)]} { - # Some older HP-UX systems need us to accept this as valid - # Bug 453883 reports that newer HP-UX systems report euc-jp - # like everybody else. + # Some older HP-UX systems need us to accept this as valid Bug 453883 + # reports that newer HP-UX systems report euc-jp like everybody else. lappend validEncodings shiftjis } - expr {[lsearch -exact $validEncodings $enc] < 0} -} 0 + expr {$enc ni $validEncodings} +} -cleanup { + unset -nocomplain env(LANG) env(LC_ALL) + catch {set env(LC_ALL) $oldlc_all} +} -result 0 test unixInit-4.1 {TclpSetVariables} {unix} { # just make sure they exist @@ -403,7 +388,7 @@ test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { removeFile crash.tcl removeFile crashtest.tcl } -returnCodes 0 - + # cleanup catch {unset env(LANG)} catch {set env(LANG) $oldlang} @@ -411,3 +396,7 @@ unset -nocomplain path ::tcltest::cleanupTests return +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 24717ee..2f03529 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -9,12 +9,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: unixNotfy.test,v 1.19 2005/11/01 16:41:20 dgp Exp $ - -# The tests should not be run if you have a notifier which is unable to -# detect infinite vwaits, as the tests below will hang. The presence of -# the "testthread" command indicates that this is the case. if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -22,11 +16,11 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } # When run in a Tk shell, these tests hang. -testConstraint noTk [expr {![info exists tk_version]}] -testConstraint testthread [expr {[info commands testthread] != {}}] +testConstraint noTk [expr {0 != [catch {package present Tk}]}] +testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # Darwin always uses a threaded notifier testConstraint unthreaded [expr { - (![info exist tcl_platform(threaded)] || !$tcl_platform(threaded)) + ![::tcl::pkgconfig get threaded] && $tcl_platform(os) ne "Darwin" }] @@ -63,16 +57,15 @@ test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} - } test unixNotfy-2.1 {Tcl_DeleteFileHandler} \ - -constraints {noTk unix testthread} \ + -constraints {noTk unix thread} \ -body { update set f [open [makeFile "" foo] w] fileevent $f writable {set x 1} vwait x close $f - testthread create "testthread send [testthread id] {set x ok}" + thread::create "thread::send [thread::id] {set x ok}" vwait x - threadReap set x } \ -result {ok} \ @@ -81,7 +74,7 @@ test unixNotfy-2.1 {Tcl_DeleteFileHandler} \ catch { removeFile foo } } test unixNotfy-2.2 {Tcl_DeleteFileHandler} \ - -constraints {noTk unix testthread} \ + -constraints {noTk unix thread} \ -body { update set f1 [open [makeFile "" foo] w] @@ -92,9 +85,8 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \ close $f1 vwait y close $f2 - testthread create "testthread send [testthread id] {set x ok}" + thread::create "thread::send [thread::id] {set x ok}" vwait x - threadReap set x } \ -result {ok} \ diff --git a/tests/unknown.test b/tests/unknown.test index 72b3252..40be6602 100644 --- a/tests/unknown.test +++ b/tests/unknown.test @@ -10,8 +10,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: unknown.test,v 1.9 2010/07/05 08:03:53 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/unload.test b/tests/unload.test index bf704c7..5a374c4 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -10,14 +10,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: unload.test,v 1.9 2010/04/02 21:21:06 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Figure out what extension is used for shared libraries on this # platform. if {![info exists ext]} { diff --git a/tests/uplevel.test b/tests/uplevel.test index f676290..0410469 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -1,17 +1,15 @@ # Commands covered: uplevel # -# 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-1993 The Regents of the University of California. # Copyright (c) 1994 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. -# -# RCS: @(#) $Id: uplevel.test,v 1.9 2008/06/08 03:21:33 msofer Exp $ +# 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 @@ -26,7 +24,7 @@ proc newset {name value} { uplevel set $name $value uplevel 1 {uplevel 1 {set xyz 22}} } - + test uplevel-1.1 {simple operation} { set xyz 0 a 22 33 @@ -85,20 +83,24 @@ test uplevel-3.4 {uplevel to same level} { a1 } 55 -test uplevel-4.1 {error: non-existent level} { - list [catch c1 msg] $msg -} {1 {bad level "#2"}} -test uplevel-4.2 {error: non-existent level} { - proc c2 {} {uplevel 3 {set a b}} - list [catch c2 msg] $msg -} {1 {bad level "3"}} -test uplevel-4.3 {error: not enough args} { - list [catch uplevel msg] $msg -} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} -test uplevel-4.4 {error: not enough args} { - proc upBug {} {uplevel 1} - list [catch upBug msg] $msg -} {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}} +test uplevel-4.1 {error: non-existent level} -returnCodes error -body { + apply {{} { + uplevel #2 {set y 222} + }} +} -result {bad level "#2"} +test uplevel-4.2 {error: non-existent level} -returnCodes error -body { + apply {{} { + uplevel 3 {set a b} + }} +} -result {bad level "3"} +test uplevel-4.3 {error: not enough args} -returnCodes error -body { + uplevel +} -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} +test uplevel-4.4 {error: not enough args} -returnCodes error -body { + apply {{} { + uplevel 1 + }} +} -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} proc a2 {} { uplevel a3 @@ -193,7 +195,12 @@ test uplevel-7.3 {var access, LVT in upper level} -setup { rename foo {} rename moo {} } -result {3 3 3} - + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/upvar.test b/tests/upvar.test index dbf6dd5..e2c9ffd 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -10,14 +10,15 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: upvar.test,v 1.20 2010/02/10 23:28:39 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testupvar [llength [info commands testupvar]] test upvar-1.1 {reading variables with upvar} { @@ -427,116 +428,103 @@ namespace eval test_ns_0 { } set ::x test_global -test upvar-NS-1.1 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { +test upvar-NS-1.1 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace upvar ::test_ns_0 x w + set w + } +} -result {test_ns_0} -cleanup { + namespace delete test_ns_1 +} +test upvar-NS-1.2 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + proc a {} { namespace upvar ::test_ns_0 x w set w } - } \ - -result {test_ns_0} \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.2 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - proc a {} { - namespace upvar ::test_ns_0 x w - set w - } - return [a] - } - } \ - -result {test_ns_0} \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.3 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { + return [a] + } +} -result {test_ns_0} -cleanup { + namespace delete test_ns_1 +} +test upvar-NS-1.3 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace upvar test_ns_0 x w + set w + } +} -returnCodes error -cleanup { + namespace delete test_ns_1 +} -result {namespace "test_ns_0" not found in "::test_ns_1"} +test upvar-NS-1.4 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + proc a {} { namespace upvar test_ns_0 x w set w } - } \ - -result {namespace "test_ns_0" not found in "::test_ns_1"} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.4 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - proc a {} { - namespace upvar test_ns_0 x w - set w - } - return [a] - } - } \ - -result {namespace "test_ns_0" not found in "::test_ns_1"} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.5 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - namespace eval test_ns_0 {} + return [a] + } +} -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 {} + namespace upvar test_ns_0 x w + set w + } +} -cleanup { + namespace delete test_ns_1 +} -result {can't read "w": no such variable} -returnCodes error +test upvar-NS-1.6 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 {} + proc a {} { namespace upvar test_ns_0 x w set w } - } \ - -result {can't read "w": no such variable} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.6 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - namespace eval test_ns_0 {} - proc a {} { - namespace upvar test_ns_0 x w - set w - } - return [a] + return [a] + } +} -cleanup { + namespace delete test_ns_1 +} -result {can't read "w": no such variable} -returnCodes error +test upvar-NS-1.7 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 { + variable x test_ns_1::test_ns_0 } - } \ - -result {can't read "w": no such variable} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.7 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - namespace eval test_ns_0 { - variable x test_ns_1::test_ns_0 - } + namespace upvar test_ns_0 x w + set w + } +} -cleanup { + namespace delete test_ns_1 +} -result {test_ns_1::test_ns_0} +test upvar-NS-1.8 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + namespace eval test_ns_0 { + variable x test_ns_1::test_ns_0 + } + proc a {} { namespace upvar test_ns_0 x w set w } - } \ - -result {test_ns_1::test_ns_0} \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.8 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - namespace eval test_ns_0 { - variable x test_ns_1::test_ns_0 - } - proc a {} { - namespace upvar test_ns_0 x w - set w - } - return [a] - } - } \ - -result {test_ns_1::test_ns_0} \ - -cleanup {namespace delete test_ns_1} -test upvar-NS-1.9 {nsupvar links to correct variable} \ - -body { - namespace eval test_ns_1 { - variable x test_ns_1 - proc a {} { - namespace upvar test_ns_0 x w - set w - } - return [a] + return [a] + } +} -cleanup { + namespace delete test_ns_1 +} -result {test_ns_1::test_ns_0} +test upvar-NS-1.9 {nsupvar links to correct variable} -body { + namespace eval test_ns_1 { + variable x test_ns_1 + proc a {} { + namespace upvar test_ns_0 x w + set w } - } \ - -result {namespace "test_ns_0" not found in "::test_ns_1"} \ - -returnCodes error \ - -cleanup {namespace delete test_ns_1} + return [a] + } +} -returnCodes error -cleanup { + namespace delete test_ns_1 +} -result {namespace "test_ns_0" not found in "::test_ns_1"} test upvar-NS-2.1 {TIP 323} -returnCodes error -body { namespace upvar diff --git a/tests/utf.test b/tests/utf.test index 575a5cd..c41cfe3 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -7,14 +7,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: utf.test,v 1.14 2007/05/02 01:37:28 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + catch {unset x} test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} { @@ -29,9 +30,12 @@ test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} { test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} { set x "\u4e4e" } [bytestring "\xe4\xb9\x8e"] -test utf-1.5 {Tcl_UniCharToUtf: negative Tcl_UniChar} { - string length [format %c -1] -} 1 +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-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" @@ -170,7 +174,7 @@ bsCheck \x 120 bsCheck \xa 10 bsCheck \xA 10 bsCheck \x41 65 -bsCheck \x541 65 +bsCheck \x541 84 bsCheck \u 117 bsCheck \uk 117 bsCheck \u41 65 @@ -179,6 +183,18 @@ 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 test utf-11.1 {Tcl_UtfToUpper} { string toupper {} @@ -246,8 +262,9 @@ test utf-16.1 {Tcl_UniCharToLower, negative delta} { string tolower aA } aa test utf-16.2 {Tcl_UniCharToLower, positive delta} { - string tolower \u0178\u00ff -} \u00ff\u00ff + string tolower \u0178\u00ff\uA78D\u01c5 +} \u00ff\u00ff\u0265\u01c6 + test utf-17.1 {Tcl_UniCharToLower, no delta} { string tolower ! } ! @@ -276,13 +293,53 @@ test utf-20.1 {TclUniCharNcmp} { } {} test utf-21.1 {TclUniCharIsAlnum} { - # this returns 1 with Unicode 3 compliance - string is alnum \u1040\u021f + # this returns 1 with Unicode 6 compliance + string is alnum \u1040\u021f\u0220 } {1} test utf-21.2 {unicode alnum char in regc_locale.c} { - # this returns 1 with Unicode 3 compliance - list [regexp {^[[:alnum:]]+$} \u1040\u021f] [regexp {^\w+$} \u1040\u021f] + # this returns 1 with Unicode 6 compliance + list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220] } {1 1} +test utf-21.3 {unicode print char in regc_locale.c} { + # this returns 1 with Unicode 6 compliance + regexp {^[[:print:]]+$} \ufbc1 +} 1 +test utf-21.4 {TclUniCharIsGraph} { + # [Bug 3464428] + string is graph \u0120 +} {1} +test utf-21.5 {unicode graph char in regc_locale.c} { + # [Bug 3464428] + regexp {^[[:graph:]]+$} \u0120 +} {1} +test utf-21.6 {TclUniCharIsGraph} { + # [Bug 3464428] + string is graph \u00a0 +} {0} +test utf-21.7 {unicode graph char in regc_locale.c} { + # [Bug 3464428] + regexp {[[:graph:]]} \u0020\u00a0\u2028\u2029 +} {0} +test utf-21.8 {TclUniCharIsPrint} { + # [Bug 3464428] + string is print \u0009 +} {0} +test utf-21.9 {unicode print char in regc_locale.c} { + # [Bug 3464428] + regexp {[[:print:]]} \u0009 +} {0} +test utf-21.10 {unicode print char in regc_locale.c} { + # [Bug 3464428] + regexp {[[:print:]]} \u0009 +} {0} +test utf-21.11 {TclUniCharIsControl} { + # [Bug 3464428] + string is control \u00ad +} {1} +test utf-21.12 {unicode control char in regc_locale.c} { + # [Bug 3464428] + regexp {^[[:cntrl:]]$} \u00ad +} {1} test utf-22.1 {TclUniCharIsWordChar} { string wordend "xyz123_bar fg" 0 @@ -292,30 +349,30 @@ test utf-22.2 {TclUniCharIsWordChar} { } 10 test utf-23.1 {TclUniCharIsAlpha} { - # this returns 1 with Unicode 3 compliance - string is alpha \u021f + # this returns 1 with Unicode 6 compliance + string is alpha \u021f\u0220 } {1} test utf-23.2 {unicode alpha char in regc_locale.c} { - # this returns 1 with Unicode 3 compliance - regexp {^[[:alpha:]]+$} \u021f + # this returns 1 with Unicode 6 compliance + regexp {^[[:alpha:]]+$} \u021f\u0220 } {1} test utf-24.1 {TclUniCharIsDigit} { - # this returns 1 with Unicode 3 compliance - string is digit \u1040 + # this returns 1 with Unicode 6 compliance + string is digit \u1040\uabf0 } {1} test utf-24.2 {unicode digit char in regc_locale.c} { - # this returns 1 with Unicode 3 compliance - list [regexp {^[[:digit:]]+$} \u1040] [regexp {^\d+$} \u1040] + # this returns 1 with Unicode 6 compliance + list [regexp {^[[:digit:]]+$} \u1040\uabf0] [regexp {^\d+$} \u1040\uabf0] } {1 1} test utf-24.3 {TclUniCharIsSpace} { - # this returns 1 with Unicode 3 compliance - string is space \u1680 + # this returns 1 with Unicode 6 compliance + string is space \u1680\u180e } {1} test utf-24.4 {unicode space char in regc_locale.c} { - # this returns 1 with Unicode 3 compliance - list [regexp {^[[:space:]]+$} \u1680] [regexp {^\s+$} \u1680] + # this returns 1 with Unicode 6 compliance + list [regexp {^[[:space:]]+$} \u1680\u180e] [regexp {^\s+$} \u1680\u180e] } {1 1} testConstraint teststringobj [llength [info commands teststringobj]] diff --git a/tests/util.test b/tests/util.test index 994fc0f..0e50483 100644 --- a/tests/util.test +++ b/tests/util.test @@ -6,16 +6,19 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: util.test,v 1.20 2008/10/14 16:35:44 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +testConstraint controversialNaN 1 testConstraint testdstring [llength [info commands testdstring]] testConstraint testconcatobj [llength [info commands testconcatobj]] +testConstraint testdoubledigits [llength [info commands testdoubledigits]] # Big test for correct ordering of data in [expr] @@ -43,6 +46,10 @@ proc testIEEE {} { ieeeValues(+Infinity) binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ ieeeValues(NaN) + binary scan \x00\x00\x00\x00\x00\x00\xf8\xff d \ + ieeeValues(-NaN) + binary scan \xef\xcd\xab\x89\x67\x45\xfb\xff d \ + ieeeValues(-NaN(3456789abcdef)) set ieeeValues(littleEndian) 1 return 1 } @@ -65,6 +72,10 @@ proc testIEEE {} { ieeeValues(+Infinity) binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) + binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-NaN) + binary scan \xff\xfb\x45\x67\x89\xab\xcd\xef d \ + ieeeValues(-NaN(3456789abcdef)) set ieeeValues(littleEndian) 0 return 1 } @@ -85,6 +96,30 @@ proc convertDouble { x } { return $result } +proc verdonk_test {sig binexp shouldbe exp} { + regexp {([-+]?)([0-9a-f]+)} $sig -> signum sig + scan $sig %llx sig + if {$signum eq {-}} { + set signum [expr 1<<63] + } else { + set signum 0 + } + regexp {E([-+]?[0-9]+)} $binexp -> binexp + set word [expr {$signum | (($binexp + 0x3ff)<<52)|($sig & ~(1<<52))}] + binary scan [binary format w $word] q double + regexp {([-+])(\d+)_(\d+)\&} $shouldbe -> signum digits1 digits2 + regexp {E([-+]\d+)} $exp -> decexp + incr decexp [expr {[string length $digits1] - 1}] + lassign [testdoubledigits $double [string length $digits1] e] \ + outdigits decpt outsign + if {[string index $digits2 0] >= 5} { + incr digits1 + } + if {$outsign != $signum || $outdigits != $digits1 || $decpt != $decexp} { + return -code error "result is ${outsign}0.${outdigits}E$decpt\ + should be ${signum}0.${digits1}E$decexp" + } +} test util-1.1 {TclFindElement procedure - binary element in middle of list} { lindex {0 foo\x00help 1} 1 @@ -144,6 +179,12 @@ test util-3.5.1 {Tcl_ConverCountedElement procedure - quote leading '#'} { rename #\{ {} set result } {#} +test util-3.6 {Tcl_ConvertElement, Bug 3371644} { + interp create #\\ + interp alias {} x #\\ concat + interp target {} x ;# Crash if bug not fixed + interp delete #\\ +} {} test util-4.1 {Tcl_ConcatObj - backslash-space at end of argument} { concat a {b\ } c @@ -1106,6 +1147,2881 @@ test util-11.23 {Tcl_PrintDouble - scaling} { expr 1.1e17 } {1.1e+17} +test util-12.1 {TclDoubleDigits - Inf} {testdoubledigits ieeeFloatingPoint} { + testdoubledigits Inf -1 shortest +} {Infinity 9999 +} +test util-12.2 {TclDoubleDigits - -Inf} {testdoubledigits ieeeFloatingPoint} { + testdoubledigits -Inf -1 shortest +} {Infinity 9999 -} +test util-12.3 {TclDoubleDigits - NaN} {testdoubledigits ieeeFloatingPoint} { + testdoubledigits $ieeeValues(NaN) -1 shortest +} {NaN 9999 +} +test util-12.4 {TclDoubleDigits - NaN} {*}{ + -constraints {testdoubledigits ieeeFloatingPoint controversialNaN} + -body { + testdoubledigits -NaN -1 shortest + } + -result {NaN 9999 -} +} +test util-12.5 {TclDoubleDigits - 0} testdoubledigits { + testdoubledigits 0.0 -1 shortest +} {0 0 +} +test util-12.6 {TclDoubleDigits - -0} testdoubledigits { + testdoubledigits -0.0 -1 shortest +} {0 0 -} + +# Verdonk test vectors + +test util-13.1 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1754e31cd072da E+1008 +4_000000000000000000& E+303 + } + -result {} +} +test util-13.2 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1afcef51f0fb5f E+265 -1_000000000000000000& E+80 + } + -result {} +} +test util-13.3 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1754e31cd072da E+1006 +1_000000000000000000& E+303 + } + -result {} +} +test util-13.4 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1754e31cd072da E+1007 -2_000000000000000000& E+303 + } + -result {} +} +test util-13.5 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1e07b27dd78b14 E-848 +1_00000000000000000& E-255 + } + -result {} +} +test util-13.6 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1e29e9c56687fe E-709 -7_00000000000000000& E-214 + } + -result {} +} +test util-13.7 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1be03d0bf225c7 E-137 +1_00000000000000000& E-41 + } + -result {} +} +test util-13.8 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1a2fe76a3f9475 E-499 -1_00000000000000000& E-150 + } + -result {} +} +test util-13.9 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 19a2028368022e E+1019 +8_999999999999999999& E+306 + } + -result {} +} +test util-13.10 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1317e5ef3ab327 E+509 -1_999999999999999999& E+153 + } + -result {} +} +test util-13.11 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1317e5ef3ab327 E+510 +3_99999999999999999& E+153 + } + -result {} +} +test util-13.12 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1317e5ef3ab327 E+511 -7_99999999999999999& E+153 + } + -result {} +} +test util-13.13 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1eb8e84fa0b278 E-1008 +6_999999999999999999& E-304 + } + -result {} +} +test util-13.14 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -13339131c46f8b E-1004 -6_999999999999999999& E-303 + } + -result {} +} +test util-13.15 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1c0f92a6276c9d E-162 +2_999999999999999999& E-49 + } + -result {} +} +test util-13.16 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -15ce1f143d7ad2 E-443 -5_99999999999999999& E-134 + } + -result {} +} +test util-13.17 {just over exact - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1c0794d9d40e96 E-301 +43_000000000000000000& E-92 + } + -result {} +} +test util-13.18 {just over exact - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1c0794d9d40e96 E-300 -86_000000000000000000& E-92 + } + -result {} +} +test util-13.19 {just over exact - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1cd5bee57763e6 E-241 +51_000000000000000000& E-74 + } + -result {} +} +test util-13.20 {just under exact - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1d1c26db7d0dae E+651 +16_999999999999999999& E+195 + } + -result {} +} +test util-13.21 {just under exact - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -13f7ced916872b E-5 -38_999999999999999999& E-3 + } + -result {} +} +test util-13.22 {just over exact - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 17d93193f78fc6 E+588 +151_0000000000000000000& E+175 + } + -result {} +} +test util-13.23 {just over exact - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1a82a1631eeb30 E-625 -119_000000000000000000& E-190 + } + -result {} +} +test util-13.24 {just under exact - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -16c309024bab4b E+290 -282_999999999999999999& E+85 + } + -result {} +} +test util-13.25 {just over exact - 8 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1dbbac6f83a821 E-800 +27869147_0000000000000000000& E-248 + } + -result {} +} +test util-13.26 {just under exact - 9 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1c569e968e0944 E+430 -491080653_9999999999999999999& E+121 + } + -result {} +} +test util-13.27 {just under exact - 9 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1c569e968e0944 E+429 +245540326_9999999999999999999& E+121 + } + -result {} +} +test util-13.28 {just over exact - 10 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1fc575867314ee E-330 -9078555839_0000000000000000000& E-109 + } + -result {} +} +test util-13.29 {just under exact - 10 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1c569e968e0944 E+428 -1227701634_9999999999999999999& E+120 + } + -result {} +} +test util-13.30 {just over exact - 11 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1fc575867314ee E-329 +18157111678_0000000000000000000& E-109 + } + -result {} +} +test util-13.31 {just over exact - 14 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -18bf7e7fa6f02a E-196 -15400733123779_0000000000000000000& E-72 + } + -result {} +} +test util-13.32 {just over exact - 17 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -13de005bd620df E+217 -26153245263757307_0000000000000000000& E+49 + } + -result {} +} +test util-13.33 {just over exact - 18 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1f92bacb3cb40c E+718 +272104041512242479_0000000000000000000& E+199 + } + -result {} +} +test util-13.34 {just over exact - 18 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1f92bacb3cb40c E+719 -544208083024484958_0000000000000000000& E+199 + } + -result {} +} +test util-13.35 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 142dbf25096cf5 E+148 +4_500000000000000000& E+44 + } + -result {} +} +test util-13.36 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1afcef51f0fb5f E+263 -2_500000000000000000& E+79 + } + -result {} +} +test util-13.37 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 102498ea6df0c4 E+145 +4_500000000000000000& E+43 + } + -result {} +} +test util-13.38 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1754e31cd072da E+1004 -2_500000000000000000& E+302 + } + -result {} +} +test util-13.39 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 12deac01e2b4f7 E-557 +2_50000000000000000& E-168 + } + -result {} +} +test util-13.40 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1b1df536c13eee E-307 -6_50000000000000000& E-93 + } + -result {} +} +test util-13.41 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 10711fed5b19a4 E-154 +4_50000000000000000& E-47 + } + -result {} +} +test util-13.42 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -148d67e8b1e00d E-151 -4_50000000000000000& E-46 + } + -result {} +} +test util-13.43 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1c8c574c0c6be7 E+187 +3_49999999999999999& E+56 + } + -result {} +} +test util-13.44 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1756183c147514 E+206 -1_49999999999999999& E+62 + } + -result {} +} +test util-13.45 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 12ab469676c410 E+203 +1_49999999999999999& E+61 + } + -result {} +} +test util-13.46 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1539684e774b48 E+246 -1_49999999999999999& E+74 + } + -result {} +} +test util-13.47 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 12e5f5dfa4fe9d E-286 +9_499999999999999999& E-87 + } + -result {} +} +test util-13.48 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1bdc2417bf7787 E-838 -9_499999999999999999& E-253 + } + -result {} +} +test util-13.49 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1eb8e84fa0b278 E-1009 +3_499999999999999999& E-304 + } + -result {} +} +test util-13.50 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1e3cbc9907fdc8 E-290 -9_499999999999999999& E-88 + } + -result {} +} +test util-13.51 {just over half ulp - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 10ad836f269a17 E-324 +30_500000000000000000& E-99 + } + -result {} +} +test util-13.52 {just over half ulp - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1b39ae1909c31b E-687 -26_500000000000000000& E-208 + } + -result {} +} +test util-13.53 {just over half ulp - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1b2ab18615fcc6 E-576 +686_500000000000000000& E-176 + } + -result {} +} +test util-13.54 {just over half ulp - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -13e1f90a573064 E-624 -178_500000000000000000& E-190 + } + -result {} +} +test util-13.55 {just under half ulp - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 16c309024bab4b E+289 +141_499999999999999999& E+85 + } + -result {} +} +test util-13.56 {just under half ulp - 4 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -159bd3ad46e346 E+193 -1695_499999999999999999& E+55 + } + -result {} +} +test util-13.57 {just under half ulp - 4 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1df4170f0fdecc E+124 +3981_499999999999999999& E+34 + } + -result {} +} +test util-13.58 {just over half ulp - 6 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 17e1e0f1c7a4ac E+415 +126300_5000000000000000000& E+120 + } + -result {} +} +test util-13.59 {just over half ulp - 6 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1dda592e398dd7 E+418 -126300_5000000000000000000& E+121 + } + -result {} +} +test util-13.60 {just under half ulp - 7 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1e597c0b94b7ae E+453 -4411845_499999999999999999& E+130 + } + -result {} +} +test util-13.61 {just under half ulp - 9 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1c569e968e0944 E+427 +613850817_4999999999999999999& E+120 + } + -result {} +} +test util-13.62 {just under half ulp - 9 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1c569e968e0944 E+428 -122770163_49999999999999999999& E+121 + } + -result {} +} +test util-13.63 {just over half ulp - 18 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 17ae0c186d8709 E+719 +408156062268363718_5000000000000000000& E+199 + } + -result {} +} +test util-13.64 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 152d02c7e14af7 E+76 +1_0000000000000000& E+23 + } + -result {} +} +test util-13.65 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -19d971e4fe8402 E+89 -1_0000000000000000& E+27 + } + -result {} +} +test util-13.66 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 19d971e4fe8402 E+90 +2_0000000000000000& E+27 + } + -result {} +} +test util-13.67 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -19d971e4fe8402 E+91 -4_0000000000000000& E+27 + } + -result {} +} +test util-13.68 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 15798ee2308c3a E-27 +1_0000000000000000& E-8 + } + -result {} +} +test util-13.69 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -15798ee2308c3a E-26 -2_0000000000000000& E-8 + } + -result {} +} +test util-13.70 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 15798ee2308c3a E-25 +4_0000000000000000& E-8 + } + -result {} +} +test util-13.71 {just over exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1ef2d0f5da7dd9 E-84 -1_0000000000000000& E-25 + } + -result {} +} +test util-13.72 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1a784379d99db4 E+78 +4_9999999999999999& E+23 + } + -result {} +} +test util-13.73 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1a784379d99db4 E+80 -1_9999999999999999& E+24 + } + -result {} +} +test util-13.74 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 13da329b633647 E+81 +2_9999999999999999& E+24 + } + -result {} +} +test util-13.75 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1cf389cd46047d E+85 -6_9999999999999999& E+25 + } + -result {} +} +test util-13.76 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 19999999999999 E-3 +1_99999999999999999& E-1 + } + -result {} +} +test util-13.77 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -13333333333333 E-2 -2_99999999999999999& E-1 + } + -result {} +} +test util-13.78 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 16849b86a12b9b E-48 +4_99999999999999999& E-15 + } + -result {} +} +test util-13.79 {just under exact - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -16849b86a12b9b E-46 -1_99999999999999999& E-14 + } + -result {} +} +test util-13.80 {just over exact - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 17ccfc73126788 E-71 +63_00000000000000000& E-23 + } + -result {} +} +test util-13.81 {just over exact - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1dc03b8fd7016a E-68 -63_00000000000000000& E-22 + } + -result {} +} +test util-13.82 {just under exact - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 13f7ced916872b E-5 +38_999999999999999999& E-3 + } + -result {} +} +test util-13.83 {just over exact - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1b297cad9f70b6 E+97 +269_000000000000000000& E+27 + } + -result {} +} +test util-13.84 {just over exact - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1b297cad9f70b6 E+98 -538_00000000000000000& E+27 + } + -result {} +} +test util-13.85 {just over exact - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1cdc06b20ef183 E-82 +373_00000000000000000& E-27 + } + -result {} +} +test util-13.86 {just over exact - 4 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1b297cad9f70b6 E+96 +1345_00000000000000000& E+26 + } + -result {} +} +# this one is not 4 digits, it is 3, and it is covered above. +test util-13.87 {just over exact - 4 digits} {*}{ + -constraints {testdoubledigits knownBadTest} + -body { + verdonk_test -1b297cad9f70b6 E+97 -2690_00000000000000000& E+26 + } + -result {} +} +test util-13.88 {just over exact - 5 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -150a246ecd44f3 E-63 -14257_00000000000000000& E-23 + } + -result {} +} +test util-13.89 {just under exact - 6 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -119b96f36ec68b E-19 -209900_999999999999999999& E-11 + } + -result {} +} +test util-13.90 {just over exact - 11 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1c06d366394441 E-35 +50980203373_000000000000000000& E-21 + } + -result {} +} +test util-13.91 {just under exact - 12 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1f58ac4db68c90 E+122 -104166211810_99999999999999999& E+26 + } + -result {} +} +test util-13.92 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 19d971e4fe8402 E+87 +2_5000000000000000& E+26 + } + -result {} +} +test util-13.93 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1dc74be914d16b E+81 -4_500000000000000& E+24 + } + -result {} +} +test util-13.94 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 14adf4b7320335 E+84 +2_500000000000000& E+25 + } + -result {} +} +test util-13.95 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1ae22487c1042b E+85 -6_5000000000000000& E+25 + } + -result {} +} +test util-13.96 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 187fe49aab41e0 E-54 +8_5000000000000000& E-17 + } + -result {} +} +test util-13.97 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1f5c05e4b23fd7 E-61 -8_5000000000000000& E-19 + } + -result {} +} +test util-13.98 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1faa7ab552a552 E-42 +4_5000000000000000& E-13 + } + -result {} +} +test util-13.99 {just over half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1b7cdfd9d7bdbb E-36 -2_5000000000000000& E-11 + } + -result {} +} +test util-13.100 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 13da329b633647 E+80 +1_4999999999999999& E+24 + } + -result {} +} +test util-13.101 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1cf389cd46047d E+84 -3_49999999999999999& E+25 + } + -result {} +} +test util-13.102 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1f04ef12cb04cf E+85 +7_4999999999999999& E+25 + } + -result {} +} +test util-13.103 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1f04ef12cb04cf E+86 -1_4999999999999999& E+26 + } + -result {} +} +test util-13.104 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 13333333333333 E-3 +1_49999999999999999& E-1 + } + -result {} +} +test util-13.105 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -107e1fe91b0b70 E-36 -1_49999999999999999& E-11 + } + -result {} +} +test util-13.106 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 149da7e361ce4c E-33 +1_49999999999999999& E-10 + } + -result {} +} +test util-13.107 {just under half ulp - 1 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -19c511dc3a41df E-30 -1_49999999999999999& E-9 + } + -result {} +} +test util-13.108 {just over half ulp - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1aa83d74267822 E+93 -16_5000000000000000& E+27 + } + -result {} +} +test util-13.109 {just over half ulp - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 18f1d5969453de E+89 +96_5000000000000000& E+25 + } + -result {} +} +test util-13.110 {just over half ulp - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 11d9bd564dcda6 E-70 +94_50000000000000000& E-23 + } + -result {} +} +test util-13.111 {just over half ulp - 2 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1a58973ecbede6 E-48 -58_50000000000000000& E-16 + } + -result {} +} +test util-13.112 {just over half ulp - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1b297cad9f70b6 E+95 +672_50000000000000000& E+26 + } + -result {} +} +test util-13.113 {just over half ulp - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -1b297cad9f70b6 E+96 -134_500000000000000000& E+27 + } + -result {} +} +test util-13.114 {just over half ulp - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1cdc06b20ef183 E-83 +186_50000000000000000& E-27 + } + -result {} +} +test util-13.115 {just over half ulp - 3 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -136071dcae4565 E-47 -860_50000000000000000& E-17 + } + -result {} +} +test util-13.116 {just over half ulp - 6 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1cb968d297dde8 E+99 +113788_50000000000000000& E+25 + } + -result {} +} +test util-13.117 {just over half ulp - 6 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test -11f3e1839eeab1 E+103 -113788_50000000000000000& E+26 + } + -result {} +} +test util-13.118 {just under half ulp - 9 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1e9cec176c96f8 E+117 +317903333_49999999999999999& E+27 + } + -result {} +} +test util-13.119 {just over half ulp - 11 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1c06d366394441 E-36 +25490101686_500000000000000000& E-21 + } + -result {} +} +test util-13.120 {just under half ulp - 11 digits} {*}{ + -constraints testdoubledigits + -body { + verdonk_test 1f58ac4db68c90 E+121 +52083105905_49999999999999999& E+26 + } + -result {} +} + +test util-14.1 {funky NaN} {*}{ + -constraints {ieeeFloatingPoint controversialNaN} + -body { + set ieeeValues(-NaN) + } + -result -NaN +} + +test util-14.2 {funky NaN} {*}{ + -constraints {ieeeFloatingPoint controversialNaN} + -body { + set ieeeValues(-NaN(3456789abcdef)) + } + -result -NaN(3456789abcdef) +} + +test util-15.1 {largest subnormal} {*}{ + -body { + binary scan [binary format w 0x000fffffffffffff] q x + set x + } + -result 2.225073858507201e-308 + -cleanup { + unset x + } +} + +test util-15.2 {largest subnormal} {*}{ + -body { + binary scan [binary format w 0x800fffffffffffff] q x + set x + } + -result -2.225073858507201e-308 + -cleanup { + unset x + } +} + +test util-15.3 {largest subnormal} {*}{ + -body { + binary scan [binary format q 2.225073858507201e-308] w x + format %#lx $x + } + -result 0xfffffffffffff + -cleanup { + unset x + } +} + +test util-15.4 {largest subnormal} {*}{ + -body { + binary scan [binary format q -2.225073858507201e-308] w x + format %#lx $x + } + -result 0x800fffffffffffff + -cleanup { + unset x + } +} + +test util-15.5 {smallest normal} {*}{ + -body { + binary scan [binary format w 0x0010000000000000] q x + set x + } + -result 2.2250738585072014e-308 + -cleanup { + unset x + } +} + +test util-15.6 {smallest normal} {*}{ + -body { + binary scan [binary format w 0x8010000000000000] q x + set x + } + -result -2.2250738585072014e-308 + -cleanup { + unset x + } +} + +test util-15.7 {smallest normal} {*}{ + -body { + binary scan [binary format q 2.2250738585072014e-308] w x + format %#lx $x + } + -result 0x10000000000000 + -cleanup { + unset x + } +} + +test util-15.8 {smallest normal} {*}{ + -body { + binary scan [binary format q -2.2250738585072014e-308] w x + format %#lx $x + } + -result 0x8010000000000000 + -cleanup { + unset x + } +} + +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} \ + "expr 1.1e$e" 1.1e$e + } +} +set tcl_precision 0 +for {set e -9} {$e < -4} {incr e} { + test util-16.1.$::tcl_precision.$e {shortening of numbers} \ + "expr 1.1e$e" 1.1e$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} \ + "expr 1.1e$e" 1.1e[format %+03d $e] +} +foreach ::tcl_precision {0 12} { + test util-16.1.$::tcl_precision.-4 {shortening of numbers} \ + {expr 1.1e-4} \ + 0.00011 + test util-16.1.$::tcl_precision.-3 {shortening of numbers} \ + {expr 1.1e-3} \ + 0.0011 + test util-16.1.$::tcl_precision.-2 {shortening of numbers} \ + {expr 1.1e-2} \ + 0.011 + test util-16.1.$::tcl_precision.-1 {shortening of numbers} \ + {expr 1.1e-1} \ + 0.11 + test util-16.1.$::tcl_precision.0 {shortening of numbers} \ + {expr 1.1} \ + 1.1 + for {set e 1} {$e < 17} {incr e} { + test util-16.1.$::tcl_precision.$e {shortening of numbers} \ + "expr 11[string repeat 0 [expr {$e-1}]].0" \ + 11[string repeat 0 [expr {$e-1}]].0 + } + for {set e 17} {$e < 309} {incr e} { + test util-16.1.$::tcl_precision.$e {shortening of numbers} \ + "expr 1.1e$e" 1.1e+$e + } +} +set tcl_precision 17 +test util-16.1.17.-300 {8.4 compatible formatting of doubles} \ + {expr 1e-300} \ + 1e-300 +test util-16.1.17.-299 {8.4 compatible formatting of doubles} \ + {expr 1e-299} \ + 9.9999999999999999e-300 +test util-16.1.17.-298 {8.4 compatible formatting of doubles} \ + {expr 1e-298} \ + 9.9999999999999991e-299 +test util-16.1.17.-297 {8.4 compatible formatting of doubles} \ + {expr 1e-297} \ + 1e-297 +test util-16.1.17.-296 {8.4 compatible formatting of doubles} \ + {expr 1e-296} \ + 1e-296 +test util-16.1.17.-295 {8.4 compatible formatting of doubles} \ + {expr 1e-295} \ + 1.0000000000000001e-295 +test util-16.1.17.-294 {8.4 compatible formatting of doubles} \ + {expr 1e-294} \ + 1e-294 +test util-16.1.17.-293 {8.4 compatible formatting of doubles} \ + {expr 1e-293} \ + 1.0000000000000001e-293 +test util-16.1.17.-292 {8.4 compatible formatting of doubles} \ + {expr 1e-292} \ + 1.0000000000000001e-292 +test util-16.1.17.-291 {8.4 compatible formatting of doubles} \ + {expr 1e-291} \ + 9.9999999999999996e-292 +test util-16.1.17.-290 {8.4 compatible formatting of doubles} \ + {expr 1e-290} \ + 1.0000000000000001e-290 +test util-16.1.17.-289 {8.4 compatible formatting of doubles} \ + {expr 1e-289} \ + 1e-289 +test util-16.1.17.-288 {8.4 compatible formatting of doubles} \ + {expr 1e-288} \ + 1.0000000000000001e-288 +test util-16.1.17.-287 {8.4 compatible formatting of doubles} \ + {expr 1e-287} \ + 1e-287 +test util-16.1.17.-286 {8.4 compatible formatting of doubles} \ + {expr 1e-286} \ + 1.0000000000000001e-286 +test util-16.1.17.-285 {8.4 compatible formatting of doubles} \ + {expr 1e-285} \ + 1.0000000000000001e-285 +test util-16.1.17.-284 {8.4 compatible formatting of doubles} \ + {expr 1e-284} \ + 1e-284 +test util-16.1.17.-283 {8.4 compatible formatting of doubles} \ + {expr 1e-283} \ + 9.9999999999999995e-284 +test util-16.1.17.-282 {8.4 compatible formatting of doubles} \ + {expr 1e-282} \ + 1e-282 +test util-16.1.17.-281 {8.4 compatible formatting of doubles} \ + {expr 1e-281} \ + 1e-281 +test util-16.1.17.-280 {8.4 compatible formatting of doubles} \ + {expr 1e-280} \ + 9.9999999999999996e-281 +test util-16.1.17.-279 {8.4 compatible formatting of doubles} \ + {expr 1e-279} \ + 1.0000000000000001e-279 +test util-16.1.17.-278 {8.4 compatible formatting of doubles} \ + {expr 1e-278} \ + 9.9999999999999994e-279 +test util-16.1.17.-277 {8.4 compatible formatting of doubles} \ + {expr 1e-277} \ + 9.9999999999999997e-278 +test util-16.1.17.-276 {8.4 compatible formatting of doubles} \ + {expr 1e-276} \ + 1.0000000000000001e-276 +test util-16.1.17.-275 {8.4 compatible formatting of doubles} \ + {expr 1e-275} \ + 9.9999999999999993e-276 +test util-16.1.17.-274 {8.4 compatible formatting of doubles} \ + {expr 1e-274} \ + 9.9999999999999997e-275 +test util-16.1.17.-273 {8.4 compatible formatting of doubles} \ + {expr 1e-273} \ + 1.0000000000000001e-273 +test util-16.1.17.-272 {8.4 compatible formatting of doubles} \ + {expr 1e-272} \ + 9.9999999999999993e-273 +test util-16.1.17.-271 {8.4 compatible formatting of doubles} \ + {expr 1e-271} \ + 9.9999999999999996e-272 +test util-16.1.17.-270 {8.4 compatible formatting of doubles} \ + {expr 1e-270} \ + 1e-270 +test util-16.1.17.-269 {8.4 compatible formatting of doubles} \ + {expr 1e-269} \ + 9.9999999999999996e-270 +test util-16.1.17.-268 {8.4 compatible formatting of doubles} \ + {expr 1e-268} \ + 9.9999999999999996e-269 +test util-16.1.17.-267 {8.4 compatible formatting of doubles} \ + {expr 1e-267} \ + 9.9999999999999998e-268 +test util-16.1.17.-266 {8.4 compatible formatting of doubles} \ + {expr 1e-266} \ + 9.9999999999999998e-267 +test util-16.1.17.-265 {8.4 compatible formatting of doubles} \ + {expr 1e-265} \ + 9.9999999999999998e-266 +test util-16.1.17.-264 {8.4 compatible formatting of doubles} \ + {expr 1e-264} \ + 1e-264 +test util-16.1.17.-263 {8.4 compatible formatting of doubles} \ + {expr 1e-263} \ + 1e-263 +test util-16.1.17.-262 {8.4 compatible formatting of doubles} \ + {expr 1e-262} \ + 1e-262 +test util-16.1.17.-261 {8.4 compatible formatting of doubles} \ + {expr 1e-261} \ + 9.9999999999999998e-262 +test util-16.1.17.-260 {8.4 compatible formatting of doubles} \ + {expr 1e-260} \ + 9.9999999999999996e-261 +test util-16.1.17.-259 {8.4 compatible formatting of doubles} \ + {expr 1e-259} \ + 1.0000000000000001e-259 +test util-16.1.17.-258 {8.4 compatible formatting of doubles} \ + {expr 1e-258} \ + 9.9999999999999995e-259 +test util-16.1.17.-257 {8.4 compatible formatting of doubles} \ + {expr 1e-257} \ + 9.9999999999999998e-258 +test util-16.1.17.-256 {8.4 compatible formatting of doubles} \ + {expr 1e-256} \ + 9.9999999999999998e-257 +test util-16.1.17.-255 {8.4 compatible formatting of doubles} \ + {expr 1e-255} \ + 1e-255 +test util-16.1.17.-254 {8.4 compatible formatting of doubles} \ + {expr 1e-254} \ + 9.9999999999999991e-255 +test util-16.1.17.-253 {8.4 compatible formatting of doubles} \ + {expr 1e-253} \ + 1.0000000000000001e-253 +test util-16.1.17.-252 {8.4 compatible formatting of doubles} \ + {expr 1e-252} \ + 9.9999999999999994e-253 +test util-16.1.17.-251 {8.4 compatible formatting of doubles} \ + {expr 1e-251} \ + 1e-251 +test util-16.1.17.-250 {8.4 compatible formatting of doubles} \ + {expr 1e-250} \ + 1.0000000000000001e-250 +test util-16.1.17.-249 {8.4 compatible formatting of doubles} \ + {expr 1e-249} \ + 1.0000000000000001e-249 +test util-16.1.17.-248 {8.4 compatible formatting of doubles} \ + {expr 1e-248} \ + 9.9999999999999998e-249 +test util-16.1.17.-247 {8.4 compatible formatting of doubles} \ + {expr 1e-247} \ + 1e-247 +test util-16.1.17.-246 {8.4 compatible formatting of doubles} \ + {expr 1e-246} \ + 9.9999999999999996e-247 +test util-16.1.17.-245 {8.4 compatible formatting of doubles} \ + {expr 1e-245} \ + 9.9999999999999993e-246 +test util-16.1.17.-244 {8.4 compatible formatting of doubles} \ + {expr 1e-244} \ + 9.9999999999999993e-245 +test util-16.1.17.-243 {8.4 compatible formatting of doubles} \ + {expr 1e-243} \ + 1e-243 +test util-16.1.17.-242 {8.4 compatible formatting of doubles} \ + {expr 1e-242} \ + 9.9999999999999997e-243 +test util-16.1.17.-241 {8.4 compatible formatting of doubles} \ + {expr 1e-241} \ + 9.9999999999999997e-242 +test util-16.1.17.-240 {8.4 compatible formatting of doubles} \ + {expr 1e-240} \ + 9.9999999999999997e-241 +test util-16.1.17.-239 {8.4 compatible formatting of doubles} \ + {expr 1e-239} \ + 1.0000000000000001e-239 +test util-16.1.17.-238 {8.4 compatible formatting of doubles} \ + {expr 1e-238} \ + 9.9999999999999999e-239 +test util-16.1.17.-237 {8.4 compatible formatting of doubles} \ + {expr 1e-237} \ + 9.9999999999999999e-238 +test util-16.1.17.-236 {8.4 compatible formatting of doubles} \ + {expr 1e-236} \ + 1e-236 +test util-16.1.17.-235 {8.4 compatible formatting of doubles} \ + {expr 1e-235} \ + 9.9999999999999996e-236 +test util-16.1.17.-234 {8.4 compatible formatting of doubles} \ + {expr 1e-234} \ + 9.9999999999999996e-235 +test util-16.1.17.-233 {8.4 compatible formatting of doubles} \ + {expr 1e-233} \ + 9.9999999999999996e-234 +test util-16.1.17.-232 {8.4 compatible formatting of doubles} \ + {expr 1e-232} \ + 1e-232 +test util-16.1.17.-231 {8.4 compatible formatting of doubles} \ + {expr 1e-231} \ + 9.9999999999999999e-232 +test util-16.1.17.-230 {8.4 compatible formatting of doubles} \ + {expr 1e-230} \ + 1e-230 +test util-16.1.17.-229 {8.4 compatible formatting of doubles} \ + {expr 1e-229} \ + 1.0000000000000001e-229 +test util-16.1.17.-228 {8.4 compatible formatting of doubles} \ + {expr 1e-228} \ + 1e-228 +test util-16.1.17.-227 {8.4 compatible formatting of doubles} \ + {expr 1e-227} \ + 9.9999999999999994e-228 +test util-16.1.17.-226 {8.4 compatible formatting of doubles} \ + {expr 1e-226} \ + 9.9999999999999992e-227 +test util-16.1.17.-225 {8.4 compatible formatting of doubles} \ + {expr 1e-225} \ + 9.9999999999999996e-226 +test util-16.1.17.-224 {8.4 compatible formatting of doubles} \ + {expr 1e-224} \ + 1e-224 +test util-16.1.17.-223 {8.4 compatible formatting of doubles} \ + {expr 1e-223} \ + 9.9999999999999997e-224 +test util-16.1.17.-222 {8.4 compatible formatting of doubles} \ + {expr 1e-222} \ + 1e-222 +test util-16.1.17.-221 {8.4 compatible formatting of doubles} \ + {expr 1e-221} \ + 1e-221 +test util-16.1.17.-220 {8.4 compatible formatting of doubles} \ + {expr 1e-220} \ + 9.9999999999999999e-221 +test util-16.1.17.-219 {8.4 compatible formatting of doubles} \ + {expr 1e-219} \ + 1e-219 +test util-16.1.17.-218 {8.4 compatible formatting of doubles} \ + {expr 1e-218} \ + 1e-218 +test util-16.1.17.-217 {8.4 compatible formatting of doubles} \ + {expr 1e-217} \ + 1.0000000000000001e-217 +test util-16.1.17.-216 {8.4 compatible formatting of doubles} \ + {expr 1e-216} \ + 1e-216 +test util-16.1.17.-215 {8.4 compatible formatting of doubles} \ + {expr 1e-215} \ + 1e-215 +test util-16.1.17.-214 {8.4 compatible formatting of doubles} \ + {expr 1e-214} \ + 9.9999999999999991e-215 +test util-16.1.17.-213 {8.4 compatible formatting of doubles} \ + {expr 1e-213} \ + 9.9999999999999995e-214 +test util-16.1.17.-212 {8.4 compatible formatting of doubles} \ + {expr 1e-212} \ + 9.9999999999999995e-213 +test util-16.1.17.-211 {8.4 compatible formatting of doubles} \ + {expr 1e-211} \ + 1.0000000000000001e-211 +test util-16.1.17.-210 {8.4 compatible formatting of doubles} \ + {expr 1e-210} \ + 1e-210 +test util-16.1.17.-209 {8.4 compatible formatting of doubles} \ + {expr 1e-209} \ + 1e-209 +test util-16.1.17.-208 {8.4 compatible formatting of doubles} \ + {expr 1e-208} \ + 1.0000000000000001e-208 +test util-16.1.17.-207 {8.4 compatible formatting of doubles} \ + {expr 1e-207} \ + 9.9999999999999993e-208 +test util-16.1.17.-206 {8.4 compatible formatting of doubles} \ + {expr 1e-206} \ + 1e-206 +test util-16.1.17.-205 {8.4 compatible formatting of doubles} \ + {expr 1e-205} \ + 1e-205 +test util-16.1.17.-204 {8.4 compatible formatting of doubles} \ + {expr 1e-204} \ + 1e-204 +test util-16.1.17.-203 {8.4 compatible formatting of doubles} \ + {expr 1e-203} \ + 1e-203 +test util-16.1.17.-202 {8.4 compatible formatting of doubles} \ + {expr 1e-202} \ + 1e-202 +test util-16.1.17.-201 {8.4 compatible formatting of doubles} \ + {expr 1e-201} \ + 9.9999999999999995e-202 +test util-16.1.17.-200 {8.4 compatible formatting of doubles} \ + {expr 1e-200} \ + 9.9999999999999998e-201 +test util-16.1.17.-199 {8.4 compatible formatting of doubles} \ + {expr 1e-199} \ + 9.9999999999999998e-200 +test util-16.1.17.-198 {8.4 compatible formatting of doubles} \ + {expr 1e-198} \ + 9.9999999999999991e-199 +test util-16.1.17.-197 {8.4 compatible formatting of doubles} \ + {expr 1e-197} \ + 9.9999999999999999e-198 +test util-16.1.17.-196 {8.4 compatible formatting of doubles} \ + {expr 1e-196} \ + 1e-196 +test util-16.1.17.-195 {8.4 compatible formatting of doubles} \ + {expr 1e-195} \ + 1.0000000000000001e-195 +test util-16.1.17.-194 {8.4 compatible formatting of doubles} \ + {expr 1e-194} \ + 1e-194 +test util-16.1.17.-193 {8.4 compatible formatting of doubles} \ + {expr 1e-193} \ + 1e-193 +test util-16.1.17.-192 {8.4 compatible formatting of doubles} \ + {expr 1e-192} \ + 1.0000000000000001e-192 +test util-16.1.17.-191 {8.4 compatible formatting of doubles} \ + {expr 1e-191} \ + 1e-191 +test util-16.1.17.-190 {8.4 compatible formatting of doubles} \ + {expr 1e-190} \ + 1e-190 +test util-16.1.17.-189 {8.4 compatible formatting of doubles} \ + {expr 1e-189} \ + 1.0000000000000001e-189 +test util-16.1.17.-188 {8.4 compatible formatting of doubles} \ + {expr 1e-188} \ + 9.9999999999999995e-189 +test util-16.1.17.-187 {8.4 compatible formatting of doubles} \ + {expr 1e-187} \ + 1e-187 +test util-16.1.17.-186 {8.4 compatible formatting of doubles} \ + {expr 1e-186} \ + 9.9999999999999991e-187 +test util-16.1.17.-185 {8.4 compatible formatting of doubles} \ + {expr 1e-185} \ + 9.9999999999999999e-186 +test util-16.1.17.-184 {8.4 compatible formatting of doubles} \ + {expr 1e-184} \ + 1.0000000000000001e-184 +test util-16.1.17.-183 {8.4 compatible formatting of doubles} \ + {expr 1e-183} \ + 1e-183 +test util-16.1.17.-182 {8.4 compatible formatting of doubles} \ + {expr 1e-182} \ + 1e-182 +test util-16.1.17.-181 {8.4 compatible formatting of doubles} \ + {expr 1e-181} \ + 1e-181 +test util-16.1.17.-180 {8.4 compatible formatting of doubles} \ + {expr 1e-180} \ + 1e-180 +test util-16.1.17.-179 {8.4 compatible formatting of doubles} \ + {expr 1e-179} \ + 1e-179 +test util-16.1.17.-178 {8.4 compatible formatting of doubles} \ + {expr 1e-178} \ + 9.9999999999999995e-179 +test util-16.1.17.-177 {8.4 compatible formatting of doubles} \ + {expr 1e-177} \ + 9.9999999999999995e-178 +test util-16.1.17.-176 {8.4 compatible formatting of doubles} \ + {expr 1e-176} \ + 1e-176 +test util-16.1.17.-175 {8.4 compatible formatting of doubles} \ + {expr 1e-175} \ + 1e-175 +test util-16.1.17.-174 {8.4 compatible formatting of doubles} \ + {expr 1e-174} \ + 1e-174 +test util-16.1.17.-173 {8.4 compatible formatting of doubles} \ + {expr 1e-173} \ + 1e-173 +test util-16.1.17.-172 {8.4 compatible formatting of doubles} \ + {expr 1e-172} \ + 1e-172 +test util-16.1.17.-171 {8.4 compatible formatting of doubles} \ + {expr 1e-171} \ + 9.9999999999999998e-172 +test util-16.1.17.-170 {8.4 compatible formatting of doubles} \ + {expr 1e-170} \ + 9.9999999999999998e-171 +test util-16.1.17.-169 {8.4 compatible formatting of doubles} \ + {expr 1e-169} \ + 1e-169 +test util-16.1.17.-168 {8.4 compatible formatting of doubles} \ + {expr 1e-168} \ + 1e-168 +test util-16.1.17.-167 {8.4 compatible formatting of doubles} \ + {expr 1e-167} \ + 1e-167 +test util-16.1.17.-166 {8.4 compatible formatting of doubles} \ + {expr 1e-166} \ + 1e-166 +test util-16.1.17.-165 {8.4 compatible formatting of doubles} \ + {expr 1e-165} \ + 1e-165 +test util-16.1.17.-164 {8.4 compatible formatting of doubles} \ + {expr 1e-164} \ + 9.9999999999999996e-165 +test util-16.1.17.-163 {8.4 compatible formatting of doubles} \ + {expr 1e-163} \ + 9.9999999999999992e-164 +test util-16.1.17.-162 {8.4 compatible formatting of doubles} \ + {expr 1e-162} \ + 9.9999999999999995e-163 +test util-16.1.17.-161 {8.4 compatible formatting of doubles} \ + {expr 1e-161} \ + 1e-161 +test util-16.1.17.-160 {8.4 compatible formatting of doubles} \ + {expr 1e-160} \ + 9.9999999999999999e-161 +test util-16.1.17.-159 {8.4 compatible formatting of doubles} \ + {expr 1e-159} \ + 9.9999999999999999e-160 +test util-16.1.17.-158 {8.4 compatible formatting of doubles} \ + {expr 1e-158} \ + 1.0000000000000001e-158 +test util-16.1.17.-157 {8.4 compatible formatting of doubles} \ + {expr 1e-157} \ + 9.9999999999999994e-158 +test util-16.1.17.-156 {8.4 compatible formatting of doubles} \ + {expr 1e-156} \ + 1e-156 +test util-16.1.17.-155 {8.4 compatible formatting of doubles} \ + {expr 1e-155} \ + 1e-155 +test util-16.1.17.-154 {8.4 compatible formatting of doubles} \ + {expr 1e-154} \ + 9.9999999999999997e-155 +test util-16.1.17.-153 {8.4 compatible formatting of doubles} \ + {expr 1e-153} \ + 1e-153 +test util-16.1.17.-152 {8.4 compatible formatting of doubles} \ + {expr 1e-152} \ + 1.0000000000000001e-152 +test util-16.1.17.-151 {8.4 compatible formatting of doubles} \ + {expr 1e-151} \ + 9.9999999999999994e-152 +test util-16.1.17.-150 {8.4 compatible formatting of doubles} \ + {expr 1e-150} \ + 1e-150 +test util-16.1.17.-149 {8.4 compatible formatting of doubles} \ + {expr 1e-149} \ + 9.9999999999999998e-150 +test util-16.1.17.-148 {8.4 compatible formatting of doubles} \ + {expr 1e-148} \ + 9.9999999999999994e-149 +test util-16.1.17.-147 {8.4 compatible formatting of doubles} \ + {expr 1e-147} \ + 9.9999999999999997e-148 +test util-16.1.17.-146 {8.4 compatible formatting of doubles} \ + {expr 1e-146} \ + 1e-146 +test util-16.1.17.-145 {8.4 compatible formatting of doubles} \ + {expr 1e-145} \ + 9.9999999999999991e-146 +test util-16.1.17.-144 {8.4 compatible formatting of doubles} \ + {expr 1e-144} \ + 9.9999999999999995e-145 +test util-16.1.17.-143 {8.4 compatible formatting of doubles} \ + {expr 1e-143} \ + 9.9999999999999995e-144 +test util-16.1.17.-142 {8.4 compatible formatting of doubles} \ + {expr 1e-142} \ + 1e-142 +test util-16.1.17.-141 {8.4 compatible formatting of doubles} \ + {expr 1e-141} \ + 1e-141 +test util-16.1.17.-140 {8.4 compatible formatting of doubles} \ + {expr 1e-140} \ + 9.9999999999999998e-141 +test util-16.1.17.-139 {8.4 compatible formatting of doubles} \ + {expr 1e-139} \ + 1e-139 +test util-16.1.17.-138 {8.4 compatible formatting of doubles} \ + {expr 1e-138} \ + 1.0000000000000001e-138 +test util-16.1.17.-137 {8.4 compatible formatting of doubles} \ + {expr 1e-137} \ + 9.9999999999999998e-138 +test util-16.1.17.-136 {8.4 compatible formatting of doubles} \ + {expr 1e-136} \ + 1e-136 +test util-16.1.17.-135 {8.4 compatible formatting of doubles} \ + {expr 1e-135} \ + 1e-135 +test util-16.1.17.-134 {8.4 compatible formatting of doubles} \ + {expr 1e-134} \ + 1e-134 +test util-16.1.17.-133 {8.4 compatible formatting of doubles} \ + {expr 1e-133} \ + 1.0000000000000001e-133 +test util-16.1.17.-132 {8.4 compatible formatting of doubles} \ + {expr 1e-132} \ + 9.9999999999999999e-133 +test util-16.1.17.-131 {8.4 compatible formatting of doubles} \ + {expr 1e-131} \ + 9.9999999999999999e-132 +test util-16.1.17.-130 {8.4 compatible formatting of doubles} \ + {expr 1e-130} \ + 1.0000000000000001e-130 +test util-16.1.17.-129 {8.4 compatible formatting of doubles} \ + {expr 1e-129} \ + 9.9999999999999993e-130 +test util-16.1.17.-128 {8.4 compatible formatting of doubles} \ + {expr 1e-128} \ + 1.0000000000000001e-128 +test util-16.1.17.-127 {8.4 compatible formatting of doubles} \ + {expr 1e-127} \ + 1e-127 +test util-16.1.17.-126 {8.4 compatible formatting of doubles} \ + {expr 1e-126} \ + 9.9999999999999995e-127 +test util-16.1.17.-125 {8.4 compatible formatting of doubles} \ + {expr 1e-125} \ + 1e-125 +test util-16.1.17.-124 {8.4 compatible formatting of doubles} \ + {expr 1e-124} \ + 9.9999999999999993e-125 +test util-16.1.17.-123 {8.4 compatible formatting of doubles} \ + {expr 1e-123} \ + 1.0000000000000001e-123 +test util-16.1.17.-122 {8.4 compatible formatting of doubles} \ + {expr 1e-122} \ + 1.0000000000000001e-122 +test util-16.1.17.-121 {8.4 compatible formatting of doubles} \ + {expr 1e-121} \ + 9.9999999999999998e-122 +test util-16.1.17.-120 {8.4 compatible formatting of doubles} \ + {expr 1e-120} \ + 9.9999999999999998e-121 +test util-16.1.17.-119 {8.4 compatible formatting of doubles} \ + {expr 1e-119} \ + 1e-119 +test util-16.1.17.-118 {8.4 compatible formatting of doubles} \ + {expr 1e-118} \ + 9.9999999999999999e-119 +test util-16.1.17.-117 {8.4 compatible formatting of doubles} \ + {expr 1e-117} \ + 1e-117 +test util-16.1.17.-116 {8.4 compatible formatting of doubles} \ + {expr 1e-116} \ + 9.9999999999999999e-117 +test util-16.1.17.-115 {8.4 compatible formatting of doubles} \ + {expr 1e-115} \ + 1.0000000000000001e-115 +test util-16.1.17.-114 {8.4 compatible formatting of doubles} \ + {expr 1e-114} \ + 1.0000000000000001e-114 +test util-16.1.17.-113 {8.4 compatible formatting of doubles} \ + {expr 1e-113} \ + 9.9999999999999998e-114 +test util-16.1.17.-112 {8.4 compatible formatting of doubles} \ + {expr 1e-112} \ + 9.9999999999999995e-113 +test util-16.1.17.-111 {8.4 compatible formatting of doubles} \ + {expr 1e-111} \ + 1.0000000000000001e-111 +test util-16.1.17.-110 {8.4 compatible formatting of doubles} \ + {expr 1e-110} \ + 1.0000000000000001e-110 +test util-16.1.17.-109 {8.4 compatible formatting of doubles} \ + {expr 1e-109} \ + 9.9999999999999999e-110 +test util-16.1.17.-108 {8.4 compatible formatting of doubles} \ + {expr 1e-108} \ + 1e-108 +test util-16.1.17.-107 {8.4 compatible formatting of doubles} \ + {expr 1e-107} \ + 1e-107 +test util-16.1.17.-106 {8.4 compatible formatting of doubles} \ + {expr 1e-106} \ + 9.9999999999999994e-107 +test util-16.1.17.-105 {8.4 compatible formatting of doubles} \ + {expr 1e-105} \ + 9.9999999999999997e-106 +test util-16.1.17.-104 {8.4 compatible formatting of doubles} \ + {expr 1e-104} \ + 9.9999999999999993e-105 +test util-16.1.17.-103 {8.4 compatible formatting of doubles} \ + {expr 1e-103} \ + 9.9999999999999996e-104 +test util-16.1.17.-102 {8.4 compatible formatting of doubles} \ + {expr 1e-102} \ + 9.9999999999999993e-103 +test util-16.1.17.-101 {8.4 compatible formatting of doubles} \ + {expr 1e-101} \ + 1.0000000000000001e-101 +test util-16.1.17.-100 {8.4 compatible formatting of doubles} \ + {expr 1e-100} \ + 1e-100 +test util-16.1.17.-99 {8.4 compatible formatting of doubles} \ + {expr 1e-99} \ + 1e-99 +test util-16.1.17.-98 {8.4 compatible formatting of doubles} \ + {expr 1e-98} \ + 9.9999999999999994e-99 +test util-16.1.17.-97 {8.4 compatible formatting of doubles} \ + {expr 1e-97} \ + 1e-97 +test util-16.1.17.-96 {8.4 compatible formatting of doubles} \ + {expr 1e-96} \ + 9.9999999999999991e-97 +test util-16.1.17.-95 {8.4 compatible formatting of doubles} \ + {expr 1e-95} \ + 9.9999999999999999e-96 +test util-16.1.17.-94 {8.4 compatible formatting of doubles} \ + {expr 1e-94} \ + 9.9999999999999996e-95 +test util-16.1.17.-93 {8.4 compatible formatting of doubles} \ + {expr 1e-93} \ + 9.999999999999999e-94 +test util-16.1.17.-92 {8.4 compatible formatting of doubles} \ + {expr 1e-92} \ + 9.9999999999999999e-93 +test util-16.1.17.-91 {8.4 compatible formatting of doubles} \ + {expr 1e-91} \ + 1e-91 +test util-16.1.17.-90 {8.4 compatible formatting of doubles} \ + {expr 1e-90} \ + 9.9999999999999999e-91 +test util-16.1.17.-89 {8.4 compatible formatting of doubles} \ + {expr 1e-89} \ + 1e-89 +test util-16.1.17.-88 {8.4 compatible formatting of doubles} \ + {expr 1e-88} \ + 9.9999999999999993e-89 +test util-16.1.17.-87 {8.4 compatible formatting of doubles} \ + {expr 1e-87} \ + 1e-87 +test util-16.1.17.-86 {8.4 compatible formatting of doubles} \ + {expr 1e-86} \ + 1.0000000000000001e-86 +test util-16.1.17.-85 {8.4 compatible formatting of doubles} \ + {expr 1e-85} \ + 9.9999999999999998e-86 +test util-16.1.17.-84 {8.4 compatible formatting of doubles} \ + {expr 1e-84} \ + 1e-84 +test util-16.1.17.-83 {8.4 compatible formatting of doubles} \ + {expr 1e-83} \ + 1e-83 +test util-16.1.17.-82 {8.4 compatible formatting of doubles} \ + {expr 1e-82} \ + 9.9999999999999996e-83 +test util-16.1.17.-81 {8.4 compatible formatting of doubles} \ + {expr 1e-81} \ + 9.9999999999999996e-82 +test util-16.1.17.-80 {8.4 compatible formatting of doubles} \ + {expr 1e-80} \ + 9.9999999999999996e-81 +test util-16.1.17.-79 {8.4 compatible formatting of doubles} \ + {expr 1e-79} \ + 1e-79 +test util-16.1.17.-78 {8.4 compatible formatting of doubles} \ + {expr 1e-78} \ + 1e-78 +test util-16.1.17.-77 {8.4 compatible formatting of doubles} \ + {expr 1e-77} \ + 9.9999999999999993e-78 +test util-16.1.17.-76 {8.4 compatible formatting of doubles} \ + {expr 1e-76} \ + 9.9999999999999993e-77 +test util-16.1.17.-75 {8.4 compatible formatting of doubles} \ + {expr 1e-75} \ + 9.9999999999999996e-76 +test util-16.1.17.-74 {8.4 compatible formatting of doubles} \ + {expr 1e-74} \ + 9.9999999999999996e-75 +test util-16.1.17.-73 {8.4 compatible formatting of doubles} \ + {expr 1e-73} \ + 1e-73 +test util-16.1.17.-72 {8.4 compatible formatting of doubles} \ + {expr 1e-72} \ + 9.9999999999999997e-73 +test util-16.1.17.-71 {8.4 compatible formatting of doubles} \ + {expr 1e-71} \ + 9.9999999999999992e-72 +test util-16.1.17.-70 {8.4 compatible formatting of doubles} \ + {expr 1e-70} \ + 1e-70 +test util-16.1.17.-69 {8.4 compatible formatting of doubles} \ + {expr 1e-69} \ + 9.9999999999999996e-70 +test util-16.1.17.-68 {8.4 compatible formatting of doubles} \ + {expr 1e-68} \ + 1.0000000000000001e-68 +test util-16.1.17.-67 {8.4 compatible formatting of doubles} \ + {expr 1e-67} \ + 9.9999999999999994e-68 +test util-16.1.17.-66 {8.4 compatible formatting of doubles} \ + {expr 1e-66} \ + 9.9999999999999998e-67 +test util-16.1.17.-65 {8.4 compatible formatting of doubles} \ + {expr 1e-65} \ + 9.9999999999999992e-66 +test util-16.1.17.-64 {8.4 compatible formatting of doubles} \ + {expr 1e-64} \ + 9.9999999999999997e-65 +test util-16.1.17.-63 {8.4 compatible formatting of doubles} \ + {expr 1e-63} \ + 1.0000000000000001e-63 +test util-16.1.17.-62 {8.4 compatible formatting of doubles} \ + {expr 1e-62} \ + 1e-62 +test util-16.1.17.-61 {8.4 compatible formatting of doubles} \ + {expr 1e-61} \ + 1e-61 +test util-16.1.17.-60 {8.4 compatible formatting of doubles} \ + {expr 1e-60} \ + 9.9999999999999997e-61 +test util-16.1.17.-59 {8.4 compatible formatting of doubles} \ + {expr 1e-59} \ + 1e-59 +test util-16.1.17.-58 {8.4 compatible formatting of doubles} \ + {expr 1e-58} \ + 1e-58 +test util-16.1.17.-57 {8.4 compatible formatting of doubles} \ + {expr 1e-57} \ + 9.9999999999999995e-58 +test util-16.1.17.-56 {8.4 compatible formatting of doubles} \ + {expr 1e-56} \ + 1e-56 +test util-16.1.17.-55 {8.4 compatible formatting of doubles} \ + {expr 1e-55} \ + 9.9999999999999999e-56 +test util-16.1.17.-54 {8.4 compatible formatting of doubles} \ + {expr 1e-54} \ + 1e-54 +test util-16.1.17.-53 {8.4 compatible formatting of doubles} \ + {expr 1e-53} \ + 1e-53 +test util-16.1.17.-52 {8.4 compatible formatting of doubles} \ + {expr 1e-52} \ + 1e-52 +test util-16.1.17.-51 {8.4 compatible formatting of doubles} \ + {expr 1e-51} \ + 1e-51 +test util-16.1.17.-50 {8.4 compatible formatting of doubles} \ + {expr 1e-50} \ + 1e-50 +test util-16.1.17.-49 {8.4 compatible formatting of doubles} \ + {expr 1e-49} \ + 9.9999999999999994e-50 +test util-16.1.17.-48 {8.4 compatible formatting of doubles} \ + {expr 1e-48} \ + 9.9999999999999997e-49 +test util-16.1.17.-47 {8.4 compatible formatting of doubles} \ + {expr 1e-47} \ + 9.9999999999999997e-48 +test util-16.1.17.-46 {8.4 compatible formatting of doubles} \ + {expr 1e-46} \ + 1e-46 +test util-16.1.17.-45 {8.4 compatible formatting of doubles} \ + {expr 1e-45} \ + 9.9999999999999998e-46 +test util-16.1.17.-44 {8.4 compatible formatting of doubles} \ + {expr 1e-44} \ + 9.9999999999999995e-45 +test util-16.1.17.-43 {8.4 compatible formatting of doubles} \ + {expr 1e-43} \ + 1.0000000000000001e-43 +test util-16.1.17.-42 {8.4 compatible formatting of doubles} \ + {expr 1e-42} \ + 1e-42 +test util-16.1.17.-41 {8.4 compatible formatting of doubles} \ + {expr 1e-41} \ + 1e-41 +test util-16.1.17.-40 {8.4 compatible formatting of doubles} \ + {expr 1e-40} \ + 9.9999999999999993e-41 +test util-16.1.17.-39 {8.4 compatible formatting of doubles} \ + {expr 1e-39} \ + 9.9999999999999993e-40 +test util-16.1.17.-38 {8.4 compatible formatting of doubles} \ + {expr 1e-38} \ + 9.9999999999999996e-39 +test util-16.1.17.-37 {8.4 compatible formatting of doubles} \ + {expr 1e-37} \ + 1.0000000000000001e-37 +test util-16.1.17.-36 {8.4 compatible formatting of doubles} \ + {expr 1e-36} \ + 9.9999999999999994e-37 +test util-16.1.17.-35 {8.4 compatible formatting of doubles} \ + {expr 1e-35} \ + 1e-35 +test util-16.1.17.-34 {8.4 compatible formatting of doubles} \ + {expr 1e-34} \ + 9.9999999999999993e-35 +test util-16.1.17.-33 {8.4 compatible formatting of doubles} \ + {expr 1e-33} \ + 1.0000000000000001e-33 +test util-16.1.17.-32 {8.4 compatible formatting of doubles} \ + {expr 1e-32} \ + 1.0000000000000001e-32 +test util-16.1.17.-31 {8.4 compatible formatting of doubles} \ + {expr 1e-31} \ + 1.0000000000000001e-31 +test util-16.1.17.-30 {8.4 compatible formatting of doubles} \ + {expr 1e-30} \ + 1.0000000000000001e-30 +test util-16.1.17.-29 {8.4 compatible formatting of doubles} \ + {expr 1e-29} \ + 9.9999999999999994e-30 +test util-16.1.17.-28 {8.4 compatible formatting of doubles} \ + {expr 1e-28} \ + 9.9999999999999997e-29 +test util-16.1.17.-27 {8.4 compatible formatting of doubles} \ + {expr 1e-27} \ + 1e-27 +test util-16.1.17.-26 {8.4 compatible formatting of doubles} \ + {expr 1e-26} \ + 1e-26 +test util-16.1.17.-25 {8.4 compatible formatting of doubles} \ + {expr 1e-25} \ + 1e-25 +test util-16.1.17.-24 {8.4 compatible formatting of doubles} \ + {expr 1e-24} \ + 9.9999999999999992e-25 +test util-16.1.17.-23 {8.4 compatible formatting of doubles} \ + {expr 1e-23} \ + 9.9999999999999996e-24 +test util-16.1.17.-22 {8.4 compatible formatting of doubles} \ + {expr 1e-22} \ + 1e-22 +test util-16.1.17.-21 {8.4 compatible formatting of doubles} \ + {expr 1e-21} \ + 9.9999999999999991e-22 +test util-16.1.17.-20 {8.4 compatible formatting of doubles} \ + {expr 1e-20} \ + 9.9999999999999995e-21 +test util-16.1.17.-19 {8.4 compatible formatting of doubles} \ + {expr 1e-19} \ + 9.9999999999999998e-20 +test util-16.1.17.-18 {8.4 compatible formatting of doubles} \ + {expr 1e-18} \ + 1.0000000000000001e-18 +test util-16.1.17.-17 {8.4 compatible formatting of doubles} \ + {expr 1e-17} \ + 1.0000000000000001e-17 +test util-16.1.17.-16 {8.4 compatible formatting of doubles} \ + {expr 1e-16} \ + 9.9999999999999998e-17 +test util-16.1.17.-15 {8.4 compatible formatting of doubles} \ + {expr 1e-15} \ + 1.0000000000000001e-15 +test util-16.1.17.-14 {8.4 compatible formatting of doubles} \ + {expr 1e-14} \ + 1e-14 +test util-16.1.17.-13 {8.4 compatible formatting of doubles} \ + {expr 1e-13} \ + 1e-13 +test util-16.1.17.-12 {8.4 compatible formatting of doubles} \ + {expr 1e-12} \ + 9.9999999999999998e-13 +test util-16.1.17.-11 {8.4 compatible formatting of doubles} \ + {expr 1e-11} \ + 9.9999999999999994e-12 +test util-16.1.17.-10 {8.4 compatible formatting of doubles} \ + {expr 1e-10} \ + 1e-10 +test util-16.1.17.-9 {8.4 compatible formatting of doubles} \ + {expr 1e-9} \ + 1.0000000000000001e-09 +test util-16.1.17.-8 {8.4 compatible formatting of doubles} \ + {expr 1e-8} \ + 1e-08 +test util-16.1.17.-7 {8.4 compatible formatting of doubles} \ + {expr 1e-7} \ + 9.9999999999999995e-08 +test util-16.1.17.-6 {8.4 compatible formatting of doubles} \ + {expr 1e-6} \ + 9.9999999999999995e-07 +test util-16.1.17.-5 {8.4 compatible formatting of doubles} \ + {expr 1e-5} \ + 1.0000000000000001e-05 +test util-16.1.17.-4 {8.4 compatible formatting of doubles} \ + {expr 1e-4} \ + 0.0001 +test util-16.1.17.-3 {8.4 compatible formatting of doubles} \ + {expr 1e-3} \ + 0.001 +test util-16.1.17.-2 {8.4 compatible formatting of doubles} \ + {expr 1e-2} \ + 0.01 +test util-16.1.17.-1 {8.4 compatible formatting of doubles} \ + {expr 1e-1} \ + 0.10000000000000001 +test util-16.1.17.0 {8.4 compatible formatting of doubles} \ + {expr 1e0} \ + 1.0 +test util-16.1.17.1 {8.4 compatible formatting of doubles} \ + {expr 1e1} \ + 10.0 +test util-16.1.17.2 {8.4 compatible formatting of doubles} \ + {expr 1e2} \ + 100.0 +test util-16.1.17.3 {8.4 compatible formatting of doubles} \ + {expr 1e3} \ + 1000.0 +test util-16.1.17.4 {8.4 compatible formatting of doubles} \ + {expr 1e4} \ + 10000.0 +test util-16.1.17.5 {8.4 compatible formatting of doubles} \ + {expr 1e5} \ + 100000.0 +test util-16.1.17.6 {8.4 compatible formatting of doubles} \ + {expr 1e6} \ + 1000000.0 +test util-16.1.17.7 {8.4 compatible formatting of doubles} \ + {expr 1e7} \ + 10000000.0 +test util-16.1.17.8 {8.4 compatible formatting of doubles} \ + {expr 1e8} \ + 100000000.0 +test util-16.1.17.9 {8.4 compatible formatting of doubles} \ + {expr 1e9} \ + 1000000000.0 +test util-16.1.17.10 {8.4 compatible formatting of doubles} \ + {expr 1e10} \ + 10000000000.0 +test util-16.1.17.11 {8.4 compatible formatting of doubles} \ + {expr 1e11} \ + 100000000000.0 +test util-16.1.17.12 {8.4 compatible formatting of doubles} \ + {expr 1e12} \ + 1000000000000.0 +test util-16.1.17.13 {8.4 compatible formatting of doubles} \ + {expr 1e13} \ + 10000000000000.0 +test util-16.1.17.14 {8.4 compatible formatting of doubles} \ + {expr 1e14} \ + 100000000000000.0 +test util-16.1.17.15 {8.4 compatible formatting of doubles} \ + {expr 1e15} \ + 1000000000000000.0 +test util-16.1.17.16 {8.4 compatible formatting of doubles} \ + {expr 1e16} \ + 10000000000000000.0 +test util-16.1.17.17 {8.4 compatible formatting of doubles} \ + {expr 1e17} \ + 1e+17 +test util-16.1.17.18 {8.4 compatible formatting of doubles} \ + {expr 1e18} \ + 1e+18 +test util-16.1.17.19 {8.4 compatible formatting of doubles} \ + {expr 1e19} \ + 1e+19 +test util-16.1.17.20 {8.4 compatible formatting of doubles} \ + {expr 1e20} \ + 1e+20 +test util-16.1.17.21 {8.4 compatible formatting of doubles} \ + {expr 1e21} \ + 1e+21 +test util-16.1.17.22 {8.4 compatible formatting of doubles} \ + {expr 1e22} \ + 1e+22 +test util-16.1.17.23 {8.4 compatible formatting of doubles} \ + {expr 1e23} \ + 9.9999999999999992e+22 +test util-16.1.17.24 {8.4 compatible formatting of doubles} \ + {expr 1e24} \ + 9.9999999999999998e+23 +test util-16.1.17.25 {8.4 compatible formatting of doubles} \ + {expr 1e25} \ + 1.0000000000000001e+25 +test util-16.1.17.26 {8.4 compatible formatting of doubles} \ + {expr 1e26} \ + 1e+26 +test util-16.1.17.27 {8.4 compatible formatting of doubles} \ + {expr 1e27} \ + 1e+27 +test util-16.1.17.28 {8.4 compatible formatting of doubles} \ + {expr 1e28} \ + 9.9999999999999996e+27 +test util-16.1.17.29 {8.4 compatible formatting of doubles} \ + {expr 1e29} \ + 9.9999999999999991e+28 +test util-16.1.17.30 {8.4 compatible formatting of doubles} \ + {expr 1e30} \ + 1e+30 +test util-16.1.17.31 {8.4 compatible formatting of doubles} \ + {expr 1e31} \ + 9.9999999999999996e+30 +test util-16.1.17.32 {8.4 compatible formatting of doubles} \ + {expr 1e32} \ + 1.0000000000000001e+32 +test util-16.1.17.33 {8.4 compatible formatting of doubles} \ + {expr 1e33} \ + 9.9999999999999995e+32 +test util-16.1.17.34 {8.4 compatible formatting of doubles} \ + {expr 1e34} \ + 9.9999999999999995e+33 +test util-16.1.17.35 {8.4 compatible formatting of doubles} \ + {expr 1e35} \ + 9.9999999999999997e+34 +test util-16.1.17.36 {8.4 compatible formatting of doubles} \ + {expr 1e36} \ + 1e+36 +test util-16.1.17.37 {8.4 compatible formatting of doubles} \ + {expr 1e37} \ + 9.9999999999999995e+36 +test util-16.1.17.38 {8.4 compatible formatting of doubles} \ + {expr 1e38} \ + 9.9999999999999998e+37 +test util-16.1.17.39 {8.4 compatible formatting of doubles} \ + {expr 1e39} \ + 9.9999999999999994e+38 +test util-16.1.17.40 {8.4 compatible formatting of doubles} \ + {expr 1e40} \ + 1e+40 +test util-16.1.17.41 {8.4 compatible formatting of doubles} \ + {expr 1e41} \ + 1e+41 +test util-16.1.17.42 {8.4 compatible formatting of doubles} \ + {expr 1e42} \ + 1e+42 +test util-16.1.17.43 {8.4 compatible formatting of doubles} \ + {expr 1e43} \ + 1e+43 +test util-16.1.17.44 {8.4 compatible formatting of doubles} \ + {expr 1e44} \ + 1.0000000000000001e+44 +test util-16.1.17.45 {8.4 compatible formatting of doubles} \ + {expr 1e45} \ + 9.9999999999999993e+44 +test util-16.1.17.46 {8.4 compatible formatting of doubles} \ + {expr 1e46} \ + 9.9999999999999999e+45 +test util-16.1.17.47 {8.4 compatible formatting of doubles} \ + {expr 1e47} \ + 1e+47 +test util-16.1.17.48 {8.4 compatible formatting of doubles} \ + {expr 1e48} \ + 1e+48 +test util-16.1.17.49 {8.4 compatible formatting of doubles} \ + {expr 1e49} \ + 9.9999999999999995e+48 +test util-16.1.17.50 {8.4 compatible formatting of doubles} \ + {expr 1e50} \ + 1.0000000000000001e+50 +test util-16.1.17.51 {8.4 compatible formatting of doubles} \ + {expr 1e51} \ + 9.9999999999999999e+50 +test util-16.1.17.52 {8.4 compatible formatting of doubles} \ + {expr 1e52} \ + 9.9999999999999999e+51 +test util-16.1.17.53 {8.4 compatible formatting of doubles} \ + {expr 1e53} \ + 9.9999999999999999e+52 +test util-16.1.17.54 {8.4 compatible formatting of doubles} \ + {expr 1e54} \ + 1.0000000000000001e+54 +test util-16.1.17.55 {8.4 compatible formatting of doubles} \ + {expr 1e55} \ + 1e+55 +test util-16.1.17.56 {8.4 compatible formatting of doubles} \ + {expr 1e56} \ + 1.0000000000000001e+56 +test util-16.1.17.57 {8.4 compatible formatting of doubles} \ + {expr 1e57} \ + 1e+57 +test util-16.1.17.58 {8.4 compatible formatting of doubles} \ + {expr 1e58} \ + 9.9999999999999994e+57 +test util-16.1.17.59 {8.4 compatible formatting of doubles} \ + {expr 1e59} \ + 9.9999999999999997e+58 +test util-16.1.17.60 {8.4 compatible formatting of doubles} \ + {expr 1e60} \ + 9.9999999999999995e+59 +test util-16.1.17.61 {8.4 compatible formatting of doubles} \ + {expr 1e61} \ + 9.9999999999999995e+60 +test util-16.1.17.62 {8.4 compatible formatting of doubles} \ + {expr 1e62} \ + 1e+62 +test util-16.1.17.63 {8.4 compatible formatting of doubles} \ + {expr 1e63} \ + 1.0000000000000001e+63 +test util-16.1.17.64 {8.4 compatible formatting of doubles} \ + {expr 1e64} \ + 1e+64 +test util-16.1.17.65 {8.4 compatible formatting of doubles} \ + {expr 1e65} \ + 9.9999999999999999e+64 +test util-16.1.17.66 {8.4 compatible formatting of doubles} \ + {expr 1e66} \ + 9.9999999999999995e+65 +test util-16.1.17.67 {8.4 compatible formatting of doubles} \ + {expr 1e67} \ + 9.9999999999999998e+66 +test util-16.1.17.68 {8.4 compatible formatting of doubles} \ + {expr 1e68} \ + 9.9999999999999995e+67 +test util-16.1.17.69 {8.4 compatible formatting of doubles} \ + {expr 1e69} \ + 1.0000000000000001e+69 +test util-16.1.17.70 {8.4 compatible formatting of doubles} \ + {expr 1e70} \ + 1.0000000000000001e+70 +test util-16.1.17.71 {8.4 compatible formatting of doubles} \ + {expr 1e71} \ + 1e+71 +test util-16.1.17.72 {8.4 compatible formatting of doubles} \ + {expr 1e72} \ + 9.9999999999999994e+71 +test util-16.1.17.73 {8.4 compatible formatting of doubles} \ + {expr 1e73} \ + 9.9999999999999998e+72 +test util-16.1.17.74 {8.4 compatible formatting of doubles} \ + {expr 1e74} \ + 9.9999999999999995e+73 +test util-16.1.17.75 {8.4 compatible formatting of doubles} \ + {expr 1e75} \ + 9.9999999999999993e+74 +test util-16.1.17.76 {8.4 compatible formatting of doubles} \ + {expr 1e76} \ + 1e+76 +test util-16.1.17.77 {8.4 compatible formatting of doubles} \ + {expr 1e77} \ + 9.9999999999999998e+76 +test util-16.1.17.78 {8.4 compatible formatting of doubles} \ + {expr 1e78} \ + 1e+78 +test util-16.1.17.79 {8.4 compatible formatting of doubles} \ + {expr 1e79} \ + 9.9999999999999997e+78 +test util-16.1.17.80 {8.4 compatible formatting of doubles} \ + {expr 1e80} \ + 1e+80 +test util-16.1.17.81 {8.4 compatible formatting of doubles} \ + {expr 1e81} \ + 9.9999999999999992e+80 +test util-16.1.17.82 {8.4 compatible formatting of doubles} \ + {expr 1e82} \ + 9.9999999999999996e+81 +test util-16.1.17.83 {8.4 compatible formatting of doubles} \ + {expr 1e83} \ + 1e+83 +test util-16.1.17.84 {8.4 compatible formatting of doubles} \ + {expr 1e84} \ + 1.0000000000000001e+84 +test util-16.1.17.85 {8.4 compatible formatting of doubles} \ + {expr 1e85} \ + 1e+85 +test util-16.1.17.86 {8.4 compatible formatting of doubles} \ + {expr 1e86} \ + 1e+86 +test util-16.1.17.87 {8.4 compatible formatting of doubles} \ + {expr 1e87} \ + 9.9999999999999996e+86 +test util-16.1.17.88 {8.4 compatible formatting of doubles} \ + {expr 1e88} \ + 9.9999999999999996e+87 +test util-16.1.17.89 {8.4 compatible formatting of doubles} \ + {expr 1e89} \ + 9.9999999999999999e+88 +test util-16.1.17.90 {8.4 compatible formatting of doubles} \ + {expr 1e90} \ + 9.9999999999999997e+89 +test util-16.1.17.91 {8.4 compatible formatting of doubles} \ + {expr 1e91} \ + 1.0000000000000001e+91 +test util-16.1.17.92 {8.4 compatible formatting of doubles} \ + {expr 1e92} \ + 1e+92 +test util-16.1.17.93 {8.4 compatible formatting of doubles} \ + {expr 1e93} \ + 1e+93 +test util-16.1.17.94 {8.4 compatible formatting of doubles} \ + {expr 1e94} \ + 1e+94 +test util-16.1.17.95 {8.4 compatible formatting of doubles} \ + {expr 1e95} \ + 1e+95 +test util-16.1.17.96 {8.4 compatible formatting of doubles} \ + {expr 1e96} \ + 1e+96 +test util-16.1.17.97 {8.4 compatible formatting of doubles} \ + {expr 1e97} \ + 1.0000000000000001e+97 +test util-16.1.17.98 {8.4 compatible formatting of doubles} \ + {expr 1e98} \ + 1e+98 +test util-16.1.17.99 {8.4 compatible formatting of doubles} \ + {expr 1e99} \ + 9.9999999999999997e+98 +test util-16.1.17.100 {8.4 compatible formatting of doubles} \ + {expr 1e100} \ + 1e+100 +test util-16.1.17.101 {8.4 compatible formatting of doubles} \ + {expr 1e101} \ + 9.9999999999999998e+100 +test util-16.1.17.102 {8.4 compatible formatting of doubles} \ + {expr 1e102} \ + 9.9999999999999998e+101 +test util-16.1.17.103 {8.4 compatible formatting of doubles} \ + {expr 1e103} \ + 1e+103 +test util-16.1.17.104 {8.4 compatible formatting of doubles} \ + {expr 1e104} \ + 1e+104 +test util-16.1.17.105 {8.4 compatible formatting of doubles} \ + {expr 1e105} \ + 9.9999999999999994e+104 +test util-16.1.17.106 {8.4 compatible formatting of doubles} \ + {expr 1e106} \ + 1.0000000000000001e+106 +test util-16.1.17.107 {8.4 compatible formatting of doubles} \ + {expr 1e107} \ + 9.9999999999999997e+106 +test util-16.1.17.108 {8.4 compatible formatting of doubles} \ + {expr 1e108} \ + 1e+108 +test util-16.1.17.109 {8.4 compatible formatting of doubles} \ + {expr 1e109} \ + 9.9999999999999998e+108 +test util-16.1.17.110 {8.4 compatible formatting of doubles} \ + {expr 1e110} \ + 1e+110 +test util-16.1.17.111 {8.4 compatible formatting of doubles} \ + {expr 1e111} \ + 9.9999999999999996e+110 +test util-16.1.17.112 {8.4 compatible formatting of doubles} \ + {expr 1e112} \ + 9.9999999999999993e+111 +test util-16.1.17.113 {8.4 compatible formatting of doubles} \ + {expr 1e113} \ + 1e+113 +test util-16.1.17.114 {8.4 compatible formatting of doubles} \ + {expr 1e114} \ + 1e+114 +test util-16.1.17.115 {8.4 compatible formatting of doubles} \ + {expr 1e115} \ + 1e+115 +test util-16.1.17.116 {8.4 compatible formatting of doubles} \ + {expr 1e116} \ + 1e+116 +test util-16.1.17.117 {8.4 compatible formatting of doubles} \ + {expr 1e117} \ + 1.0000000000000001e+117 +test util-16.1.17.118 {8.4 compatible formatting of doubles} \ + {expr 1e118} \ + 9.9999999999999997e+117 +test util-16.1.17.119 {8.4 compatible formatting of doubles} \ + {expr 1e119} \ + 9.9999999999999994e+118 +test util-16.1.17.120 {8.4 compatible formatting of doubles} \ + {expr 1e120} \ + 9.9999999999999998e+119 +test util-16.1.17.121 {8.4 compatible formatting of doubles} \ + {expr 1e121} \ + 1e+121 +test util-16.1.17.122 {8.4 compatible formatting of doubles} \ + {expr 1e122} \ + 1e+122 +test util-16.1.17.123 {8.4 compatible formatting of doubles} \ + {expr 1e123} \ + 9.9999999999999998e+122 +test util-16.1.17.124 {8.4 compatible formatting of doubles} \ + {expr 1e124} \ + 9.9999999999999995e+123 +test util-16.1.17.125 {8.4 compatible formatting of doubles} \ + {expr 1e125} \ + 9.9999999999999992e+124 +test util-16.1.17.126 {8.4 compatible formatting of doubles} \ + {expr 1e126} \ + 9.9999999999999992e+125 +test util-16.1.17.127 {8.4 compatible formatting of doubles} \ + {expr 1e127} \ + 9.9999999999999995e+126 +test util-16.1.17.128 {8.4 compatible formatting of doubles} \ + {expr 1e128} \ + 1.0000000000000001e+128 +test util-16.1.17.129 {8.4 compatible formatting of doubles} \ + {expr 1e129} \ + 1e+129 +test util-16.1.17.130 {8.4 compatible formatting of doubles} \ + {expr 1e130} \ + 1.0000000000000001e+130 +test util-16.1.17.131 {8.4 compatible formatting of doubles} \ + {expr 1e131} \ + 9.9999999999999991e+130 +test util-16.1.17.132 {8.4 compatible formatting of doubles} \ + {expr 1e132} \ + 9.9999999999999999e+131 +test util-16.1.17.133 {8.4 compatible formatting of doubles} \ + {expr 1e133} \ + 1e+133 +test util-16.1.17.134 {8.4 compatible formatting of doubles} \ + {expr 1e134} \ + 9.9999999999999992e+133 +test util-16.1.17.135 {8.4 compatible formatting of doubles} \ + {expr 1e135} \ + 9.9999999999999996e+134 +test util-16.1.17.136 {8.4 compatible formatting of doubles} \ + {expr 1e136} \ + 1.0000000000000001e+136 +test util-16.1.17.137 {8.4 compatible formatting of doubles} \ + {expr 1e137} \ + 1e+137 +test util-16.1.17.138 {8.4 compatible formatting of doubles} \ + {expr 1e138} \ + 1e+138 +test util-16.1.17.139 {8.4 compatible formatting of doubles} \ + {expr 1e139} \ + 1e+139 +test util-16.1.17.140 {8.4 compatible formatting of doubles} \ + {expr 1e140} \ + 1.0000000000000001e+140 +test util-16.1.17.141 {8.4 compatible formatting of doubles} \ + {expr 1e141} \ + 1e+141 +test util-16.1.17.142 {8.4 compatible formatting of doubles} \ + {expr 1e142} \ + 1.0000000000000001e+142 +test util-16.1.17.143 {8.4 compatible formatting of doubles} \ + {expr 1e143} \ + 1e+143 +test util-16.1.17.144 {8.4 compatible formatting of doubles} \ + {expr 1e144} \ + 1e+144 +test util-16.1.17.145 {8.4 compatible formatting of doubles} \ + {expr 1e145} \ + 9.9999999999999999e+144 +test util-16.1.17.146 {8.4 compatible formatting of doubles} \ + {expr 1e146} \ + 9.9999999999999993e+145 +test util-16.1.17.147 {8.4 compatible formatting of doubles} \ + {expr 1e147} \ + 9.9999999999999998e+146 +test util-16.1.17.148 {8.4 compatible formatting of doubles} \ + {expr 1e148} \ + 1e+148 +test util-16.1.17.149 {8.4 compatible formatting of doubles} \ + {expr 1e149} \ + 1e+149 +test util-16.1.17.150 {8.4 compatible formatting of doubles} \ + {expr 1e150} \ + 9.9999999999999998e+149 +test util-16.1.17.151 {8.4 compatible formatting of doubles} \ + {expr 1e151} \ + 1e+151 +test util-16.1.17.152 {8.4 compatible formatting of doubles} \ + {expr 1e152} \ + 1e+152 +test util-16.1.17.153 {8.4 compatible formatting of doubles} \ + {expr 1e153} \ + 1e+153 +test util-16.1.17.154 {8.4 compatible formatting of doubles} \ + {expr 1e154} \ + 1e+154 +test util-16.1.17.155 {8.4 compatible formatting of doubles} \ + {expr 1e155} \ + 1e+155 +test util-16.1.17.156 {8.4 compatible formatting of doubles} \ + {expr 1e156} \ + 9.9999999999999998e+155 +test util-16.1.17.157 {8.4 compatible formatting of doubles} \ + {expr 1e157} \ + 9.9999999999999998e+156 +test util-16.1.17.158 {8.4 compatible formatting of doubles} \ + {expr 1e158} \ + 9.9999999999999995e+157 +test util-16.1.17.159 {8.4 compatible formatting of doubles} \ + {expr 1e159} \ + 9.9999999999999993e+158 +test util-16.1.17.160 {8.4 compatible formatting of doubles} \ + {expr 1e160} \ + 1e+160 +test util-16.1.17.161 {8.4 compatible formatting of doubles} \ + {expr 1e161} \ + 1e+161 +test util-16.1.17.162 {8.4 compatible formatting of doubles} \ + {expr 1e162} \ + 9.9999999999999994e+161 +test util-16.1.17.163 {8.4 compatible formatting of doubles} \ + {expr 1e163} \ + 9.9999999999999994e+162 +test util-16.1.17.164 {8.4 compatible formatting of doubles} \ + {expr 1e164} \ + 1e+164 +test util-16.1.17.165 {8.4 compatible formatting of doubles} \ + {expr 1e165} \ + 9.999999999999999e+164 +test util-16.1.17.166 {8.4 compatible formatting of doubles} \ + {expr 1e166} \ + 9.9999999999999994e+165 +test util-16.1.17.167 {8.4 compatible formatting of doubles} \ + {expr 1e167} \ + 1e+167 +test util-16.1.17.168 {8.4 compatible formatting of doubles} \ + {expr 1e168} \ + 9.9999999999999993e+167 +test util-16.1.17.169 {8.4 compatible formatting of doubles} \ + {expr 1e169} \ + 9.9999999999999993e+168 +test util-16.1.17.170 {8.4 compatible formatting of doubles} \ + {expr 1e170} \ + 1e+170 +test util-16.1.17.171 {8.4 compatible formatting of doubles} \ + {expr 1e171} \ + 9.9999999999999995e+170 +test util-16.1.17.172 {8.4 compatible formatting of doubles} \ + {expr 1e172} \ + 1.0000000000000001e+172 +test util-16.1.17.173 {8.4 compatible formatting of doubles} \ + {expr 1e173} \ + 1e+173 +test util-16.1.17.174 {8.4 compatible formatting of doubles} \ + {expr 1e174} \ + 1.0000000000000001e+174 +test util-16.1.17.175 {8.4 compatible formatting of doubles} \ + {expr 1e175} \ + 9.9999999999999994e+174 +test util-16.1.17.176 {8.4 compatible formatting of doubles} \ + {expr 1e176} \ + 1e+176 +test util-16.1.17.177 {8.4 compatible formatting of doubles} \ + {expr 1e177} \ + 1e+177 +test util-16.1.17.178 {8.4 compatible formatting of doubles} \ + {expr 1e178} \ + 1.0000000000000001e+178 +test util-16.1.17.179 {8.4 compatible formatting of doubles} \ + {expr 1e179} \ + 9.9999999999999998e+178 +test util-16.1.17.180 {8.4 compatible formatting of doubles} \ + {expr 1e180} \ + 1e+180 +test util-16.1.17.181 {8.4 compatible formatting of doubles} \ + {expr 1e181} \ + 9.9999999999999992e+180 +test util-16.1.17.182 {8.4 compatible formatting of doubles} \ + {expr 1e182} \ + 1.0000000000000001e+182 +test util-16.1.17.183 {8.4 compatible formatting of doubles} \ + {expr 1e183} \ + 9.9999999999999995e+182 +test util-16.1.17.184 {8.4 compatible formatting of doubles} \ + {expr 1e184} \ + 1e+184 +test util-16.1.17.185 {8.4 compatible formatting of doubles} \ + {expr 1e185} \ + 9.9999999999999998e+184 +test util-16.1.17.186 {8.4 compatible formatting of doubles} \ + {expr 1e186} \ + 9.9999999999999998e+185 +test util-16.1.17.187 {8.4 compatible formatting of doubles} \ + {expr 1e187} \ + 9.9999999999999991e+186 +test util-16.1.17.188 {8.4 compatible formatting of doubles} \ + {expr 1e188} \ + 1e+188 +test util-16.1.17.189 {8.4 compatible formatting of doubles} \ + {expr 1e189} \ + 1e+189 +test util-16.1.17.190 {8.4 compatible formatting of doubles} \ + {expr 1e190} \ + 1.0000000000000001e+190 +test util-16.1.17.191 {8.4 compatible formatting of doubles} \ + {expr 1e191} \ + 1.0000000000000001e+191 +test util-16.1.17.192 {8.4 compatible formatting of doubles} \ + {expr 1e192} \ + 1e+192 +test util-16.1.17.193 {8.4 compatible formatting of doubles} \ + {expr 1e193} \ + 1.0000000000000001e+193 +test util-16.1.17.194 {8.4 compatible formatting of doubles} \ + {expr 1e194} \ + 9.9999999999999994e+193 +test util-16.1.17.195 {8.4 compatible formatting of doubles} \ + {expr 1e195} \ + 9.9999999999999998e+194 +test util-16.1.17.196 {8.4 compatible formatting of doubles} \ + {expr 1e196} \ + 9.9999999999999995e+195 +test util-16.1.17.197 {8.4 compatible formatting of doubles} \ + {expr 1e197} \ + 9.9999999999999995e+196 +test util-16.1.17.198 {8.4 compatible formatting of doubles} \ + {expr 1e198} \ + 1e+198 +test util-16.1.17.199 {8.4 compatible formatting of doubles} \ + {expr 1e199} \ + 1.0000000000000001e+199 +test util-16.1.17.200 {8.4 compatible formatting of doubles} \ + {expr 1e200} \ + 9.9999999999999997e+199 +test util-16.1.17.201 {8.4 compatible formatting of doubles} \ + {expr 1e201} \ + 1e+201 +test util-16.1.17.202 {8.4 compatible formatting of doubles} \ + {expr 1e202} \ + 9.999999999999999e+201 +test util-16.1.17.203 {8.4 compatible formatting of doubles} \ + {expr 1e203} \ + 9.9999999999999999e+202 +test util-16.1.17.204 {8.4 compatible formatting of doubles} \ + {expr 1e204} \ + 9.9999999999999999e+203 +test util-16.1.17.205 {8.4 compatible formatting of doubles} \ + {expr 1e205} \ + 1e+205 +test util-16.1.17.206 {8.4 compatible formatting of doubles} \ + {expr 1e206} \ + 1e+206 +test util-16.1.17.207 {8.4 compatible formatting of doubles} \ + {expr 1e207} \ + 1e+207 +test util-16.1.17.208 {8.4 compatible formatting of doubles} \ + {expr 1e208} \ + 9.9999999999999998e+207 +test util-16.1.17.209 {8.4 compatible formatting of doubles} \ + {expr 1e209} \ + 1.0000000000000001e+209 +test util-16.1.17.210 {8.4 compatible formatting of doubles} \ + {expr 1e210} \ + 9.9999999999999993e+209 +test util-16.1.17.211 {8.4 compatible formatting of doubles} \ + {expr 1e211} \ + 9.9999999999999996e+210 +test util-16.1.17.212 {8.4 compatible formatting of doubles} \ + {expr 1e212} \ + 9.9999999999999991e+211 +test util-16.1.17.213 {8.4 compatible formatting of doubles} \ + {expr 1e213} \ + 9.9999999999999998e+212 +test util-16.1.17.214 {8.4 compatible formatting of doubles} \ + {expr 1e214} \ + 9.9999999999999995e+213 +test util-16.1.17.215 {8.4 compatible formatting of doubles} \ + {expr 1e215} \ + 9.9999999999999991e+214 +test util-16.1.17.216 {8.4 compatible formatting of doubles} \ + {expr 1e216} \ + 1e+216 +test util-16.1.17.217 {8.4 compatible formatting of doubles} \ + {expr 1e217} \ + 9.9999999999999996e+216 +test util-16.1.17.218 {8.4 compatible formatting of doubles} \ + {expr 1e218} \ + 1.0000000000000001e+218 +test util-16.1.17.219 {8.4 compatible formatting of doubles} \ + {expr 1e219} \ + 9.9999999999999997e+218 +test util-16.1.17.220 {8.4 compatible formatting of doubles} \ + {expr 1e220} \ + 1e+220 +test util-16.1.17.221 {8.4 compatible formatting of doubles} \ + {expr 1e221} \ + 1e+221 +test util-16.1.17.222 {8.4 compatible formatting of doubles} \ + {expr 1e222} \ + 1e+222 +test util-16.1.17.223 {8.4 compatible formatting of doubles} \ + {expr 1e223} \ + 1e+223 +test util-16.1.17.224 {8.4 compatible formatting of doubles} \ + {expr 1e224} \ + 9.9999999999999997e+223 +test util-16.1.17.225 {8.4 compatible formatting of doubles} \ + {expr 1e225} \ + 9.9999999999999993e+224 +test util-16.1.17.226 {8.4 compatible formatting of doubles} \ + {expr 1e226} \ + 9.9999999999999996e+225 +test util-16.1.17.227 {8.4 compatible formatting of doubles} \ + {expr 1e227} \ + 1.0000000000000001e+227 +test util-16.1.17.228 {8.4 compatible formatting of doubles} \ + {expr 1e228} \ + 9.9999999999999992e+227 +test util-16.1.17.229 {8.4 compatible formatting of doubles} \ + {expr 1e229} \ + 9.9999999999999999e+228 +test util-16.1.17.230 {8.4 compatible formatting of doubles} \ + {expr 1e230} \ + 1.0000000000000001e+230 +test util-16.1.17.231 {8.4 compatible formatting of doubles} \ + {expr 1e231} \ + 1.0000000000000001e+231 +test util-16.1.17.232 {8.4 compatible formatting of doubles} \ + {expr 1e232} \ + 1.0000000000000001e+232 +test util-16.1.17.233 {8.4 compatible formatting of doubles} \ + {expr 1e233} \ + 9.9999999999999997e+232 +test util-16.1.17.234 {8.4 compatible formatting of doubles} \ + {expr 1e234} \ + 1e+234 +test util-16.1.17.235 {8.4 compatible formatting of doubles} \ + {expr 1e235} \ + 1.0000000000000001e+235 +test util-16.1.17.236 {8.4 compatible formatting of doubles} \ + {expr 1e236} \ + 1.0000000000000001e+236 +test util-16.1.17.237 {8.4 compatible formatting of doubles} \ + {expr 1e237} \ + 9.9999999999999994e+236 +test util-16.1.17.238 {8.4 compatible formatting of doubles} \ + {expr 1e238} \ + 1e+238 +test util-16.1.17.239 {8.4 compatible formatting of doubles} \ + {expr 1e239} \ + 9.9999999999999999e+238 +test util-16.1.17.240 {8.4 compatible formatting of doubles} \ + {expr 1e240} \ + 1e+240 +test util-16.1.17.241 {8.4 compatible formatting of doubles} \ + {expr 1e241} \ + 1.0000000000000001e+241 +test util-16.1.17.242 {8.4 compatible formatting of doubles} \ + {expr 1e242} \ + 1.0000000000000001e+242 +test util-16.1.17.243 {8.4 compatible formatting of doubles} \ + {expr 1e243} \ + 1.0000000000000001e+243 +test util-16.1.17.244 {8.4 compatible formatting of doubles} \ + {expr 1e244} \ + 1.0000000000000001e+244 +test util-16.1.17.245 {8.4 compatible formatting of doubles} \ + {expr 1e245} \ + 1e+245 +test util-16.1.17.246 {8.4 compatible formatting of doubles} \ + {expr 1e246} \ + 1.0000000000000001e+246 +test util-16.1.17.247 {8.4 compatible formatting of doubles} \ + {expr 1e247} \ + 9.9999999999999995e+246 +test util-16.1.17.248 {8.4 compatible formatting of doubles} \ + {expr 1e248} \ + 1e+248 +test util-16.1.17.249 {8.4 compatible formatting of doubles} \ + {expr 1e249} \ + 9.9999999999999992e+248 +test util-16.1.17.250 {8.4 compatible formatting of doubles} \ + {expr 1e250} \ + 9.9999999999999992e+249 +test util-16.1.17.251 {8.4 compatible formatting of doubles} \ + {expr 1e251} \ + 1e+251 +test util-16.1.17.252 {8.4 compatible formatting of doubles} \ + {expr 1e252} \ + 1.0000000000000001e+252 +test util-16.1.17.253 {8.4 compatible formatting of doubles} \ + {expr 1e253} \ + 9.9999999999999994e+252 +test util-16.1.17.254 {8.4 compatible formatting of doubles} \ + {expr 1e254} \ + 9.9999999999999994e+253 +test util-16.1.17.255 {8.4 compatible formatting of doubles} \ + {expr 1e255} \ + 9.9999999999999999e+254 +test util-16.1.17.256 {8.4 compatible formatting of doubles} \ + {expr 1e256} \ + 1e+256 +test util-16.1.17.257 {8.4 compatible formatting of doubles} \ + {expr 1e257} \ + 1e+257 +test util-16.1.17.258 {8.4 compatible formatting of doubles} \ + {expr 1e258} \ + 1.0000000000000001e+258 +test util-16.1.17.259 {8.4 compatible formatting of doubles} \ + {expr 1e259} \ + 9.9999999999999993e+258 +test util-16.1.17.260 {8.4 compatible formatting of doubles} \ + {expr 1e260} \ + 1.0000000000000001e+260 +test util-16.1.17.261 {8.4 compatible formatting of doubles} \ + {expr 1e261} \ + 9.9999999999999993e+260 +test util-16.1.17.262 {8.4 compatible formatting of doubles} \ + {expr 1e262} \ + 1e+262 +test util-16.1.17.263 {8.4 compatible formatting of doubles} \ + {expr 1e263} \ + 1e+263 +test util-16.1.17.264 {8.4 compatible formatting of doubles} \ + {expr 1e264} \ + 1e+264 +test util-16.1.17.265 {8.4 compatible formatting of doubles} \ + {expr 1e265} \ + 1.0000000000000001e+265 +test util-16.1.17.266 {8.4 compatible formatting of doubles} \ + {expr 1e266} \ + 1e+266 +test util-16.1.17.267 {8.4 compatible formatting of doubles} \ + {expr 1e267} \ + 9.9999999999999997e+266 +test util-16.1.17.268 {8.4 compatible formatting of doubles} \ + {expr 1e268} \ + 9.9999999999999997e+267 +test util-16.1.17.269 {8.4 compatible formatting of doubles} \ + {expr 1e269} \ + 1e+269 +test util-16.1.17.270 {8.4 compatible formatting of doubles} \ + {expr 1e270} \ + 1e+270 +test util-16.1.17.271 {8.4 compatible formatting of doubles} \ + {expr 1e271} \ + 9.9999999999999995e+270 +test util-16.1.17.272 {8.4 compatible formatting of doubles} \ + {expr 1e272} \ + 1.0000000000000001e+272 +test util-16.1.17.273 {8.4 compatible formatting of doubles} \ + {expr 1e273} \ + 9.9999999999999995e+272 +test util-16.1.17.274 {8.4 compatible formatting of doubles} \ + {expr 1e274} \ + 9.9999999999999992e+273 +test util-16.1.17.275 {8.4 compatible formatting of doubles} \ + {expr 1e275} \ + 9.9999999999999996e+274 +test util-16.1.17.276 {8.4 compatible formatting of doubles} \ + {expr 1e276} \ + 1.0000000000000001e+276 +test util-16.1.17.277 {8.4 compatible formatting of doubles} \ + {expr 1e277} \ + 1e+277 +test util-16.1.17.278 {8.4 compatible formatting of doubles} \ + {expr 1e278} \ + 9.9999999999999996e+277 +test util-16.1.17.279 {8.4 compatible formatting of doubles} \ + {expr 1e279} \ + 1.0000000000000001e+279 +test util-16.1.17.280 {8.4 compatible formatting of doubles} \ + {expr 1e280} \ + 1e+280 +test util-16.1.17.281 {8.4 compatible formatting of doubles} \ + {expr 1e281} \ + 1e+281 +test util-16.1.17.282 {8.4 compatible formatting of doubles} \ + {expr 1e282} \ + 1e+282 +test util-16.1.17.283 {8.4 compatible formatting of doubles} \ + {expr 1e283} \ + 9.9999999999999996e+282 +test util-16.1.17.284 {8.4 compatible formatting of doubles} \ + {expr 1e284} \ + 1.0000000000000001e+284 +test util-16.1.17.285 {8.4 compatible formatting of doubles} \ + {expr 1e285} \ + 9.9999999999999998e+284 +test util-16.1.17.286 {8.4 compatible formatting of doubles} \ + {expr 1e286} \ + 1e+286 +test util-16.1.17.287 {8.4 compatible formatting of doubles} \ + {expr 1e287} \ + 1.0000000000000001e+287 +test util-16.1.17.288 {8.4 compatible formatting of doubles} \ + {expr 1e288} \ + 1e+288 +test util-16.1.17.289 {8.4 compatible formatting of doubles} \ + {expr 1e289} \ + 1.0000000000000001e+289 +test util-16.1.17.290 {8.4 compatible formatting of doubles} \ + {expr 1e290} \ + 1.0000000000000001e+290 +test util-16.1.17.291 {8.4 compatible formatting of doubles} \ + {expr 1e291} \ + 9.9999999999999996e+290 +test util-16.1.17.292 {8.4 compatible formatting of doubles} \ + {expr 1e292} \ + 1e+292 +test util-16.1.17.293 {8.4 compatible formatting of doubles} \ + {expr 1e293} \ + 9.9999999999999992e+292 +test util-16.1.17.294 {8.4 compatible formatting of doubles} \ + {expr 1e294} \ + 1.0000000000000001e+294 +test util-16.1.17.295 {8.4 compatible formatting of doubles} \ + {expr 1e295} \ + 9.9999999999999998e+294 +test util-16.1.17.296 {8.4 compatible formatting of doubles} \ + {expr 1e296} \ + 9.9999999999999998e+295 +test util-16.1.17.297 {8.4 compatible formatting of doubles} \ + {expr 1e297} \ + 1e+297 +test util-16.1.17.298 {8.4 compatible formatting of doubles} \ + {expr 1e298} \ + 9.9999999999999996e+297 +test util-16.1.17.299 {8.4 compatible formatting of doubles} \ + {expr 1e299} \ + 1.0000000000000001e+299 +test util-16.1.17.300 {8.4 compatible formatting of doubles} \ + {expr 1e300} \ + 1.0000000000000001e+300 +test util-16.1.17.301 {8.4 compatible formatting of doubles} \ + {expr 1e301} \ + 1.0000000000000001e+301 +test util-16.1.17.302 {8.4 compatible formatting of doubles} \ + {expr 1e302} \ + 1.0000000000000001e+302 +test util-16.1.17.303 {8.4 compatible formatting of doubles} \ + {expr 1e303} \ + 1e+303 +test util-16.1.17.304 {8.4 compatible formatting of doubles} \ + {expr 1e304} \ + 9.9999999999999994e+303 +test util-16.1.17.305 {8.4 compatible formatting of doubles} \ + {expr 1e305} \ + 9.9999999999999994e+304 +test util-16.1.17.306 {8.4 compatible formatting of doubles} \ + {expr 1e306} \ + 1e+306 +test util-16.1.17.307 {8.4 compatible formatting of doubles} \ + {expr 1e307} \ + 9.9999999999999999e+306 + +test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { + set r {} + foreach {input} { + 0x1ffffffffffffc000 + 0x1ffffffffffffc800 + 0x1ffffffffffffd000 + 0x1ffffffffffffd800 + 0x1ffffffffffffe000 + 0x1ffffffffffffe800 + 0x1fffffffffffff000 + 0x1fffffffffffff800 + } { + binary scan [binary format q [expr double($input)]] wu x + lappend r [format %#llx $x] + binary scan [binary format q [expr double(-$input)]] wu x + lappend r [format %#llx $x] + } + set r +} [list {*}{ + 0x43fffffffffffffc 0xc3fffffffffffffc + 0x43fffffffffffffc 0xc3fffffffffffffc + 0x43fffffffffffffd 0xc3fffffffffffffd + 0x43fffffffffffffe 0xc3fffffffffffffe + 0x43fffffffffffffe 0xc3fffffffffffffe + 0x43fffffffffffffe 0xc3fffffffffffffe + 0x43ffffffffffffff 0xc3ffffffffffffff + 0x4400000000000000 0xc400000000000000 +}] + +set ::tcl_precision $saved_precision + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/var.test b/tests/var.test index dd9483b..ed7e930 100644 --- a/tests/var.test +++ b/tests/var.test @@ -1,27 +1,27 @@ -# This file contains tests for the tclVar.c source file. Tests appear in -# the same order as the C code that they test. The set of tests is -# currently incomplete since it currently includes only new tests for -# code changed for the addition of Tcl namespaces. Other variable- -# related tests appear in several other test files including -# namespace.test, set.test, trace.test, and upvar.test. +# This file contains tests for the tclVar.c source file. Tests appear in the +# same order as the C code that they test. The set of tests is currently +# incomplete since it currently includes only new tests for code changed for +# the addition of Tcl namespaces. Other variable-related tests appear in +# several other test files including namespace.test, set.test, trace.test, and +# upvar.test. # -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# 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. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: var.test,v 1.36 2010/08/03 17:25:13 andreas_kupries Exp $ -# +# 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} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.2 namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testupvar [llength [info commands testupvar]] testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] testConstraint testsetnoerr [llength [info commands testsetnoerr]] @@ -35,13 +35,14 @@ catch {unset i} catch {unset a} catch {unset arr} -test var-1.1 {TclLookupVar, Array handling} { +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 i 10 set arr(foo) 37 list [$x i] $i [$x arr(foo)] $arr(foo) -} {11 11 38 38} +} -result {11 11 38 38} test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} { set x "global value" namespace eval test_ns_var { @@ -71,34 +72,35 @@ test var-1.5 {TclLookupVar, active call frame pushed for namespace eval implies test var-1.6 {TclLookupVar, name starts with :: implies some namespace var} { namespace eval test_ns_var {set ::x} } {global value} -test var-1.7 {TclLookupVar, error finding namespace var} { - list [catch {set a:::b} msg] $msg -} {1 {can't read "a:::b": no such variable}} -test var-1.8 {TclLookupVar, error finding namespace var} { - list [catch {set ::foobarfoo} msg] $msg -} {1 {can't read "::foobarfoo": no such variable}} +test var-1.7 {TclLookupVar, error finding namespace var} -body { + set a:::b +} -returnCodes error -result {can't read "a:::b": no such variable} +test var-1.8 {TclLookupVar, error finding namespace var} -body { + set ::foobarfoo +} -returnCodes error -result {can't read "::foobarfoo": no such variable} test var-1.9 {TclLookupVar, create new namespace var} { namespace eval test_ns_var { set v hello } } {hello} -test var-1.10 {TclLookupVar, create new namespace var} { +test var-1.10 {TclLookupVar, create new namespace var} -setup { catch {unset y} +} -body { namespace eval test_ns_var { set ::y 789 } set y -} {789} -test var-1.11 {TclLookupVar, error creating new namespace var} { +} -result {789} +test var-1.11 {TclLookupVar, error creating new namespace var} -body { namespace eval test_ns_var { - list [catch {set ::test_ns_var::foo::bar 314159} msg] $msg + set ::test_ns_var::foo::bar 314159 } -} {1 {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist}} -test var-1.12 {TclLookupVar, error creating new namespace var} { +} -returnCodes error -result {can't set "::test_ns_var::foo::bar": parent namespace doesn't exist} +test var-1.12 {TclLookupVar, error creating new namespace var} -body { namespace eval test_ns_var { - list [catch {set ::test_ns_var::foo:: 1997} msg] $msg + set ::test_ns_var::foo:: 1997 } -} {1 {can't set "::test_ns_var::foo::": parent namespace doesn't exist}} +} -returnCodes error -result {can't set "::test_ns_var::foo::": parent namespace doesn't exist} test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} { catch {unset aNeWnAmEiNnS} namespace eval test_ns_var { @@ -116,9 +118,9 @@ test var-1.14 {TclLookupVar, namespace code ignores ":"s in middle and end of va set x:y: 789 list [set :] [set v:] [set x:y:] \ ${:} ${v:} ${x:y:} \ - [expr {[lsearch [info vars] :] != -1}] \ - [expr {[lsearch [info vars] v:] != -1}] \ - [expr {[lsearch [info vars] x:y:] != -1}] + [expr {":" in [info vars]}] \ + [expr {"v:" in [info vars]}] \ + [expr {"x:y:" in [info vars]}] } } {123 456 789 123 456 789 1 1 1} test var-1.15 {TclLookupVar, resurrect variable via upvar to deleted namespace: compiled code path} { @@ -177,24 +179,25 @@ test var-1.18 {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.19 {TclLookupVar, right error message when parsing variable name} { - list [catch {[format set] thisvar(doesntexist)} msg] $msg -} {1 {can't read "thisvar(doesntexist)": no such variable}} +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-2.1 {Tcl_LappendObjCmd, create var if new} { catch {unset x} lappend x 1 2 } {1 2} -test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} { +test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup { catch {unset x} +} -body { set x 1997 proc p {} { global x ;# calls MakeUpvar with TCL_NAMESPACE_ONLY for other var x return $x } p -} {1997} +} -result {1997} test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { namespace eval test_ns_var { catch {unset v} @@ -206,17 +209,19 @@ test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { p } } {1998} -test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} testupvar { +test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup { catch {unset a} +} -constraints testupvar -body { set a 123321 proc p {} { # create global xx linked to global a testupvar 1 a {} xx global } list [p] $xx [set xx 789] $a -} {{} 123321 789 789} -test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} testupvar { +} -result {{} 123321 789 789} +test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { catch {unset a} +} -constraints testupvar -body { set a 456 namespace eval test_ns_var { catch {unset ::test_ns_var::vv} @@ -227,58 +232,64 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} testupvar { p } list $test_ns_var::vv [set test_ns_var::vv 123] $a -} {456 123 123} -test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} { +} -result {456 123 123} +test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { catch {unset aaaaa} catch {unset xxxxx} +} -body { set aaaaa 77777 upvar #0 aaaaa xxxxx list [set xxxxx] [set aaaaa] -} {77777 77777} -test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} { +} -result {77777 77777} +test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} -setup { catch {unset a} +} -body { set a 121212 namespace eval test_ns_var { upvar ::a vvv set vvv } -} {121212} -test var-3.7 {MakeUpvar, my var has ::s} { +} -result {121212} +test var-3.7 {MakeUpvar, my var has ::s} -setup { catch {unset a} +} -body { set a 789789 upvar #0 a test_ns_var::lnk namespace eval test_ns_var { set lnk } -} {789789} -test var-3.8 {MakeUpvar, my var already exists in global ns} { +} -result {789789} +test var-3.8 {MakeUpvar, my var already exists in global ns} -setup { catch {unset aaaaa} catch {unset xxxxx} +} -body { set aaaaa 456654 set xxxxx hello upvar #0 aaaaa xxxxx set xxxxx -} {hello} -test var-3.9 {MakeUpvar, my var has invalid ns name} { +} -result {hello} +test var-3.9 {MakeUpvar, my var has invalid ns name} -setup { catch {unset aaaaa} +} -returnCodes error -body { set aaaaa 789789 - list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg -} {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}} -test var-3.10 {MakeUpvar, } { + upvar #0 aaaaa test_ns_fred::lnk +} -result {can't create "test_ns_fred::lnk": parent namespace doesn't exist} +test var-3.10 {MakeUpvar, between namespaces} -body { namespace eval {} { - set bar 0 + variable bar 0 namespace eval foo upvar bar bar set foo::bar 1 - catch {list $bar $foo::bar} msg - unset ::aaaaa - set msg + list $bar $foo::bar } -} {1 1} -test var-3.11 {MakeUpvar, my var looks like array elem} -body { +} -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) -} -returnCodes 1 -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)": upvar won't create a scalar variable that looks like an array element} test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { catch {unset a} @@ -291,17 +302,19 @@ test var-4.2 {Tcl_GetVariableName, namespace variable} testgetvarfullname { testgetvarfullname george namespace } } ::test_ns_var::george -test var-4.3 {Tcl_GetVariableName, variable can't be array element} testgetvarfullname { +test var-4.3 {Tcl_GetVariableName, variable can't be array element} -setup { catch {unset a} +} -constraints testgetvarfullname -body { set a(1) foo - list [catch {testgetvarfullname a(1) global} msg] $msg -} {1 {unknown variable "a(1)"}} + testgetvarfullname a(1) global +} -returnCodes error -result {unknown variable "a(1)"} -test var-5.1 {Tcl_GetVariableFullName, global variable} { +test var-5.1 {Tcl_GetVariableFullName, global variable} -setup { catch {unset a} +} -body { set a bar namespace which -variable a -} {::a} +} -result {::a} test var-5.2 {Tcl_GetVariableFullName, namespace variable} { namespace eval test_ns_var { variable martha @@ -316,11 +329,10 @@ test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { namespace eval test_ns_var { variable boeing 777 } - proc p {} { + apply {{} { global ::test_ns_var::boeing set boeing - } - p + }} } {777} test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { namespace eval test_ns_var { @@ -336,11 +348,10 @@ test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { } {java} test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} { set ::test_ns_var::test_ns_nested:: 24 - proc p {} { + apply {{} { global ::test_ns_var::test_ns_nested:: set {} - } - p + }} } {24} test var-6.4 {Tcl_GlobalObjCmd, variable name matching :*} { # Test for Tcl Bug 480176 @@ -362,13 +373,14 @@ test var-6.6 {Tcl_GlobalObjCmd, no-op case (TIP 323)} { p } {} -test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} { +test var-7.1 {Tcl_VariableObjCmd, create and initialize one new ns variable} -setup { catch {namespace delete test_ns_var} +} -body { namespace eval test_ns_var { variable one 1 } list [info vars test_ns_var::*] [set test_ns_var::one] -} {::test_ns_var::one 1} +} -result {::test_ns_var::one 1} test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} { set two 2222222 namespace eval test_ns_var { @@ -390,10 +402,11 @@ test var-7.4 {Tcl_VariableObjCmd, list of vars} { 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] -test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} { +test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { catch {unset a} catch {unset five} catch {unset six} +} -body { set a "" set five 555 set six 666 @@ -403,23 +416,25 @@ test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} { } lappend a $test_ns_var::five \ [set test_ns_var::six 6] [set test_ns_var::six] $six +} -cleanup { catch {unset five} catch {unset six} - set a -} {5 5 6 6 666} -catch {unset newvar} -test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} { +} -result {5 5 6 6 666} +test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} -setup { + catch {unset newvar} +} -body { namespace eval test_ns_var { variable ::newvar cheers! } - set newvar -} {cheers!} -catch {unset newvar} -test var-7.7 {Tcl_VariableObjCmd, bad var name} { + return $newvar +} -cleanup { + catch {unset newvar} +} -result {cheers!} +test var-7.7 {Tcl_VariableObjCmd, bad var name} -returnCodes error -body { namespace eval test_ns_var { - list [catch {variable sev:::en 7} msg] $msg + variable sev:::en 7 } -} {1 {can't define "sev:::en": parent namespace doesn't exist}} +} -result {can't define "sev:::en": parent namespace doesn't exist} test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} { set a "" namespace eval test_ns_var { @@ -430,8 +445,9 @@ test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, l } set a } {8 8} -test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} { +test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} -setup { catch {namespace delete test_ns_var2} +} -body { set a "" namespace eval test_ns_var2 { variable x 123 @@ -451,8 +467,7 @@ test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until na lappend a [info exists test_ns_var2::y] [info exists test_ns_var2::z] lappend a [list [catch {unset test_ns_var2::z} msg] $msg] lappend a [namespace delete test_ns_var2] - set a -} [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\ +} -result [list [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 1 0 0\ {1 {can't read "test_ns_var2::y": no such variable}}\ [lsort {::test_ns_var2::x ::test_ns_var2::y ::test_ns_var2::z}] 0 0\ hello 1 0\ @@ -496,20 +511,16 @@ test var-7.13 {Tcl_VariableObjCmd, variable named ":"} { p } } {{My name is ":"} :} -test var-7.14 {Tcl_VariableObjCmd, array element parameter} { - catch {namespace eval test_ns_var { variable arrayvar(1) }} res - set res -} "can't define \"arrayvar(1)\": name refers to an element in an array" -test var-7.15 {Tcl_VariableObjCmd, array element parameter} { - catch { - namespace eval test_ns_var { - variable arrayvar - set arrayvar(1) x - variable arrayvar(1) y - } - } res - set res -} "can't define \"arrayvar(1)\": name refers to an element in an array" +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 { + 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 } {} @@ -519,158 +530,173 @@ test var-7.17 {Tcl_VariableObjCmd, no args (TIP 323)} { } } {} -test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} { +test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} -setup { catch {namespace delete test_ns_var} catch {unset a} +} -body { namespace eval test_ns_var { variable v 123 variable info "" - proc traceUnset {name1 name2 op} { variable info set info [concat $info [list $name1 $name2 $op]] } - trace var v u [namespace code traceUnset] } list [unset test_ns_var::v] $test_ns_var::info -} {{} {test_ns_var::v {} u}} - -test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} { +} -result {{} {test_ns_var::v {} u}} +test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} -setup { catch {namespace delete test_ns_var} catch {unset a} +} -body { set info "" namespace eval test_ns_var { variable v 123 1 trace var v u ::traceUnset } - proc traceUnset {name1 name2 op} { set ::info [concat $::info [list $name1 $name2 $op]] } - list [namespace delete test_ns_var] $::info -} {{} {::test_ns_var::v {} u}} +} -result {{} {::test_ns_var::v {} u}} -test var-9.1 {behaviour of TclGet/SetVar simple get/set} testsetnoerr { - catch {unset u}; catch {unset v} +test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup { + catch {unset u} + catch {unset v} +} -constraints testsetnoerr -body { list \ - [set u a; testsetnoerr u] \ - [testsetnoerr v b] \ - [testseterr u] \ - [unset v; testseterr v b] -} [list {before get a} {before set b} {before get a} {before set b}] -test var-9.2 {behaviour of TclGet/SetVar namespace get/set} testsetnoerr { + [set u a; testsetnoerr u] \ + [testsetnoerr v b] \ + [testseterr u] \ + [unset v; testseterr v b] +} -result [list {before get a} {before set b} {before get a} {before set b}] +test var-9.2 {behaviour of TclGet/SetVar namespace get/set} -setup { catch {namespace delete ns} +} -constraints testsetnoerr -body { namespace eval ns {variable u a; variable v} list \ - [testsetnoerr ns::u] \ - [testsetnoerr ns::v b] \ - [testseterr ns::u] \ - [unset ns::v; testseterr ns::v b] -} [list {before get a} {before set b} {before get a} {before set b}] -test var-9.3 {behaviour of TclGetVar no variable} testsetnoerr { + [testsetnoerr ns::u] \ + [testsetnoerr ns::v b] \ + [testseterr ns::u] \ + [unset ns::v; testseterr ns::v b] +} -result [list {before get a} {before set b} {before get a} {before set b}] +test var-9.3 {behaviour of TclGetVar no variable} -setup { catch {unset u} +} -constraints testsetnoerr -body { list \ - [catch {testsetnoerr u} res] $res \ - [catch {testseterr u} res] $res -} {1 {before get} 1 {can't read "u": no such variable}} -test var-9.4 {behaviour of TclGetVar no namespace variable} testsetnoerr { + [catch {testsetnoerr u} res] $res \ + [catch {testseterr u} res] $res +} -result {1 {before get} 1 {can't read "u": no such variable}} +test var-9.4 {behaviour of TclGetVar no namespace variable} -setup { catch {namespace delete ns} +} -constraints testsetnoerr -body { namespace eval ns {} list \ - [catch {testsetnoerr ns::w} res] $res \ - [catch {testseterr ns::w} res] $res -} {1 {before get} 1 {can't read "ns::w": no such variable}} -test var-9.5 {behaviour of TclGetVar no namespace} testsetnoerr { + [catch {testsetnoerr ns::w} res] $res \ + [catch {testseterr ns::w} res] $res +} -result {1 {before get} 1 {can't read "ns::w": no such variable}} +test var-9.5 {behaviour of TclGetVar no namespace} -setup { catch {namespace delete ns} +} -constraints testsetnoerr -body { list \ - [catch {testsetnoerr ns::u} res] $res \ - [catch {testseterr ns::v} res] $res -} {1 {before get} 1 {can't read "ns::v": no such variable}} -test var-9.6 {behaviour of TclSetVar no namespace} testsetnoerr { + [catch {testsetnoerr ns::u} res] $res \ + [catch {testseterr ns::v} res] $res +} -result {1 {before get} 1 {can't read "ns::v": no such variable}} +test var-9.6 {behaviour of TclSetVar no namespace} -setup { catch {namespace delete ns} +} -constraints testsetnoerr -body { list \ - [catch {testsetnoerr ns::v 1} res] $res \ - [catch {testseterr ns::v 1} res] $res -} {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} -test var-9.7 {behaviour of TclGetVar array variable} testsetnoerr { + [catch {testsetnoerr ns::v 1} res] $res \ + [catch {testseterr ns::v 1} res] $res +} -result {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} +test var-9.7 {behaviour of TclGetVar array variable} -setup { catch {unset arr} - set arr(1) 1; +} -constraints testsetnoerr -body { + set arr(1) 1 list \ - [catch {testsetnoerr arr} res] $res \ - [catch {testseterr arr} res] $res -} {1 {before get} 1 {can't read "arr": variable is array}} -test var-9.8 {behaviour of TclSetVar array variable} testsetnoerr { + [catch {testsetnoerr arr} res] $res \ + [catch {testseterr arr} res] $res +} -result {1 {before get} 1 {can't read "arr": variable is array}} +test var-9.8 {behaviour of TclSetVar array variable} -setup { catch {unset arr} +} -constraints testsetnoerr -body { set arr(1) 1 list \ - [catch {testsetnoerr arr 2} res] $res \ - [catch {testseterr arr 2} res] $res -} {1 {before set} 1 {can't set "arr": variable is array}} -test var-9.9 {behaviour of TclGetVar read trace success} testsetnoerr { + [catch {testsetnoerr arr 2} res] $res \ + [catch {testseterr arr 2} res] $res +} -result {1 {before set} 1 {can't set "arr": variable is array}} +test var-9.9 {behaviour of TclGetVar read trace success} -setup { + catch {unset u} + catch {unset v} +} -constraints testsetnoerr -body { proc resetvar {val name elem op} {upvar 1 $name v; set v $val} - catch {unset u}; catch {unset v} set u 10 trace var u r [list resetvar 1] trace var v r [list resetvar 2] list \ - [testsetnoerr u] \ - [testseterr v] -} {{before get 1} {before get 2}} + [testsetnoerr u] \ + [testseterr v] +} -result {{before get 1} {before get 2}} test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr { proc writeonly args {error "write-only"} set v 456 trace var v r writeonly list \ - [catch {testsetnoerr v} msg] $msg \ - [catch {testseterr v} msg] $msg + [catch {testsetnoerr v} msg] $msg \ + [catch {testseterr v} msg] $msg } {1 {before get} 1 {can't read "v": write-only}} -test var-9.11 {behaviour of TclSetVar write trace success} testsetnoerr { +test var-9.11 {behaviour of TclSetVar write trace success} -setup { + catch {unset u} + catch {unset v} +} -constraints testsetnoerr -body { proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} - catch {unset u}; catch {unset v} set v 1 trace var v w doubleval trace var u w doubleval list \ - [testsetnoerr u 2] \ - [testseterr v 3] -} {{before set 4} {before set 6}} + [testsetnoerr u 2] \ + [testseterr v 3] +} -result {{before set 4} {before set 6}} test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr { proc readonly args {error "read-only"} set v 456 trace var v w readonly list \ - [catch {testsetnoerr v 2} msg] $msg $v \ - [catch {testseterr v 3} msg] $msg $v + [catch {testsetnoerr v 2} msg] $msg $v \ + [catch {testseterr v 3} msg] $msg $v } {1 {before set} 2 1 {can't set "v": read-only} 3} -test var-10.1 {can't nest arrays with array set} { +test var-10.1 {can't nest arrays with array set} -setup { catch {unset arr} - list [catch {array set arr(x) {a 1 b 2}} res] $res -} {1 {can't set "arr(x)": variable isn't array}} -test var-10.2 {can't nest arrays with array set} { +} -returnCodes error -body { + array set arr(x) {a 1 b 2} +} -result {can't set "arr(x)": variable isn't array} +test var-10.2 {can't nest arrays with array set} -setup { catch {unset arr} - list [catch {array set arr(x) {}} res] $res -} {1 {can't set "arr(x)": variable isn't array}} +} -returnCodes error -body { + array set arr(x) {} +} -result {can't set "arr(x)": variable isn't array} -test var-11.1 {array unset} { +test var-11.1 {array unset} -setup { catch {unset a} +} -body { array set a { 1,1 a 1,2 b 2,1 c 2,3 d } array unset a 1,* lsort -dict [array names a] -} {2,1 2,3} -test var-11.2 {array unset} { +} -result {2,1 2,3} +test var-11.2 {array unset} -setup { catch {unset a} +} -body { array set a { 1,1 a 1,2 b } array unset a array exists a -} 0 -test var-11.3 {array unset errors} { +} -result 0 +test var-11.3 {array unset errors} -setup { catch {unset a} +} -returnCodes error -body { array set a { 1,1 a 1,2 b } - list [catch {array unset a pattern too} msg] $msg -} {1 {wrong # args: should be "array unset arrayName ?pattern?"}} + array unset a pattern too +} -result {wrong # args: should be "array unset arrayName ?pattern?"} test var-12.1 {TclFindCompiledLocals, {} array name} { namespace eval n { @@ -687,8 +713,9 @@ test var-12.1 {TclFindCompiledLocals, {} array name} { } } {0 1 2 2,foo} -test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} { +test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup { catch {unset t} +} -body { proc foo {var ind op} { global t set foo bar @@ -699,15 +726,14 @@ test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} { unset t } set x "If you see this, it worked" -} "If you see this, it worked" +} -result "If you see this, it worked" test var-14.1 {array names syntax} -body { array names foo bar baz snafu } -returnCodes 1 -match glob -result * - test var-14.2 {array names -glob} -body { array names tcl_platform -glob os -} -returnCodes 0 -match exact -result os +} -result os test var-15.1 {segfault in [unset], [Bug 735335]} { proc A { name } { @@ -723,7 +749,6 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { namespace eval test unset useSomeUnlikelyNameHere } {} - test var-16.1 {CallVarTraces: save/restore interp error state} { trace add variable ::errorCode write " ;#" catch {error foo bar baz} @@ -763,7 +788,6 @@ test var-18.1 {array unset and unset traces: Bug 2939073} -setup { unset x already } -result 0 - test var-19.1 {crash when freeing locals hashtable: Bug 3037525} { proc foo {} { catch {upvar 0 dummy \$index} } foo ; # This crashes without the fix for the bug diff --git a/tests/while-old.test b/tests/while-old.test index 12e8537..ee17d0b 100644 --- a/tests/while-old.test +++ b/tests/while-old.test @@ -12,8 +12,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: while-old.test,v 1.8 2006/10/09 19:15:45 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/while.test b/tests/while.test index 323e160..642ec93 100644 --- a/tests/while.test +++ b/tests/while.test @@ -9,8 +9,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: while.test,v 1.14 2009/10/30 16:28:02 dkf Exp $ if {"::tcltest" ni [namespace children]} { package require tcltest 2 diff --git a/tests/winConsole.test b/tests/winConsole.test index 51c1781..fdde41c 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -8,8 +8,6 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: winConsole.test,v 1.8 2006/11/03 00:34:53 hobbs Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest diff --git a/tests/winDde.test b/tests/winDde.test index f59a7f2..f04fb45 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -8,26 +8,21 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: winDde.test,v 1.28 2005/05/10 18:35:25 kennykb Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 #tcltest::configure -verbose {pass start} namespace import -force ::tcltest::* } +testConstraint debug [::tcl::pkgconfig get debug] +testConstraint dde 0 if {[testConstraint win]} { - if [catch { - # Is the dde extension already static to this shell? - if [catch {load {} Dde; set ::ddelib {}}] { - # try the location given to use on the commandline to tcltest + if {![catch { ::tcltest::loadTestedCommands - load $::ddelib Dde - } + set ::ddever [package require dde 1.4.0] + set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} { testConstraint dde 1 - }] { - testConstraint dde 0 } } @@ -38,22 +33,20 @@ if {[testConstraint win]} { set scriptName [makeFile {} script1.tcl] -proc createChildProcess { ddeServerName {handler {}}} { +proc createChildProcess {ddeServerName args} { file delete -force $::scriptName set f [open $::scriptName w+] puts $f [list set ddeServerName $ddeServerName] - if {$::ddelib != ""} { - puts $f [list load $::ddelib Dde] - } + puts $f [list load $::ddelib dde] puts $f { # DDE child server - # - if {[lsearch [namespace children] ::tcltest] == -1} { + if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } - + # If an error occurs during the tests, this process may end up not # being closed down. To deal with this we create a 30s timeout. proc ::DoTimeout {} { @@ -63,16 +56,19 @@ proc createChildProcess { ddeServerName {handler {}}} { flush stdout } set timeout [after 30000 ::DoTimeout] - + # Define a restricted handler. proc Handler1 {cmd} { if {$cmd eq "stop"} {set ::done 1} - puts $cmd ; flush stdout + if {$cmd == ""} { + set cmd "null data" + } + puts $cmd ; flush stdout return } proc Handler2 {cmd} { if {$cmd eq "stop"} {set ::done 1} - puts [uplevel \#0 $cmd] ; flush stdout + puts [uplevel \#0 $cmd] ; flush stdout return } proc Handler3 {prefix cmd} { @@ -82,11 +78,7 @@ proc createChildProcess { ddeServerName {handler {}}} { } } # set the dde server name to the supplied argument. - if {$handler == {}} { - puts $f [list dde servername $ddeServerName] - } else { - puts $f [list dde servername -handler $handler -- $ddeServerName] - } + puts $f [list dde servername {*}$args -- $ddeServerName] puts $f { # run the server and handle final cleanup. after 200;# give dde a chance to get going. @@ -96,12 +88,12 @@ proc createChildProcess { ddeServerName {handler {}}} { # allow enough time for the calling process to # claim all results, to avoid spurious "server did # not respond" - after 200 { set reallyDone 1 } + after 200 {set reallyDone 1} vwait reallyDone exit } close $f - + # run the child server script. set f [open |[list [interpreter] $::scriptName] r] fconfigure $f -buffering line @@ -110,147 +102,184 @@ proc createChildProcess { ddeServerName {handler {}}} { } # ------------------------------------------------------------------------- +test winDde-1.0 {check if we are testing the right dll} {win dde} { + set ::ddever +} {1.4.0} -test winDde-1.1 {Settings the server's topic name} {win dde} { +test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] -} {foobar foobar self} +} -result {foobar foobar self} -test winDde-2.1 {Checking for other services} {win dde} { +test winDde-2.1 {Checking for other services} -constraints dde -body { expr [llength [dde services {} {}]] >= 0 -} 1 +} -result 1 test winDde-2.2 {Checking for existence, with service and topic specified} \ - {win dde} { + -constraints dde -body { llength [dde services TclEval self] -} 1 +} -result 1 test winDde-2.3 {Checking for existence, with only the service specified} \ - {win dde} { + -constraints dde -body { expr [llength [dde services TclEval {}]] >= 1 -} 1 +} -result 1 test winDde-2.4 {Checking for existence, with only the topic specified} \ - {win dde} { + -constraints dde -body { expr [llength [dde services {} self]] >= 1 -} 1 +} -result 1 # ------------------------------------------------------------------------- -test winDde-3.1 {DDE execute locally} {win dde} { - set a "" - dde execute TclEval self {set a "foo"} - set a -} foo -test winDde-3.2 {DDE execute -async locally} {win dde} { - set a "" - dde execute -async TclEval self {set a "foo"} +test winDde-3.1 {DDE execute locally} -constraints dde -body { + set \xe1 "" + dde execute TclEval self [list set \xe1 foo] + set \xe1 +} -result foo +test winDde-3.2 {DDE execute -async locally} -constraints dde -body { + set \xe1 "" + dde execute -async TclEval self [list set \xe1 foo] update - set a -} foo -test winDde-3.3 {DDE request locally} {win dde} { - set a "" - dde execute TclEval self {set a "foo"} - dde request TclEval self a -} foo -test winDde-3.4 {DDE eval locally} {win dde} { - set a "" - dde eval self set a "foo" -} foo -test winDde-3.5 {DDE request locally} {win dde} { - set a "" - dde execute TclEval self {set a "foo"} - dde request -binary TclEval self a -} "foo\x00" + set \xe1 +} -result foo +test winDde-3.3 {DDE request locally} -constraints dde -body { + set \xe1 "" + dde execute TclEval self [list set \xe1 foo] + dde request TclEval self \xe1 +} -result foo +test winDde-3.4 {DDE eval locally} -constraints dde -body { + set \xe1 "" + dde eval self set \xe1 foo +} -result foo +test winDde-3.5 {DDE request locally} -constraints dde -body { + set \xe1 "" + dde execute TclEval self [list set \xe1 foo] + 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 { + 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 \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 # ------------------------------------------------------------------------- -test winDde-4.1 {DDE execute remotely} {stdio win dde} { - set a "" - set name child-4.1 +test winDde-4.1 {DDE execute remotely} -constraints {dde stdio} -body { + set \xe1 "" + set name ch\xEDld-4.1 set child [createChildProcess $name] - dde execute TclEval $name {set a "foo"} + dde execute TclEval $name [list set \xe1 foo] dde execute TclEval $name {set done 1} update - set a -} "" -test winDde-4.2 {DDE execute async remotely} {stdio win dde} { - set a "" - set name child-4.2 + set \xe1 +} -result "" +test winDde-4.2 {DDE execute async remotely} -constraints {dde stdio} -body { + set \xe1 "" + set name ch\xEDld-4.2 set child [createChildProcess $name] - dde execute -async TclEval $name {set a "foo"} + dde execute -async TclEval $name [list set \xe1 foo] update dde execute TclEval $name {set done 1} update - set a -} "" -test winDde-4.3 {DDE request remotely} {stdio win dde} { - set a "" - set name chile-4.3 + set \xe1 +} -result "" +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 {set a "foo"} - set a [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 a -} foo -test winDde-4.4 {DDE eval remotely} {stdio win dde} { - set a "" - set name child-4.4 + set \xe1 +} -result foo +test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body { + set \xe1 "" + set name ch\xEDld-4.4 set child [createChildProcess $name] - set a [dde eval $name set a "foo"] + set \xe1 [dde eval $name set \xe1 foo] dde execute TclEval $name {set done 1} update - set a -} foo + 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 # ------------------------------------------------------------------------- -test winDde-5.1 {check for bad arguments} -constraints {win dde} -body { +test winDde-5.1 {check for bad arguments} -constraints dde -body { dde execute "" "" "" "" -} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"} -test winDde-5.2 {check for bad arguments} -constraints {win dde} -body { - dde execute "" "" "" +} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"} +test winDde-5.2 {check for bad arguments} -constraints dde -body { + dde execute -binary "" "" "" } -returnCodes error -result {cannot execute null data} -test winDde-5.3 {check for bad arguments} -constraints {win dde} -body { +test winDde-5.3 {check for bad arguments} -constraints dde -body { dde execute -foo "" "" "" -} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"} -test winDde-5.4 {DDE eval bad arguments} -constraints {win dde} -body { +} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"} +test winDde-5.4 {DDE eval bad arguments} -constraints dde -body { dde eval "" "foo" } -returnCodes error -result {invalid service name ""} # ------------------------------------------------------------------------- -test winDde-6.1 {DDE servername bad arguments} -constraints {win dde} -body { +test winDde-6.1 {DDE servername bad arguments} -constraints dde -body { dde servername -z -z -z } -returnCodes error -result {bad option "-z": must be -force, -handler, or --} -test winDde-6.2 {DDE servername set name} -constraints {win dde} -body { +test winDde-6.2 {DDE servername set name} -constraints dde -body { dde servername -- winDde-6.2 } -result {winDde-6.2} -test winDde-6.3 {DDE servername set exact name} -constraints {win dde} -body { +test winDde-6.3 {DDE servername set exact name} -constraints dde -body { dde servername -force winDde-6.3 } -result {winDde-6.3} -test winDde-6.4 {DDE servername set exact name} -constraints {win dde} -body { +test winDde-6.4 {DDE servername set exact name} -constraints dde -body { dde servername -force -- winDde-6.4 } -result {winDde-6.4} -test winDde-6.5 {DDE remote servername collision} -constraints {stdio win dde} -setup { - set name child-6.5 +test winDde-6.5 {DDE remote servername collision} -constraints {dde stdio} -setup { + set name ch\xEDld-6.5 set child [createChildProcess $name] } -body { dde servername -- $name } -cleanup { dde execute TclEval $name {set done 1} update -} -result "child-6.5 #2" -test winDde-6.6 {DDE remote servername collision force} -constraints {stdio win dde} -setup { - set name child-6.6 +} -result "ch\xEDld-6.5 #2" +test winDde-6.6 {DDE remote servername collision force} -constraints {dde stdio} -setup { + set name ch\xEDld-6.6 set child [createChildProcess $name] } -body { dde servername -force -- $name } -cleanup { dde execute TclEval $name {set done 1} update -} -result {child-6.6} +} -result "ch\xEDld-6.6" # ------------------------------------------------------------------------- -test winDde-7.1 {Load DDE in slave interpreter } -constraints {win dde} -setup { +test winDde-7.1 {Load DDE in slave interpreter} -constraints dde -setup { interp create slave } -body { slave eval [list load $::ddelib Dde] @@ -258,7 +287,7 @@ test winDde-7.1 {Load DDE in slave interpreter } -constraints {win dde} -setup { } -cleanup { interp delete slave } -result {dde-interp-7.1} -test winDde-7.2 {DDE slave cleanup} -constraints {win dde} -setup { +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] @@ -267,11 +296,11 @@ test winDde-7.2 {DDE slave cleanup} -constraints {win dde} -setup { dde services TclEval {} set s [dde services TclEval {}] set m [list [list TclEval dde-interp-7.5]] - if {[lsearch -exact $s $m] != -1} { + if {$m in $s} { set s } } -result {} -test winDde-7.3 {DDE present in slave interp} -constraints {win dde} -setup { +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] @@ -280,7 +309,7 @@ test winDde-7.3 {DDE present in slave interp} -constraints {win dde} -setup { } -cleanup { interp delete slave } -result {{TclEval dde-interp-7.3}} -test winDde-7.4 {interp name collision with -force} -constraints {win dde} -setup { +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] @@ -289,7 +318,7 @@ test winDde-7.4 {interp name collision with -force} -constraints {win dde} -setu } -cleanup { interp delete slave } -result {dde-interp-7.4} -test winDde-7.5 {interp name collision without -force} -constraints {win dde} -setup { +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] @@ -301,7 +330,7 @@ test winDde-7.5 {interp name collision without -force} -constraints {win dde} -s # ------------------------------------------------------------------------- -test winDde-8.1 {Safe DDE load} -constraints {win dde} -setup { +test winDde-8.1 {Safe DDE load} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde } -body { @@ -309,20 +338,20 @@ test winDde-8.1 {Safe DDE load} -constraints {win dde} -setup { } -cleanup { interp delete slave } -returnCodes error -result {invalid command name "dde"} -test winDde-8.2 {Safe DDE set servername} -constraints {win dde} -setup { +test winDde-8.2 {Safe DDE set servername} -constraints dde -setup { interp create -safe slave slave invokehidden load $::ddelib Dde } -body { slave invokehidden dde servername slave } -cleanup {interp delete slave} -result {slave} -test winDde-8.3 {Safe DDE check handler required for eval} -constraints {win dde} -setup { +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 } -body { catch {dde eval slave set a 1} msg } -cleanup {interp delete slave} -result {1} -test winDde-8.4 {Safe DDE check that execute is denied} -constraints {win dde} -setup { +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 @@ -331,7 +360,7 @@ test winDde-8.4 {Safe DDE check that execute is denied} -constraints {win dde} - dde execute TclEval slave {set a 2} slave eval set a } -cleanup {interp delete slave} -result 1 -test winDde-8.5 {Safe DDE check that request is denied} -constraints {win dde} -setup { +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 @@ -341,14 +370,14 @@ test winDde-8.5 {Safe DDE check that request is denied} -constraints {win dde} - } -cleanup { interp delete slave } -returnCodes error -result {remote server cannot handle this command} -test winDde-8.6 {Safe DDE assign handler procedure} -constraints {win dde} -setup { +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}} } -body { slave invokehidden dde servername -handler DDEACCEPT slave } -cleanup {interp delete slave} -result slave -test winDde-8.7 {Safe DDE check simple command} -constraints {win dde} -setup { +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}} @@ -356,7 +385,7 @@ test winDde-8.7 {Safe DDE check simple command} -constraints {win dde} -setup { } -body { dde eval slave set x 1 } -cleanup {interp delete slave} -result {set x 1} -test winDde-8.8 {Safe DDE check non-list command} -constraints {win dde} -setup { +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}} @@ -366,16 +395,16 @@ test winDde-8.8 {Safe DDE check non-list command} -constraints {win dde} -setup dde eval slave $s string equal [slave eval set DDECMD] $s } -cleanup {interp delete slave} -result 1 -test winDde-8.9 {Safe DDE check command evaluation} -constraints {win dde} -setup { +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 } -body { - dde eval slave set x 1 - slave eval set x + dde eval slave set \xe1 1 + slave eval set \xe1 } -cleanup {interp delete slave} -result 1 -test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints {win dde} -setup { +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]}} @@ -384,7 +413,7 @@ test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints {win dde} dde eval slave [list set x 1] slave eval set x } -cleanup {interp delete slave} -result 1 -test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints {win dde} -setup { +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]}} @@ -396,9 +425,9 @@ test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints {win dde} # ------------------------------------------------------------------------- -test winDde-9.1 {External safe DDE check string passing} -constraints {win dde stdio} -setup { - set name child-9.1 - set child [createChildProcess $name Handler1] +test winDde-9.1 {External safe DDE check string passing} -constraints {dde stdio} -setup { + set name ch\xEDld-9.1 + set child [createChildProcess $name -handler Handler1] file copy -force script1.tcl dde-script.tcl } -body { dde eval $name set x 1 @@ -409,9 +438,9 @@ test winDde-9.1 {External safe DDE check string passing} -constraints {win dde s update file delete -force -- dde-script.tcl } -result {set x 1} -test winDde-9.2 {External safe DDE check command evaluation} -constraints {win dde stdio} -setup { - set name child-9.2 - set child [createChildProcess $name Handler2] +test winDde-9.2 {External safe DDE check command evaluation} -constraints {dde stdio} -setup { + set name ch\xEDld-9.2 + set child [createChildProcess $name -handler Handler2] file copy -force script1.tcl dde-script.tcl } -body { dde eval $name set x 1 @@ -422,9 +451,9 @@ test winDde-9.2 {External safe DDE check command evaluation} -constraints {win d update file delete -force -- dde-script.tcl } -result 1 -test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {win dde stdio} -setup { - set name child-9.3 - set child [createChildProcess $name [list Handler3 ARG]] +test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {dde stdio} -setup { + set name ch\xEDld-9.3 + set child [createChildProcess $name -handler [list Handler3 ARG]] file copy -force script1.tcl dde-script.tcl } -body { dde eval $name set x 1 @@ -435,6 +464,19 @@ test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {win d update file delete -force -- dde-script.tcl } -result {ARG {set x 1}} +test winDde-9.4 {External safe DDE check null data passing} -constraints {dde stdio} -setup { + set name ch\xEDld-9.4 + set child [createChildProcess $name -handler Handler1] + file copy -force script1.tcl dde-script.tcl +} -body { + dde execute TclEval $name "" + gets $child line + set line +} -cleanup { + dde execute TclEval $name stop + update + file delete -force -- dde-script.tcl +} -result {null data} # ------------------------------------------------------------------------- diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 7736985..28a0e9f 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -9,15 +9,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: winFCmd.test,v 1.46 2009/11/10 20:40:06 patthoyts Exp $ -# if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Initialise the test constraints testConstraint winVista 0 diff --git a/tests/winFile.test b/tests/winFile.test index d502b30..fba9bcb 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -9,8 +9,6 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: winFile.test,v 1.22 2008/10/23 12:18:47 das Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." @@ -18,6 +16,9 @@ if {[catch {package require tcltest 2.0.2}]} { } namespace import -force ::tcltest::* +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint notNTFS 0 testConstraint win2000 0 diff --git a/tests/winNotify.test b/tests/winNotify.test index 09ddc1c..3e9aa29 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.test @@ -9,14 +9,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: winNotify.test,v 1.10 2004/06/23 15:36:59 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testeventloop [expr {[info commands testeventloop] != {}}] # There is no explicit test for InitNotifier or NotifierExitHandler diff --git a/tests/winPipe.test b/tests/winPipe.test index a2df9b6..d2e804d 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -9,15 +9,18 @@ # Copyright (c) 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. -# -# RCS: @(#) $Id: winPipe.test,v 1.33 2006/11/03 15:31:26 dkf Exp $ +# 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::* unset -nocomplain path +catch { + ::tcltest::loadTestedCommands + package require -exact Tcltest [info patchlevel] + set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] +} set bindir [file join [pwd] [file dirname [info nameofexecutable]]] set cat32 [file join $bindir cat32.exe] @@ -26,6 +29,8 @@ 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]] + set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n append big $big @@ -60,7 +65,7 @@ set path(more) [makeFile { set path(stdout) [makeFile {} stdout] set path(stderr) [makeFile {} stderr] - + test winpipe-1.1 {32 bit comprehensive tests: from little file} {win exec cat32} { exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] @@ -70,15 +75,15 @@ test winpipe-1.2 {32 bit comprehensive tests: from big file} {win exec cat32} { 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} { - exec [interpreter] more < little | $cat32 > $path(stdout) 2> $path(stderr) + 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} { - exec [interpreter] more < big | $cat32 > $path(stdout) 2> $path(stderr) + 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 big |& $cat32 > $path(stdout) 2> $path(stderr) + 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} \ @@ -173,7 +178,6 @@ test winpipe-1.22 {Checking command.com for Win95/98 hanging} {win 95 exec} { exec command.com /c dir /b set result 1 } 1 -file delete more test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { proc readResults {f} { @@ -186,8 +190,7 @@ test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { set result "$result$line" } } - - set f [open "|[list $cat32] < big 2> $path(stderr)" r] + set f [open "|[list $cat32] < $path(big) 2> $path(stderr)" r] fconfigure $f -buffering none -blocking 0 fileevent $f readable "readResults $f" set x 0 @@ -195,30 +198,34 @@ 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} { +test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] + puts $f "load $::tcltestlib Tcltest" puts $f "testexcept float_underflow" 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} { +test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] + puts $f "load $::tcltestlib Tcltest" puts $f "testexcept access_violation" 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} { +test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] + puts $f "load $::tcltestlib Tcltest" puts $f "testexcept illegal_instruction" 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} { +test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] + puts $f "load $::tcltestlib Tcltest" puts $f "testexcept ctrl+c" set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] @@ -236,9 +243,9 @@ set env(TEMP) c:/ test winpipe-5.1 {TclpCreateTempFile: cleanup temp files} {win exec} { set x {} set existing [glob -nocomplain c:/tcl*.tmp] - exec [interpreter] < nothing + exec [interpreter] < $path(nothing) foreach p [glob -nocomplain c:/tcl*.tmp] { - if {[lsearch $existing $p] == -1} { + if {$p ni $existing} { lappend x $p } } @@ -249,7 +256,7 @@ test winpipe-5.2 {TclpCreateTempFile: TMP and TEMP not defined} {win exec} { set temp $env(TEMP) unset env(TMP) unset env(TEMP) - exec [interpreter] < nothing + exec [interpreter] < $path(nothing) set env(TMP) $tmp set env(TEMP) $temp set x {} @@ -258,7 +265,7 @@ test winpipe-5.3 {TclpCreateTempFile: TMP specifies non-existent directory} \ {win exec } { set tmp $env(TMP) set env(TMP) snarky - exec [interpreter] < nothing + exec [interpreter] < $path(nothing) set env(TMP) $tmp set x {} } {} @@ -268,7 +275,7 @@ test winpipe-5.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \ set temp $env(TEMP) unset env(TMP) set env(TEMP) snarky - exec [interpreter] < nothing + exec [interpreter] < $path(nothing) set env(TMP) $tmp set env(TEMP) $temp set x {} @@ -313,7 +320,6 @@ set path(echoArgs.tcl) [makeFile { puts "[list $argv0 $argv]" } echoArgs.tcl] - ### validate the raw output of BuildCommandLine(). ### test winpipe-7.1 {BuildCommandLine: null arguments} {win exec} { @@ -430,7 +436,7 @@ test winpipe-8.18 {BuildCommandLine/parse_cmdline pass-thru: special chars #2} { 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]] - + # restore old values for env(TMP) and env(TEMP) if {[catch {set env(TMP) $env_tmp}]} { @@ -441,6 +447,16 @@ if {[catch {set env(TEMP) $env_temp}]} { } # cleanup -file delete big little stdout stderr nothing echoArgs.tcl +removeFile little +removeFile big +removeFile more +removeFile stdout +removeFile stderr +removeFile nothing +removeFile echoArgs.tcl ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/winTime.test b/tests/winTime.test index 00cf4d8..add8f98 100644 --- a/tests/winTime.test +++ b/tests/winTime.test @@ -9,14 +9,15 @@ # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: winTime.test,v 1.10 2004/06/23 15:36:59 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testwinclock [llength [info commands testwinclock]] # The next two tests will crash on Windows if the check for negative diff --git a/tests/zlib.test b/tests/zlib.test index 6159e65..891dba0 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -9,10 +9,8 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: zlib.test,v 1.12 2010/02/26 00:39:29 patthoyts Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -25,6 +23,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 zlib +} -result 2.0 test zlib-2.1 {zlib compress/decompress} zlib { zlib decompress [zlib compress abcdefghijklm] @@ -72,7 +76,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 @@ -105,6 +109,22 @@ test zlib-7.4 {zlib stream} zlib { $s close lappend result $data } {{} 1 abcdeEDCBA} +test zlib-7.5 {zlib stream} zlib { + set s [zlib stream gzip] + $s put -finalize abcdeEDCBA.. + set data [$s get] + set result [list [$s get] [format %x [$s checksum]]] + $s close + lappend result [zlib gunzip $data] +} {{} 69f34b6a abcdeEDCBA..} +test zlib-7.6 {zlib stream} zlib { + set s [zlib stream gunzip] + $s put -finalize [zlib gzip abcdeEDCBA..] + set data [$s get] + set result [list [$s get] [format %x [$s checksum]]] + $s close + lappend result $data +} {{} 69f34b6a abcdeEDCBA..} test zlib-8.1 {zlib transformation} -constraints zlib -setup { set file [makeFile {} test.gz] @@ -132,7 +152,7 @@ test zlib-8.2 {zlib transformation} -constraints zlib -setup { } -result ok test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - fconfigure $c -translation binary + fconfigure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c }}} 0] @@ -149,6 +169,7 @@ test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup { set ::total [expr {$e eq {} ? $c : $e}] }}} vwait total + after cancel {set total timeout} } finally { close $sin } @@ -158,6 +179,194 @@ test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup { close $srv removeFile $file } -result 81920-->81920 +test zlib-8.4 {transformation and flushing: Bug 3517696} -setup { + set file [makeFile {} test.z] + set fd [open $file w] +} -constraints zlib -body { + zlib push compress $fd + puts $fd "qwertyuiop" + fconfigure $fd -flush sync + puts $fd "qwertyuiop" +} -cleanup { + catch {close $fd} + removeFile $file +} -result {} +test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup { + foreach {r w} [chan pipe] break +} -constraints zlib -body { + set ::res {} + fconfigure $w -buffering none + zlib push compress $w + puts -nonewline $w qwertyuiop + chan configure $w -flush sync + after 500 {puts -nonewline $w asdfghjkl;close $w} + fconfigure $r -blocking 0 -buffering none + zlib push decompress $r + fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}} + after 250 {lappend ::res MIDDLE} + vwait ::done + set ::res +} -cleanup { + catch {close $r} +} -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 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push compress $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $spdyHeaders + chan pop $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 {transformtion 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 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $spdyHeaders + set result [fconfigure $outSide -checksum] + chan pop $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 {transformtion and fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push deflate $outSide -dictionary $spdyDict + fconfigure $outSide -blocking 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $spdyHeaders + chan pop $outSide + set compressed [read $inSide] + catch {zlib inflate $compressed} 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 {transformtion 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 0 -translation binary -buffering none + fconfigure $inSide -blocking 0 -translation binary + puts -nonewline $outSide $spdyHeaders + chan pop $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 {transformtion 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 0 -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 {transformtion 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 0 -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 {transformtion 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 0 -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 {transformtion 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 0 -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-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] set file [makeFile {} test.gz] @@ -176,7 +385,7 @@ test zlib-9.1 "check fcopy with push" -constraints zlib -setup { } -result {copied 81920 size 81920} test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -encoding binary -translation binary + chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c }}} 0] @@ -198,7 +407,7 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { #puts "connection from $a:$p on $c" - chan configure $c -encoding binary -translation binary + chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [string repeat a 81920] close $c }}} 0] @@ -215,6 +424,7 @@ test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup set ::total [expr {$e eq {} ? $c : $e}] }}} vwait ::total + after cancel {set ::total timeout} close $sin; close $fout list read $::total size [file size $file] } -cleanup { @@ -223,7 +433,7 @@ test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup } -returnCodes {ok error} -result {read 81920 size 81920} test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -encoding binary -translation binary + chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c }}} 0] @@ -240,6 +450,7 @@ test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup { set ::total [expr {$e eq {} ? $c : $e}] }}} vwait ::total + after cancel {set ::total timeout} close $sin; close $fout list read $::total size [file size $file] } -cleanup { @@ -248,7 +459,7 @@ test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup { } -result {read 81920 size 81920} test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -encoding binary -translation binary + chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c }}} 0] @@ -273,6 +484,7 @@ test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup { after 1000 {set ::total timeout} fcopy $sin $fout -size 8192 -command [list zlib95copy $sin $fout 0] vwait ::total + after cancel {set ::total timeout} close $sin; close $fout list $::total size [file size $file] } -cleanup { @@ -282,7 +494,7 @@ test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup { } -result {{eof 81920} size 81920} test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary -buffering none -blocking 0 zlib push gzip $c puts -nonewline $c [string repeat hello 100] close $c @@ -291,7 +503,7 @@ test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup { lassign [chan configure $srv -sockname] addr name port after 1000 {set ::total timeout} set s [socket $addr $port] - chan configure $s -translation binary -buffering none + chan configure $s -translation binary zlib push gunzip $s chan event $s readable [list apply {{s} { set d [read $s] @@ -301,6 +513,7 @@ test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup { } }} $s] vwait ::total + after cancel {set ::total timeout} close $s set ::total } -cleanup { @@ -309,7 +522,7 @@ test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup { } -result {eof 500} test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary -buffering none -blocking 0 zlib push compress $c puts -nonewline $c [string repeat hello 100] close $c @@ -318,7 +531,7 @@ test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup { lassign [chan configure $srv -sockname] addr name port after 1000 {set ::total timeout} set s [socket $addr $port] - chan configure $s -translation binary -buffering none + chan configure $s -translation binary zlib push decompress $s chan event $s readable [list apply {{s} { set d [read $s] @@ -328,6 +541,7 @@ test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup { } }} $s] vwait ::total + after cancel {set ::total timeout} close $s set ::total } -cleanup { @@ -336,7 +550,7 @@ test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup { } -result {eof 500} test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary -buffering none -blocking 0 zlib push deflate $c puts -nonewline $c [string repeat hello 100] close $c @@ -345,7 +559,7 @@ test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup { lassign [chan configure $srv -sockname] addr name port after 1000 {set ::total timeout} set s [socket $addr $port] - chan configure $s -translation binary -buffering none + chan configure $s -translation binary zlib push inflate $s chan event $s readable [list apply {{s} { set d [read $s] @@ -355,6 +569,7 @@ test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup { } }} $s] vwait ::total + after cancel {set ::total timeout} close $s set ::total } -cleanup { @@ -364,7 +579,7 @@ test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup { test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup { proc bgerror {s} {set ::total [list error $s]} set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary -buffering none -blocking 0 zlib push gzip $c puts -nonewline $c [string repeat hello 100] close $c @@ -374,7 +589,7 @@ test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup { after 1000 {set ::total timeout} set s [socket $addr $port] try { - chan configure $s -translation binary -buffering none + chan configure $s -translation binary zlib push inflate $s chan event $s readable [list apply {{s} { set d [read $s] @@ -385,6 +600,7 @@ test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup { }} $s] vwait ::total } finally { + after cancel {set ::total timeout} close $s } set ::total @@ -396,7 +612,7 @@ test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup { test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup { proc bgerror {s} {set ::total [list error $s]} set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary -buffering none -blocking 0 zlib push compress $c puts -nonewline $c [string repeat hello 100] close $c @@ -406,7 +622,7 @@ test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup { after 1000 {set ::total timeout} set s [socket $addr $port] try { - chan configure $s -translation binary -buffering none + chan configure $s -translation binary zlib push inflate $s chan event $s readable [list apply {{s} { set d [read $s] @@ -417,6 +633,7 @@ test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup { }} $s] vwait ::total } finally { + after cancel {set ::total timeout} close $s } set ::total @@ -428,7 +645,7 @@ test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup { test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup { proc bgerror {s} {set ::total [list error $s]} set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary -buffering none -blocking 0 zlib push deflate $c puts -nonewline $c [string repeat hello 100] close $c @@ -438,7 +655,7 @@ test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup { after 1000 {set ::total timeout} set s [socket $addr $port] try { - chan configure $s -translation binary -buffering none + chan configure $s -translation binary zlib push gunzip $s chan event $s readable [list apply {{s} { set d [read $s] @@ -449,6 +666,7 @@ test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup { }} $s] vwait ::total } finally { + after cancel {set ::total timeout} close $s } set ::total @@ -463,7 +681,7 @@ test zlib-10.0 "bug #2818131 (close with null interp)" -constraints { } -setup { proc bgerror {s} {set ::total [list error $s]} set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary zlib push inflate $c chan event $c readable [list apply {{c} { set d [read $c] @@ -478,7 +696,7 @@ test zlib-10.0 "bug #2818131 (close with null interp)" -constraints { lassign [chan configure $srv -sockname] addr name port after 1000 {set ::total timeout} set s [socket $addr $port] - chan configure $s -translation binary -buffering none + chan configure $s -translation binary -buffering none -blocking 0 zlib push gzip $s chan event $s xyzzy [list apply {{s} { if {[gets $s line] < 0} { @@ -491,6 +709,8 @@ test zlib-10.0 "bug #2818131 (close with null interp)" -constraints { after 100 {set ::total done} }} $s] vwait ::total + after cancel {set ::total timeout} + after cancel {set ::total done} set ::total } -cleanup { close $srv @@ -510,7 +730,7 @@ test zlib-10.1 "bug #2818131 (mismatch read)" -constraints { } } set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary zlib push inflate $c chan event $c readable [list zlibRead $c] }}} 0] @@ -518,7 +738,7 @@ test zlib-10.1 "bug #2818131 (mismatch read)" -constraints { lassign [chan configure $srv -sockname] addr name port after 1000 {set ::total timeout} set s [socket $addr $port] - chan configure $s -translation binary -buffering none + chan configure $s -translation binary -buffering none -blocking 0 zlib push gzip $s chan event $s readable [list zlibRead $s] after idle [list apply {{s} { @@ -527,6 +747,8 @@ test zlib-10.1 "bug #2818131 (mismatch read)" -constraints { after 100 {set ::total done} }} $s] vwait ::total + after cancel {set ::total timeout} + after cancel {set ::total done} set ::total } -cleanup { close $srv @@ -548,7 +770,7 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints { } } set srv [socket -myaddr localhost -server {apply {{c a p} { - chan configure $c -translation binary -buffering none + chan configure $c -translation binary zlib push inflate $c chan event $c readable [list zlibRead $c] }}} 0] @@ -556,7 +778,7 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints { lassign [chan configure $srv -sockname] addr name port after 1000 {set ::total timeout} set s [socket $addr $port] - chan configure $s -translation binary -buffering none + chan configure $s -translation binary -buffering none -blocking 0 zlib push gzip $s chan event $s readable [list zlibRead $s] after idle [list apply {{s} { @@ -565,12 +787,59 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints { after 100 {set ::total done} }} $s] vwait ::total + after cancel {set ::total timeout} + after cancel {set ::total done} set ::total } -cleanup { close $srv rename bgerror {} rename zlibRead {} } -result {error {invalid block type}} + +test zlib-11.1 "Bug #3390073: mis-appled gzip filtering" -setup { + set file [makeFile {} test.input] +} -constraints zlib -body { + set f [open $file wb] + puts -nonewline [zlib push gzip $f] [string repeat "hello" 1000] + close $f + set f [open $file rb] + set d [read $f] + close $f + set d [zlib gunzip $d] + list [regexp -all "hello" $d] [string length [regsub -all "hello" $d {}]] +} -cleanup { + removeFile $file +} -result {1000 0} +test zlib-11.2 "Bug #3390073: mis-appled gzip filtering" -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 + set d [zlib gunzip $d -header h] + list [regexp -all "hello" $d] [dict get $h filename] \ + [string length [regsub -all "hello" $d {}]] +} -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} ::tcltest::cleanupTests return |