diff options
Diffstat (limited to 'tests')
175 files changed, 7877 insertions, 4875 deletions
diff --git a/tests/aaa_exit.test b/tests/aaa_exit.test index 3ba5167..fffc1cc 100644 --- a/tests/aaa_exit.test +++ b/tests/aaa_exit.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/all.tcl b/tests/all.tcl index 52c8763..8cd0cf4 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -1,17 +1,16 @@ # all.tcl -- # # This file contains a top-level script to run all of the Tcl -# tests. Execute it by invoking "source all.test" when running tcltest +# tests. Execute it by invoking "source all.tcl" when running tcltest # in this directory. # -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2000 by Ajuba Solutions +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2000 Ajuba Solutions # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package prefer latest -package require Tcl 8.5- package require tcltest 2.5 namespace import ::tcltest::* diff --git a/tests/append.test b/tests/append.test index 8fa4e61..f26925f 100644 --- a/tests/append.test +++ b/tests/append.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } unset -nocomplain x @@ -32,7 +32,7 @@ test append-1.3 {append command} { test append-2.1 {long appends} { set x "" - for {set i 0} {$i < 1000} {set i [expr $i+1]} { + for {set i 0} {$i < 1000} {incr i} { append x "foobar " } set y "foobar" @@ -53,6 +53,18 @@ test append-3.3 {append errors} -returnCodes error -body { unset -nocomplain x append x } -result {can't read "x": no such variable} +test append-3.4 {append surrogates} -body { + set x \uD83D + append x \uDE02 +} -result \uD83D\uDE02 +test append-3.5 {append surrogates} -body { + set x \uD83D + set x $x\uDE02 +} -result \uD83D\uDE02 +test append-3.5 {append surrogates} -body { + set x \uDE02 + set x \uD83D$x +} -result \uD83D\uDE02 test append-4.1 {lappend command} { unset -nocomplain x @@ -158,7 +170,7 @@ test append-5.1 {long lappends} -setup { if {$l != $size} { return "length mismatch: should have been $size, was $l" } - for {set i 0} {$i < $size} {set i [expr $i+1]} { + for {set i 0} {$i < $size} {incr i} { set j [lindex $var $i] if {$j ne "item $i"} { return "element $i should have been \"item $i\", was \"$j\"" diff --git a/tests/appendComp.test b/tests/appendComp.test index bbf5f9c..66f2a5c 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } catch {unset x} @@ -41,7 +41,7 @@ test appendComp-1.3 {append command} { test appendComp-2.1 {long appends} { proc foo {} { set x "" - for {set i 0} {$i < 1000} {set i [expr $i+1]} { + for {set i 0} {$i < 1000} {incr i} { append x "foobar " } set y "foobar" @@ -223,7 +223,7 @@ test appendComp-5.1 {long lappends} -setup { } } -body { set x "" - for {set i 0} {$i < 300} {set i [expr $i+1]} { + for {set i 0} {$i < 300} {incr i} { lappend x "item $i" } check $x 300 @@ -359,9 +359,9 @@ test appendComp-7.9 {append var does not trigger read trace} -setup { } -result {0} test appendComp-8.1 {defer error to runtime} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { proc foo {} { proc append args {} append @@ -369,7 +369,7 @@ test appendComp-8.1 {defer error to runtime} -setup { foo } } -cleanup { - interp delete slave + interp delete child } -result {} # New tests for bug 3057639 to show off the more consistent behaviour of diff --git a/tests/apply.test b/tests/apply.test index 597cd97..e2be172 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -4,16 +4,16 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2005-2006 Miguel Sofer +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2005-2006 Miguel Sofer # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -25,7 +25,7 @@ testConstraint memory [llength [info commands memory]] # Tests for wrong number of arguments -test apply-1.1 {too few arguments} -returnCodes error -body { +test apply-1.1 {not enough arguments} -returnCodes error -body { apply } -result {wrong # args: should be "apply lambdaExpr ?arg ...?"} diff --git a/tests/assemble.test b/tests/assemble.test index 5d86c47..55124d0 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -2,8 +2,8 @@ # # Test suite for the 'tcl::unsupported::assemble' command # -# Copyright (c) 2010 by Ozgur Dogan Ugurlu. -# Copyright (c) 2010 by Kevin B. Kenny. +# Copyright © 2010 Ozgur Dogan Ugurlu. +# Copyright © 2010 Kevin B. Kenny. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/assocd.test b/tests/assocd.test index edf55c4..9a200ae 100644 --- a/tests/assocd.test +++ b/tests/assocd.test @@ -4,18 +4,20 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testgetassocdata [llength [info commands testgetassocdata]] testConstraint testsetassocdata [llength [info commands testsetassocdata]] diff --git a/tests/async.test b/tests/async.test index df13f83..0f0af0e 100644 --- a/tests/async.test +++ b/tests/async.test @@ -4,23 +4,23 @@ # library procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testasync [llength [info commands testasync]] -testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] +testConstraint knownMsvcBug [expr {![info exists ::env(CI_BUILD_WITH_MSVC)]}] proc async1 {result code} { global aresult acode diff --git a/tests/auto-files.zip b/tests/auto-files.zip Binary files differnew file mode 100644 index 0000000..b8bdf88 --- /dev/null +++ b/tests/auto-files.zip diff --git a/tests/auto0/auto1/file1.tcl b/tests/auto0/auto1/file1.tcl new file mode 100644 index 0000000..bd8b92b --- /dev/null +++ b/tests/auto0/auto1/file1.tcl @@ -0,0 +1,3 @@ +proc report1 {args} { + return ok1 +} diff --git a/tests/auto0/auto1/package1.tcl b/tests/auto0/auto1/package1.tcl new file mode 100644 index 0000000..32d7c56 --- /dev/null +++ b/tests/auto0/auto1/package1.tcl @@ -0,0 +1,5 @@ +proc HeresPackage1 {args} { + return OK1 +} + +package provide SafeTestPackage1 1.2.3 diff --git a/tests/auto0/auto1/pkgIndex.tcl b/tests/auto0/auto1/pkgIndex.tcl new file mode 100644 index 0000000..babb6d5 --- /dev/null +++ b/tests/auto0/auto1/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded SafeTestPackage1 1.2.3 [list source [file join $dir package1.tcl]] diff --git a/tests/auto0/auto1/tclIndex b/tests/auto0/auto1/tclIndex new file mode 100644 index 0000000..bbfa6d4 --- /dev/null +++ b/tests/auto0/auto1/tclIndex @@ -0,0 +1,9 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(report1) [list source [file join $dir file1.tcl]] diff --git a/tests/auto0/auto2/file2.tcl b/tests/auto0/auto2/file2.tcl new file mode 100644 index 0000000..5bc622f --- /dev/null +++ b/tests/auto0/auto2/file2.tcl @@ -0,0 +1,3 @@ +proc report2 {args} { + return ok2 +} diff --git a/tests/auto0/auto2/package2.tcl b/tests/auto0/auto2/package2.tcl new file mode 100644 index 0000000..61774df --- /dev/null +++ b/tests/auto0/auto2/package2.tcl @@ -0,0 +1,5 @@ +proc HeresPackage2 {args} { + return OK2 +} + +package provide SafeTestPackage2 2.3.4 diff --git a/tests/auto0/auto2/pkgIndex.tcl b/tests/auto0/auto2/pkgIndex.tcl new file mode 100644 index 0000000..1022691 --- /dev/null +++ b/tests/auto0/auto2/pkgIndex.tcl @@ -0,0 +1,11 @@ +# Tcl package index file, version 1.1 +# This file is generated by the "pkg_mkIndex" command +# and sourced either when an application starts up or +# by a "package unknown" script. It invokes the +# "package ifneeded" command to set up package-related +# information so that packages will be loaded automatically +# in response to "package require" commands. When this +# script is sourced, the variable $dir must contain the +# full path name of this file's directory. + +package ifneeded SafeTestPackage2 2.3.4 [list source [file join $dir package2.tcl]] diff --git a/tests/auto0/auto2/tclIndex b/tests/auto0/auto2/tclIndex new file mode 100644 index 0000000..9cd2a74 --- /dev/null +++ b/tests/auto0/auto2/tclIndex @@ -0,0 +1,9 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(report2) [list source [file join $dir file2.tcl]] diff --git a/tests/auto0/modules/mod1/test1-1.0.tm b/tests/auto0/modules/mod1/test1-1.0.tm new file mode 100644 index 0000000..927fa6f --- /dev/null +++ b/tests/auto0/modules/mod1/test1-1.0.tm @@ -0,0 +1,5 @@ +namespace eval mod1::test1 {} + +proc mod1::test1::try1 args { + return res1 +} diff --git a/tests/auto0/modules/mod2/test2-2.0.tm b/tests/auto0/modules/mod2/test2-2.0.tm new file mode 100644 index 0000000..b5cd45b --- /dev/null +++ b/tests/auto0/modules/mod2/test2-2.0.tm @@ -0,0 +1,5 @@ +namespace eval mod2::test2 {} + +proc mod2::test2::try2 args { + return res2 +} diff --git a/tests/auto0/modules/test0-0.5.tm b/tests/auto0/modules/test0-0.5.tm new file mode 100644 index 0000000..19f3613 --- /dev/null +++ b/tests/auto0/modules/test0-0.5.tm @@ -0,0 +1,5 @@ +namespace eval test0 {} + +proc test0::try0 args { + return res0 +} diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test index b42d50d..214a969 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -3,14 +3,14 @@ # This file contains tests related to autoloading and generating the # autoloading index. # -# Copyright (c) 1998 Lucent Technologies, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998 Lucent Technologies, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -32,7 +32,7 @@ makeFile {# Test file for: # Note that procedures and itcl class definitions can be nested inside of # namespaces. # -# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# Copyright © 1993-1998 Lucent Technologies, Inc. # This shouldn't cause any problems namespace import -force blt::* @@ -40,8 +40,8 @@ namespace import -force blt::* # Should be able to handle "proc" definitions, even if they are preceded by # white space. -proc normal {x y} {return [expr $x+$y]} - proc indented {x y} {return [expr $x+$y]} +proc normal {x y} {return [expr {$x+$y}]} + proc indented {x y} {return [expr {$x+$y}]} # # Should be able to handle proc declarations within namespaces, even if they @@ -146,10 +146,10 @@ test autoMkindex-1.3 {examine tclIndex} -setup { test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { file delete tclIndex - interp create slave + interp create child } -body { auto_mkindex . autoMkindex.tcl - slave eval { + child eval { namespace eval blt {} set auto_path [linsert $auto_path 0 .] set info [list [catch {namespace import buried::*} result] $result] @@ -159,22 +159,22 @@ test autoMkindex-2.1 {commands on the autoload path can be imported} -setup { return $info } } -cleanup { - interp delete slave + interp delete child } -result "0 {} pub_one ::buried::pub_one pub_two ::buried::pub_two" # Test auto_mkindex hooks -# Slave hook executes interesting code in the interp used to watch code. -test autoMkindex-3.1 {slaveHook} -setup { +# Child hook executes interesting code in the interp used to watch code. +test autoMkindex-3.1 {childHook} -setup { file delete tclIndex } -body { - auto_mkindex_parser::slavehook { + auto_mkindex_parser::childhook { _%@namespace eval ::blt { proc foo {} {} _%@namespace export foo } } - auto_mkindex_parser::slavehook { _%@namespace import -force ::blt::* } + auto_mkindex_parser::childhook { _%@namespace import -force ::blt::* } auto_mkindex . autoMkindex.tcl file exists tclIndex } -cleanup { @@ -335,14 +335,14 @@ test autoMkindex-5.2 {correctly locate auto loaded procs with []} -setup { proc {[magic mojo proc]} {} {} } [file join pkg magicchar2.tcl] set result {} - interp create slave + interp create child } -body { auto_mkindex . pkg/magicchar2.tcl - # Make a slave interp to test the autoloading - slave eval {lappend auto_path [pwd]} - slave eval {catch {{[magic mojo proc]}}} + # Make a child interp to test the autoloading + child eval {lappend auto_path [pwd]} + child eval {catch {{[magic mojo proc]}}} } -cleanup { - interp delete slave + interp delete child removeFile [file join pkg magicchar2.tcl] removeDirectory pkg } -result 0 diff --git a/tests/basic.test b/tests/basic.test index 428fd93..f4c57fe 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -9,17 +9,19 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testevalex [llength [info commands testevalex]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] @@ -672,7 +674,7 @@ proc l3 {} { # Do all tests once byte compiled and once with direct string evaluation foreach noComp {0 1} { -if $noComp { +if {$noComp} { interp alias {} run {} testevalex set constraints testevalex } else { @@ -999,13 +1001,13 @@ test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { } {global} test basic-50.1 {[586e71dce4] EvalObjv level #0 exception handling} -setup { - interp create slave - interp alias {} foo slave return + interp create child + interp alias {} foo child return } -body { list [catch foo m] $m } -cleanup { unset -nocomplain m - interp delete slave + interp delete child } -result {0 {}} # Clean up after expand tests diff --git a/tests/binary.test b/tests/binary.test index b06afe0..36e31ce 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -4,14 +4,14 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] @@ -25,9 +25,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -37,19 +37,19 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -59,11 +59,11 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 @@ -160,16 +160,16 @@ test binary-4.3 {Tcl_BinaryObjCmd: format} { } \x80 test binary-4.4 {Tcl_BinaryObjCmd: format} { binary format B* 010011 -} \x4c +} \x4C test binary-4.5 {Tcl_BinaryObjCmd: format} { binary format B8 01001101 -} \x4d +} \x4D test binary-4.6 {Tcl_BinaryObjCmd: format} { binary format A2X2B9 oo 01001101 -} \x4d\x00 +} \x4D\x00 test binary-4.7 {Tcl_BinaryObjCmd: format} { binary format B9 010011011010 -} \x4d\x80 +} \x4D\x80 test binary-4.8 {Tcl_BinaryObjCmd: format} { binary format B2B3 10 010 } \x80\x40 @@ -191,16 +191,16 @@ test binary-5.4 {Tcl_BinaryObjCmd: format} { } 2 test binary-5.5 {Tcl_BinaryObjCmd: format} { binary format b8 01001101 -} \xb2 +} \xB2 test binary-5.6 {Tcl_BinaryObjCmd: format} { binary format A2X2b9 oo 01001101 -} \xb2\x00 +} \xB2\x00 test binary-5.7 {Tcl_BinaryObjCmd: format} { binary format b9 010011011010 -} \xb2\x01 +} \xB2\x01 test binary-5.8 {Tcl_BinaryObjCmd: format} { binary format b17 1 -} \x01\00\00 +} \x01\x00\x00 test binary-5.9 {Tcl_BinaryObjCmd: format} { binary format b2b3 10 010 } \x01\x02 @@ -219,19 +219,19 @@ test binary-6.3 {Tcl_BinaryObjCmd: format} { } \x01 test binary-6.4 {Tcl_BinaryObjCmd: format} { binary format h c -} \x0c +} \x0C test binary-6.5 {Tcl_BinaryObjCmd: format} { binary format h* baadf00d -} \xab\xda\x0f\xd0 +} \xAB\xDA\x0F\xD0 test binary-6.6 {Tcl_BinaryObjCmd: format} { binary format h4 c410 -} \x4c\x01 +} \x4C\x01 test binary-6.7 {Tcl_BinaryObjCmd: format} { binary format h6 c4102 -} \x4c\x01\x02 +} \x4C\x01\x02 test binary-6.8 {Tcl_BinaryObjCmd: format} { binary format h5 c41020304 -} \x4c\x01\x02 +} \x4C\x01\x02 test binary-6.9 {Tcl_BinaryObjCmd: format} { binary format a3X3h5 foo 2 } \x02\x00\x00 @@ -253,19 +253,19 @@ test binary-7.3 {Tcl_BinaryObjCmd: format} { } \x10 test binary-7.4 {Tcl_BinaryObjCmd: format} { binary format H c -} \xc0 +} \xC0 test binary-7.5 {Tcl_BinaryObjCmd: format} { binary format H* baadf00d -} \xba\xad\xf0\x0d +} \xBA\xAD\xF0\x0D test binary-7.6 {Tcl_BinaryObjCmd: format} { binary format H4 c410 -} \xc4\x10 +} \xC4\x10 test binary-7.7 {Tcl_BinaryObjCmd: format} { binary format H6 c4102 -} \xc4\x10\x20 +} \xC4\x10\x20 test binary-7.8 {Tcl_BinaryObjCmd: format} { binary format H5 c41023304 -} \xc4\x10\x20 +} \xC4\x10\x20 test binary-7.9 {Tcl_BinaryObjCmd: format} { binary format a3X3H5 foo 2 } \x20\x00\x00 @@ -485,34 +485,34 @@ test binary-13.3 {Tcl_BinaryObjCmd: format} { } {} test binary-13.4 {Tcl_BinaryObjCmd: format} bigEndian { binary format f 1.6 -} \x3f\xcc\xcc\xcd +} \x3F\xCC\xCC\xCD test binary-13.5 {Tcl_BinaryObjCmd: format} littleEndian { binary format f 1.6 -} \xcd\xcc\xcc\x3f +} \xCD\xCC\xCC\x3F test binary-13.6 {Tcl_BinaryObjCmd: format} bigEndian { binary format f* {1.6 3.4} -} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A test binary-13.7 {Tcl_BinaryObjCmd: format} littleEndian { binary format f* {1.6 3.4} -} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 test binary-13.8 {Tcl_BinaryObjCmd: format} bigEndian { binary format f2 {1.6 3.4} -} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A test binary-13.9 {Tcl_BinaryObjCmd: format} littleEndian { binary format f2 {1.6 3.4} -} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 test binary-13.10 {Tcl_BinaryObjCmd: format} bigEndian { binary format f2 {1.6 3.4 5.6} -} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A test binary-13.11 {Tcl_BinaryObjCmd: format} littleEndian { binary format f2 {1.6 3.4 5.6} -} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 test binary-13.12 {Tcl_BinaryObjCmd: float overflow} bigEndian { binary format f -3.402825e+38 -} \xff\x7f\xff\xff +} \xFF\x7F\xFF\xFF test binary-13.13 {Tcl_BinaryObjCmd: float overflow} littleEndian { binary format f -3.402825e+38 -} \xff\xff\x7f\xff +} \xFF\xFF\x7F\xFF test binary-13.14 {Tcl_BinaryObjCmd: float underflow} bigEndian { binary format f -3.402825e-100 } \x80\x00\x00\x00 @@ -529,11 +529,11 @@ test binary-13.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-13.18 {Tcl_BinaryObjCmd: format} bigEndian { set a {1.6 3.4} binary format f1 $a -} \x3f\xcc\xcc\xcd +} \x3F\xCC\xCC\xCD test binary-13.19 {Tcl_BinaryObjCmd: format} littleEndian { set a {1.6 3.4} binary format f1 $a -} \xcd\xcc\xcc\x3f +} \xCD\xCC\xCC\x3F test binary-14.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { binary format d @@ -546,28 +546,28 @@ test binary-14.3 {Tcl_BinaryObjCmd: format} { } {} test binary-14.4 {Tcl_BinaryObjCmd: format} bigEndian { binary format d 1.6 -} \x3f\xf9\x99\x99\x99\x99\x99\x9a +} \x3F\xF9\x99\x99\x99\x99\x99\x9A test binary-14.5 {Tcl_BinaryObjCmd: format} littleEndian { binary format d 1.6 -} \x9a\x99\x99\x99\x99\x99\xf9\x3f +} \x9A\x99\x99\x99\x99\x99\xF9\x3F test binary-14.6 {Tcl_BinaryObjCmd: format} bigEndian { binary format d* {1.6 3.4} -} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 test binary-14.7 {Tcl_BinaryObjCmd: format} littleEndian { binary format d* {1.6 3.4} -} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 test binary-14.8 {Tcl_BinaryObjCmd: format} bigEndian { binary format d2 {1.6 3.4} -} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 test binary-14.9 {Tcl_BinaryObjCmd: format} littleEndian { binary format d2 {1.6 3.4} -} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 test binary-14.10 {Tcl_BinaryObjCmd: format} bigEndian { binary format d2 {1.6 3.4 5.6} -} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 test binary-14.11 {Tcl_BinaryObjCmd: format} littleEndian { binary format d2 {1.6 3.4 5.6} -} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 test binary-14.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body { binary format d2 {1.6} } -result {number of elements in list does not match count} @@ -578,11 +578,11 @@ test binary-14.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-14.16 {Tcl_BinaryObjCmd: format} bigEndian { set a {1.6 3.4} binary format d1 $a -} \x3f\xf9\x99\x99\x99\x99\x99\x9a +} \x3F\xF9\x99\x99\x99\x99\x99\x9A test binary-14.17 {Tcl_BinaryObjCmd: format} littleEndian { set a {1.6 3.4} binary format d1 $a -} \x9a\x99\x99\x99\x99\x99\xf9\x3f +} \x9A\x99\x99\x99\x99\x99\xF9\x3F test binary-14.18 {FormatNumber: Bug 1116542} { binary scan [binary format d 1.25] d w set w @@ -759,7 +759,16 @@ test binary-21.12 {Tcl_BinaryObjCmd: scan} -setup { } -body { list [binary scan "abc def \x00ghi " A* arg1] $arg1 } -result [list 1 "abc def \x00ghi"] - +test binary-21.13 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { + list [binary scan "abc def \x00 " C* arg1] $arg1 +} -result {1 {abc def }} +test binary-21.12 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { + list [binary scan "abc def \x00ghi" C* arg1] $arg1 +} -result {1 {abc def }} test binary-22.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { binary scan abc b } -result {not enough arguments for all format specifiers} @@ -865,11 +874,11 @@ test binary-24.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-24.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 h* arg1] $arg1 + list [binary scan \x52\xA3 h* arg1] $arg1 } {1 253a} test binary-24.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xc2\xa3 h arg1] $arg1 + list [binary scan \xC2\xA3 h arg1] $arg1 } {1 2} test binary-24.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -881,7 +890,7 @@ test binary-24.5 {Tcl_BinaryObjCmd: scan} { } {1 {}} test binary-24.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xf2\x53 h2 arg1] $arg1 + list [binary scan \xF2\x53 h2 arg1] $arg1 } {1 2f} test binary-24.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -911,11 +920,11 @@ test binary-25.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-25.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 H* arg1] $arg1 + list [binary scan \x52\xA3 H* arg1] $arg1 } {1 52a3} test binary-25.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xc2\xa3 H arg1] $arg1 + list [binary scan \xC2\xA3 H arg1] $arg1 } {1 c} test binary-25.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -927,7 +936,7 @@ test binary-25.5 {Tcl_BinaryObjCmd: scan} { } {1 {}} test binary-25.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xf2\x53 H2 arg1] $arg1 + list [binary scan \xF2\x53 H2 arg1] $arg1 } {1 f2} test binary-25.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -956,27 +965,27 @@ test binary-26.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-26.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 c* arg1] $arg1 + list [binary scan \x52\xA3 c* arg1] $arg1 } {1 {82 -93}} test binary-26.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 c arg1] $arg1 + list [binary scan \x52\xA3 c arg1] $arg1 } {1 82} test binary-26.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 c1 arg1] $arg1 + list [binary scan \x52\xA3 c1 arg1] $arg1 } {1 82} test binary-26.5 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 c0 arg1] $arg1 + list [binary scan \x52\xA3 c0 arg1] $arg1 } {1 {}} test binary-26.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 c2 arg1] $arg1 + list [binary scan \x52\xA3 c2 arg1] $arg1 } {1 {82 -93}} test binary-26.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xff c arg1] $arg1 + list [binary scan \xFF c arg1] $arg1 } {1 -1} test binary-26.8 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -997,15 +1006,15 @@ test binary-26.10 {Tcl_BinaryObjCmd: scan} { } {2 {112 -121} 5} test binary-26.11 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 cu* arg1] $arg1 + list [binary scan \x52\xA3 cu* arg1] $arg1 } {1 {82 163}} test binary-26.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 cu arg1] $arg1 + list [binary scan \x52\xA3 cu arg1] $arg1 } {1 82} test binary-26.13 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xff cu arg1] $arg1 + list [binary scan \xFF cu arg1] $arg1 } {1 255} test binary-26.14 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 @@ -1025,23 +1034,23 @@ test binary-27.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-27.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 s* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 s* arg1] $arg1 } {1 {-23726 21587}} test binary-27.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 s arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 s arg1] $arg1 } {1 -23726} test binary-27.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 s1 arg1] $arg1 + list [binary scan \x52\xA3 s1 arg1] $arg1 } {1 -23726} test binary-27.5 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 s0 arg1] $arg1 + list [binary scan \x52\xA3 s0 arg1] $arg1 } {1 {}} test binary-27.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 s2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 s2 arg1] $arg1 } {1 {-23726 21587}} test binary-27.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1058,23 +1067,23 @@ test binary-27.9 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2 } {2 {-23726 21587} 5} test binary-27.10 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 su* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 su* arg1] $arg1 } {1 {41810 21587}} test binary-27.11 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \xff\xff\xff\xff sus arg1 arg2] $arg1 $arg2 + list [binary scan \xFF\xFF\xFF\xFF sus arg1 arg2] $arg1 $arg2 } {2 65535 -1} test binary-27.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \xff\xff\xff\xff ssu arg1 arg2] $arg1 $arg2 + list [binary scan \xFF\xFF\xFF\xFF ssu arg1 arg2] $arg1 $arg2 } {2 -1 65535} test binary-28.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { @@ -1082,23 +1091,23 @@ test binary-28.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-28.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 S* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 S* arg1] $arg1 } {1 {21155 21332}} test binary-28.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 S arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 S arg1] $arg1 } {1 21155} test binary-28.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 S1 arg1] $arg1 + list [binary scan \x52\xA3 S1 arg1] $arg1 } {1 21155} test binary-28.5 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3 S0 arg1] $arg1 + list [binary scan \x52\xA3 S0 arg1] $arg1 } {1 {}} test binary-28.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 S2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 S2 arg1] $arg1 } {1 {21155 21332}} test binary-28.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1115,15 +1124,15 @@ test binary-28.9 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2 } {2 {21155 21332} 5} test binary-28.10 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 Su* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 Su* arg1] $arg1 } {1 {21155 21332}} test binary-28.11 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \xa3\x52\x54\x53 Su* arg1] $arg1 + list [binary scan \xA3\x52\x54\x53 Su* arg1] $arg1 } {1 {41810 21587}} test binary-29.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { @@ -1131,23 +1140,23 @@ test binary-29.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-29.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1 } {1 {1414767442 67305985}} test binary-29.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 i arg1] $arg1 } {1 1414767442} test binary-29.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 i1 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 i1 arg1] $arg1 } {1 1414767442} test binary-29.5 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53 i0 arg1] $arg1 + list [binary scan \x52\xA3\x53 i0 arg1] $arg1 } {1 {}} test binary-29.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 i2 arg1] $arg1 } {1 {1414767442 67305985}} test binary-29.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1164,15 +1173,15 @@ test binary-29.9 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2 } {2 {1414767442 67305985} 5} test binary-29.10 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 - list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iui arg1 arg2] $arg1 $arg2 + list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF iui arg1 arg2] $arg1 $arg2 } {2 4294967295 -1} test binary-29.11 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 - list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iiu arg1 arg2] $arg1 $arg2 + list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF iiu arg1 arg2] $arg1 $arg2 } {2 -1 4294967295} test binary-29.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 @@ -1184,23 +1193,23 @@ test binary-30.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-30.2 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1 } {1 {1386435412 16909060}} test binary-30.3 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 I arg1] $arg1 } {1 1386435412} test binary-30.4 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 I1 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 I1 arg1] $arg1 } {1 1386435412} test binary-30.5 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53 I0 arg1] $arg1 + list [binary scan \x52\xA3\x53 I0 arg1] $arg1 } {1 {}} test binary-30.6 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 I2 arg1] $arg1 } {1 {1386435412 16909060}} test binary-30.7 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1217,15 +1226,15 @@ test binary-30.9 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2 } {2 {1386435412 16909060} 5} test binary-30.10 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 - list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IuI arg1 arg2] $arg1 $arg2 + list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF IuI arg1 arg2] $arg1 $arg2 } {2 4294967295 -1} test binary-30.11 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 - list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IIu arg1 arg2] $arg1 $arg2 + list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF IIu arg1 arg2] $arg1 $arg2 } {2 -1 4294967295} test binary-30.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 arg2 @@ -1237,43 +1246,43 @@ test binary-31.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-31.2 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A f* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.3 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 f* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.4 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A f arg1] $arg1 } {1 1.600000023841858} test binary-31.5 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 f arg1] $arg1 } {1 1.600000023841858} test binary-31.6 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD f1 arg1] $arg1 } {1 1.600000023841858} test binary-31.7 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F f1 arg1] $arg1 } {1 1.600000023841858} test binary-31.8 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD f0 arg1] $arg1 } {1 {}} test binary-31.9 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f f0 arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F f0 arg1] $arg1 } {1 {}} test binary-31.10 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A f2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.11 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 f2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1284,19 +1293,19 @@ test binary-31.13 {Tcl_BinaryObjCmd: scan} -setup { unset -nocomplain arg1 } -returnCodes error -body { set arg1 1 - binary scan \x3f\xcc\xcc\xcd f1 arg1(a) + binary scan \x3F\xCC\xCC\xCD f1 arg1(a) } -result {can't set "arg1(a)": variable isn't array} test binary-31.14 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A\x05 f2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-31.15 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-32.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { @@ -1304,43 +1313,43 @@ test binary-32.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-32.2 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d* arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 d* arg1] $arg1 } {1 {1.6 3.4}} test binary-32.3 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d* arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 d* arg1] $arg1 } {1 {1.6 3.4}} test binary-32.4 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 d arg1] $arg1 } {1 1.6} test binary-32.5 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 d arg1] $arg1 } {1 1.6} test binary-32.6 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A d1 arg1] $arg1 } {1 1.6} test binary-32.7 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d1 arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F d1 arg1] $arg1 } {1 1.6} test binary-32.8 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d0 arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A d0 arg1] $arg1 } {1 {}} test binary-32.9 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d0 arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F d0 arg1] $arg1 } {1 {}} test binary-32.10 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d2 arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 d2 arg1] $arg1 } {1 {1.6 3.4}} test binary-32.11 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d2 arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 d2 arg1] $arg1 } {1 {1.6 3.4}} test binary-32.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -1351,19 +1360,19 @@ test binary-32.13 {Tcl_BinaryObjCmd: scan} -setup { unset -nocomplain arg1 } -returnCodes error -body { set arg1 1 - binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1(a) + binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A d1 arg1(a) } -result {can't set "arg1(a)": variable isn't array} test binary-32.14 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 d2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33\x05 d2c* arg1 arg2] $arg1 $arg2 } {2 {1.6 3.4} 5} test binary-32.15 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 d2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40\x05 d2c* arg1 arg2] $arg1 $arg2 } {2 {1.6 3.4} 5} test binary-33.1 {Tcl_BinaryObjCmd: scan} { @@ -1534,20 +1543,20 @@ test binary-38.4 {FormatNumber: word alignment} { } \x01\x00\x00\x00\x01 test binary-38.5 {FormatNumber: word alignment} bigEndian { set x [binary format c1d1 1 1.6] -} \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a +} \x01\x3F\xF9\x99\x99\x99\x99\x99\x9A test binary-38.6 {FormatNumber: word alignment} littleEndian { set x [binary format c1d1 1 1.6] -} \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f +} \x01\x9A\x99\x99\x99\x99\x99\xF9\x3F test binary-38.7 {FormatNumber: word alignment} bigEndian { set x [binary format c1f1 1 1.6] -} \x01\x3f\xcc\xcc\xcd +} \x01\x3F\xCC\xCC\xCD test binary-38.8 {FormatNumber: word alignment} littleEndian { set x [binary format c1f1 1 1.6] -} \x01\xcd\xcc\xcc\x3f +} \x01\xCD\xCC\xCC\x3F test binary-39.1 {ScanNumber: sign extension} { unset -nocomplain arg1 - list [binary scan \x52\xa3 c2 arg1] $arg1 + list [binary scan \x52\xA3 c2 arg1] $arg1 } {1 {82 -93}} test binary-39.2 {ScanNumber: sign extension} { unset -nocomplain arg1 @@ -1567,7 +1576,7 @@ test binary-39.5 {ScanNumber: sign extension} { } {1 {16843010 -2130640639 25297153 16876033 16843137}} test binary-39.6 {ScanNumber: no sign extension} { unset -nocomplain arg1 - list [binary scan \x52\xa3 cu2 arg1] $arg1 + list [binary scan \x52\xA3 cu2 arg1] $arg1 } {1 {82 163}} test binary-39.7 {ScanNumber: no sign extension} { unset -nocomplain arg1 @@ -1588,11 +1597,11 @@ test binary-39.10 {ScanNumber: no sign extension} { test binary-40.3 {ScanNumber: NaN} -body { unset -nocomplain arg1 - list [binary scan \xff\xff\xff\xff f1 arg1] $arg1 + list [binary scan \xFF\xFF\xFF\xFF f1 arg1] $arg1 } -match glob -result {1 -NaN*} test binary-40.4 {ScanNumber: NaN} -body { unset -nocomplain arg1 - list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1 + list [binary scan \xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF d arg1] $arg1 } -match glob -result {1 -NaN*} test binary-41.1 {ScanNumber: word alignment} -setup { @@ -1618,22 +1627,22 @@ test binary-41.4 {ScanNumber: word alignment} -setup { test binary-41.5 {ScanNumber: word alignment} -setup { unset -nocomplain arg1 arg2 } -constraints bigEndian -body { - list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2 + list [binary scan \x01\x3F\xCC\xCC\xCD c1f1 arg1 arg2] $arg1 $arg2 } -result {2 1 1.600000023841858} test binary-41.6 {ScanNumber: word alignment} -setup { unset -nocomplain arg1 arg2 } -constraints littleEndian -body { - list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2 + list [binary scan \x01\xCD\xCC\xCC\x3F c1f1 arg1 arg2] $arg1 $arg2 } -result {2 1 1.600000023841858} test binary-41.7 {ScanNumber: word alignment} -setup { unset -nocomplain arg1 arg2 } -constraints bigEndian -body { - list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2 + list [binary scan \x01\x3F\xF9\x99\x99\x99\x99\x99\x9A c1d1 arg1 arg2] $arg1 $arg2 } -result {2 1 1.6} test binary-41.8 {ScanNumber: word alignment} -setup { unset -nocomplain arg1 arg2 } -constraints littleEndian -body { - list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2 + list [binary scan \x01\x9A\x99\x99\x99\x99\x99\xF9\x3F c1d1 arg1 arg2] $arg1 $arg2 } -result {2 1 1.6} test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} -constraints {} -body { @@ -1704,26 +1713,26 @@ test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} { } {66 64 0 0 0 0 127 -1 -1 -1 65 76} test binary-46.1 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} { - binary format a* \u20ac -} \u00ac + binary format a* € +} \xAC test binary-46.2 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} { - list [binary scan [binary format a* \u20ac\u20bd] s x] $x + list [binary scan [binary format a* €₽] s x] $x } {1 -16980} test binary-46.3 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} { set x {} set y {} set z {} - list [binary scan [binary format a* \u20ac\u20bd] aaa x y z] $x $y $z -} "2 \u00ac \u00bd {}" + list [binary scan [binary format a* €₽] aaa x y z] $x $y $z +} "2 \xAC \xBD {}" test binary-46.4 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} { - set x [encoding convertto iso8859-15 \u20ac] + set x [encoding convertto iso8859-15 €] set y [binary format a* $x] list $x $y -} "\u00a4 \u00a4" +} "\xA4 \xA4" test binary-46.5 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} { - set x [binary scan \u00a4 a* y] + set x [binary scan \xA4 a* y] list $x $y [encoding convertfrom iso8859-15 $y] -} "1 \u00a4 \u20ac" +} "1 \xA4 €" test binary-47.1 {Tcl_BinaryObjCmd: number cache reference count handling} { # This test is only reliable when memory debugging is turned on, but @@ -1889,28 +1898,28 @@ test binary-51.3 {Tcl_BinaryObjCmd: format} { } {} test binary-51.4 {Tcl_BinaryObjCmd: format} {} { binary format Q 1.6 -} \x3f\xf9\x99\x99\x99\x99\x99\x9a +} \x3F\xF9\x99\x99\x99\x99\x99\x9A test binary-51.5 {Tcl_BinaryObjCmd: format} {} { binary format q 1.6 -} \x9a\x99\x99\x99\x99\x99\xf9\x3f +} \x9A\x99\x99\x99\x99\x99\xF9\x3F test binary-51.6 {Tcl_BinaryObjCmd: format} {} { binary format Q* {1.6 3.4} -} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 test binary-51.7 {Tcl_BinaryObjCmd: format} {} { binary format q* {1.6 3.4} -} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 test binary-51.8 {Tcl_BinaryObjCmd: format} {} { binary format Q2 {1.6 3.4} -} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 test binary-51.9 {Tcl_BinaryObjCmd: format} {} { binary format q2 {1.6 3.4} -} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 test binary-51.10 {Tcl_BinaryObjCmd: format} {} { binary format Q2 {1.6 3.4 5.6} -} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 +} \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 test binary-51.11 {Tcl_BinaryObjCmd: format} {} { binary format q2 {1.6 3.4 5.6} -} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 +} \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 test binary-51.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body { binary format q2 {1.6} } -result {number of elements in list does not match count} @@ -1921,11 +1930,11 @@ test binary-51.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-51.16 {Tcl_BinaryObjCmd: format} {} { set a {1.6 3.4} binary format Q1 $a -} \x3f\xf9\x99\x99\x99\x99\x99\x9a +} \x3F\xF9\x99\x99\x99\x99\x99\x9A test binary-51.17 {Tcl_BinaryObjCmd: format} {} { set a {1.6 3.4} binary format q1 $a -} \x9a\x99\x99\x99\x99\x99\xf9\x3f +} \x9A\x99\x99\x99\x99\x99\xF9\x3F # format R/r test binary-53.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { @@ -1939,34 +1948,34 @@ test binary-53.3 {Tcl_BinaryObjCmd: format} { } {} test binary-53.4 {Tcl_BinaryObjCmd: format} {} { binary format R 1.6 -} \x3f\xcc\xcc\xcd +} \x3F\xCC\xCC\xCD test binary-53.5 {Tcl_BinaryObjCmd: format} {} { binary format r 1.6 -} \xcd\xcc\xcc\x3f +} \xCD\xCC\xCC\x3F test binary-53.6 {Tcl_BinaryObjCmd: format} {} { binary format R* {1.6 3.4} -} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A test binary-53.7 {Tcl_BinaryObjCmd: format} {} { binary format r* {1.6 3.4} -} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 test binary-53.8 {Tcl_BinaryObjCmd: format} {} { binary format R2 {1.6 3.4} -} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A test binary-53.9 {Tcl_BinaryObjCmd: format} {} { binary format r2 {1.6 3.4} -} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 test binary-53.10 {Tcl_BinaryObjCmd: format} {} { binary format R2 {1.6 3.4 5.6} -} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a +} \x3F\xCC\xCC\xCD\x40\x59\x99\x9A test binary-53.11 {Tcl_BinaryObjCmd: format} {} { binary format r2 {1.6 3.4 5.6} -} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 +} \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 test binary-53.12 {Tcl_BinaryObjCmd: float overflow} {} { binary format R -3.402825e+38 -} \xff\x7f\xff\xff +} \xFF\x7F\xFF\xFF test binary-53.13 {Tcl_BinaryObjCmd: float overflow} {} { binary format r -3.402825e+38 -} \xff\xff\x7f\xff +} \xFF\xFF\x7F\xFF test binary-53.14 {Tcl_BinaryObjCmd: float underflow} {} { binary format R -3.402825e-100 } \x80\x00\x00\x00 @@ -1983,11 +1992,11 @@ test binary-53.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body { test binary-53.18 {Tcl_BinaryObjCmd: format} {} { set a {1.6 3.4} binary format R1 $a -} \x3f\xcc\xcc\xcd +} \x3F\xCC\xCC\xCD test binary-53.19 {Tcl_BinaryObjCmd: format} {} { set a {1.6 3.4} binary format r1 $a -} \xcd\xcc\xcc\x3f +} \xCD\xCC\xCC\x3F # scan t (s) test binary-54.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { @@ -1995,23 +2004,23 @@ test binary-54.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-54.2 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 t* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 t* arg1] $arg1 } {1 {-23726 21587}} test binary-54.3 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 t arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 t arg1] $arg1 } {1 -23726} test binary-54.4 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3 t1 arg1] $arg1 + list [binary scan \x52\xA3 t1 arg1] $arg1 } {1 -23726} test binary-54.5 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3 t0 arg1] $arg1 + list [binary scan \x52\xA3 t0 arg1] $arg1 } {1 {}} test binary-54.6 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 t2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 t2 arg1] $arg1 } {1 {-23726 21587}} test binary-54.7 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 @@ -2028,7 +2037,7 @@ test binary-54.9 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2 } {2 {-23726 21587} 5} test binary-54.10 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 @@ -2049,23 +2058,23 @@ test binary-55.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-55.2 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 t* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 t* arg1] $arg1 } {1 {21155 21332}} test binary-55.3 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 t arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 t arg1] $arg1 } {1 21155} test binary-55.4 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3 t1 arg1] $arg1 + list [binary scan \x52\xA3 t1 arg1] $arg1 } {1 21155} test binary-55.5 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3 t0 arg1] $arg1 + list [binary scan \x52\xA3 t0 arg1] $arg1 } {1 {}} test binary-55.6 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 t2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 t2 arg1] $arg1 } {1 {21155 21332}} test binary-55.7 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 @@ -2082,7 +2091,7 @@ test binary-55.9 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2 } {2 {21155 21332} 5} test binary-55.10 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 @@ -2103,23 +2112,23 @@ test binary-56.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-56.2 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1 } {1 {1414767442 67305985}} test binary-56.3 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n arg1] $arg1 } {1 1414767442} test binary-56.4 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 n1 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 n1 arg1] $arg1 } {1 1414767442} test binary-56.5 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53 n0 arg1] $arg1 + list [binary scan \x52\xA3\x53 n0 arg1] $arg1 } {1 {}} test binary-56.6 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1 } {1 {1414767442 67305985}} test binary-56.7 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 @@ -2136,7 +2145,7 @@ test binary-56.9 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 } {2 {1414767442 67305985} 5} test binary-56.10 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 @@ -2157,23 +2166,23 @@ test binary-57.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-57.2 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1 } {1 {1386435412 16909060}} test binary-57.3 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n arg1] $arg1 } {1 1386435412} test binary-57.4 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54 n1 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54 n1 arg1] $arg1 } {1 1386435412} test binary-57.5 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53 n0 arg1] $arg1 + list [binary scan \x52\xA3\x53 n0 arg1] $arg1 } {1 {}} test binary-57.6 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1 } {1 {1386435412 16909060}} test binary-57.7 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 @@ -2190,7 +2199,7 @@ test binary-57.9 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x52\xA3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 } {2 {1386435412 16909060} 5} test binary-57.10 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 @@ -2211,43 +2220,43 @@ test binary-58.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-58.2 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q* arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 Q* arg1] $arg1 } {1 {1.6 3.4}} test binary-58.3 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q* arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 q* arg1] $arg1 } {1 {1.6 3.4}} test binary-58.4 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 Q arg1] $arg1 } {1 1.6} test binary-58.5 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 q arg1] $arg1 } {1 1.6} test binary-58.6 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a Q1 arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A Q1 arg1] $arg1 } {1 1.6} test binary-58.7 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f q1 arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F q1 arg1] $arg1 } {1 1.6} test binary-58.8 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a Q0 arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A Q0 arg1] $arg1 } {1 {}} test binary-58.9 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f q0 arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F q0 arg1] $arg1 } {1 {}} test binary-58.10 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q2 arg1] $arg1 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33 Q2 arg1] $arg1 } {1 {1.6 3.4}} test binary-58.11 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q2 arg1] $arg1 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40 q2 arg1] $arg1 } {1 {1.6 3.4}} test binary-58.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -2258,19 +2267,19 @@ test binary-58.13 {Tcl_BinaryObjCmd: scan} -setup { unset -nocomplain arg1 } -returnCodes error -body { set arg1 1 - binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a q1 arg1(a) + binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A q1 arg1(a) } -result {can't set "arg1(a)": variable isn't array} test binary-58.14 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 Q2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x3F\xF9\x99\x99\x99\x99\x99\x9A\x40\x0B\x33\x33\x33\x33\x33\x33\x05 Q2c* arg1 arg2] $arg1 $arg2 } {2 {1.6 3.4} 5} test binary-58.15 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 q2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x9A\x99\x99\x99\x99\x99\xF9\x3F\x33\x33\x33\x33\x33\x33\x0B\x40\x05 q2c* arg1 arg2] $arg1 $arg2 } {2 {1.6 3.4} 5} # scan R/r @@ -2279,43 +2288,43 @@ test binary-59.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { } -result {not enough arguments for all format specifiers} test binary-59.2 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R* arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A R* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.3 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r* arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 r* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.4 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A R arg1] $arg1 } {1 1.600000023841858} test binary-59.5 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 r arg1] $arg1 } {1 1.600000023841858} test binary-59.6 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd R1 arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD R1 arg1] $arg1 } {1 1.600000023841858} test binary-59.7 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f r1 arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F r1 arg1] $arg1 } {1 1.600000023841858} test binary-59.8 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd R0 arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD R0 arg1] $arg1 } {1 {}} test binary-59.9 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f r0 arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F r0 arg1] $arg1 } {1 {}} test binary-59.10 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R2 arg1] $arg1 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A R2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.11 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r2 arg1] $arg1 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40 r2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.12 {Tcl_BinaryObjCmd: scan} { unset -nocomplain arg1 @@ -2326,19 +2335,19 @@ test binary-59.13 {Tcl_BinaryObjCmd: scan} -setup { unset -nocomplain arg1 } -returnCodes error -body { set arg1 1 - binary scan \x3f\xcc\xcc\xcd r1 arg1(a) + binary scan \x3F\xCC\xCC\xCD r1 arg1(a) } -result {can't set "arg1(a)": variable isn't array} test binary-59.14 {Tcl_BinaryObjCmd: scan} bigEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 R2c* arg1 arg2] $arg1 $arg2 + list [binary scan \x3F\xCC\xCC\xCD\x40\x59\x99\x9A\x05 R2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-59.15 {Tcl_BinaryObjCmd: scan} littleEndian { unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar - list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2 + list [binary scan \xCD\xCC\xCC\x3F\x9A\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-60.1 {[binary format] with NaN} -body { @@ -2487,7 +2496,7 @@ test binary-70.4 {binary encode hex} -body { binary encode hex [string repeat a 20] } -result [string repeat 61 20] test binary-70.5 {binary encode hex} -body { - binary encode hex \0\1\2\3\4\0\1\2\3\4 + binary encode hex \x00\x01\x02\x03\x04\x00\x01\x02\x03\x04 } -result {00010203040001020304} test binary-71.1 {binary decode hex} -body { @@ -2504,7 +2513,7 @@ test binary-71.4 {binary decode hex} -body { } -result [string repeat a 20] test binary-71.5 {binary decode hex} -body { binary decode hex 00010203040001020304 -} -result "\0\1\2\3\4\0\1\2\3\4" +} -result "\x00\x01\x02\x03\x04\x00\x01\x02\x03\x04" test binary-71.6 {binary decode hex} -body { binary decode hex "61 61" } -result {aa} @@ -2563,19 +2572,19 @@ test binary-72.4 {binary encode base64} -body { binary encode base64 [string repeat abc 20] } -result [string repeat YWJj 20] test binary-72.5 {binary encode base64} -body { - binary encode base64 \0\1\2\3\4\0\1\2\3 + binary encode base64 \x00\x01\x02\x03\x04\x00\x01\x02\x03 } -result {AAECAwQAAQID} test binary-72.6 {binary encode base64} -body { - binary encode base64 \0 + binary encode base64 \x00 } -result {AA==} test binary-72.7 {binary encode base64} -body { - binary encode base64 \0\0 + binary encode base64 \x00\x00 } -result {AAA=} test binary-72.8 {binary encode base64} -body { - binary encode base64 \0\0\0 + binary encode base64 \x00\x00\x00 } -result {AAAA} test binary-72.9 {binary encode base64} -body { - binary encode base64 \0\0\0\0 + binary encode base64 \x00\x00\x00\x00 } -result {AAAAAA==} test binary-72.10 {binary encode base64} -body { binary encode base64 -maxlen 0 -wrapchar : abcabcabc @@ -2635,7 +2644,7 @@ test binary-72.28 {binary encode base64} -body { binary encode base64 -maxlen 6 -wrapchar 0123456789 abcabcabc } -result {YWJjYW0123456789JjYWJj} test binary-72.29 {binary encode base64} { - string length [binary encode base64 -maxlen 3 -wrapchar \xca abc] + string length [binary encode base64 -maxlen 3 -wrapchar \xCA abc] } 5 test binary-73.1 {binary decode base64} -body { @@ -2652,19 +2661,19 @@ test binary-73.4 {binary decode base64} -body { } -result [string repeat abc 20] test binary-73.5 {binary decode base64} -body { binary decode base64 AAECAwQAAQID -} -result "\0\1\2\3\4\0\1\2\3" +} -result "\x00\x01\x02\x03\x04\x00\x01\x02\x03" test binary-73.6 {binary decode base64} -body { binary decode base64 AA== -} -result "\0" +} -result "\x00" test binary-73.7 {binary decode base64} -body { binary decode base64 AAA= -} -result "\0\0" +} -result "\x00\x00" test binary-73.8 {binary decode base64} -body { binary decode base64 AAAA -} -result "\0\0\0" +} -result "\x00\x00\x00" test binary-73.9 {binary decode base64} -body { binary decode base64 AAAAAA== -} -result "\0\0\0\0" +} -result "\x00\x00\x00\x00" test binary-73.10 {binary decode base64} -body { set s "[string repeat YWJj 10]\n[string repeat YWJj 10]" binary decode base64 $s @@ -2782,22 +2791,22 @@ test binary-74.4 {binary encode uuencode} -body { binary encode uuencode [string repeat abc 20] } -result "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" test binary-74.5 {binary encode uuencode} -body { - binary encode uuencode \0\1\2\3\4\0\1\2\3 + binary encode uuencode \x00\x01\x02\x03\x04\x00\x01\x02\x03 } -result ")``\$\"`P0``0(#\n" test binary-74.6 {binary encode uuencode} -body { binary encode uuencode \0 } -result {!`` } test binary-74.7 {binary encode uuencode} -body { - binary encode uuencode \0\0 + binary encode uuencode \x00\x00 } -result "\"``` " test binary-74.8 {binary encode uuencode} -body { - binary encode uuencode \0\0\0 + binary encode uuencode \x00\x00\x00 } -result {#```` } test binary-74.9 {binary encode uuencode} -body { - binary encode uuencode \0\0\0\0 + binary encode uuencode \x00\x00\x00\x00 } -result {$`````` } test binary-74.10 {binary encode uuencode} -returnCodes error -body { @@ -2833,7 +2842,7 @@ test binary-75.4 {binary decode uuencode} -body { } -result [string repeat abc 20] test binary-75.5 {binary decode uuencode} -body { binary decode uuencode ")``\$\"`P0``0(#" -} -result "\0\1\2\3\4\0\1\2\3" +} -result "\x00\x01\x02\x03\x04\x00\x01\x02\x03" test binary-75.6 {binary decode uuencode} -body { string length [binary decode uuencode "`\n"] } -result 0 @@ -2939,18 +2948,18 @@ test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength { testsetbytearraylength [string cat A B C] 1 } A test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength { - testsetbytearraylength [string cat \u0141 B C] 1 + testsetbytearraylength [string cat Ł B C] 1 } A test binary-80.1 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { - testbytestring "\u4E4E" -} -result "expected byte sequence but character 0 was '\u4E4E' (U+004E4E)" + testbytestring "乎" +} -result "expected byte sequence but character 0 was '乎' (U+004E4E)" test binary-80.2 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\x00\xA0\xA0\xA0\xE4\xB9\x8E"] -} -result "expected byte sequence but character 4 was '\u4E4E' (U+004E4E)" +} -result "expected byte sequence but character 4 was '乎' (U+004E4E)" test binary-80.3 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xE4\xB9\x8E"] -} -result "expected byte sequence but character 4 was '\u4E4E' (U+004E4E)" +} -result "expected byte sequence but character 4 was '乎' (U+004E4E)" test binary-80.4 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"] } -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)" diff --git a/tests/case.test b/tests/case.test index d7558a9..1c12e3a 100644 --- a/tests/case.test +++ b/tests/case.test @@ -4,9 +4,9 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -16,8 +16,8 @@ if {![llength [info commands case]]} { return } -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/chan.test b/tests/chan.test index 6808453..92846d5 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -2,13 +2,13 @@ # command. Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # -# Copyright (c) 2005 Donal K. Fellows +# Copyright © 2005 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -48,10 +48,10 @@ test chan-4.1 {chan command: configure subcommand} -body { chan configure } -returnCodes error -result "wrong # args: should be \"chan configure channelId ?-option value ...?\"" test chan-4.2 {chan command: [Bug 800753]} -body { - chan configure stdout -eofchar \u0100 + chan configure stdout -eofchar Ā } -returnCodes error -match glob -result {bad value*} test chan-4.3 {chan command: [Bug 800753]} -body { - chan configure stdout -eofchar \u0000 + chan configure stdout -eofchar \x00 } -returnCodes error -match glob -result {bad value*} test chan-4.4 {chan command: check valid inValue, no outValue} -body { chan configure stdout -eofchar [list \x27 {}] @@ -173,7 +173,7 @@ test chan-16.9 {chan command: pending input subcommand} -setup { lappend ::chan-16.9-data $r $l $e $b $i - if {$r != -1 || $e || $l || !$b || $i > 128} { + if {$r >= 0 || $e || $l || !$b || $i > 128} { set data [read $sock $i] lappend ::chan-16.9-data [string range $data 0 2] lappend ::chan-16.9-data [string range $data end-2 end] diff --git a/tests/chanio.test b/tests/chanio.test index c7c07ce..8dfefb7 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6,20 +6,24 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# TODO: This test is likely worthless. Confirm and remove -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcl::test::io { - namespace import ::tcltest::* + + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } variable umaskValue variable path @@ -32,18 +36,20 @@ namespace eval ::tcl::test::io { catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] - set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [info loaded {} Tcltest] } package require tcltests testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] - testConstraint openpipe 1 testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] - testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] + testConstraint testservicemode [llength [info commands testservicemode]] + testConstraint notWinCI [expr { + $::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] + testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] # You need a *very* special environment to do some tests. In particular, # many file systems do not support large-files... @@ -73,7 +79,7 @@ namespace eval ::tcl::test::io { if {$argv != ""} { set f [open [lindex $argv 0]] } - chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a + chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A chan configure stdout -encoding binary -translation lf -buffering none chan event $f readable "foo $f" proc foo {f} { @@ -109,17 +115,17 @@ set path(test1) [makeFile {} test1] test chan-io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] chan configure $f -encoding binary - chan puts -nonewline $f "a\u4e4d\0" + chan puts -nonewline $f "a乍\x00" chan close $f contents $path(test1) -} "a\x4d\x00" +} "aM\x00" test chan-io-1.7 {Tcl_WriteChars: WriteChars} { set f [open $path(test1) w] chan configure $f -encoding shiftjis - chan puts -nonewline $f "a\u4e4d\0" + chan puts -nonewline $f "a乍\x00" chan close $f contents $path(test1) -} "a\x93\xe1\x00" +} "a\x93\xE1\x00" set path(test2) [makeFile {} test2] test chan-io-1.8 {Tcl_WriteChars: WriteChars} { # This test written for SF bug #506297. @@ -132,7 +138,7 @@ test chan-io-1.8 {Tcl_WriteChars: WriteChars} { chan puts -nonewline $f [format %s%c [string repeat " " 4] 12399] chan close $f contents $path(test2) -} " \x1b\$B\$O\x1b(B" +} " \x1B\$B\$O\x1B(B" test chan-io-1.9 {Tcl_WriteChars: WriteChars} { # When closing a channel with an encoding that appends escape bytes, check # for the case where the escape bytes overflow the current IO buffer. The @@ -267,13 +273,13 @@ test chan-io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { # to the beginning of that UTF-8 character and try again. # # Translate the first 16 bytes, produce 14 bytes of output, 2 left over - # (first two bytes of \uff21 in UTF-8). Given those two bytes try + # (first two bytes of Ａ in UTF-8). Given those two bytes try # translating them again, find that no bytes are read produced, and break # to outer loop where those two bytes will have the remaining 4 bytes (the - # last byte of \uff21 plus the all of \uff22) appended. + # last byte of Ａ plus the all of Ｂ) appended. set f [open $path(test1) w] chan configure $f -encoding shiftjis -buffersize 16 - chan puts -nonewline $f "12345678901234\uff21\uff22" + chan puts -nonewline $f "12345678901234ＡＢ" set x [list [contents $path(test1)]] chan close $f lappend x [contents $path(test1)] @@ -415,7 +421,7 @@ test chan-io-6.3 {Tcl_GetsObj: how many have we used?} -body { 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 puts $f "\x81\u1234\x00" chan close $f set f [open $path(test1)] chan configure $f -translation binary @@ -426,14 +432,14 @@ test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} -body { 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 puts $f "\x88\xEA\x92\x9A" chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis list [chan gets $f line] $line } -cleanup { chan close $f -} -result [list 2 "\u4e00\u4e01"] +} -result [list 2 "一丁"] set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a @@ -448,7 +454,7 @@ test chan-io-6.6 {Tcl_GetsObj: loop test} -body { } -cleanup { chan close $f } -result [list 256 $a] -test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints {stdio openpipe} -body { +test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints stdio -body { # if (FilterInputBytes(chanPtr, &gs) != 0) set f [openpipe w+ $path(cat)] chan puts -nonewline $f "hi\nwould" @@ -461,20 +467,20 @@ test chan-io-6.7 {Tcl_GetsObj: error in input} -constraints {stdio openpipe} -bo } -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 puts $f "abcdef\x1Aghijk\nwombat" chan close $f set f [open $path(test1)] - chan configure $f -eofchar \x1a + chan configure $f -eofchar \x1A list [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f } -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 puts $f "abcdefghijk\nwom\x1Abat" chan close $f set f [open $path(test1)] - chan configure $f -eofchar \x1a + chan configure $f -eofchar \x1A list [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f @@ -709,7 +715,7 @@ test chan-io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} -constraints {testc } -result [list 15 "123456789012345" 15] test chan-io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # (FilterInputBytes() != 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {crlf lf} -buffering none @@ -849,7 +855,7 @@ test chan-io-6.42 {Tcl_GetsObj: auto mode: several chars} -setup { } -result {4 abcd 4 efgh 4 ijkl 4 mnop -1 {}} test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # if (chanPtr->flags & INPUT_SAW_CR) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none @@ -859,7 +865,7 @@ test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { 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" + 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 { @@ -867,7 +873,7 @@ test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { } -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg} test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # not (*eol == '\n') set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none @@ -877,7 +883,7 @@ test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { 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" + 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 { @@ -885,7 +891,7 @@ test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { } -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg} test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # Tcl_ExternalToUtf() set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none @@ -903,7 +909,7 @@ test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup } -result {15 123456789abcdef 1 4 abcd 0} test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # memmove() set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none @@ -913,7 +919,7 @@ test chan-io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eo chan configure $f -blocking 0 lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan configure $f -blocking 1 - chan puts -nonewline $f "\n\x1a" + chan puts -nonewline $f "\n\x1A" lappend x [chan gets $f line] $line [testchannel queuedcr $f] } -cleanup { chan close $f @@ -979,10 +985,10 @@ test chan-io-6.52 {Tcl_GetsObj: saw EOF character} -constraints {testchannel} -b # if (eof != NULL) set f [open $path(test1) w] chan configure $f -translation lf - chan puts -nonewline $f "123456\x1ak9012345\r" + chan puts -nonewline $f "123456\x1Ak9012345\r" chan close $f set f [open $path(test1)] - chan configure $f -eofchar \x1a + chan configure $f -eofchar \x1A list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] } -cleanup { chan close $f @@ -1010,18 +1016,18 @@ 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 - chan puts $f "there\u4e00ok\n\u4e01more bytes\nhere" + chan puts $f "there一ok\n丁more bytes\nhere" chan close $f set f [open $path(test1)] chan configure $f -encoding iso2022-jp list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f -} -result [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] +} -result [list 8 "there一ok" 11 "丁more bytes" 4 "here"] test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup { update variable x {} -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe w+ $path(cat)] chan configure $f -buffering none chan puts -nonewline $f "foobar" @@ -1051,19 +1057,19 @@ 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 - chan puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend" + chan puts $f "1234567890123０１２３４\nend" chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis -buffersize 16 chan gets $f } -cleanup { chan close $f -} -result "1234567890123\uff10\uff11\uff12\uff13\uff14" +} -result "1234567890123０１２３４" 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 - chan puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" + chan puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82" chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis @@ -1076,7 +1082,7 @@ test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup { } -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 puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" chan close $f set f [open $path(test1)] chan configure $f -encoding shiftjis @@ -1085,13 +1091,13 @@ test chan-io-7.3 {FilterInputBytes: split up character at EOF} -setup { lappend x [chan gets $f line] $line } -cleanup { chan close $f -} -result [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] +} -result [list 15 "1234567890123０１" 18 0 1 -1 ""] test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup { variable x "" -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none - chan puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + chan puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" chan configure $f -encoding shiftjis -blocking 0 chan event $f read [namespace code { lappend x [chan gets $f line] $line [chan blocked $f] @@ -1104,7 +1110,7 @@ test chan-io-7.4 {FilterInputBytes: recover from split up character} -setup { return $x } -cleanup { chan close $f -} -result [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] +} -result [list -1 "" 1 17 "1234567890123０１２３" 0] test chan-io-8.1 {PeekAhead: only go to device if no more cached data} -constraints {testchannel} -body { # (bufPtr->nextPtr == NULL) @@ -1122,7 +1128,7 @@ test chan-io-8.1 {PeekAhead: only go to device if no more cached data} -constrai } -result 7 test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { variable x {} -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # not (bufPtr->nextPtr == NULL) set f [openpipe w+ $path(cat)] chan configure $f -translation lf -encoding ascii -buffering none @@ -1139,7 +1145,7 @@ test chan-io-8.2 {PeekAhead: only go to device if no more cached data} -setup { } -cleanup { chan close $f } -result {-1 {} 42 15 123456789012345 25} -test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel openpipe fileevent} -body { +test chan-io-8.3 {PeekAhead: no cached data available} -constraints {stdio testchannel fileevent} -body { # (bytesLeft == 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} @@ -1168,7 +1174,7 @@ test chan-io-8.4 {PeekAhead: cached data available in this buffer} -body { chan close $f } -result $a unset a -test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel openpipe fileevent} -body { +test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {stdio testchannel fileevent} -body { # (bufPtr->nextAdded < bufPtr->length) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} @@ -1179,7 +1185,7 @@ test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {st } -cleanup { chan close $f } -result {15 abcdefghijklmno 1} -test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel openpipe fileevent} -body { +test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel fileevent} -body { # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffersize 16 @@ -1192,14 +1198,14 @@ test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio te } -result {15 abcdefghijklmno 1} test chan-io-8.7 {PeekAhead: cleanup} -setup { set x "" -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # Make sure bytes are removed from buffer. set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffering none chan puts -nonewline $f "abcdefghijklmno\r" # here lappend x [chan gets $f line] $line [testchannel queuedcr $f] - chan puts -nonewline $f "\x1a" + chan puts -nonewline $f "\x1A" lappend x [chan gets $f line] $line } -cleanup { chan close $f @@ -1343,7 +1349,7 @@ test chan-io-12.3 {ReadChars: allocate more space} -body { } -result {abcdefghijklmnopqrstuvwxyz} test chan-io-12.4 {ReadChars: split-up char} -setup { variable x {} -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # (srcRead == 0) set f [openpipe w+ $path(cat)] chan configure $f -encoding binary -buffering none -buffersize 16 @@ -1355,22 +1361,22 @@ test chan-io-12.4 {ReadChars: split-up char} -setup { chan configure $f -encoding shiftjis vwait [namespace which -variable x] chan configure $f -encoding binary -blocking 1 - chan puts -nonewline $f "\x7b" + chan puts -nonewline $f "\x7B" 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 -} -result [list "123456789012345" 1 "\u672c" 0] +} -result [list "123456789012345" 1 "本" 0] test chan-io-12.5 {ReadChars: chan events on partial characters} -setup { variable x {} -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set path(test1) [makeFile { chan configure stdout -encoding binary -buffering none - chan gets stdin; chan puts -nonewline "\xe7" + chan gets stdin; chan puts -nonewline "\xE7" chan gets stdin; chan puts -nonewline "\x89" - chan gets stdin; chan puts -nonewline "\xa6" + chan gets stdin; chan puts -nonewline "\xA6" } test1] set f [openpipe r+ $path(test1)] chan event $f readable [namespace code { @@ -1395,7 +1401,7 @@ test chan-io-12.5 {ReadChars: chan events on partial characters} -setup { vwait [namespace which -variable x] vwait [namespace which -variable x] lappend x [catch {chan close $f} msg] $msg -} -result "{} timeout {} timeout \u7266 {} eof 0 {}" +} -result "{} timeout {} timeout 牦 {} eof 0 {}" test chan-io-13.1 {TranslateInputEOL: cr mode} -body { set f [open $path(test1) w] @@ -1458,7 +1464,7 @@ test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} -body { test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup { variable x {} variable y {} -} -constraints {stdio testchannel openpipe fileevent} -body { +} -constraints {stdio testchannel fileevent} -body { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. set f [openpipe w+ $path(cat)] @@ -1476,7 +1482,7 @@ test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup } -cleanup { chan close $f } -result [list "abcdefghj\n" 1 "01234" 0] -test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints {testchannel openpipe} -body { +test chan-io-13.7 {TranslateInputEOL: auto mode: naked \r} -constraints testchannel -body { # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf @@ -1524,7 +1530,7 @@ test chan-io-13.10 {TranslateInputEOL: auto mode: \n} -body { chan close $f } -result "abcd\ndef" test chan-io-13.11 {TranslateInputEOL: EOF char} -body { - # (*chanPtr->inEofChar != '\0') + # (*chanPtr->inEofChar != '\x00') set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\ndefgh" @@ -1536,7 +1542,7 @@ test chan-io-13.11 {TranslateInputEOL: EOF char} -body { chan close $f } -result "abcd\nd" test chan-io-13.12 {TranslateInputEOL: find EOF char in src} -body { - # (*chanPtr->inEofChar != '\0') + # (*chanPtr->inEofChar != '\x00') set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n" @@ -1577,7 +1583,7 @@ test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} -setup { interp delete x } -result {line line none} set path(test3) [makeFile {} test3] -test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec openpipe} -body { +test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints exec -body { set f [open $path(test1) w] chan puts -nonewline $f { chan close stdin @@ -1674,7 +1680,7 @@ set path(script) [makeFile {} script] test chan-io-14.8 {reuse of stdio special channels} -setup { file delete $path(script) file delete $path(test1) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [open $path(script) w] chan puts -nonewline $f { chan close stderr @@ -1697,7 +1703,7 @@ test chan-io-14.8 {reuse of stdio special channels} -setup { test chan-io-14.9 {reuse of stdio special channels} -setup { file delete $path(script) file delete $path(test1) -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [open $path(script) w] chan puts $f { array set path [lindex $argv 0] @@ -1872,7 +1878,7 @@ test chan-io-20.2 {Tcl_CreateChannel: initial settings} -constraints {win} -body list [chan configure $f -eofchar] [chan configure $f -translation] } -cleanup { chan close $f -} -result [list [list \x1a ""] {auto crlf}] +} -result [list [list \x1A ""] {auto crlf}] test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -body { set f [open $path(test1) w+] list [chan configure $f -eofchar] [chan configure $f -translation] @@ -1881,7 +1887,7 @@ test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -bod } -result {{{} {}} {auto lf}} test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { set path(stdout) [makeFile {} stdout] -} -constraints {stdio openpipe knownMsvcBug} -body { +} -constraints {stdio notWinCI} -body { set f [open $path(script) w] chan puts -nonewline $f { chan close stdout @@ -1966,7 +1972,7 @@ test chan-io-26.1 {Tcl_GetChannelInstanceData} -body { # Don't care what pid is (but must be a number), just want to exercise it. set f [openpipe r << exit] pid $f -} -constraints {stdio openpipe} -cleanup { +} -constraints stdio -cleanup { chan close $f } -match regexp -result {^\d+$} @@ -2041,7 +2047,7 @@ set path(output) [makeFile {} output] test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio asyncPipeChan Close openpipe} -body { +} -constraints {stdio asyncPipeChan Close} -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f { @@ -2111,7 +2117,7 @@ test chan-io-28.2 {Chan CloseChannel called when all references are dropped} -se test chan-io-28.3 {Chan CloseChannel, not called before output queue is empty} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio asyncPipeChan Close nonPortable openpipe} -body { +} -constraints {stdio asyncPipeChan Close nonPortable} -body { set f [open $path(pipe) w] chan puts $f { # Need to not have eof char appended on chan close, because the other @@ -2165,7 +2171,7 @@ test chan-io-28.4 {Tcl_Chan Close} -constraints {testchannel} -setup { } -result ok test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { file delete $path(script) -} -constraints {stdio unix testchannel openpipe} -body { +} -constraints {stdio unix testchannel} -body { set f [open $path(script) w] chan puts $f { chan close stdin @@ -2382,7 +2388,7 @@ test chan-io-29.11 {Tcl_WriteChars, no newline, implicit flush} -setup { test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 "set f1 \[[list open $path(longfile) r]]" chan puts $f1 { @@ -2409,7 +2415,7 @@ test chan-io-29.12 {Tcl_WriteChars on a pipe} -setup { test chan-io-29.13 {Tcl_WriteChars to a pipe, line buffered} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts [chan gets stdin] @@ -2462,7 +2468,7 @@ test chan-io-29.15 {Tcl_Flush, channel not open for writing} -setup { } -match glob -result {channel "*" wasn't opened for writing} test chan-io-29.16 {Tcl_Flush on pipe opened only for reading} -setup { set fd [openpipe r cat longfile] -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { chan flush $fd } -returnCodes error -cleanup { catch {chan close $fd} @@ -2538,7 +2544,7 @@ test chan-io-29.20 {Implicit flush when buffer is full} -setup { } -result {4096 12288 12600} test chan-io-29.21 {Tcl_Flush to pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {set x [chan read stdin 6]} chan puts $f1 {set cnt [string length $x]} @@ -2553,7 +2559,7 @@ test chan-io-29.21 {Tcl_Flush to pipe} -setup { } -result "read 6 characters" test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan configure stdout -buffering full @@ -2577,7 +2583,7 @@ test chan-io-29.22 {Tcl_Flush called at other end of pipe} -setup { } -result {hello hello bye} test chan-io-29.23 {Tcl_Flush and line buffering at end of pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts hello @@ -2614,7 +2620,7 @@ test chan-io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} -setup { } -result "{} {Line 1\nLine 2}" test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup { file delete $path(test3) -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe w $path(cat) | [interpreter] $path(cat) > $path(test3)] chan puts $f "Line 1" chan puts $f "Line 2" @@ -2625,7 +2631,7 @@ test chan-io-29.25 {Implicit flush with Tcl_Flush to command pipelines} -setup { } -cleanup { chan close $f } -result "Line 1\nLine 2\n" -test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs openpipe} -body { +test chan-io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} -constraints {stdio unixExecs} -body { set f [open "|[list cat -u]" r+] chan puts $f "Line1" chan flush $f @@ -2638,7 +2644,7 @@ test chan-io-29.27 {Tcl_Flush on chan closed pipeline} -setup { set f [open $path(pipe) w] chan puts $f {exit} chan close $f -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [openpipe r+ $path(pipe)] chan gets $f chan puts $f output @@ -2691,7 +2697,7 @@ test chan-io-29.30 {Tcl_WriteChars, crlf mode} -setup { test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f {chan configure $f -translation lf} @@ -2724,7 +2730,7 @@ test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { set result ok } # allow a little time for the background process to chan close. - # otherwise, the following test fails on the [file delete $path(output) + # otherwise, the following test fails on the [file delete $path(output)] # on Windows because a process still has the file open. after 100 set v 1; vwait v return $result @@ -2732,7 +2738,7 @@ test chan-io-29.31 {Tcl_WriteChars, background flush} -setup { test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} -setup { file delete $path(pipe) file delete $path(output) -} -constraints {stdio asyncPipeChan Close openpipe} -body { +} -constraints {stdio asyncPipeChan Close} -body { set f [open $path(pipe) w] chan puts $f "set f \[[list open $path(output) w]]" chan puts $f {chan configure $f -translation lf} @@ -2791,7 +2797,7 @@ test chan-io-29.34 {Tcl_Chan Close, async flush on chan close, using sockets} -s chan puts $s $l } } -} -constraints {socket tempNotMac fileevent knownMsvcBug} -body { +} -constraints {socket tempNotMac fileevent notWinCI} -body { proc accept {s a p} { variable x chan event $s readable [namespace code [list readit $s]] @@ -3045,7 +3051,7 @@ test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} -setup { string length [chan read $f] } -cleanup { chan close $f -} -result [expr 700*15+1] +} -result [expr {700*15 + 1}] test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup { file delete $path(test1) } -body { @@ -3062,7 +3068,7 @@ test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup { string length [chan read $f] } -cleanup { chan close $f -} -result [expr 700*15+1] +} -result [expr {700*15 + 1}] test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} -setup { file delete $path(test1) } -body { @@ -3085,10 +3091,10 @@ test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} -setup { } -body { set f [open $path(test1) w] chan configure $f -translation lf - chan puts -nonewline $f hello\nthere\nand\rhere\n\x1a + 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 + chan configure $f -translation auto -eofchar \x1A chan read $f } -cleanup { chan close $f @@ -3101,11 +3107,11 @@ 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 configure $f -translation lf -eofchar \x1A chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A chan read $f } -cleanup { chan close $f @@ -3123,7 +3129,7 @@ test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $s chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A set l "" lappend l [chan gets $f] lappend l [chan gets $f] @@ -3144,7 +3150,7 @@ test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} -setup { chan puts $f $s chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A set l "" lappend l [chan gets $f] lappend l [chan gets $f] @@ -3177,7 +3183,7 @@ test chan-io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} -setup { lappend l [chan eof $f] } -cleanup { chan close $f -} -result "abc def 0 \x1aghi 0 qrs 0 {} 1" +} -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 "" @@ -3189,7 +3195,7 @@ test chan-io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} -setup { set f [open $path(test1) r] chan configure $f -translation cr -eofchar {} set x [chan gets $f] - lappend l [string equal $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] @@ -3207,7 +3213,7 @@ test chan-io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} -setup { set f [open $path(test1) r] chan configure $f -translation crlf -eofchar {} set x [chan gets $f] - lappend l [string equal $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] @@ -3222,7 +3228,7 @@ test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} -setup { 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 + chan configure $f -translation auto -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3236,7 +3242,7 @@ test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3250,7 +3256,7 @@ test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3264,7 +3270,7 @@ test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3278,7 +3284,7 @@ test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3292,7 +3298,7 @@ test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3643,7 +3649,7 @@ test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} -setup { 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 + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3659,11 +3665,11 @@ test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} -setup { set l "" } -body { set f [open $path(test1) w] - chan configure $f -eofchar \x1a -translation lf + chan configure $f -translation lf -eofchar \x1A chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3683,8 +3689,7 @@ test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} -setup { 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 + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3702,7 +3707,7 @@ test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} 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 + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3732,7 +3737,7 @@ test chan-io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} -setup { lappend l [chan eof $f] } -cleanup { chan close $f -} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1" +} -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 "" @@ -3754,7 +3759,7 @@ test chan-io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} -setup { lappend l [chan eof $f] } -cleanup { chan close $f -} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1" +} -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 "" @@ -3776,7 +3781,7 @@ test chan-io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} -setup { lappend l [chan eof $f] } -cleanup { chan close $f -} -result "abc def 0 \x1aqrs 0 tuv 0 {} 1" +} -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 "" @@ -3786,7 +3791,7 @@ test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} -setup { 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 + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3804,7 +3809,7 @@ test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} -setup { 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 + chan configure $f -translation lf -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3822,7 +3827,7 @@ test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup { 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 + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3840,7 +3845,7 @@ test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} -setup { 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 + chan configure $f -translation cr -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3858,7 +3863,7 @@ test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} -setup { 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 + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3876,7 +3881,7 @@ test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} -setup { 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 + chan configure $f -translation crlf -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3904,7 +3909,7 @@ test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} -setup { } chan close $f string length $c -} -result [expr 700*15+1] +} -result [expr {700*15 + 1}] test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup { file delete $path(test1) set c "" @@ -3924,7 +3929,7 @@ test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup { } chan close $f string length $c -} -result [expr 700*15+1] +} -result [expr {700*15 + 1}] # Test Tcl_Read and buffering. @@ -4005,7 +4010,7 @@ test chan-io-32.9 {Tcl_Read, read to end of file} { } ok test chan-io-32.10 {Tcl_Read from a pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 @@ -4019,7 +4024,7 @@ test chan-io-32.10 {Tcl_Read from a pipe} -setup { test chan-io-32.11 {Tcl_Read from a pipe} -setup { file delete $path(pipe) set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan puts $f1 {chan puts [chan gets stdin]} @@ -4131,7 +4136,7 @@ test chan-io-33.2 {Tcl_Gets into variable} { } ok test chan-io-33.3 {Tcl_Gets from pipe} -setup { file delete $path(pipe) -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 {chan puts [chan gets stdin]} chan close $f1 @@ -4341,7 +4346,7 @@ test chan-io-34.7 {Tcl_Seek to offset from end of file, then to current position } -result {44 rstuv 49} test chan-io-34.8 {Tcl_Seek on pipes: not supported} -setup { set pipe [openpipe] -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { chan seek $pipe 0 current } -returnCodes error -cleanup { chan close $pipe @@ -4451,13 +4456,13 @@ test chan-io-34.15 {Tcl_Tell combined with seeking} -setup { } -cleanup { chan close $f1 } -result {10 20} -test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints {stdio openpipe} -body { +test chan-io-34.16 {Tcl_Tell on pipe: always -1} -constraints stdio -body { set f1 [openpipe] chan tell $f1 } -cleanup { chan close $f1 } -result -1 -test chan-io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { +test chan-io-34.17 {Tcl_Tell on pipe: always -1} stdio { set f1 [openpipe] chan puts $f1 {chan puts hello} chan flush $f1 @@ -4559,7 +4564,7 @@ test chan-io-35.1 {Tcl_Eof} -setup { } -cleanup { chan close $f } -result {0 0 0 0 1 1} -test chan-io-35.2 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { +test chan-io-35.2 {Tcl_Eof with pipe} -constraints stdio -setup { file delete $path(pipe) } -body { set f1 [open $path(pipe) w] @@ -4578,7 +4583,7 @@ test chan-io-35.2 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { } -cleanup { chan close $f1 } -result {0 0 0 1} -test chan-io-35.3 {Tcl_Eof with pipe} -constraints {stdio openpipe} -setup { +test chan-io-35.3 {Tcl_Eof with pipe} -constraints stdio -setup { file delete $path(pipe) } -body { set f1 [open $path(pipe) w] @@ -4616,7 +4621,7 @@ test chan-io-35.4 {Tcl_Eof, eof detection on nonblocking file} -setup { test chan-io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} -setup { file delete $path(pipe) set l "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f [open $path(pipe) w] chan puts $f { exit @@ -4632,12 +4637,12 @@ 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 configure $f -translation lf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4646,12 +4651,12 @@ 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 configure $f -translation lf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4660,12 +4665,12 @@ 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 configure $f -translation cr -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4674,12 +4679,12 @@ 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 configure $f -translation cr -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4688,12 +4693,12 @@ 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 configure $f -translation crlf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4702,12 +4707,12 @@ 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 configure $f -translation crlf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4721,7 +4726,7 @@ test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4735,7 +4740,7 @@ test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4749,7 +4754,7 @@ test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4763,7 +4768,7 @@ test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4777,7 +4782,7 @@ test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4791,7 +4796,7 @@ test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4801,7 +4806,7 @@ test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup { test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup { set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [openpipe] chan puts $f1 {chan puts hello_from_pipe} chan flush $f1 @@ -4821,7 +4826,7 @@ test chan-io-36.1 {Tcl_InputBlocked on nonblocking pipe} -setup { } -result {{} 1 hello 0 {} 1} test chan-io-36.2 {Tcl_InputBlocked on blocking pipe} -setup { set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [openpipe] chan configure $f1 -buffering line chan puts $f1 {chan puts hello_from_pipe} @@ -5095,7 +5100,7 @@ test chan-io-39.9 {Tcl_SetChannelOption, blocking mode} -setup { test chan-io-39.10 {Tcl_SetChannelOption, blocking mode} -setup { file delete $path(pipe) set x "" -} -constraints {stdio openpipe} -body { +} -constraints stdio -body { set f1 [open $path(pipe) w] chan puts $f1 { chan gets stdin @@ -5161,27 +5166,27 @@ test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup { } -body { set f [open $path(test1) w] chan configure $f -encoding {} - chan puts -nonewline $f \xe7\x89\xa6 + chan puts -nonewline $f \xE7\x89\xA6 chan close $f set f [open $path(test1) r] chan configure $f -encoding utf-8 chan read $f } -cleanup { chan close $f -} -result \u7266 +} -result 牦 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 puts -nonewline $f \xE7\x89\xA6 chan close $f set f [open $path(test1) r] chan configure $f -encoding utf-8 chan read $f } -cleanup { chan close $f -} -result \u7266 +} -result 牦 test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup { file delete $path(test1) set f [open $path(test1) w] @@ -5192,10 +5197,10 @@ test chan-io-39.16 {Tcl_SetChannelOption: -encoding, errors} -setup { } -result {unknown encoding "foobar"} test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} -setup { variable x {} -} -constraints {stdio openpipe fileevent} -body { +} -constraints {stdio fileevent} -body { set f [openpipe r+ $path(cat)] chan configure $f -encoding binary - chan puts -nonewline $f "\xe7" + chan puts -nonewline $f "\xE7" chan flush $f chan configure $f -encoding utf-8 -blocking 0 chan event $f readable [namespace code { lappend x [chan read $f] }] @@ -5213,7 +5218,7 @@ test chan-io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_ return $x } -cleanup { chan close $f -} -result "{} timeout {} timeout \xe7 timeout" +} -result "{} timeout {} timeout \xE7 timeout" test chan-io-39.18 {Tcl_SetChannelOption, setting read mode independently} \ -constraints {socket} -body { proc accept {s a p} {chan close $s} @@ -5333,9 +5338,9 @@ test chan-io-40.1 {POSIX open access modes: RDWR} -setup { test chan-io-40.2 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -constraints {unix} -body { - set f [open $path(test3) {WRONLY CREAT} 0600] + set f [open $path(test3) {WRONLY CREAT} 0o600] file stat $path(test3) stats - set x [format "%#o" [expr $stats(mode)&0o777]] + set x [format 0o%03o [expr {$stats(mode) & 0o777}]] chan puts $f "line 1" chan close $f set f [open $path(test3) r] @@ -5349,8 +5354,8 @@ test chan-io-40.3 {POSIX open access modes: CREAT} -setup { # 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 "%#o" [expr $stats(mode)&0o777] -} -result [format %#5o [expr {0o666 & ~ $umaskValue}]] + format 0o%03o [expr {$stats(mode) & 0o777}] +} -result [format 0o%03o [expr {0o666 & ~ $umaskValue}]] test chan-io-40.4 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -body { @@ -5527,11 +5532,11 @@ test chan-io-42.2 {Tcl_FileeventCmd: replacing} {fileevent} { } {{first script} {new script} {yet another} {}} test chan-io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {fileevent} { set result {} - chan event $f r "first scr\0ipt" + chan event $f r "first scr\x00ipt" lappend result [string length [chan event $f readable]] - chan event $f r "new scr\0ipt" + chan event $f r "new scr\x00ipt" lappend result [string length [chan event $f readable]] - chan event $f r "yet ano\0ther" + chan event $f r "yet ano\x00ther" lappend result [string length [chan event $f readable]] chan event $f r "" lappend result [chan event $f readable] @@ -5552,7 +5557,7 @@ test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] set result {} -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] chan event $f r "chan read f" chan event $f2 r "chan read f2" @@ -5572,7 +5577,7 @@ test chan-io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { test chan-io-44.1 {FileEventProc procedure: normal read event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 readable [namespace code { set x [chan gets $f2]; chan event $f2 readable {} }] @@ -5592,7 +5597,7 @@ test chan-io-44.2 {FileEventProc procedure: error in read event} -setup { } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 readable {error bogus} chan puts $f2 text; chan flush $f2 variable x initial @@ -5606,7 +5611,7 @@ test chan-io-44.2 {FileEventProc procedure: error in read event} -setup { test chan-io-44.3 {FileEventProc procedure: normal write event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 writable [namespace code { lappend x "triggered" incr count -1 @@ -5632,7 +5637,7 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -setup { } set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { chan event $f2 writable {error bad-write} variable x initial vwait [namespace which -variable x] @@ -5642,7 +5647,9 @@ test chan-io-44.4 {FileEventProc procedure: eror in write event} -setup { catch {chan close $f2} catch {chan close $f3} } -result {bad-write {}} -test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { +test chan-io-44.5 {FileEventProc procedure: end of file} -constraints { + stdio unixExecs fileevent +} -body { set f4 [openpipe r $path(cat) << foo] chan event $f4 readable [namespace code { if {[chan gets $f4 line] < 0} { @@ -5655,9 +5662,10 @@ test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpi variable x initial vwait [namespace which -variable x] vwait [namespace which -variable x] - chan close $f4 set x -} {initial foo eof} +} -cleanup { + chan close $f4 +} -result {initial foo eof} chan close $f makeFile "foo bar" foo @@ -5718,7 +5726,7 @@ test chan-io-45.3 {DeleteFileEvent, cleanup on chan close} {fileevent} { # Execute these tests only if the "testfevent" command is present. -test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { +test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent notOSX} { testfevent create set script "set f \[[list open $path(foo) r]]\n" append script { @@ -5728,9 +5736,10 @@ test chan-io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileeven chan event $f readable {} }] } + set timer [after 10 lappend x timeout] testfevent cmd $script - after 1 ;# We must delay because Windows takes a little time to notice - update + vwait x + after cancel $timer testfevent cmd {chan close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} @@ -5918,7 +5927,7 @@ test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { set path(my_script) [makeFile {} my_script] test chan-io-48.3 {testing readability conditions} -setup { set l "" -} -constraints {stdio unix nonBlockFiles openpipe fileevent} -body { +} -constraints {stdio unix nonBlockFiles fileevent} -body { set f [open $path(bar) w] chan puts $f abcdefg chan puts $f abcdefg @@ -5973,7 +5982,7 @@ test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -5997,7 +6006,7 @@ test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6021,7 +6030,7 @@ test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6045,7 +6054,7 @@ test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6069,7 +6078,7 @@ test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mo chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6093,7 +6102,7 @@ test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation auto + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6117,7 +6126,7 @@ test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} - chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation lf + chan configure $f -translation lf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6141,7 +6150,7 @@ test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6165,7 +6174,7 @@ test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} - chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation cr + chan configure $f -translation cr -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6189,7 +6198,7 @@ test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6213,7 +6222,7 @@ test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mod chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -eofchar \x1a -translation crlf + chan configure $f -translation crlf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6237,7 +6246,7 @@ test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} - chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6372,17 +6381,21 @@ test chan-io-49.5 {testing crlf reading, leftover cr disgorgment} -setup { test chan-io-50.1 {testing handler deletion} -setup { file delete $path(test1) -} -constraints {testchannelevent} -body { +} -constraints testchannelevent -body { set f [open $path(test1) w] chan close $f set f [open $path(test1) r] + variable z not_called + set timer [after 50 lappend z timeout] + testservicemode 0 testchannelevent $f add readable [namespace code { variable z called testchannelevent $f delete 0 }] - variable z not_called - update - return $z + testservicemode 1 + vwait z + after cancel $timer + set z } -cleanup { chan close $f } -result called @@ -6390,16 +6403,21 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] set z "" -} -constraints {testchannelevent} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] +} -constraints {testchannelevent testservicemode} -body { proc delhandler {f i} { variable z lappend z "called delhandler $f $i" testchannelevent $f delete 0 } - update + set z "" + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + vwait z + after cancel $timer string equal $z \ [list [list called delhandler $f 0] [list called delhandler $f 1]] } -cleanup { @@ -6408,11 +6426,7 @@ test chan-io-50.2 {testing handler deletion with multiple handlers} -setup { test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { file delete $path(test1) chan close [open $path(test1) w] - set z "" -} -constraints {testchannelevent} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] +} -constraints {testchannelevent testservicemode} -body { proc notcalled {f i} { variable z lappend z "notcalled was called!! $f $i" @@ -6424,7 +6438,15 @@ test chan-io-50.3 {testing handler deletion with multiple handlers} -setup { testchannelevent $f delete 0 lappend z "delhandler $f $i deleted myself" } - update + set z "" + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + vwait z + after cancel $timer string equal $z \ [list [list delhandler $f 0 called] \ [list delhandler $f 0 deleted myself]] @@ -6435,7 +6457,7 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent} -body { +} -constraints testchannelevent -body { set f [open $path(test1) r] testchannelevent $f add readable [namespace code { if {$u eq "recursive"} { @@ -6449,19 +6471,20 @@ test chan-io-50.4 {testing handler deletion vs reentrant calls} -setup { }] variable u toplevel variable z "" - update - return $z + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z } -cleanup { chan close $f + update } -result {{delrecursive calling recursive} {delrecursive deleting recursive}} test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f]] - testchannelevent $f add readable [namespace code [list del $f]] + update +} -constraints {testchannelevent testservicemode notOSX} -body { proc notcalled {f} { variable z lappend z "notcalled was called!! $f" @@ -6477,33 +6500,46 @@ test chan-io-50.5 {testing handler deletion vs reentrant calls} -setup { } else { set u recursive lappend z "del calling recursive" - update + set timer [after 50 lappend z timeout] + set mode [testservicemode 1] + vwait z + after cancel $timer + testservicemode $mode lappend z "del after update" } } set z "" set u toplevel - update - return $z + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f]] + testchannelevent $f add readable [namespace code [list del $f]] + testservicemode 1 + vwait z + after cancel $timer + set z } -cleanup { chan close $f + update } -result [list {del calling recursive} {del deleted notcalled} \ {del deleted myself} {del after update}] test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { file delete $path(test1) set f [open $path(test1) w] chan close $f -} -constraints {testchannelevent} -body { - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list second $f]] - testchannelevent $f add readable [namespace code [list first $f]] +} -constraints {testchannelevent testservicemode} -body { proc first {f} { variable u variable z if {$u eq "toplevel"} { lappend z "first called" + set mode [testservicemode 1] + set timer [after 50 lappend z timeout] set u first - update + vwait z + after cancel $timer + testservicemode $mode lappend z "first after update" } else { lappend z "first called not toplevel" @@ -6526,8 +6562,15 @@ test chan-io-50.6 {testing handler deletion vs reentrant calls} -setup { } set z "" set u toplevel - update - return $z + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list second $f]] + testchannelevent $f add readable [namespace code [list first $f]] + testservicemode 1 + vwait z + after cancel $timer + set z } -cleanup { chan close $f } -result [list {first called} {first called not toplevel} \ @@ -6678,7 +6721,7 @@ test chan-io-52.6 {TclCopyChannel} -setup { set f2 [open $path(test1) w] chan configure $f1 -translation lf -blocking 0 chan configure $f2 -translation lf -blocking 0 - set s0 [chan copy $f1 $f2 -size [expr [file size $thisScript] + 5]] + set s0 [chan copy $f1 $f2 -size [expr {[file size $thisScript] + 5}]] set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 chan close $f2 @@ -6709,7 +6752,7 @@ test chan-io-52.7 {TclCopyChannel} -constraints {fcopy} -setup { test chan-io-52.8 {TclCopyChannel} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set f1 [open $path(pipe) w] chan configure $f1 -translation lf chan puts $f1 " @@ -6740,7 +6783,7 @@ set path(utf8-rp.txt) [makeFile {} utf8-rp.txt] # Create kyrillic file, use lf translation to avoid os eol issues set out [open $path(kyrillic.txt) w] chan configure $out -encoding koi8-r -translation lf -chan puts $out "\u0410\u0410" +chan puts $out "АА" chan close $out test chan-io-52.9 {TclCopyChannel & encodings} {fcopy} { # Copy kyrillic to UTF-8, using chan copy. @@ -6778,7 +6821,7 @@ test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} { test chan-io-52.11 {TclCopyChannel & encodings} -setup { set f [open $path(utf8-fcopy.txt) w] fconfigure $f -encoding utf-8 -translation lf - puts $f "\u0410\u0410" + puts $f "АА" close $f } -constraints {fcopy} -body { # binary to encoding => the input has to be in utf-8 to make sense to the @@ -6830,7 +6873,7 @@ test chan-io-53.2 {CopyData} -setup { test chan-io-53.3 {CopyData: background read underflow} -setup { file delete $path(test1) file delete $path(pipe) -} -constraints {stdio unix openpipe fcopy} -body { +} -constraints {stdio unix fcopy} -body { set f1 [open $path(pipe) w] chan puts -nonewline $f1 { chan puts ready @@ -6868,7 +6911,7 @@ test chan-io-53.4 {CopyData: background write overflow} -setup { } file delete $path(test1) file delete $path(pipe) -} -constraints {stdio unix openpipe fileevent fcopy} -body { +} -constraints {stdio unix fileevent fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 { chan puts ready @@ -6920,7 +6963,7 @@ test chan-io-53.5 {CopyData: error during chan copy} {socket fcopy} { chan close $listen ;# This means the socket open never really succeeds chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g. } chan close $in @@ -6932,7 +6975,7 @@ test chan-io-53.6 {CopyData: error during chan copy} -setup { file delete $path(pipe) file delete $path(test1) catch {unset fcopyTestDone} -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 "exit 1" chan close $f1 @@ -6940,7 +6983,7 @@ test chan-io-53.6 {CopyData: error during chan copy} -setup { set out [open $path(test1) w] chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] } return $fcopyTestDone ;# 0 for plain end of file @@ -6966,7 +7009,7 @@ test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup { variable fcopyTestDone file delete $path(pipe) catch {unset fcopyTestDone} -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set fcopyTestCount 0 set f1 [open $path(pipe) w] chan puts $f1 { @@ -6993,7 +7036,7 @@ test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup { vwait [namespace which -variable fcopyTestDone] } # -1=error 0=script error N=number of bytes - expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1 + expr {($fcopyTestDone == 0) ? $fcopyTestCount : -1} } -cleanup { catch {chan close $in} chan close $out @@ -7016,7 +7059,7 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. @@ -7056,7 +7099,7 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at # Channels to copy between set f [open $foo r] ; chan configure $f -translation binary set g [open $bar w] ; chan configure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Initialize and force eof on the input. chan seek $f 0 end ; chan read $f 1 set ::RES [chan eof $f] @@ -7114,7 +7157,7 @@ test chan-io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { } set ::forever {} set out [open $out w] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { chan copy $pipe $out -size 6 -command ::done set token [after 5000 { set ::forever {fcopy hangs} @@ -7187,7 +7230,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { chan configure $b -translation binary -buffering none chan event $a readable [namespace code "done $a"] chan event $b readable [namespace code "done $b"] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Now pass data through the server in both directions. set ::forever {} chan puts $a AB @@ -7409,7 +7452,7 @@ test chan-io-57.2 {buffered data and file events, read} -setup { chan close $server } -result {1 readable 234567890 timer} -test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin openpipe fileevent} { +test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} { set out [open $path(script) w] chan puts $out { chan puts "normal message from pipe" @@ -7447,12 +7490,12 @@ test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} { string equal $result [testmainthread] } {1} -test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} { +test chan-io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] chan puts $out "catch {load $::tcltestlib Tcltest}" chan puts $out { - chan puts [testbytestring \xe2] + chan puts [testbytestring \xE2] exit 1 } proc readit {pipe} { diff --git a/tests/clock.test b/tests/clock.test index 55607ce..2a53259 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -6,13 +6,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. +# Copyright © 2004 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -234,7 +234,7 @@ namespace eval ::testClock { Bias 300 \ StandardBias 0 \ DaylightBias -60 \ - StandardStart \x00\x00\x0b\x00\x01\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00 \ + StandardStart \x00\x00\x0B\x00\x01\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00 \ DaylightStart \x00\x00\x03\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00]] } @@ -250,7 +250,6 @@ proc ::testClock::registry { cmd path key } { return [dict get $reg $path $key] } - # Test some of the basics of [clock format] test clock-1.0 "clock format - wrong # args" { @@ -35025,6 +35024,24 @@ test clock-30.8 {clock add months, negative} { set x4 [clock format $f4 -format %Y-%m-%d -timezone :UTC] list $x1 $x2 $x3 $x4 } {2000-02-29 2000-01-31 1999-12-31 1999-11-30} +test clock-30.8a {clock add months, negative, over threshold of a year} { + set t [clock scan 2019-01-31 -format %Y-%m-%d -gmt 1] + list [clock format [clock add $t -1 month -gmt 1] -format %Y-%m-%d -gmt 1] \ + [clock format [clock add $t -2 month -gmt 1] -format %Y-%m-%d -gmt 1] \ + [clock format [clock add $t -3 month -gmt 1] -format %Y-%m-%d -gmt 1] \ + [clock format [clock add $t -4 month -gmt 1] -format %Y-%m-%d -gmt 1] +} {2018-12-31 2018-11-30 2018-10-31 2018-09-30} +test clock-30.8b {clock add months, negative, over threshold of a year} { + set t [clock scan 2000-01-28 -format %Y-%m-%d -gmt 1] + for {set i 1} {$i < 24} {incr i 1} { + set f1 [clock add $t -$i month -gmt 1] + set f2 [clock add $f1 $i month -gmt 1] + if {$f2 != $t} { + error "\[clock add $t -$i month -gmt 1\] does not consider\ + \[clock add $f1 $i month -gmt 1\] != $t" + } + } +} {} test clock-30.9 {clock add days} { set t [clock scan {2000-01-01 12:34:56} -format {%Y-%m-%d %H:%M:%S} \ -timezone :UTC] @@ -35419,7 +35436,7 @@ test clock-32.1 {scan/format across the Gregorian change} { # clock clicks test clock-33.1 {clock clicks tests} { - expr [clock clicks]+1 + expr {[clock clicks] + 1} concat {} } {} test clock-33.2 {clock clicks tests} { @@ -35432,7 +35449,7 @@ test clock-33.3 {clock clicks tests} { list [catch {clock clicks foo} msg] $msg } {1 {bad option "foo": must be -milliseconds or -microseconds}} test clock-33.4 {clock clicks tests} { - expr [clock clicks -milliseconds]+1 + expr {[clock clicks -milliseconds] + 1} concat {} } {} test clock-33.4a {clock milliseconds} { @@ -35453,7 +35470,7 @@ test clock-33.5 {clock clicks tests, millisecond timing test} { expr { ($end > $start) && (($end - $start) <= 60) ? "ok" : - "test should have taken 0-60 ms, actually took [expr $end - $start]"} + "test should have taken 0-60 ms, actually took [expr {$end - $start}]"} } {ok} test clock-33.5a {clock tests, millisecond timing test} { # This test can fail on a system that is so heavily loaded that @@ -35469,7 +35486,7 @@ test clock-33.5a {clock tests, millisecond timing test} { expr { ($end > $start) && (($end - $start) <= 60) ? "ok" : - "test should have taken 0-60 ms, actually took [expr $end - $start]"} + "test should have taken 0-60 ms, actually took [expr {$end - $start}]"} } {ok} test clock-33.6 {clock clicks, milli with too much abbreviation} { list [catch { clock clicks ? } msg] $msg @@ -35613,7 +35630,6 @@ test clock-34.11 {clock scan tests} { set time [clock scan "1/1/37" -gmt true] clock format $time -format {%b %d,%Y %H:%M GMT} -gmt true } {Jan 01,2037 00:00 GMT} - test clock-34.12 {clock scan, relative times} { set time [clock scan "Oct 23, 1992 -1 day"] clock format $time -format {%b %d, %Y} @@ -35765,7 +35781,6 @@ test clock-34.43 {last monday in november} { } set res } {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25} - test clock-34.44 {2nd monday in november} { set res {} foreach i {91 92 93 94 95 96} { @@ -35798,42 +35813,99 @@ test clock-34.47 {ago with multiple relative units} { set res [clock scan "2 days 2 hours ago" -base $base] expr {$base - $res} } 180000 - test clock-34.48 {more than one ToD} {*}{ -body {clock scan {10:00 11:00}} -returnCodes error -result {unable to convert date-time string "10:00 11:00": more than one time of day in string} } - test clock-34.49 {more than one date} {*}{ -body {clock scan {1/1/2001 2/2/2002}} -returnCodes error -result {unable to convert date-time string "1/1/2001 2/2/2002": more than one date in string} } - test clock-34.50 {more than one time zone} {*}{ -body {clock scan {10:00 EST CST}} -returnCodes error -result {unable to convert date-time string "10:00 EST CST": more than one time zone in string} } - test clock-34.51 {more than one weekday} {*}{ -body {clock scan {Monday Tuesday}} -returnCodes error -result {unable to convert date-time string "Monday Tuesday": more than one weekday in string} } - test clock-34.52 {more than one ordinal month} {*}{ -body {clock scan {next January next March}} -returnCodes error -result {unable to convert date-time string "next January next March": more than one ordinal month in string} } - - +test clock-34.53 {clock scan, ISO 8601 point in time format} { + set time [clock scan "19921023T00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} "Oct 23, 1992 00:00:00" +test clock-34.54 {clock scan, ISO 8601 point in time format} { + set time [clock scan "1992-10-23T00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} "Oct 23, 1992 00:00:00" +test clock-34.55 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "19921023MST000000"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.56 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "19921023M000000"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.57 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "1992-10-23M00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.58 {clock scan, ISO 8601 invalid TZ} -body { + set time [clock scan "1992-10-23MST00:00:00"] + clock format $time -format {%b %d, %Y %H:%M:%S} +} -returnCodes error -match glob -result {unable to convert date-time string*} +test clock-34.59 {clock scan tests (-TZ)} { + set time [clock scan "31 Jan 14 23:59:59 -0100"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Feb 01,2014 00:59:59 GMT} +test clock-34.60 {clock scan tests (+TZ)} { + set time [clock scan "31 Jan 14 23:59:59 +0100"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 31,2014 22:59:59 GMT} +test clock-34.61 {clock scan tests (-TZ)} { + set time [clock scan "23:59:59 -0100" -base 0 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 02,1970 00:59:59 GMT} +test clock-34.62 {clock scan tests (+TZ)} { + set time [clock scan "23:59:59 +0100" -base 0 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 01,1970 22:59:59 GMT} +test clock-34.63 {clock scan tests (TZ)} { + set time [clock scan "Mon, 30 Jun 2014 23:59:59 CEST"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jun 30,2014 21:59:59 GMT} +test clock-34.64 {clock scan tests (TZ)} { + set time [clock scan "Fri, 31 Jan 2014 23:59:59 CET"] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 31,2014 22:59:59 GMT} +test clock-34.65 {clock scan tests (relspec, day unit not TZ)} { + set time [clock scan "23:59:59 +15 day" -base 2000000 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Feb 08,1970 23:59:59 GMT} +test clock-34.66 {clock scan tests (relspec, day unit not TZ)} { + set time [clock scan "23:59:59 -15 day" -base 2000000 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 09,1970 23:59:59 GMT} +test clock-34.67 {clock scan tests (merid and TZ)} { + set time [clock scan "10:59 pm CET" -base 2000000 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 24,1970 21:59:00 GMT} +test clock-34.68 {clock scan tests (merid and TZ)} { + set time [clock scan "10:59 pm +0100" -base 2000000 -gmt true] + clock format $time -format {%b %d,%Y %H:%M:%S %Z} -gmt true +} {Jan 24,1970 21:59:00 GMT} # clock seconds test clock-35.1 {clock seconds tests} { - expr [clock seconds]+1 + expr {[clock seconds] + 1} concat {} } {} test clock-35.2 {clock seconds tests} { @@ -36717,16 +36789,16 @@ test clock-58.1 {clock l10n - Japanese localisation} {*}{ -body { set trouble {} foreach {date jdate} { - 1872-12-31 \u897f\u66a61872\u5e7412\u670831\u65e5 - 1873-01-01 \u660e\u6cbb06\u5e7401\u670801\u65e5 - 1912-07-29 \u660e\u6cbb45\u5e7407\u670829\u65e5 - 1912-07-30 \u5927\u6b6301\u5e7407\u670830\u65e5 - 1926-12-24 \u5927\u6b6315\u5e7412\u670824\u65e5 - 1926-12-25 \u662d\u548c01\u5e7412\u670825\u65e5 - 1989-01-07 \u662d\u548c64\u5e7401\u670807\u65e5 - 1989-01-08 \u5e73\u621001\u5e7401\u670808\u65e5 - 2019-04-30 \u5e73\u621031\u5e7404\u670830\u65e5 - 2019-05-01 \u4ee4\u548c01\u5e7405\u670801\u65e5 + 1872-12-31 西暦1872年12月31日 + 1873-01-01 明治06年01月01日 + 1912-07-29 明治45年07月29日 + 1912-07-30 大正01年07月30日 + 1926-12-24 大正15年12月24日 + 1926-12-25 昭和01年12月25日 + 1989-01-07 昭和64年01月07日 + 1989-01-08 平成01年01月08日 + 2019-04-30 平成31年04月30日 + 2019-05-01 令和01年05月01日 } { set status [catch { set secs [clock scan $date \ @@ -36858,10 +36930,10 @@ test clock-61.2 {overflow of a wide integer on output} {*}{ } test clock-61.3 {near-miss overflow of a wide integer on output} { clock format 0x7fffffffffffffff -format %s -gmt true -} [expr 0x7fffffffffffffff] +} [expr {0x7fffffffffffffff}] test clock-61.4 {near-miss overflow of a wide integer on output} { clock format -0x8000000000000000 -format %s -gmt true -} [expr -0x8000000000000000] +} [expr {-0x8000000000000000}] test clock-62.1 {Bug 1902423} {*}{ -setup {::tcl::clock::ClearCaches} @@ -36929,12 +37001,10 @@ test clock-67.2 {Bug d19a30db57} -body { # error, not segfault tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222 } -returnCodes error -match glob -result * - test clock-67.3 {Bug d19a30db57} -body { # error, not segfault tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222 } -returnCodes error -match glob -result * - test clock-67.4 {Change format %x output on global locale change [Bug 4a0c163d24]} -setup { package require msgcat set current [msgcat::mclocale] @@ -36946,7 +37016,6 @@ test clock-67.4 {Change format %x output on global locale change [Bug 4a0c163d24 } -cleanup { msgcat::mclocale $current } -result {1 1} - test clock-67.5 {Change scan %x output on global locale change [Bug 4a0c163d24]} -setup { package require msgcat set current [msgcat::mclocale] diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 992a8f4..5fefbeb 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -4,19 +4,19 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1996-1998 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] @@ -30,6 +30,7 @@ testConstraint linkDirectory [expr { ($::tcl_platform(osVersion) >= 5.0 && [lindex [file system [temporaryDirectory]] 1] eq "NTFS") }] +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] global env set cmdAHwd [pwd] @@ -148,10 +149,10 @@ test cmdAH-2.6.2 {cd} -constraints {unix nonPortable} -setup { test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -setup { set dir [pwd] } -returnCodes error -body { - cd .\0 + cd .\x00 } -cleanup { cd $dir -} -match glob -result "couldn't change working directory to \".\0\": *" +} -match glob -result "couldn't change working directory to \".\x00\": *" test cmdAH-2.7 {Tcl_ConcatObjCmd} { concat } {} @@ -185,7 +186,7 @@ test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { encoding system jis0208 - encoding convertto \u4e4e + encoding convertto 乎 } -cleanup { encoding system $system } -result 8C @@ -193,7 +194,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { encoding system iso8859-1 - encoding convertto jis0208 \u4e4e + encoding convertto jis0208 乎 } -cleanup { encoding system $system } -result 8C @@ -210,7 +211,7 @@ test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup { encoding convertfrom 8C } -cleanup { encoding system $system -} -result \u4e4e +} -result 乎 test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { @@ -218,7 +219,7 @@ test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup { encoding convertfrom jis0208 8C } -cleanup { encoding system $system -} -result \u4e4e +} -result 乎 test cmdAH-4.11 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding names foo } -result {wrong # args: should be "encoding names"} @@ -261,7 +262,7 @@ test cmdAH-6.3 {Tcl_FileObjCmd: volumes} -constraints unix -body { test cmdAH-6.4 {Tcl_FileObjCmd: volumes} -constraints win -body { set volumeList [string tolower [file volumes]] set element [lsearch -exact $volumeList "c:/"] - list [expr {$element>-1}] [glob -nocomplain [lindex $volumeList $element]*] + list [expr {$element>=0}] [glob -nocomplain [lindex $volumeList $element]*] } -match glob -result {1 *} # attributes @@ -965,10 +966,10 @@ test cmdAH-19.11 {Tcl_FileObjCmd: exists} -constraints {unix notRoot} -setup { } -body { makeDirectory /tmp/tcl.foo.dir makeFile 12345 /tmp/tcl.foo.dir/file - file attributes /tmp/tcl.foo.dir -permissions 0000 + file attributes /tmp/tcl.foo.dir -permissions 0 file exists /tmp/tcl.foo.dir/file } -cleanup { - file attributes /tmp/tcl.foo.dir -permissions 0775 + file attributes /tmp/tcl.foo.dir -permissions 0o775 removeFile /tmp/tcl.foo.dir/file removeDirectory /tmp/tcl.foo.dir } -result 0 @@ -991,7 +992,7 @@ test cmdAH-19.12 {Bug 3608360: [file exists] mustn't do globbing} -setup { catch {testsetplatform $platform} removeFile $gorpfile set gorpfile [makeFile "Test string" gorp.file] -catch {file attributes $gorpfile -permissions 0765} +catch {file attributes $gorpfile -permissions 0o765} # avoid problems with non-local filesystems if {[testConstraint unix] && [file exists /tmp]} { @@ -1092,7 +1093,7 @@ test cmdAH-23.4 {Tcl_FileObjCmd: lstat} -setup { unset -nocomplain stat } -constraints {unix nonPortable} -body { file lstat $linkfile stat - list $stat(nlink) [expr $stat(mode)&0777] $stat(type) + list $stat(nlink) [expr {$stat(mode) & 0o777}] $stat(type) } -result {1 511 link} test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} { list [catch {file lstat _bogus_ stat} msg] [string tolower $msg] \ @@ -1220,7 +1221,7 @@ test cmdAH-24.9 {Tcl_FileObjCmd: mtime touch with non-ascii chars} -setup { set oldfile $file } -constraints unix -body { # introduce some non-ascii characters. - append file \u2022 + append file • file delete -force $file file rename $oldfile $file set mtime [file mtime $file] @@ -1245,7 +1246,7 @@ test cmdAH-24.11 {Tcl_FileObjCmd: mtime touch with non-ascii chars} -setup { set oldfile $file } -constraints win -body { # introduce some non-ascii characters. - append file \u2022 + append file • file delete -force $file file rename $oldfile $file set mtime [file mtime $file] @@ -1348,7 +1349,7 @@ test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup { test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} { file owned / } 0 -test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints win -body { +test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints {win notWine} -body { if {[info exists env(SystemRoot)]} { file owned $env(SystemRoot) } else { @@ -1407,7 +1408,7 @@ test cmdAH-27.4.1 { catch {testsetplatform $platform} removeFile $gorpfile set gorpfile [makeFile "Test string" gorp.file] -catch {file attributes $gorpfile -permissions 0765} +catch {file attributes $gorpfile -permissions 0o765} # stat test cmdAH-28.1 {Tcl_FileObjCmd: stat} -returnCodes error -body { @@ -1434,8 +1435,8 @@ test cmdAH-28.5 {Tcl_FileObjCmd: stat} -constraints {unix} -setup { unset -nocomplain stat } -body { file stat $gorpfile stat - expr {$stat(mode) & 0o777} -} -result {501} + format 0o%03o [expr {$stat(mode) & 0o777}] +} -result 0o765 test cmdAH-28.6 {Tcl_FileObjCmd: stat} { list [catch {file stat _bogus_ stat} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} @@ -1538,7 +1539,7 @@ test cmdAH-29.4 {Tcl_FileObjCmd: type} -constraints {unix} -setup { } -cleanup { file delete $linkfile } -result link -test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory} -setup { +test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory notWine} -setup { set tempdir [makeDirectory temp] } -body { set linkdir [file join [temporaryDirectory] link.dir] @@ -1638,7 +1639,7 @@ test cmdAH-31.9 {Tcl_FileObjCmd: channels in other interp} { lsort [safeInterp eval [list file channels]] } [lsort [list stdout $newFileId]] test cmdAH-31.10 {Tcl_FileObjCmd: channels in other interp} { - # we can now write to $newFileId from slave + # we can now write to $newFileId from child safeInterp eval [list puts $newFileId "hello"] } {} interp transfer {} $newFileId safeInterp @@ -1771,7 +1772,7 @@ unset -nocomplain platform # Tcl_ForObjCmd is tested in for.test -catch {file attributes $dirfile -permissions 0777} +catch {file attributes $dirfile -permissions 0o777} removeDirectory $dirfile removeFile $gorpfile # No idea how well [removeFile] copes with links... diff --git a/tests/cmdIL.test b/tests/cmdIL.test index fe72d94..063750c 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -2,19 +2,20 @@ # tclCmdIL.c. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } + ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -150,17 +151,17 @@ test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} { } } {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}} test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { - lsort -ascii [list \0 \x7f \x80 \uffff] -} [list \0 \x7f \x80 \uffff] + lsort -ascii [list \x00 \x7F \x80 \uFFFF] +} [list \x00 \x7F \x80 \uFFFF] test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { - lsort -ascii -nocase [list \0 \x7f \x80 \uffff] -} [list \0 \x7f \x80 \uffff] + lsort -ascii -nocase [list \x00 \x7F \x80 \uFFFF] +} [list \x00 \x7F \x80 \uFFFF] test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { - lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff] -} [list \0 \x7f \x80 \uffff \U01ffff] + lsort -ascii [list \x00 \x7F \x80 \U01ffff \uFFFF] +} [list \x00 \x7F \x80 \uFFFF \U01ffff] test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { - lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff] -} [list \0 \x7f \x80 \uffff \U01ffff] + lsort -ascii -nocase [list \x00 \x7F \x80 \U01ffff \uFFFF] +} [list \x00 \x7F \x80 \uFFFF \U01FFFF] test cmdIL-1.41 {lsort -stride and -index} -body { lsort -stride 2 -index -2 {a 2 b 1} } -returnCodes error -result {index "-2" out of range} @@ -176,7 +177,7 @@ test cmdIL-2.1 {MergeSort and MergeLists procedures} -setup { set r 1435753299 proc rand {} { global r - set r [expr {(16807 * $r) % (0x7fffffff)}] + set r [expr {(16807 * $r) % (0x7FFFFFFF)}] } } -body { for {set i 0} {$i < 150} {incr i} { @@ -395,16 +396,16 @@ test cmdIL-4.23 {DictionaryCompare procedure, case} { } {ABcd AbCd} test cmdIL-4.24 {DictionaryCompare procedure, international characters} {hasIsoLocale} { ::tcltest::set_iso8859_1_locale - set result [lsort -dictionary "a b c A B C \xe3 \xc4"] + set result [lsort -dictionary "a b c A B C ã Ä"] ::tcltest::restore_locale set result -} "A a B b C c \xe3 \xc4" +} "A a B b C c ã Ä" test cmdIL-4.25 {DictionaryCompare procedure, international characters} {hasIsoLocale} { ::tcltest::set_iso8859_1_locale - set result [lsort -dictionary "a23\xe3 a23\xc5 a23\xe4"] + set result [lsort -dictionary "a23ã a23Å a23ä"] ::tcltest::restore_locale set result -} "a23\xe3 a23\xe4 a23\xc5" +} "a23ã a23ä a23Å" test cmdIL-4.26 {DefaultCompare procedure, signed characters} { set l [lsort [list "abc\200" "abc"]] set viewlist {} @@ -471,10 +472,10 @@ test cmdIL-4.36 {SortCompare procedure, UTF-8 with -nocase option} { scan [lsort -ascii -nocase [list \u101 \u100]] %c%c%c } {257 32 256} test cmdIL-4.37 {SortCompare procedure, UTF-8 with -nocase option} { - scan [lsort -ascii -nocase [list a\u0000a a]] %c%c%c%c%c + scan [lsort -ascii -nocase [list a\x00a a]] %c%c%c%c%c } {97 32 97 0 97} test cmdIL-4.38 {SortCompare procedure, UTF-8 with -nocase option} { - scan [lsort -ascii -nocase [list a a\u0000a]] %c%c%c%c%c + scan [lsort -ascii -nocase [list a a\x00a]] %c%c%c%c%c } {97 32 97 0 97} test cmdIL-5.1 {lsort with list style index} { @@ -513,7 +514,7 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { foreach e $l {lappend n [list [expr {rand()}] $e]} lindex [lsort -real -index $l $n] 1 1 } - expr srand(1) + expr {srand(1)} test_lsort 0 } -result 0 -cleanup { rename test_lsort "" diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index 0a587e8..37b8a0b 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -6,18 +6,20 @@ # and generates output for errors. No output means no errors were # found. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testcmdinfo [llength [info commands testcmdinfo]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 43b3703..a1cb6c2 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -4,16 +4,16 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcl::test::cmdMZ { @@ -59,7 +59,7 @@ test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} -setup { # This test fails on various unix platforms (eg Linux) where permissions # caching causes this to fail. The caching is strictly incorrect, but we # have no control over that. - file attr . -permissions 000 + file attr . -permissions 0 pwd } -returnCodes error -cleanup { cd $cwd @@ -299,19 +299,19 @@ test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} { } {]\n} test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} { apply {{} { - set x ab\000c + set x ab\x00c set y [split $x {}] binary scan $y c* z return $z }} } {97 32 98 32 0 32 99} test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} { - split "a0ab1b2bbb3\000c4" ab\000c + split "a0ab1b2bbb3\x00c4" ab\x00c } {{} 0 {} 1 2 {} {} 3 {} 4} test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { - # if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq" - split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e" -} "a b qw\u5e4eN wq" + # if not UTF-8 aware, result is "a {} {} b qwå {} N wq" + split "a乎b qw幎N wq" " 乎" +} "a b qw幎N wq" # The tests for Tcl_StringObjCmd are in string.test # The tests for Tcl_SubstObjCmd are in subst.test diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index e57f799..b70e65c 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -6,19 +6,20 @@ # "compExpr.test". Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } + ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Big test for correct ordering of data in [expr] @@ -28,9 +29,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -40,19 +41,19 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -62,11 +63,11 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 @@ -577,13 +578,13 @@ test compExpr-old-15.3 {CompileMathFuncCall: too many arguments} -body { test compExpr-old-15.4 {CompileMathFuncCall: ')' found before last required arg} -body { catch {expr sin()} msg set ::errorInfo -} -match glob -result {too few arguments for math function* +} -match glob -result {not enough arguments for math function* while *ing "expr sin()"} -test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body { +test compExpr-old-15.5 {CompileMathFuncCall: not enough arguments} -body { catch {expr pow(1)} msg set ::errorInfo -} -match glob -result {too few arguments for math function* +} -match glob -result {not enough arguments for math function* while *ing "expr pow(1)"} test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body { diff --git a/tests/compExpr.test b/tests/compExpr.test index 3b44af8..eaef772 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -2,19 +2,19 @@ # tclCompExpr.c. Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Constrain memory leak tests testConstraint memory [llength [info commands memory]] @@ -308,16 +308,16 @@ test compExpr-4.9 {CompileCondExpr procedure, error in "false" clause} { } {0 15} test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { - format %.6g [expr atan2(1.0, 2.0)] + format %.6g [expr {atan2(1.0, 2.0)}] } 0.463648 test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body { expr {do_it()} } -returnCodes error -match glob -result {* "*do_it"} -test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body { +test compExpr-5.5 {CompileMathFuncCall procedure, not enough arguments} -body { expr {atan2(1.0)} -} -returnCodes error -match glob -result {too few arguments for math function*} +} -returnCodes error -match glob -result {not enough arguments for math function*} test compExpr-5.6 {CompileMathFuncCall procedure, complex argument} { - format %.6g [expr pow(2.1, 27.5-(24.4*(5%2)))] + format %.6g [expr {pow(2.1, 27.5-(24.4*(5%2)))}] } 9.97424 test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} -body { expr {sinh(2.*)} @@ -341,9 +341,9 @@ test compExpr-7.1 {Memory Leak} -constraints memory -setup { } -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { - interp create slave - slave eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13 - interp delete slave + interp create child + child eval expr 1+2+3+4+5+6+7+8+9+10+11+12+13 + interp delete child set tmp $end set end [getbytes] } @@ -371,10 +371,46 @@ test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setu unset end i tmp rename getbytes {} } -result 0 + +proc extract {opcodes descriptor} { + set instructions [dict values [dict get $descriptor instructions]] + return [lmap i $instructions { + if {[lindex $i 0] in $opcodes} {string cat $i} else continue + }] +} + +test compExpr-8.1 {TIP 582: expression comments} -setup {} -body { + extract {loadStk add} [tcl::unsupported::getbytecode script {expr { + $abc + # + $def + + $ghi + }}] +} -result {loadStk loadStk add} +test compExpr-8.2 {TIP 582: expression comments} -setup {} -body { + extract {loadStk add} [tcl::unsupported::getbytecode script {expr { + $abc + # + $def + # + $ghi }}] +} -result loadStk +test compExpr-8.3 {TIP 582: expression comments} -setup {} -body { + extract {loadStk add} [tcl::unsupported::getbytecode script {expr { + $abc + # + $def\ + + $ghi + }}] +} -result loadStk +test compExpr-8.4 {TIP 582: expression comments} -setup {} -body { + extract {loadStk add} [tcl::unsupported::getbytecode script {expr { + $abc + # + $def\\ + + $ghi + }}] +} -result {loadStk loadStk add} # cleanup catch {unset a} catch {unset b} +catch {rename extract ""} ::tcltest::cleanupTests return diff --git a/tests/compile.test b/tests/compile.test index 18e978f..31af2e2 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -5,17 +5,20 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint exec [llength [info commands exec]] testConstraint memory [llength [info commands memory]] @@ -201,7 +204,7 @@ test compile-4.1 {TclCompileForCmd: command substituted test expression} { set i 0 set j 0 # Should be "forever" - for {} [expr $i < 3] {} { + for {} [expr {$i < 3}] {} { set j [incr i] if {$j > 3} break } @@ -275,7 +278,7 @@ test compile-7.1 {TclCompileWhileCmd: command substituted test expression} { set i 0 set j 0 # Should be "forever" - while [expr $i < 3] { + while [expr {$i < 3}] { set j [incr i] if {$j > 3} break } @@ -283,10 +286,10 @@ test compile-7.1 {TclCompileWhileCmd: command substituted test expression} { } {4} test compile-8.1 {CollectArgInfo: binary data} { - list [catch "string length \000foo" msg] $msg + list [catch "string length \x00foo" msg] $msg } {0 4} test compile-8.2 {CollectArgInfo: binary data} { - list [catch "string length foo\000" msg] $msg + list [catch "string length foo\x00" msg] $msg } {0 4} test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} { set x ] @@ -334,7 +337,7 @@ test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; incr}} } -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { - apply {{} { set r [list foobar] ; expr !a }} + apply {{} { set r [list foobar] ; expr [concat !a] }} } -returnCodes error -match glob -result * test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; expr {!a} }} @@ -563,7 +566,7 @@ test compile-15.5 {proper TCL_RETURN code from [return]} { # Do all tests once byte compiled and once with direct string evaluation foreach noComp {0 1} { -if $noComp { +if {$noComp} { interp alias {} run {} testevalex set constraints testevalex } else { diff --git a/tests/concat.test b/tests/concat.test index eeb11ca..976591e 100644 --- a/tests/concat.test +++ b/tests/concat.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/config.test b/tests/config.test index 468a1df..2d8b593 100644 --- a/tests/config.test +++ b/tests/config.test @@ -5,21 +5,21 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } -test pkgconfig-1.1 {query keys} { +test pkgconfig-1.1 {query keys} -body { lsort [::tcl::pkgconfig list] -} {64bit bindir,install bindir,runtime compile_debug compile_stats debug dllfile,runtime docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded zipfile,runtime} +} -match glob -result {64bit bindir,install bindir,runtime compile_debug compile_stats debug*docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded} test pkgconfig-1.2 {query keys multiple times} { string compare [::tcl::pkgconfig list] [::tcl::pkgconfig list] } 0 diff --git a/tests/coroutine.test b/tests/coroutine.test index 86a5481..b129c03 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -4,18 +4,18 @@ # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. # -# Copyright (c) 2008 by Miguel Sofer. +# Copyright © 2008 Miguel Sofer. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testnrelevels [llength [info commands testnrelevels]] testConstraint memory [llength [info commands memory]] @@ -771,25 +771,25 @@ test coroutine-8.0.1 {coro inject after error} -body { lappend ::result [catch {demo} err] $err } -result {inject-executed 1 test} test coroutine-8.1.1 {coro inject, ticket 42202ba1e5ff566e} -body { - interp create slave - slave eval { + interp create child + child eval { coroutine demo apply {{} { while {1} yield }} demo tcl::unsupported::inject demo set ::result inject-executed } - interp delete slave + interp delete child } -result {} test coroutine-8.1.2 {coro inject with result, ticket 42202ba1e5ff566e} -body { - interp create slave - slave eval { + interp create child + child eval { coroutine demo apply {{} { while {1} yield }} demo tcl::unsupported::inject demo set ::result inject-executed } - slave eval demo - set result [slave eval {set ::result}] + child eval demo + set result [child eval {set ::result}] - interp delete slave + interp delete child set result } -result {inject-executed} diff --git a/tests/dcall.test b/tests/dcall.test index 41dd777..e407e48 100644 --- a/tests/dcall.test +++ b/tests/dcall.test @@ -4,18 +4,20 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testdcall [llength [info commands testdcall]] diff --git a/tests/dict.test b/tests/dict.test index e5284fc..d67f703 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -5,11 +5,11 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 2003-2009 Donal K. Fellows +# Copyright © 2003-2009 Donal K. Fellows # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/dstring.test b/tests/dstring.test index 5feb355..11c5754 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -4,20 +4,20 @@ # procedures. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testdstring [llength [info commands testdstring]] if {[testConstraint testdstring]} { diff --git a/tests/encoding.test b/tests/encoding.test index ccc32da..c8daed6 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -2,22 +2,24 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + namespace eval ::tcl::test::encoding { variable x -namespace import -force ::tcltest::* - catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] + package require -exact tcl::test [info patchlevel] } proc toutf {args} { @@ -62,12 +64,12 @@ test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} { return $x } {{fromutf }} test encoding-1.3 {Tcl_GetEncoding: load encoding} { - list [encoding convertto jis0208 \u4e4e] \ + list [encoding convertto jis0208 乎] \ [encoding convertfrom jis0208 8C] -} "8C \u4e4e" +} "8C 乎" test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} { - encoding convertto jis0208 \u4e4e + encoding convertto jis0208 乎 } {8C} test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { set system [encoding system] @@ -75,15 +77,15 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { } -constraints {testencoding} -body { encoding system shiftjis ;# incr ref count encoding dirs [list [pwd]] - set x [encoding convertto shiftjis \u4e4e] ;# old one found + set x [encoding convertto shiftjis 乎] ;# old one found encoding system iso8859-1 llength shiftjis ;# Shimmer away any cache of Tcl_Encoding - lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg + lappend x [catch {encoding convertto shiftjis 乎} msg] $msg } -cleanup { encoding system iso8859-1 encoding dirs $path encoding system $system -} -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" +} -result "\x8C\xC1 1 {unknown encoding \"shiftjis\"}" test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup { set old [encoding system] @@ -135,7 +137,7 @@ test encoding-5.1 {Tcl_SetSystemEncoding} -setup { set old [encoding system] } -body { encoding system jis0208 - encoding convertto \u4e4e + encoding convertto 乎 } -cleanup { encoding system iso8859-1 encoding system $old @@ -167,7 +169,7 @@ test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} { test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} { encoding convertfrom jis0208 8c8c8c8c -} "\u543e\u543e\u543e\u543e" +} "吾吾吾吾" test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C append a $a @@ -176,12 +178,12 @@ test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { append a $a set x [encoding convertfrom jis0208 $a] list [string length $x] [string index $x 0] -} "512 \u4e4e" +} "512 乎" test encoding-8.1 {Tcl_ExternalToUtf} { set f [open [file join [temporaryDirectory] dummy] w] fconfigure $f -translation binary -encoding iso8859-1 - puts -nonewline $f "ab\x8c\xc1g" + puts -nonewline $f "ab\x8C\xC1g" close $f set f [open [file join [temporaryDirectory] dummy] r] fconfigure $f -translation binary -encoding shiftjis @@ -189,13 +191,13 @@ test encoding-8.1 {Tcl_ExternalToUtf} { close $f file delete [file join [temporaryDirectory] dummy] return $x -} "ab\u4e4eg" +} "ab乎g" test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} { - encoding convertto jis0208 "\u543e\u543e\u543e\u543e" + encoding convertto jis0208 "吾吾吾吾" } {8c8c8c8c} test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} { - set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e + set a 乎乎乎乎乎乎乎乎 append a $a append a $a append a $a @@ -209,7 +211,7 @@ test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} { test encoding-10.1 {Tcl_UtfToExternal} { set f [open [file join [temporaryDirectory] dummy] w] fconfigure $f -translation binary -encoding shiftjis - puts -nonewline $f "ab\u4e4eg" + puts -nonewline $f "ab乎g" close $f set f [open [file join [temporaryDirectory] dummy] r] fconfigure $f -translation binary -encoding iso8859-1 @@ -217,7 +219,7 @@ test encoding-10.1 {Tcl_UtfToExternal} { close $f file delete [file join [temporaryDirectory] dummy] return $x -} "ab\x8c\xc1g" +} "ab\x8C\xC1g" proc viewable {str} { set res "" @@ -225,7 +227,7 @@ proc viewable {str} { if {[string is print $c] && [string is ascii $c]} { append res $c } else { - append res "\\u[format %4.4x [scan $c %c]]" + append res "\\u[format %4.4X [scan $c %c]]" } } return "$str ($res)" @@ -237,26 +239,26 @@ test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} { encoding system iso8859-1 encoding dirs {} llength jis0208 ;# Shimmer any cached Tcl_Encoding in shared literal - set x [list [catch {encoding convertto jis0208 \u4e4e} msg] $msg] + set x [list [catch {encoding convertto jis0208 乎} msg] $msg] encoding dirs $path encoding system $system - lappend x [encoding convertto jis0208 \u4e4e] + lappend x [encoding convertto jis0208 乎] } {1 {unknown encoding "jis0208"} 8C} test encoding-11.2 {LoadEncodingFile: single-byte} { - encoding convertfrom jis0201 \xa1 -} "\uff61" + encoding convertfrom jis0201 \xA1 +} "｡" test encoding-11.3 {LoadEncodingFile: double-byte} { encoding convertfrom jis0208 8C -} "\u4e4e" +} 乎 test encoding-11.4 {LoadEncodingFile: multi-byte} { - encoding convertfrom shiftjis \x8c\xc1 -} "\u4e4e" + encoding convertfrom shiftjis \x8C\xC1 +} 乎 test encoding-11.5 {LoadEncodingFile: escape file} { - viewable [encoding convertto iso2022 \u4e4e] -} [viewable "\x1b\$B8C\x1b(B"] + viewable [encoding convertto iso2022 乎] +} [viewable "\x1B\$B8C\x1B(B"] test encoding-11.5.1 {LoadEncodingFile: escape file} { - viewable [encoding convertto iso2022-jp \u4e4e] -} [viewable "\x1b\$B8C\x1b(B"] + viewable [encoding convertto iso2022-jp 乎] +} [viewable "\x1B\$B8C\x1B(B"] test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup { set system [encoding system] set path [encoding dirs] @@ -270,7 +272,7 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} fconfigure $f -translation binary puts $f "abcdefghijklmnop" close $f - encoding convertto splat \u4e4e + encoding convertto splat 乎 } -returnCodes error -cleanup { file delete [file join [temporaryDirectory] tmp encoding splat.enc] removeDirectory [file join tmp encoding] @@ -279,45 +281,50 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} encoding dirs $path encoding system $system } -result {invalid encoding file "splat"} - +test encoding-11.8 {encoding: extended Unicode UTF-16} { + viewable [encoding convertto utf-16le 😹] +} {=Ø9Þ (=\u00D89\u00DE)} +test encoding-11.9 {encoding: extended Unicode UTF-16} { + viewable [encoding convertto utf-16be 😹] +} {Ø=Þ9 (\u00D8=\u00DE9)} # OpenEncodingFile is fully tested by the rest of the tests in this file. test encoding-12.1 {LoadTableEncoding: normal encoding} { - set x [encoding convertto iso8859-3 \u0120] - append x [encoding convertto iso8859-3 \xD5] - append x [encoding convertfrom iso8859-3 \xD5] -} "\xd5?\u120" + set x [encoding convertto iso8859-3 Ġ] + append x [encoding convertto iso8859-3 Õ] + append x [encoding convertfrom iso8859-3 Õ] +} "Õ?Ġ" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { - set x [encoding convertto iso8859-3 ab\u0120g] - append x [encoding convertfrom iso8859-3 ab\xD5g] -} "ab\xd5gab\u120g" + set x [encoding convertto iso8859-3 abĠg] + append x [encoding convertfrom iso8859-3 abÕg] +} "abÕgabĠg" test encoding-12.3 {LoadTableEncoding: multi-byte encoding} { - set x [encoding convertto shiftjis ab\u4E4Eg] - append x [encoding convertfrom shiftjis ab\x8c\xc1g] -} "ab\x8c\xc1gab\u4e4eg" + set x [encoding convertto shiftjis ab乎g] + append x [encoding convertfrom shiftjis ab\x8C\xC1g] +} "ab\x8C\xC1gab乎g" test encoding-12.4 {LoadTableEncoding: double-byte encoding} { - set x [encoding convertto jis0208 \u4e4e\u3b1] + set x [encoding convertto jis0208 乎α] append x [encoding convertfrom jis0208 8C&A] -} "8C&A\u4e4e\u3b1" +} "8C&A乎α" test encoding-12.5 {LoadTableEncoding: symbol encoding} { - set x [encoding convertto symbol \u3b3] - append x [encoding convertto symbol \u67] - append x [encoding convertfrom symbol \x67] -} "\x67\x67\u3b3" + set x [encoding convertto symbol γ] + append x [encoding convertto symbol g] + append x [encoding convertfrom symbol g] +} "ggγ" test encoding-13.1 {LoadEscapeTable} { - viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]] -} [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"] + viewable [set x [encoding convertto iso2022 ab乎棙g]] +} [viewable "ab\x1B\$B8C\x1B\$\(DD%\x1B(Bg"] test encoding-15.1 {UtfToUtfProc} { - encoding convertto utf-8 \xa3 -} "\xc2\xa3" + encoding convertto utf-8 £ +} "\xC2\xA3" test encoding-15.2 {UtfToUtfProc null character output} testbytestring { - binary scan [testbytestring [encoding convertto utf-8 \u0000]] H* z + binary scan [testbytestring [encoding convertto utf-8 \x00]] H* z set z } 00 test encoding-15.3 {UtfToUtfProc null character input} teststringbytes { - set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]] + set y [encoding convertfrom utf-8 [encoding convertto utf-8 \x00]] binary scan [teststringbytes $y] H* z set z } c080 @@ -325,12 +332,12 @@ test encoding-15.4 {UtfToUtfProc emoji character input} -body { set x \xED\xA0\xBD\xED\xB8\x82 set y [encoding convertfrom utf-8 \xED\xA0\xBD\xED\xB8\x82] list [string length $x] $y -} -result "6 \U1F602" +} -result "6 😂" test encoding-15.5 {UtfToUtfProc emoji character input} { set x \xF0\x9F\x98\x82 set y [encoding convertfrom utf-8 \xF0\x9F\x98\x82] list [string length $x] $y -} "4 \U1F602" +} "4 😂" test encoding-15.6 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uDE02\uD83D set y [encoding convertto utf-8 \uDE02\uD83D\uDE02\uD83D] @@ -344,8 +351,8 @@ test encoding-15.7 {UtfToUtfProc emoji character output} { list [string length $x] [string length $y] $z } {3 9 edb882eda0bdeda0bd} test encoding-15.8 {UtfToUtfProc emoji character output} { - set x \uDE02\uD83D\xE9 - set y [encoding convertto utf-8 \uDE02\uD83D\xE9] + set x \uDE02\uD83Dé + set y [encoding convertto utf-8 \uDE02\uD83Dé] binary scan $y H* z list [string length $x] [string length $y] $z } {3 8 edb882eda0bdc3a9} @@ -356,14 +363,14 @@ test encoding-15.9 {UtfToUtfProc emoji character output} { list [string length $x] [string length $y] $z } {3 7 edb882eda0bd58} test encoding-15.10 {UtfToUtfProc high surrogate character output} { - set x \uDE02\xE9 - set y [encoding convertto utf-8 \uDE02\xE9] + set x \uDE02é + set y [encoding convertto utf-8 \uDE02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 edb882c3a9} test encoding-15.11 {UtfToUtfProc low surrogate character output} { - set x \uDA02\xE9 - set y [encoding convertto utf-8 \uDA02\xE9] + set x \uDA02é + set y [encoding convertto utf-8 \uDA02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 eda882c3a9} @@ -391,9 +398,14 @@ test encoding-15.15 {UtfToUtfProc low surrogate character output} { binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 eda882} -test encoding-15.16 {UtfToUtfProc emoji character output} { - set x \U1F602 - set y [encoding convertto utf-8 \U1F602] +test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { + set x \xF0\xA0\xA1\xC2 + set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2] + list [string length $x] $y +} "4 \xF0\xA0\xA1\xC2" +test encoding-15.17 {UtfToUtfProc emoji character output} { + set x 😂 + set y [encoding convertto utf-8 😂] binary scan $y H* z list [string length $y] $z } {4 f09f9882} @@ -401,7 +413,7 @@ test encoding-15.16 {UtfToUtfProc emoji character output} { test encoding-16.1 {Utf16ToUtfProc} -body { set val [encoding convertfrom utf-16 NN] list $val [format %x [scan $val %c]] -} -result "\u4E4E 4e4e" +} -result "乎 4e4e" test encoding-16.2 {Utf16ToUtfProc} -body { set val [encoding convertfrom utf-16 "\xD8\xD8\xDC\xDC"] list $val [format %x [scan $val %c]] @@ -413,7 +425,7 @@ test encoding-16.3 {Utf16ToUtfProc} -body { test encoding-16.4 {Ucs2ToUtfProc} -body { set val [encoding convertfrom ucs-2 NN] list $val [format %x [scan $val %c]] -} -result "\u4E4E 4e4e" +} -result "乎 4e4e" test encoding-16.4 {Ucs2ToUtfProc} -body { set val [encoding convertfrom ucs-2 "\xD8\xD8\xDC\xDC"] list $val [format %x [scan $val %c]] @@ -447,18 +459,18 @@ test encoding-21.1 {EscapeToUtfProc} { test encoding-22.1 {EscapeFromUtfProc} { } {} -set iso2022encData "\u001b\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\u001b(B -\u001b\$B>.@Z<jAwIU@h\$H\$7\$F;HMQ\$7\$F\$*\$j\$^\$9!#62\$lF~\$j\$^\$9\$,!\"@5\$7\$\$=;=j\$r\$4EPO?\$7\$J\$*\u001b(B -\u001b\$B\$*4j\$\$\$\$\$?\$7\$^\$9!#\$^\$?!\"BgJQ62=L\$G\$9\$,!\"=;=jJQ99\$N\$\"\$H!\"F|K\\8l%5!<%S%9It!J\u001b(B -casino_japanese@___.com \u001b\$B!K\$^\$G\$4=;=jJQ99:Q\$NO\"Mm\$r\$\$\$?\$@\$1\$J\$\$\$G\u001b(B -\u001b\$B\$7\$g\$&\$+!)\u001b(B" +set iso2022encData "\x1B\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\x1B(B +\x1B\$B>.@Z<jAwIU@h\$H\$7\$F;HMQ\$7\$F\$*\$j\$^\$9!#62\$lF~\$j\$^\$9\$,!\"@5\$7\$\$=;=j\$r\$4EPO?\$7\$J\$*\x1B(B +\x1B\$B\$*4j\$\$\$\$\$?\$7\$^\$9!#\$^\$?!\"BgJQ62=L\$G\$9\$,!\"=;=jJQ99\$N\$\"\$H!\"F|K\\8l%5!<%S%9It!J\x1B(B +casino_japanese@___.com \x1B\$B!K\$^\$G\$4=;=jJQ99:Q\$NO\"Mm\$r\$\$\$?\$@\$1\$J\$\$\$G\x1B(B +\x1B\$B\$7\$g\$&\$+!)\x1B(B" set iso2022uniData [encoding convertfrom iso2022-jp $iso2022encData] -set iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u3054\u8cfc\u5165\u6642\u306b\u3054\u767b\u9332\u3044\u305f\u3060\u3044\u305f\u3054\u4f4f\u6240\u3092\u30ad\u30e3\u30c3\u30b7\u30e5\u30a2\u30a6\u30c8\u306e\u969b\u306e -\u5c0f\u5207\u624b\u9001\u4ed8\u5148\u3068\u3057\u3066\u4f7f\u7528\u3057\u3066\u304a\u308a\u307e\u3059\u3002\u6050\u308c\u5165\u308a\u307e\u3059\u304c\u3001\u6b63\u3057\u3044\u4f4f\u6240\u3092\u3054\u767b\u9332\u3057\u306a\u304a -\u304a\u9858\u3044\u3044\u305f\u3057\u307e\u3059\u3002\u307e\u305f\u3001\u5927\u5909\u6050\u7e2e\u3067\u3059\u304c\u3001\u4f4f\u6240\u5909\u66f4\u306e\u3042\u3068\u3001\u65e5\u672c\u8a9e\u30b5\u30fc\u30d3\u30b9\u90e8\uff08 -\u0063\u0061\u0073\u0069\u006e\u006f\u005f\u006a\u0061\u0070\u0061\u006e\u0065\u0073\u0065\u0040\u005f\u005f\u005f\u002e\u0063\u006f\u006d\u0020\uff09\u307e\u3067\u3054\u4f4f\u6240\u5909\u66f4\u6e08\u306e\u9023\u7d61\u3092\u3044\u305f\u3060\u3051\u306a\u3044\u3067 -\u3057\u3087\u3046\u304b\uff1f" +set iso2022uniData2 "私どもでは、チップご購入時にご登録いただいたご住所をキャッシュアウトの際の +小切手送付先として使用しております。恐れ入りますが、正しい住所をご登録しなお +お願いいたします。また、大変恐縮ですが、住所変更のあと、日本語サービス部（ +casino_japanese@___.com ）までご住所変更済の連絡をいただけないで +しょうか？" cd [temporaryDirectory] set fid [open iso2022.txt w] @@ -523,17 +535,17 @@ test encoding-24.2 {EscapeFreeProc on open channels} {exec} { viewable [runInSubprocess { encoding system cp1252; # Bug #2891556 crash revelator fconfigure stdout -encoding iso2022-jp - puts ab\u4e4e\u68d9g + puts ab乎棙g set env(TCL_FINALIZE_ON_EXIT) 1 exit }] -} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)" +} "ab\x1B\$B8C\x1B\$(DD%\x1B(Bg (ab\\u001B\$B8C\\u001B\$(DD%\\u001B(Bg)" test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { # Bug #219314 - if we don't free escape encodings correctly on channel # closure, we go boom set file [makeFile { encoding system iso2022-jp - set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters + set a "乎乞也"; # 3 Japanese Kanji letters puts $a } iso2022.tcl] set f [open "|[list [interpreter] $file]"] @@ -542,31 +554,31 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { close $f removeFile iso2022.tcl list $count [viewable $line] -} [list 3 "\u4e4e\u4e5e\u4e5f (\\u4e4e\\u4e5e\\u4e5f)"] +} [list 3 "乎乞也 (\\u4E4E\\u4E5E\\u4E5F)"] test encoding-24.4 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xc0\x80"] + string length [encoding convertfrom utf-8 "\xC0\x80"] } 1 test encoding-24.5 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xc0\x81"] + string length [encoding convertfrom utf-8 "\xC0\x81"] } 2 test encoding-24.6 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xc1\xbf"] + string length [encoding convertfrom utf-8 "\xC1\xBF"] } 2 test encoding-24.7 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xc2\x80"] + string length [encoding convertfrom utf-8 "\xC2\x80"] } 1 test encoding-24.8 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xe0\x80\x80"] + string length [encoding convertfrom utf-8 "\xE0\x80\x80"] } 3 test encoding-24.9 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xe0\x9f\xbf"] + string length [encoding convertfrom utf-8 "\xE0\x9F\xBF"] } 3 test encoding-24.10 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xe0\xa0\x80"] + string length [encoding convertfrom utf-8 "\xE0\xA0\x80"] } 1 test encoding-24.11 {Parse valid or invalid utf-8} { - string length [encoding convertfrom utf-8 "\xef\xbf\xbf"] + string length [encoding convertfrom utf-8 "\xEF\xBF\xBF"] } 1 file delete [file join [temporaryDirectory] iso2022.txt] @@ -620,20 +632,20 @@ proc foreach-jisx0208 {varName command} { } proc gen-jisx0208-euc-jp {code} { binary format cc \ - [expr {($code >> 8) | 0x80}] [expr {($code & 0xff) | 0x80}] + [expr {($code >> 8) | 0x80}] [expr {($code & 0xFF) | 0x80}] } proc gen-jisx0208-iso2022-jp {code} { binary format a3cca3 \ - "\x1b\$B" [expr {$code >> 8}] [expr {$code & 0xff}] "\x1b(B" + "\x1B\$B" [expr {$code >> 8}] [expr {$code & 0xFF}] "\x1B(B" } proc gen-jisx0208-cp932 {code} { set c1 [expr {($code >> 8) | 0x80}] set c2 [expr {($code & 0xff)| 0x80}] if {$c1 % 2} { - set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x31 : 0x71)}] - incr c2 [expr {- (0x60 + ($c2 < 0xe0))}] + set c1 [expr {($c1 >> 1) + ($c1 < 0xDF ? 0x31 : 0x71)}] + incr c2 [expr {- (0x60 + ($c2 < 0xE0))}] } else { - set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x30 : 0x70)}] + set c1 [expr {($c1 >> 1) + ($c1 < 0xDF ? 0x30 : 0x70)}] incr c2 -2 } binary format cc $c1 $c2 diff --git a/tests/env.test b/tests/env.test index 4af46c3..5250ac8 100644 --- a/tests/env.test +++ b/tests/env.test @@ -4,20 +4,20 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] package require tcltests # [exec] is required here to see the actual environment received by child @@ -102,9 +102,11 @@ proc cleanup1 {} { variable keep { TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH - DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING + DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING MSYSTEM __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432 + CommonProgramFiles CommonProgramFiles(x86) ProgramFiles + ProgramFiles(x86) CommonProgramW6432 ProgramW6432 + WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR } variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { @@ -326,11 +328,11 @@ test env-5.2 {corner cases - unset the env array} -setup { } -result {0} -test env-5.3 {corner cases: unset the env in master should unset child} -setup { +test env-5.3 {corner cases: unset the env in parent should unset child} -setup { setup1 interp create i } -body { - # Variables deleted in a master interp should be deleted in child interp + # Variables deleted in a parent interp should be deleted in child interp # too. i eval {set env(THIS_SHOULD_EXIST) a} set result [set env(THIS_SHOULD_EXIST)] diff --git a/tests/error.test b/tests/error.test index af07ed7..064edc7 100644 --- a/tests/error.test +++ b/tests/error.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/eval.test b/tests/eval.test index 70ceac8..5ffe309 100644 --- a/tests/eval.test +++ b/tests/eval.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/event.test b/tests/event.test index 5c111f8..3f9735a 100644 --- a/tests/event.test +++ b/tests/event.test @@ -3,19 +3,19 @@ # this file into Tcl runs the tests and generates output for errors. No # output means no errors were found. # -# Copyright (c) 1995-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 namespace import -force ::tcltest::* catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] - set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [info loaded {} Tcltest] } @@ -23,16 +23,18 @@ testConstraint testfilehandler [llength [info commands testfilehandler]] testConstraint testexithandler [llength [info commands testexithandler]] testConstraint testfilewait [llength [info commands testfilewait]] testConstraint exec [llength [info commands exec]] - +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] + test event-1.1 {Tcl_CreateFileHandler, reading} -setup { testfilehandler close set result "" -} -constraints {testfilehandler} -body { +} -constraints {testfilehandler notOSX} -body { testfilehandler create 0 readable off testfilehandler clear 0 testfilehandler oneevent lappend result [testfilehandler counts 0] testfilehandler fillpartial 0 + update idletasks testfilehandler oneevent lappend result [testfilehandler counts 0] testfilehandler oneevent diff --git a/tests/exec.test b/tests/exec.test index 36aeae5..6e4718a 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -4,9 +4,9 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -14,17 +14,20 @@ # There is no point in running Valgrind on cases where [exec] forks but then # fails and the child process doesn't go through full cleanup. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] package require tcltests # All tests require the "exec" command. # Skip them if exec is not defined. testConstraint exec [llength [info commands exec]] -testConstraint noosx [expr {![info exists ::env(TRAVIS_OSX_IMAGE)] || ![string match xcode* $::env(TRAVIS_OSX_IMAGE)]}] +# Some skips when running in a macOS CI environment +testConstraint noosxCI [expr {![info exists ::env(MAC_CI)]}] unset -nocomplain path @@ -110,7 +113,7 @@ set path(sh2) [makeFile { exit } sh2] set path(sleep) [makeFile { - after [expr $argv*1000] + after [expr {$argv*1000}] exit } sleep] set path(exit) [makeFile { @@ -166,19 +169,19 @@ test exec-2.6 {redirecting input from immediate source, with UTF} -setup { encoding system iso8859-1 proc quotenonascii s { regsub -all {\[|\\|\]} $s {\\&} s - regsub -all "\[\u007f-\uffff\]" $s \ - {[apply {c {format {\u%04x} [scan $c %c]}} &]} s + regsub -all "\[\x7F-\xFF\]" $s \ + {[apply {c {format {\x%02X} [scan $c %c]}} &]} s return [subst -novariables $s] } } -constraints {exec} -body { - # If this fails, it may give back: "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1" + # If this fails, it may give back: "\xC3\xA9\xC3\xA0\xC3\xBC\xC3\xB1" # If it does, this means that the UTF -> external conversion did not occur # before writing out the temp file. - quotenonascii [exec [interpreter] $path(cat) << "\uE9\uE0\uFC\uF1"] + quotenonascii [exec [interpreter] $path(cat) << "\xE9\xE0\xFC\xF1"] } -cleanup { encoding system $sysenc rename quotenonascii {} -} -result {\u00e9\u00e0\u00fc\u00f1} +} -result {\xE9\xE0\xFC\xF1} # I/O redirection: output to file. @@ -671,7 +674,9 @@ test exec-18.2 {exec cat deals with weird file names} -body { # Note that this test cannot be adapted to work on Windows; that platform has # no kernel support for an analog of O_APPEND. OTOH, that means we can assume # that there is a POSIX shell... -test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind noosx} -setup { +# +# This test also fails in some cases when building with macOS +test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind noosxCI} -setup { set tmpfile [makeFile {0} tmpfile.exec-19.1] } -body { # Note that we have to allow for the current contents of the temporary diff --git a/tests/execute.test b/tests/execute.test index fbc4f99..d86ad0e 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -8,19 +8,19 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} @@ -657,56 +657,56 @@ test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} -se namespace delete foo } -result {0 AHA!} test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup { - interp create slave + interp create child } -body { set script { llength {} } - slave eval {proc llength args {return AHA!}} + child eval {proc llength args {return AHA!}} set result {} lappend result [if 1 $script] - lappend result [slave eval $script] + lappend result [child eval $script] } -cleanup { - interp delete slave + interp delete child } -result {0 AHA!} test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body { set script { llength {} } - interp create slave + interp create child set result {} - lappend result [slave eval $script] - interp delete slave - interp create slave - lappend result [slave eval $script] + lappend result [child eval $script] + interp delete child + interp create child + lappend result [child eval $script] } -cleanup { - catch {interp delete slave} + catch {interp delete child} } -result {0 0} test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -constraints testexprlongobj -body { set e { [llength {}]+1 } set result {} - load {} Tcltest slave - interp alias {} e slave testexprlongobj + load {} Tcltest child + interp alias {} e child testexprlongobj lappend result [e $e] - interp delete slave - interp create slave - load {} Tcltest slave - interp alias {} e slave testexprlongobj + interp delete child + interp create child + load {} Tcltest child + interp alias {} e child testexprlongobj lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {{This is a result: 1} {This is a result: 1}} test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -body { set e { [llength {}]+1 } set result {} - interp alias {} e slave expr + interp alias {} e child expr lappend result [e $e] - interp delete slave - interp create slave - interp alias {} e slave expr + interp delete child + interp create child + interp alias {} e child expr lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {1 1} test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body { set e { [llength {}]+1 } @@ -747,16 +747,16 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setu namespace delete foo } -result {1 2} test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup { - interp create slave + interp create child } -body { set e { [llength {}]+1 } - interp alias {} e slave expr - slave eval {proc llength args {return 1}} + interp alias {} e child expr + child eval {proc llength args {return 1}} set result {} lappend result [expr $e] lappend result [e $e] } -cleanup { - interp delete slave + interp delete child } -result {1 2} test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body { proc foo e {set v 0; expr $e} @@ -821,49 +821,49 @@ test execute-7.10 {Wide int handling in INST_MOD} { expr {((wide(1)<<60)-1) % 0x400000000} } 17179869183 test execute-7.11 {Wide int handling in INST_LSHIFT} { - expr wide(42)<<30 + expr {wide(42) << 30} } 45097156608 test execute-7.12 {Wide int handling in INST_LSHIFT} { - expr 12345678901<<3 + expr {12345678901 << 3} } 98765431208 test execute-7.13 {Wide int handling in INST_RSHIFT} { - expr 0x543210febcda9876>>7 + expr {0x543210febcda9876 >> 7} } 47397893236700464 test execute-7.14 {Wide int handling in INST_RSHIFT} { - expr wide(0x9876543210febcda)>>7 + expr {wide(0x9876543210febcda) >> 7} } -58286587177206407 test execute-7.15 {Wide int handling in INST_BITOR} { - expr wide(0x9876543210febcda) | 0x543210febcda9876 + expr {wide(0x9876543210febcda) | 0x543210febcda9876} } -2560765885044310786 test execute-7.16 {Wide int handling in INST_BITXOR} { - expr wide(0x9876543210febcda) ^ 0x543210febcda9876 + expr {wide(0x9876543210febcda) ^ 0x543210febcda9876} } -3727778945703861076 test execute-7.17 {Wide int handling in INST_BITAND} { - expr wide(0x9876543210febcda) & 0x543210febcda9876 + expr {wide(0x9876543210febcda) & 0x543210febcda9876} } 1167013060659550290 test execute-7.18 {Wide int handling in INST_ADD} { - expr wide(0x7fffffff)+wide(0x7fffffff) + expr {wide(0x7fffffff) + wide(0x7fffffff)} } 4294967294 test execute-7.19 {Wide int handling in INST_ADD} { - expr 0x7fffffff+wide(0x7fffffff) + expr {0x7fffffff + wide(0x7fffffff)} } 4294967294 test execute-7.20 {Wide int handling in INST_ADD} { - expr wide(0x7fffffff)+0x7fffffff + expr {wide(0x7fffffff) + 0x7fffffff} } 4294967294 test execute-7.21 {Wide int handling in INST_ADD} { - expr double(0x7fffffff)+wide(0x7fffffff) + expr {double(0x7fffffff) + wide(0x7fffffff)} } 4294967294.0 test execute-7.22 {Wide int handling in INST_ADD} { - expr wide(0x7fffffff)+double(0x7fffffff) + expr {wide(0x7fffffff) + double(0x7fffffff)} } 4294967294.0 test execute-7.23 {Wide int handling in INST_SUB} { - expr 0x123456789a-0x20406080a + expr {0x123456789a - 0x20406080a} } 69530054800 test execute-7.24 {Wide int handling in INST_MULT} { - expr 0x123456789a*193 + expr {0x123456789a * 193} } 15090186251290 test execute-7.25 {Wide int handling in INST_DIV} { - expr 0x123456789a/193 + expr {0x123456789a / 193} } 405116546 test execute-7.26 {Wide int handling in INST_UPLUS} { set x 0x123456871234568 @@ -982,43 +982,43 @@ test execute-8.5 {Bug 2038069} -setup { "catch \[list error FOO\] m o"} -errorline 2} test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup { - interp create slave - slave eval { - package require tcltest - catch [list package require -exact Tcltest [info patchlevel]] + interp create child + child eval { + package require tcltest 2.5 + catch [list package require -exact tcl::test [info patchlevel]] ::tcltest::loadTestedCommands if {[namespace which -command testbumpinterpepoch] eq ""} { proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } } } } -body { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C; } - slave eval { + child eval { set i 0; while {[incr i] < 3} { lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C; } } - slave eval { + child eval { set i 0; while {[incr i] < 3} { lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C; } } - slave eval { + child eval { catch { lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C; } } - slave eval {set res} + child eval {set res} } -cleanup { - interp delete slave + interp delete child } -result [lrepeat 4 A B] test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup { - interp create slave - slave eval { - package require tcltest - catch [list package require -exact Tcltest [info patchlevel]] + interp create child + child eval { + package require tcltest 2.5 + catch [list package require -exact tcl::test [info patchlevel]] ::tcltest::loadTestedCommands if {[namespace which -command testbumpinterpepoch] eq ""} { proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set } @@ -1027,28 +1027,28 @@ test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), excepti } -body { set res {} lappend res [catch { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C; } } e] $e lappend res [catch { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C; } } e] $e lappend res [catch { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C; } } e] $e lappend res [catch { - slave eval { + child eval { lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C; } } e] $e - list $res [slave eval {set res}] + list $res [child eval {set res}] } -cleanup { - interp delete slave + interp delete child } -result [list {1 test 1 test 2 test 3 {}} [lrepeat 4 A B]] test execute-9.1 {Interp result resetting [Bug 1522803]} { @@ -1066,19 +1066,19 @@ test execute-9.1 {Interp result resetting [Bug 1522803]} { } SUCCESS test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} { - apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130 + apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} İ } {48 {304 304}} test execute-10.2 {Bug 2802881} -setup { - interp create slave + interp create child } -body { # If [Bug 2802881] is not fixed, this will segfault - slave eval { + child eval { trace add variable ::errorInfo write {expr {$foo} ;#} proc demo {} {a {}{}} demo } } -cleanup { - interp delete slave + interp delete child } -returnCodes error -match glob -result * test execute-10.3 {Bug 3072640} -setup { proc generate {n} { @@ -1103,9 +1103,9 @@ test execute-10.3 {Bug 3072640} -setup { } -result 4 test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { set x [lrepeat 1320 199] for {set i 0} {$i < 20} {incr i} { lappend x $i @@ -1115,7 +1115,7 @@ test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup { return ok } } -cleanup { - interp delete slave + interp delete child } -result ok test execute-11.2 {Bug 268b23df11} -setup { diff --git a/tests/expr-old.test b/tests/expr-old.test index 003ee00..676443a 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -6,18 +6,20 @@ # "compExpr.test". Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-2000 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2.1 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] @@ -33,9 +35,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -45,19 +47,19 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -67,11 +69,11 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 @@ -522,7 +524,7 @@ test expr-old-26.10b {error conditions} ieeeFloatingPoint { list [catch {expr 2.0/0.0} msg] $msg } {0 Inf} test expr-old-26.11 {error conditions} -body { - expr 2# + expr 2` } -returnCodes error -match glob -result * test expr-old-26.12 {error conditions} -body { expr a.b @@ -850,7 +852,7 @@ test expr-old-32.46 {math functions in expressions} -body { } -match glob -result {1 {too many arguments for math function*}} test expr-old-32.47 {math functions in expressions} -body { list [catch {expr srand()} msg] $msg -} -match glob -result {1 {too few arguments for math function*}} +} -match glob -result {1 {not enough arguments for math function*}} test expr-old-32.48 {math functions in expressions} -body { expr srand(3.79) } -returnCodes error -match glob -result * @@ -907,7 +909,7 @@ test expr-old-34.6 {errors in math functions} -body { } -returnCodes error -match glob -result * test expr-old-34.7 {errors in math functions} -body { list [catch {expr hypot(1.0)} msg] $msg -} -match glob -result {1 {too few arguments for math function*}} +} -match glob -result {1 {not enough arguments for math function*}} test expr-old-34.8 {errors in math functions} -body { list [catch {expr hypot(1.0, 2.0, 3.0)} msg] $msg } -match glob -result {1 {too many arguments for math function*}} @@ -1148,7 +1150,7 @@ test expr-old-40.2 {min math function} -body { } -result 0.0 test expr-old-40.3 {min math function} -body { expr {min()} -} -returnCodes error -result {too few arguments for math function "min"} +} -returnCodes error -result {not enough arguments for math function "min"} test expr-old-40.4 {min math function} -body { expr {min(wide(-1) << 30, 4.5, -10)} } -result [expr {wide(-1) << 30}] @@ -1173,7 +1175,7 @@ test expr-old-41.2 {max math function} -body { } -result 0.0 test expr-old-41.3 {max math function} -body { expr {max()} -} -returnCodes error -result {too few arguments for math function "max"} +} -returnCodes error -result {not enough arguments for math function "max"} test expr-old-41.4 {max math function} -body { expr {max(wide(1) << 30, 4.5, -10)} } -result [expr {wide(1) << 30}] diff --git a/tests/expr.test b/tests/expr.test index f0b75f4..32706d9 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -4,19 +4,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-2000 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.1 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. @@ -33,9 +33,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -45,21 +45,21 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) - binary scan \x00\x00\x00\x00\x00\x00\xf8\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\xFF d \ ieeeValues(-NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -69,13 +69,13 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) - binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-NaN) set ieeeValues(littleEndian) 0 return 1 @@ -351,7 +351,7 @@ test expr-8.11 {CompileEqualityExpr: error compiling equality arm} -body { expr 2!=x } -returnCodes error -match glob -result * test expr-8.12 {CompileBitAndExpr: equality expr} {expr {"a"eq"a"}} 1 -test expr-8.13 {CompileBitAndExpr: equality expr} {expr {"\374" eq [set s \u00fc]}} 1 +test expr-8.13 {CompileBitAndExpr: equality expr} {expr {"\374" eq [set s \xFC]}} 1 test expr-8.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0 test expr-8.15 {CompileBitAndExpr: equality expr} {expr 2.0eq2} 0 test expr-8.16 {CompileBitAndExpr: equality expr} {expr 3.2ne2.2} 1 @@ -685,13 +685,13 @@ test expr-15.3 {CompileMathFuncCall: too many arguments} -body { test expr-15.4 {CompileMathFuncCall: ')' found before last required arg} -body { catch {expr sin()} msg set ::errorInfo -} -match glob -result {too few arguments for math function* +} -match glob -result {not enough arguments for math function* while *ing "expr sin()"} -test expr-15.5 {CompileMathFuncCall: too few arguments} -body { +test expr-15.5 {CompileMathFuncCall: not enough arguments} -body { catch {expr pow(1)} msg set ::errorInfo -} -match glob -result {too few arguments for math function* +} -match glob -result {not enough arguments for math function* while *ing "expr pow(1)"} test expr-15.6 {CompileMathFuncCall: missing ')'} -body { @@ -6699,6 +6699,12 @@ test expr-38.12 {abs and -0x0 [Bug 2954959]} { test expr-38.13 {abs and 0.0 [Bug 2954959]} { ::tcl::mathfunc::abs 1e-324 } 1e-324 +test expr-38.14 {abs and INT64_MIN special-case} { + ::tcl::mathfunc::abs -9223372036854775808 +} 9223372036854775808 +test expr-38.15 {abs and INT128_MIN special-case} { + ::tcl::mathfunc::abs -170141183460469231731687303715884105728 +} 170141183460469231731687303715884105728 testConstraint testexprlongobj [llength [info commands testexprlongobj]] testConstraint testexprdoubleobj [llength [info commands testexprdoubleobj]] @@ -7251,7 +7257,7 @@ test expr-52.1 { foreach func {isfinite isinf isnan isnormal issubnormal} { test expr-53.1.$func {float classification: basic arg handling} -body { expr ${func}() - } -returnCodes error -result "too few arguments for math function \"$func\"" + } -returnCodes error -result "not enough arguments for math function \"$func\"" test expr-53.2.$func {float classification: basic arg handling} -body { expr ${func}(1,2) } -returnCodes error -result "too many arguments for math function \"$func\"" @@ -7346,10 +7352,10 @@ test expr-59.12 {float classification: fpclassify} -returnCodes error -body { test expr-60.1 {float classification: basic arg handling} -body { expr isunordered() -} -returnCodes error -result {too few arguments for math function "isunordered"} +} -returnCodes error -result {not enough arguments for math function "isunordered"} test expr-60.2 {float classification: basic arg handling} -body { expr isunordered(1) -} -returnCodes error -result {too few arguments for math function "isunordered"} +} -returnCodes error -result {not enough arguments for math function "isunordered"} test expr-60.3 {float classification: basic arg handling} -body { expr {isunordered(1, 2, 3)} } -returnCodes error -result {too many arguments for math function "isunordered"} @@ -7384,6 +7390,67 @@ foreach v1 $values r1 $results { } } unset -nocomplain values results ctr + +test expr-62.1 {TIP 582: comments} -body { + expr {1 # + 2} +} -result 1 +test expr-62.2 {TIP 582: comments} -body { + expr "1 #\n+ 2" +} -result 3 +test expr-62.3 {TIP 582: comments} -setup { + set ctr 0 +} -body { + expr { + # This is a demonstration of a comment + 1 + 2 + 3 + # and another comment + + 4 + 5 + # + [incr ctr] + + [incr ctr] + } +} -result 16 +# Buggy because line breaks aren't tracked inside expressions at all +test expr-62.4 {TIP 582: comments don't hide line breaks} -setup { + proc getline {} { + dict get [info frame -1] line + } + set base [getline] +} -constraints knownBug -body { + expr { + 0 + # a comment + + [getline] - $base + } +} -cleanup { + rename getline "" +} -result 5 +test expr-62.5 {TIP 582: comments don't splice tokens} { + set a False + expr {$a#don't splice +ne#don't splice +false} +} 1 +test expr-62.6 {TIP 582: comments don't splice tokens} { + expr {0x2#don't splice +ne#don't splice +2} +} 1 +test expr-62.7 {TIP 582: comments can go inside function calls} { + expr {max(1,# comment + 2)} +} 2 +test expr-62.8 {TIP 582: comments can go inside function calls} { + expr {max(1# comment + ,2)} +} 2 +test expr-62.9 {TIP 582: comments can go inside function calls} { + expr {max(# comment + 1,2)} +} 2 +test expr-62.10 {TIP 582: comments can go inside function calls} { + expr {max# comment + (1,2)} +} 2 # cleanup unset -nocomplain a diff --git a/tests/fCmd.test b/tests/fCmd.test index e8ed6f9..d1d1930 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -4,26 +4,25 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1999 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] cd [temporaryDirectory] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testchmod [llength [info commands testchmod]] -testConstraint winVista 0 -testConstraint winXP 0 +testConstraint winLessThan10 0 # Don't know how to determine this constraint correctly testConstraint notNetworkFilesystem 0 testConstraint reg 0 @@ -41,6 +40,7 @@ if {[testConstraint win]} { testConstraint reg 1 } } +testConstraint notInCIenv [expr {![info exists ::env(CI)] || !$::env(CI)}] set tmpspace /tmp;# default value # Find a group that exists on this Unix system, or else skip tests that @@ -64,12 +64,8 @@ if {[testConstraint unix]} { } # Also used in winFCmd... -if {[testConstraint win]} { - if {$::tcl_platform(osVersion) >= 5.0} { - testConstraint winVista 1 - } else { - testConstraint winXP 1 - } +if {[testConstraint win] && $::tcl_platform(osVersion) < 10.0} { + testConstraint winLessThan10 1 } testConstraint darwin9 [expr { @@ -78,6 +74,7 @@ testConstraint darwin9 [expr { && [package vsatisfies 1.$::tcl_platform(osVersion) 1.9] }] testConstraint notDarwin9 [expr {![testConstraint darwin9]}] +testConstraint notContinuousIntegration [expr {![info exists ::env(CI)]}] testConstraint fileSharing 0 testConstraint notFileSharing 1 @@ -274,7 +271,7 @@ test fCmd-3.14 {FileCopyRename: FileBasename fails} -setup { file mkdir td1 file rename ~_totally_bogus_user td1 } -result {user "_totally_bogus_user" doesn't exist} -test fCmd-3.15 {FileCopyRename: source[0] == '\0'} -setup { +test fCmd-3.15 {FileCopyRename: source[0] == '\x00'} -setup { cleanup } -constraints {notRoot unixOrWin} -returnCodes error -body { file mkdir td1 @@ -316,7 +313,7 @@ test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} -setup { } -constraints {notRoot} -returnCodes error -body { file mkdir ~_totally_bogus_user } -result {user "_totally_bogus_user" doesn't exist} -test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\0'} -setup { +test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\x00'} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { file mkdir "" @@ -416,7 +413,7 @@ test fCmd-5.4 {TclFileDeleteCmd: multiple files} -constraints notRoot -setup { } -cleanup {cleanup} -result {1 1 1 0 0 0} test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup { cleanup -} -constraints {notRoot unixOrWin} -body { +} -constraints {notRoot unixOrWin notWine} -body { createfile tf1 createfile tf2 file mkdir td1 @@ -563,7 +560,7 @@ test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} -setup { } -result 1 test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir [file join td1 td2] createfile [file join td1 td2 tf1] file mkdir td2 @@ -572,12 +569,12 @@ test fCmd-6.16 {CopyRenameOneFile: TclpCopyRenameOneFile fails} -setup { [subst {error renaming "td2" to "[file join td1 td2]": file *}] test fCmd-6.17 {CopyRenameOneFile: errno == EINVAL} -setup { cleanup -} -constraints {notRoot} -returnCodes error -body { +} -constraints {notRoot notWine} -returnCodes error -body { file rename -force $root tf1 } -result [subst {error renaming "$root" to "tf1": trying to rename a volume or move a directory into itself}] test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir [file join td1 td2] createfile [file join td1 td2 tf1] file mkdir td2 @@ -621,10 +618,10 @@ test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { cleanup $tmpspace } -constraints {xdev notRoot} -body { file mkdir td1/td2/td3 - file attributes td1 -permissions 0000 + file attributes td1 -permissions 0 file rename td1 $tmpspace } -returnCodes error -cleanup { - file attributes td1 -permissions 0755 + file attributes td1 -permissions 0o755 cleanup } -match regexp -result {^error renaming "td1"( to "/tmp/tcl\d+/td1")?: permission denied$} test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup { @@ -632,10 +629,10 @@ test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup { } -constraints {unix notRoot} -body { file mkdir ~/td1/td2 set td1name [file join [file dirname ~] [file tail ~] td1] - file attributes $td1name -permissions 0000 + file attributes $td1name -permissions 0 file copy ~/td1 td1 } -returnCodes error -cleanup { - file attributes $td1name -permissions 0755 + file attributes $td1name -permissions 0o755 file delete -force ~/td1 } -result {error copying "~/td1": permission denied} test fCmd-6.25 {CopyRenameOneFile: error uses original name} -setup { @@ -644,10 +641,10 @@ test fCmd-6.25 {CopyRenameOneFile: error uses original name} -setup { file mkdir td2 file mkdir ~/td1 set td1name [file join [file dirname ~] [file tail ~] td1] - file attributes $td1name -permissions 0000 + file attributes $td1name -permissions 0 file copy td2 ~/td1 } -returnCodes error -cleanup { - file attributes $td1name -permissions 0755 + file attributes $td1name -permissions 0o755 file delete -force ~/td1 } -result {error copying "td2" to "~/td1/td2": permission denied} test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} -setup { @@ -655,10 +652,10 @@ test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} -setup { } -constraints {unix notRoot} -body { file mkdir ~/td1/td2 set td2name [file join [file dirname ~] [file tail ~] td1 td2] - file attributes $td2name -permissions 0000 + file attributes $td2name -permissions 0 file copy ~/td1 td1 } -returnCodes error -cleanup { - file attributes $td2name -permissions 0755 + file attributes $td2name -permissions 0o755 file delete -force ~/td1 } -result "error copying \"~/td1\" to \"td1\": \"[file join $::env(HOME) td1 td2]\": permission denied" test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { @@ -673,10 +670,10 @@ test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { cleanup $tmpspace } -constraints {notRoot xdev} -body { file mkdir td1/td2/td3 - file attributes td1/td2/td3 -permissions 0000 + file attributes td1/td2/td3 -permissions 0 file rename td1 $tmpspace } -returnCodes error -cleanup { - file attributes td1/td2/td3 -permissions 0755 + file attributes td1/td2/td3 -permissions 0o755 cleanup $tmpspace } -match glob -result {error renaming "td1" to "/tmp/tcl*/td1": "td1/td2/td3": permission denied} test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} -setup { @@ -787,18 +784,7 @@ 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.a {file rename: comprehensive: dir to new name} -setup { - cleanup -} -constraints {win winXP testchmod} -body { - file mkdir td1 td2 - testchmod 0o555 td2 - file rename td1 td3 - file rename td2 td4 - list [lsort [glob td*]] [file writable td3] [file writable td4] -} -cleanup { - cleanup -} -result {{td3 td4} 1 0} -test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup { +test fCmd-9.4 {file rename: comprehensive: dir to new name} -setup { cleanup } -constraints {unix notRoot testchmod notDarwin9} -body { file mkdir td1 td2 @@ -811,7 +797,7 @@ test fCmd-9.4.b {file rename: comprehensive: dir to new name} -setup { } -result {{td3 td4} 1 0} test fCmd-9.5 {file rename: comprehensive: file to self} -setup { cleanup -} -constraints {notRoot testchmod} -body { +} -constraints {notRoot testchmod notWine} -body { createfile tf1 tf1 createfile tf2 tf2 testchmod 0o444 tf2 @@ -819,17 +805,7 @@ 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.a {file rename: comprehensive: dir to self} -setup { - cleanup -} -constraints {win winXP testchmod} -body { - file mkdir td1 - file mkdir td2 - testchmod 0o555 td2 - file rename -force td1 . - file rename -force td2 . - list [lsort [glob td*]] [file writable td1] [file writable td2] -} -result {{td1 td2} 1 0} -test fCmd-9.6.b {file rename: comprehensive: dir to self} -setup { +test fCmd-9.6 {file rename: comprehensive: dir to self} -setup { cleanup } -constraints {unix notRoot testchmod} -body { file mkdir td1 @@ -841,7 +817,7 @@ test fCmd-9.6.b {file rename: comprehensive: dir to self} -setup { } -result {{td1 td2} 1 0} test fCmd-9.7 {file rename: comprehensive: file to existing file} -setup { cleanup -} -constraints {notRoot testchmod} -body { +} -constraints {notRoot testchmod notWine} -body { createfile tf1 createfile tf2 createfile tfs1 @@ -902,21 +878,14 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { # Test can hit EEXIST or EBUSY, depending on underlying filesystem test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup { cleanup -} -constraints {notRoot testchmod} -body { +} -constraints {notRoot testchmod notWine} -body { file mkdir tds1 file mkdir tds2 file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] - if {!([testConstraint unix] || [testConstraint winVista])} { - testchmod 0o555 tds2 - } set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg] set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg] - if {[testConstraint unix] || [testConstraint winVista]} { - set w2 0 - } else { - set w2 [file writable tds2] - } + set w2 0 list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2 } -match glob -result \ [subst {{tdd1 tdd2 tds1 tds2} {1 {error renaming "tds1" to "[file join tdd1 tds1]": file *}} {1 {error renaming "tds2" to "[file join tdd2 tds2]": file *}} 1 0}] @@ -938,16 +907,9 @@ test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} -setup { file mkdir td1 file mkdir td2 file mkdir td3 - if {!([testConstraint unix] || [testConstraint winVista])} { - testchmod 0o555 td2 - } file rename td1 [file join td3 td3] file rename td2 [file join td3 td4] - if {[testConstraint unix] || [testConstraint winVista]} { - set w4 0 - } else { - set w4 [file writable [file join td3 td4]] - } + set w4 0 list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ [file writable [file join td3 td3]] $w4 } -result [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}] @@ -966,14 +928,14 @@ test fCmd-9.12 {file rename: comprehensive: target exists} -setup { # Test can hit EEXIST or EBUSY, depending on underlying filesystem test fCmd-9.13 {file rename: comprehensive: can't overwrite target} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir [file join td1 td2] [file join td2 td1 td4] file rename -force td1 td2 } -returnCodes error -match glob -result \ [subst {error renaming "td1" to "[file join td2 td1]": file *}] test fCmd-9.14 {file rename: comprehensive: dir into self} -setup { cleanup -} -constraints {notRoot} -body { +} -constraints {notRoot notWine} -body { file mkdir td1 list [glob td*] [list [catch {file rename td1 td1} msg] $msg] } -result [subst {td1 {1 {error renaming "td1" to "[file join td1 td1]": trying to rename a volume or move a directory into itself}}}] @@ -1068,7 +1030,7 @@ test fCmd-10.3.1 {file copy: comprehensive: dir to new name} -setup { } -result [list {td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1] test fCmd-10.4 {file copy: comprehensive: file to existing file} -setup { cleanup -} -constraints {notRoot testchmod} -body { +} -constraints {notRoot testchmod notWine} -body { createfile tf1 createfile tf2 createfile tfs1 @@ -1340,10 +1302,10 @@ test fCmd-12.8 {renamefile: generic error} -setup { } -constraints {unix notRoot} -body { file mkdir tfa file mkdir tfa/dir - file attributes tfa -permissions 0555 + file attributes tfa -permissions 0o555 catch {file rename tfa/dir tfa2} } -cleanup { - catch {file attributes tfa -permissions 0777} + catch {file attributes tfa -permissions 0o777} file delete -force tfa } -result {1} test fCmd-12.9 {renamefile: moving a file across volumes} -setup { @@ -1526,10 +1488,10 @@ test fCmd-14.8 {copyfile: copy directory failing} -setup { catch {file delete -force -- tfa} } -constraints {unix notRoot} -body { file mkdir tfa/dir/a/b/c - file attributes tfa/dir -permissions 0000 + file attributes tfa/dir -permissions 0 catch {file copy tfa tfa2} } -cleanup { - file attributes tfa/dir -permissions 0777 + file attributes tfa/dir -permissions 0o777 file delete -force tfa tfa2 } -result {1} @@ -1569,10 +1531,10 @@ test fCmd-15.4 {TclMakeDirsCmd - stat failing} -setup { } -constraints {unix notRoot} -body { file mkdir tfa createfile tfa/file - file attributes tfa -permissions 0000 + file attributes tfa -permissions 0 catch {file mkdir tfa/file} } -cleanup { - file attributes tfa -permissions 0777 + file attributes tfa -permissions 0o777 file delete -force tfa } -result {1} test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep} -setup { @@ -1669,7 +1631,7 @@ test fCmd-16.9 {error while deleting file} -setup { } -constraints {unix notRoot} -body { file mkdir tfa createfile tfa/a - file attributes tfa -permissions 0555 + file attributes tfa -permissions 0o555 catch {file delete tfa/a} ####### ####### If any directory in a tree that is being removed does not have @@ -1677,7 +1639,7 @@ test fCmd-16.9 {error while deleting file} -setup { ####### with "rm -rf" ####### } -cleanup { - file attributes tfa -permissions 0777 + file attributes tfa -permissions 0o777 file delete -force tfa } -result {1} test fCmd-16.10 {deleting multiple files} -constraints {notRoot} -setup { @@ -1699,10 +1661,10 @@ test fCmd-17.1 {mkdir stat failing on target but not ENOENT} -setup { catch {file delete -force -- tfa1} } -constraints {unix notRoot} -body { file mkdir tfa1 - file attributes tfa1 -permissions 0555 + file attributes tfa1 -permissions 0o555 catch {file mkdir tfa1/tfa2} } -cleanup { - file attributes tfa1 -permissions 0777 + file attributes tfa1 -permissions 0o777 file delete -force tfa1 } -result {1} test fCmd-17.2 {mkdir several levels deep - relative} -setup { @@ -1910,10 +1872,10 @@ test fCmd-19.2 {rmdir error besides EEXIST} -setup { } -constraints {unix notRoot} -body { file mkdir tfa file mkdir tfa/a - file attributes tfa -permissions 0555 + file attributes tfa -permissions 0o555 catch {file delete tfa/a} } -cleanup { - file attributes tfa -permissions 0777 + file attributes tfa -permissions 0o777 file delete -force tfa } -result {1} test fCmd-19.3 {recursive remove} -constraints {notRoot} -setup { @@ -1938,10 +1900,10 @@ test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory} -se } -constraints {unix notRoot} -body { file mkdir tfa file mkdir tfa/a - file attributes tfa/a -permissions 0000 + file attributes tfa/a -permissions 00000 catch {file delete -force tfa} } -cleanup { - file attributes tfa/a -permissions 0777 + file attributes tfa/a -permissions 0o777 file delete -force tfa } -result {1} test fCmd-20.2 {TraverseUnixTree : recursive delete of large directory: Bug 1034337} -setup { @@ -2352,13 +2314,15 @@ test fCmd-28.7 {file link: source already exists} -setup { } -returnCodes error -cleanup { cd [workingDirectory] } -result {could not create new link "abc.file": that path already exists} -test fCmd-28.8 {file link} -constraints {linkFile win} -setup { +# In Windows 10 developer mode, we _can_ create symbolic links to files! +test fCmd-28.8 {file link} -constraints {linkFile winLessThan10} -setup { cd [temporaryDirectory] } -body { file link -symbolic abc.link abc.file -} -returnCodes error -cleanup { +} -cleanup { + file delete -force abc.link cd [workingDirectory] -} -result {could not create new link "abc.link" pointing to "abc.file": not a directory} +} -returnCodes error -result {could not create new link "abc.link" pointing to "abc.file": invalid argument} test fCmd-28.9 {file link: success with file} -constraints {linkFile} -setup { cd [temporaryDirectory] file delete -force abc.link @@ -2401,7 +2365,7 @@ test fCmd-28.10.1 {file link: linking to nonexistent path} -setup { test fCmd-28.11 {file link: success with directory} -setup { cd [temporaryDirectory] file delete -force abc.link -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { file link abc.link abc.dir } -cleanup { cd [workingDirectory] @@ -2409,7 +2373,7 @@ test fCmd-28.11 {file link: success with directory} -setup { test fCmd-28.12 {file link: cd into a link} -setup { cd [temporaryDirectory] file delete -force abc.link -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { file link abc.link abc.dir set orig [pwd] cd abc.link @@ -2435,7 +2399,7 @@ test fCmd-28.12 {file link: cd into a link} -setup { file delete -force abc.link cd [workingDirectory] } -result ok -test fCmd-28.13 {file link} -constraints {linkDirectory} -setup { +test fCmd-28.13 {file link} -constraints {linkDirectory notWine} -setup { cd [temporaryDirectory] file link abc.link abc.dir } -body { @@ -2469,7 +2433,7 @@ test fCmd-28.15.1 {file link: copies link not dir} -setup { test fCmd-28.15.2 {file link: copies link not dir} -setup { cd [temporaryDirectory] file delete -force abc.link -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { file link abc.link abc.dir file copy abc.link abc2.link list [file type abc2.link] [file tail [file link abc2.link]] @@ -2490,7 +2454,7 @@ cd [workingDirectory] test fCmd-28.16 {file link: glob inside link} -setup { cd [temporaryDirectory] file delete -force abc.link -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { file link abc.link abc.dir lsort [glob -dir abc.link -tails *] } -cleanup { @@ -2500,13 +2464,13 @@ test fCmd-28.16 {file link: glob inside link} -setup { test fCmd-28.17 {file link: glob -type l} -setup { cd [temporaryDirectory] file link abc.link abc.dir -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { glob -dir [pwd] -type l -tails abc* } -cleanup { file delete -force abc.link cd [workingDirectory] } -result {abc.link} -test fCmd-28.18 {file link: glob -type d} -constraints linkDirectory -setup { +test fCmd-28.18 {file link: glob -type d} -constraints {linkDirectory notWine} -setup { cd [temporaryDirectory] file link abc.link abc.dir } -body { @@ -2517,7 +2481,7 @@ test fCmd-28.18 {file link: glob -type d} -constraints linkDirectory -setup { } -result [lsort [list abc.link abc.dir abc2.dir]] test fCmd-28.19 {file link: relative paths} -setup { cd [temporaryDirectory] -} -constraints {win linkDirectory} -body { +} -constraints {win linkDirectory notWine} -body { file mkdir d1/d2/d3 file link d1/l2 d1/d2 } -cleanup { @@ -2575,12 +2539,14 @@ test fCmd-30.1 {file writable on 'My Documents'} -setup { } -constraints {win reg} -body { file writable $mydocsname } -result 1 -test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win} -body { +test fCmd-30.2 {file readable on 'NTUSER.DAT'} -constraints {win notWine} -body { expr {[info exists env(USERPROFILE)] && [file exists $env(USERPROFILE)/NTUSER.DAT] && [file readable $env(USERPROFILE)/NTUSER.DAT]} } -result {1} -test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win} -body { +# At least one CI environment (GitHub Actions) is set up with the page file in +# an unusual location; skip the test if that is so. +test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win notInCIenv} -body { set r {} if {[info exists env(SystemDrive)]} { set path $env(SystemDrive)/pagefile.sys diff --git a/tests/fileName.test b/tests/fileName.test index 0e4cb9e..04273d7 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -4,19 +4,20 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1999 by Scriptics Corporation. +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } + ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testtranslatefilename [llength [info commands testtranslatefilename]] @@ -30,6 +31,7 @@ if {[testConstraint win]} { testConstraint symbolicLinkFile 0 testConstraint sharedCdrive [expr {![catch {cd //[info hostname]/c}]}] } +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] # This match compares the first two words of the result. If the wanted result # is "equal", then this is successful if the words are equal. If the wanted # result is "not equal", then this is successful if the words are different. @@ -788,7 +790,7 @@ test filename-11.17 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.17.1 {Tcl_GlobCmd} {win} { +test filename-11.17.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -directory $globname *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -799,7 +801,7 @@ test filename-11.17.1 {Tcl_GlobCmd} {win} { [file join $globname y1.c] [file join $globname z1.c]]] test filename-11.17.2 {Tcl_GlobCmd} -setup { set dir [pwd] -} -constraints {notRoot linkDirectory} -body { +} -constraints {notRoot linkDirectory notWine} -body { cd $globname file link -symbolic link a1 cd $dir @@ -812,7 +814,7 @@ test filename-11.17.2 {Tcl_GlobCmd} -setup { # Simpler version of the above test to illustrate a given bug. test filename-11.17.3 {Tcl_GlobCmd} -setup { set dir [pwd] -} -constraints {notRoot linkDirectory} -body { +} -constraints {notRoot linkDirectory notWine} -body { cd $globname file link -symbolic link a1 cd $dir @@ -827,7 +829,7 @@ test filename-11.17.3 {Tcl_GlobCmd} -setup { # Make sure the bugfix isn't too simple. We don't want to break 'glob -type l' test filename-11.17.4 {Tcl_GlobCmd} -setup { set dir [pwd] -} -constraints {notRoot linkDirectory} -body { +} -constraints {notRoot linkDirectory notWine} -body { cd $globname file link -symbolic link a1 cd $dir @@ -845,7 +847,7 @@ test filename-11.17.6 {Tcl_GlobCmd} { [list "weird name.c" x,z1.c x1.c y1.c z1.c]]] test filename-11.17.7 {Tcl_GlobCmd: broken link and glob -l} -setup { set dir [pwd] -} -constraints {linkDirectory} -body { +} -constraints {linkDirectory notWine} -body { cd $globname file mkdir nonexistent file link -symbolic link nonexistent @@ -877,7 +879,7 @@ test filename-11.18 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.18.1 {Tcl_GlobCmd} {win} { +test filename-11.18.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -path $globname/ *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -894,7 +896,7 @@ test filename-11.19 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.19.1 {Tcl_GlobCmd} {win} { +test filename-11.19.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -join -path [string range $globname 0 5] * *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -903,7 +905,7 @@ test filename-11.19.1 {Tcl_GlobCmd} {win} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.20 {Tcl_GlobCmd} { +test filename-11.20 {Tcl_GlobCmd} notWine { lsort [glob -type d -dir $globname *] } [lsort [list [file join $globname a1]\ [file join $globname a2]\ @@ -933,7 +935,7 @@ test filename-11.22 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.22.1 {Tcl_GlobCmd} {win} { +test filename-11.22.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -dir $globname *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -950,7 +952,7 @@ test filename-11.23 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.23.1 {Tcl_GlobCmd} {win} { +test filename-11.23.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -path $globname/ *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -967,7 +969,7 @@ test filename-11.24 {Tcl_GlobCmd} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.24.1 {Tcl_GlobCmd} {win} { +test filename-11.24.1 {Tcl_GlobCmd} {win notWine} { lsort [glob -join -path [string range $globname 0 5] * *] } [lsort [list [file join $globname a1] [file join $globname a2]\ [file join $globname .1]\ @@ -976,17 +978,17 @@ test filename-11.24.1 {Tcl_GlobCmd} {win} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-11.25 {Tcl_GlobCmd} { +test filename-11.25 {Tcl_GlobCmd} notWine { lsort [glob -type d -dir $globname *] } [lsort [list [file join $globname a1]\ [file join $globname a2]\ [file join $globname a3]]] -test filename-11.25.1 {Tcl_GlobCmd} { +test filename-11.25.1 {Tcl_GlobCmd} notWine { lsort [glob -type {d r} -dir $globname *] } [lsort [list [file join $globname a1]\ [file join $globname a2]\ [file join $globname a3]]] -test filename-11.25.2 {Tcl_GlobCmd} { +test filename-11.25.2 {Tcl_GlobCmd} notWine { lsort [glob -type {d r w} -dir $globname *] } [lsort [list [file join $globname a1]\ [file join $globname a2]\ @@ -1061,10 +1063,10 @@ test filename-11.45 {Tcl_GlobCmd on root volume} -setup { set tmpd [pwd] } -body { catch { - set res1 [glob -dir [lindex [file volumes] 0] -tails *] + set res1 [glob -dir [lindex [file volumes] end] -tails *] } catch { - cd [lindex [file volumes] 0] + cd [lindex [file volumes] end] set res2 [glob *] } list $res1 $res2 @@ -1083,6 +1085,12 @@ test filename-11.48 {Tcl_GlobCmd} -returnCodes error -body { test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body { glob -types abcde -path foo -join * * } -result {bad argument to "-types": abcde} +test filename-11.50 {Tcl_GlobCmd} -returnCodes error -body { + glob -path hello -path salut * +} -result {"-path" may only be used once} +test filename-11.51 {Tcl_GlobCmd} -returnCodes error -body { + glob -dir hello -dir salut * +} -result {"-directory" may only be used once} file rename $horribleglobname globTest file delete -force $tildeglobname @@ -1224,10 +1232,10 @@ test filename-14.5 {asterisks, question marks, and brackets} -setup { test filename-14.7 {asterisks, question marks, and brackets} {unix} { lsort [glob globTest/*] } {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} -test filename-14.7.1 {asterisks, question marks, and brackets} {win} { +test filename-14.7.1 {asterisks, question marks, and brackets} {win notWine} { lsort [glob globTest/*] } {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c} -test filename-14.9 {asterisks, question marks, and brackets} {unixOrWin} { +test filename-14.9 {asterisks, question marks, and brackets} {unixOrWin notWine} { lsort [glob globTest/.*] } {globTest/. globTest/.. globTest/.1} test filename-14.11 {asterisks, question marks, and brackets} {unixOrWin} { @@ -1236,7 +1244,7 @@ test filename-14.11 {asterisks, question marks, and brackets} {unixOrWin} { test filename-14.13 {asterisks, question marks, and brackets} {unixOrWin} { lsort [glob {globTest/[xyab]1.*}] } {globTest/x1.c globTest/y1.c} -test filename-14.15 {asterisks, question marks, and brackets} {unixOrWin} { +test filename-14.15 {asterisks, question marks, and brackets} {unixOrWin notWine} { lsort [glob globTest/*/] } {globTest/a1/ globTest/a2/ globTest/a3/} test filename-14.17 {asterisks, question marks, and brackets} -setup { @@ -1276,7 +1284,7 @@ test filename-14.25 {type specific globbing} {unix} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]] -test filename-14.25.1 {type specific globbing} {win} { +test filename-14.25.1 {type specific globbing} {win notWine} { lsort [glob -dir globTest -types f *] } [lsort [list \ [file join $globname .1]\ @@ -1321,7 +1329,7 @@ unset globname # AFS, "000" protection doesn't prevent access by owner, so the following test # is not portable. -catch {file attributes globTest/a1 -permissions 0000} +catch {file attributes globTest/a1 -permissions 0} test filename-15.1 {unix specific globbing} {unix nonPortable} { string tolower [list [catch {glob globTest/a1/*} msg] $msg $errorCode] } {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}} @@ -1333,7 +1341,7 @@ test filename-15.3 {unix specific no complain: no errors, good result} \ # test fails because if an error occurs, the interp's result is reset... glob -nocomplain globTest/a2 globTest/a1/* globTest/a3 } {globTest/a2 globTest/a3} -catch {file attributes globTest/a1 -permissions 0755} +catch {file attributes globTest/a1 -permissions 0o755} test filename-15.4 {unix specific no complain: no errors, good result} \ {unix nonPortable} { # test fails because if an error occurs, the interp's result is reset... diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 361542d..0b53be5 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -4,14 +4,17 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 2002 Vincent Darley. +# Copyright © 2002 Vincent Darley. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 namespace eval ::tcl::test::fileSystem { - namespace import ::tcltest::* + + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } catch { file delete -force link.file @@ -22,19 +25,21 @@ namespace eval ::tcl::test::fileSystem { testConstraint loaddll 0 catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] + package require -exact tcl::test [info patchlevel] set ::ddever [package require dde] - set ::ddelib [lindex [package ifneeded dde $::ddever] 1] + set ::ddelib [info loaded {} Dde] set ::regver [package require registry] - set ::reglib [lindex [package ifneeded registry $::regver] 1] - testConstraint loaddll 1 + set ::reglib [info loaded {} Registry] + testConstraint loaddll [expr {$::ddelib ne "" && $::reglib ne ""}] } -# Test for commands defined in Tcltest executable +# Test for commands defined in tcl::test package testConstraint testfilesystem [llength [info commands ::testfilesystem]] testConstraint testsetplatform [llength [info commands ::testsetplatform]] testConstraint testsimplefilesystem [llength [info commands ::testsimplefilesystem]] -testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] +# Some things fail under all Continuous Integration systems for subtle reasons +# such as CI often running with elevated privileges in a container. +testConstraint notInCIenv [expr {![info exists ::env(CI)]}] cd [tcltest::temporaryDirectory] makeFile "test file" gorp.file @@ -162,7 +167,7 @@ test filesystem-1.12 {file new native path} {} { } } # If we reach here we've succeeded. We used to crash above. - expr 1 + expr {1} } {1} test filesystem-1.13 {file normalisation} {win} { # This used to be broken @@ -313,7 +318,7 @@ test filesystem-1.37 {file normalisation with '/./'} -body { } -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$} test filesystem-1.38 {file normalisation with volume relative} -setup { set dir [pwd] -} -constraints {win moreThanOneDrive knownMsvcBug} -body { +} -constraints {win moreThanOneDrive notInCIenv} -body { set path "[string range [lindex $drives 0] 0 1]foo" cd [lindex $drives 1] file norm $path @@ -562,7 +567,7 @@ test filesystem-7.1.1 {load from vfs} -setup { cd [file dirname $::ddelib] testsimplefilesystem 1 # This loads dde via a complex copy-to-temp operation - load simplefs:/[file tail $::ddelib] dde + load simplefs:/[file tail $::ddelib] Dde testsimplefilesystem 0 return ok # The real result of this test is what happens when Tcl exits. @@ -689,7 +694,7 @@ test filesystem-7.5 {cross-filesystem file copy with -force} -setup { # First copy should succeed set res [catch {file copy simplefs:/simplefile file2} err] lappend res $err - file attributes file2 -permissions 0000 + file attributes file2 -permissions 0 # Second copy should fail (no -force) lappend res [catch {file copy simplefs:/simplefile file2} err] lappend res $err diff --git a/tests/fileSystemEncoding.test b/tests/fileSystemEncoding.test index 0f8a2a7..c9d36d2 100644 --- a/tests/fileSystemEncoding.test +++ b/tests/fileSystemEncoding.test @@ -1,16 +1,19 @@ #! /usr/bin/env tclsh -# Copyright (c) 2019 Poor Yorick +# Copyright © 2019 Poor Yorick if {[string equal $::tcl_platform(os) "Windows NT"]} { return } namespace eval ::tcl::test::fileSystemEncoding { - package require tcltest 2 - namespace import ::tcltest::* - variable fname1 \u767b\u9e1b\u9d72\u6a13 + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* + } + + variable fname1 登鸛鵲樓 proc autopath {} { global auto_path diff --git a/tests/for-old.test b/tests/for-old.test index a11a791..f5d1de9 100644 --- a/tests/for-old.test +++ b/tests/for-old.test @@ -6,14 +6,14 @@ # into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -22,23 +22,23 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch {unset a i} test for-old-1.1 {for tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { + for {set i 1} {$i<6} {incr i} { set a [concat $a $i] } set a } {1 2 3 4 5} test for-old-1.2 {for tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 continue + for {set i 1} {$i<6} {incr i} { + if {$i==4} continue set a [concat $a $i] } set a } {1 2 3 5} test for-old-1.3 {for tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break + for {set i 1} {$i<6} {incr i} { + if {$i==4} break set a [concat $a $i] } set a @@ -55,12 +55,12 @@ test for-old-1.7 {for tests} { } {wrong # args: should be "for start test next command"} test for-old-1.8 {for tests} { set a {xyz} - for {set i 1} {$i<6} {set i [expr $i+1]} {} + for {set i 1} {$i<6} {incr i} {} set a } xyz test for-old-1.9 {for tests} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]; if $i==4 break} { + for {set i 1} {$i<6} {incr i; if {$i==4} break} { set a [concat $a $i] } set a diff --git a/tests/for.test b/tests/for.test index c8a8187..8284a09 100644 --- a/tests/for.test +++ b/tests/for.test @@ -4,13 +4,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright © 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -62,15 +62,15 @@ test for-1.8 {TclCompileForCmd: error compiling command body} -body { catch {unset a} test for-1.9 {TclCompileForCmd: simple command body} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break + for {set i 1} {$i<6} {incr i} { + if {$i==4} break set a [concat $a $i] } set a } {1 2 3} test for-1.10 {TclCompileForCmd: command body in quotes} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} "append a x" + for {set i 1} {$i<6} {incr i} "append a x" set a } {xxxxx} test for-1.11 {TclCompileForCmd: computed command body} { @@ -81,7 +81,7 @@ test for-1.11 {TclCompileForCmd: computed command body} { set bb {break} set x2 {; append a x2} set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 + for {set i 1} {$i<6} {incr i} $x1$bb$x2 set a } {x1} test for-1.12 {TclCompileForCmd: error in "next" command} -body { @@ -92,9 +92,9 @@ test for-1.12 {TclCompileForCmd: error in "next" command} -body { "set"*} test for-1.13 {TclCompileForCmd: long command body} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break - if $i>5 continue + for {set i 1} {$i<6} {incr i} { + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -129,7 +129,7 @@ test for-1.14 {TclCompileForCmd: for command result} { set a } {} test for-1.15 {TclCompileForCmd: for command result} { - set a [for {set i 0} {$i < 5} {incr i} {if $i==3 break}] + set a [for {set i 0} {$i < 5} {incr i} {if {$i==3} break}] set a } {} @@ -144,7 +144,7 @@ test for-2.2 {TclCompileContinueCmd: continue result} { } 4 test for-2.3 {continue tests} { set a {} - for {set i 1} {$i <= 4} {set i [expr $i+1]} { + for {set i 1} {$i <= 4} {incr i} { if {$i == 2} continue set a [concat $a $i] } @@ -152,7 +152,7 @@ test for-2.3 {continue tests} { } {1 3 4} test for-2.4 {continue tests} { set a {} - for {set i 1} {$i <= 4} {set i [expr $i+1]} { + for {set i 1} {$i <= 4} {incr i} { if {$i != 2} continue set a [concat $a $i] } @@ -170,10 +170,10 @@ test for-2.5 {continue tests, nested loops} { } {1.1 1.2 2.1 3.1 4.1} test for-2.6 {continue tests, long command body} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==2 continue - if $i==4 break - if $i>5 continue + for {set i 1} {$i<6} {incr i} { + if {$i==2} continue + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -246,10 +246,10 @@ test for-3.4 {break tests, nested loops} { } {1.1 1.2 2.1 3.1 4.1} test for-3.5 {break tests, long command body} { set a {} - for {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==2 continue - if $i==5 break - if $i>5 continue + for {set i 1} {$i<6} {incr i} { + if {$i==2} continue + if {$i==5} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -265,7 +265,7 @@ test for-3.5 {break tests, long command body} { catch {incr i 5} msg catch {incr i -5} msg } - if $i==4 break + if {$i==4} break if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -386,7 +386,7 @@ proc formatMail {} { continue } } - if $inheaders { + if {$inheaders} { set limit 55 } else { set limit 55 @@ -430,12 +430,12 @@ proc formatMail {} { continue } } - set climit [expr $limit-1] + set climit [expr {$limit-1}] set cutoff 50 set continuation 0 while {[string length $line] > $limit} { - for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} { + for {set c [expr {$limit-1}]} {$c >= $cutoff} {incr c -1} { set char [string index $line $c] if {$char == " " || $char == "\t"} { break @@ -446,7 +446,7 @@ proc formatMail {} { } if {$c < $cutoff} { if {! $inheaders} { - set c [expr $limit-1] + set c [expr {$limit-1}] } else { set c [string length $line] } @@ -585,7 +585,7 @@ Tcl/Tk Shop. Check it out! test for-4.1 {break must reset the interp result} { catch { set z GLOBTESTDIR/dir2/file2.c - if [string match GLOBTESTDIR/dir2/* $z] { + if {[string match GLOBTESTDIR/dir2/* $z]} { break } } j @@ -696,8 +696,8 @@ test for-6.9 {Tcl_ForObjCmd: error executing command body} -body { test for-6.10 {Tcl_ForObjCmd: simple command body} { set z for set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break + $z {set i 1} {$i<6} {incr i} { + if {$i==4} break set a [concat $a $i] } set a @@ -705,7 +705,7 @@ test for-6.10 {Tcl_ForObjCmd: simple command body} { test for-6.11 {Tcl_ForObjCmd: command body in quotes} { set z for set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} "append a x" + $z {set i 1} {$i<6} {incr i} "append a x" set a } {xxxxx} test for-6.12 {Tcl_ForObjCmd: computed command body} { @@ -717,7 +717,7 @@ test for-6.12 {Tcl_ForObjCmd: computed command body} { set bb {break} set x2 {; append a x2} set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 + $z {set i 1} {$i<6} {incr i} $x1$bb$x2 set a } {x1} test for-6.13 {Tcl_ForObjCmd: error in "next" command} -body { @@ -733,9 +733,9 @@ test for-6.13 {Tcl_ForObjCmd: error in "next" command} -body { test for-6.14 {Tcl_ForObjCmd: long command body} { set z for set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} { - if $i==4 break - if $i>5 continue + $z {set i 1} {$i<6} {incr i} { + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg diff --git a/tests/foreach.test b/tests/foreach.test index 84af4bd..4a1c35a 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -4,14 +4,14 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -165,7 +165,7 @@ test foreach-4.1 {noncompiled foreach and shared variable or value list objects catch {unset x} foreach {12.0} {a b c} { set x 12.0 - set x [expr $x + 1] + set x [expr {$x + 1}] } set x } 13.0 diff --git a/tests/format.test b/tests/format.test index 3640376..41918b2 100644 --- a/tests/format.test +++ b/tests/format.test @@ -4,14 +4,14 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1998 Sun Microsystems, Inc. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -20,7 +20,10 @@ testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] -testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] +# MSVC uses a broken libc that gets sprintf("%g") wrong. This is a pain +# particularly in Continuous Integration, and there isn't anything much we can +# do about it. +testConstraint knownMsvcBug [expr {![info exists ::env(CI_BUILD_WITH_MSVC)]}] test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 @@ -102,17 +105,17 @@ test format-2.4 {string formatting} { format "%s %s %% %c %s" abcd {This is a very long test string.} 120 x } {abcd This is a very long test string. % x x} test format-2.5 {string formatting, embedded nulls} { - format "%10s" abc\0def -} " abc\0def" + format "%10s" abc\x00def +} " abc\x00def" test format-2.6 {string formatting, international chars} { - format "%10s" abc\ufeffdef -} " abc\ufeffdef" + format "%10s" abc\uFEFFdef +} " abc\uFEFFdef" test format-2.7 {string formatting, international chars} { - format "%.5s" abc\ufeffdef -} "abc\ufeffd" + format "%.5s" abc\uFEFFdef +} "abc\uFEFFd" test format-2.8 {string formatting, international chars} { - format "foo\ufeffbar%s" baz -} "foo\ufeffbarbaz" + format "foo\uFEFFbar%s" baz +} "foo\uFEFFbarbaz" test format-2.9 {string formatting, width} { format "a%5sa" f } "a fa" @@ -140,13 +143,19 @@ test format-2.16 {string formatting, width and precision} { test format-2.17 {string formatting, width and precision} { format "a%5.7sa" foobarbaz } "afoobarba" +test format-2.18 {string formatting, surrogates} { + format "\uD83D%s" \uDE02 +} \uD83D\uDE02 +test format-2.19 {string formatting, surrogates} { + format "%s\uDE02" \uD83D +} \uD83D\uDE02 test format-3.1 {Tcl_FormatObjCmd: character formatting} { format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 65 65 65 65 65 65 3 65 -4 65 } "|A|A|A|A|A | A| A|A |" test format-3.2 {Tcl_FormatObjCmd: international character formatting} { - format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xa2 0x4e4e 0x25a 0xc3 0xff08 0 3 0x6575 -4 0x4e4f -} "|\ua2|\u4e4e|\u25a|\uc3|\uff08 | \0| \u6575|\u4e4f |" + format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 0xA2 0x4E4E 0x25A 0xC3 0xFF08 0 3 0x6575 -4 0x4E4F +} "|¢|乎|ɚ|Ã|（ | \x00| 敵|乏 |" test format-4.1 {e and f formats} {eformat} { format "%e %e %e %e" 34.2e12 68.514 -.125 -16000. .000053 @@ -378,20 +387,20 @@ test format-8.23 {error conditions} { # scripts, therefore they are not documented. It's intended use is through # the function Tcl_AppendPrintfToObj (et al). test format-8.24 {Undocumented formats} -body { - format "%zd %td %d" [expr 2**30] [expr 2**30] [expr 2**30] + format "%zd %td %d" [expr {2**30}] [expr {2**30}] [expr {2**30}] } -result {1073741824 1073741824 1073741824} test format-8.25 {Undocumented formats} -constraints pointerIs64bit -body { - format "%zd %td %lld" [expr 2**33] [expr 2**33] [expr 2**33] + format "%zd %td %lld" [expr {2**33}] [expr {2**33}] [expr {2**33}] } -result {8589934592 8589934592 8589934592} # Since "%p" is equivalent to "%#llx" in 64-bit platforms and equivalent # to "%#x" in 32-bit platforms, it are really not useful in scripts, # therefore they are not documented. It's intended use is through the # function Tcl_AppendPrintfToObj (et al). test format-8.26 {Undocumented formats} -body { - format "%p %#x" [expr 2**31] [expr 2**31] + format "%p %#x" [expr {2**31}] [expr {2**31}] } -result {0x80000000 0x80000000} test format-8.27 {Undocumented formats} -constraints pointerIs64bit -body { - format "%p %#llx" [expr 2**33] [expr 2**33] + format "%p %#llx" [expr {2**33}] [expr {2**33}] } -result {0x200000000 0x200000000} test format-9.1 {long result} { @@ -466,7 +475,7 @@ test format-13.1 {tcl_precision fuzzy comparison} { set a 0.0000000000001 set b 0.00000000000001 set c 0.00000000000000001 - set d [expr $a + $b + $c] + set d [expr {$a + $b + $c}] format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d } {0.0000000000 0.000000000000 0.000000000000110 0.00000000000011001} test format-13.2 {tcl_precision fuzzy comparison} { @@ -477,7 +486,7 @@ test format-13.2 {tcl_precision fuzzy comparison} { set a 0.000000000001 set b 0.000000000000005 set c 0.0000000000000008 - set d [expr $a + $b + $c] + set d [expr {$a + $b + $c}] format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d } {0.0000000000 0.000000000001 0.000000000001006 0.00000000000100580} test format-13.3 {tcl_precision fuzzy comparison} { @@ -486,7 +495,7 @@ test format-13.3 {tcl_precision fuzzy comparison} { catch {unset c} set a 0.00000000000099 set b 0.000000000000011 - set c [expr $a + $b] + set c [expr {$a + $b}] format {%0.10f %0.12f %0.15f %0.17f} $c $c $c $c } {0.0000000000 0.000000000001 0.000000000001001 0.00000000000100100} test format-13.4 {tcl_precision fuzzy comparison} { @@ -495,7 +504,7 @@ test format-13.4 {tcl_precision fuzzy comparison} { catch {unset c} set a 0.444444444444 set b 0.33333333333333 - set c [expr $a + $b] + set c [expr {$a + $b}] format {%0.10f %0.12f %0.15f %0.16f} $c $c $c $c } {0.7777777778 0.777777777777 0.777777777777330 0.7777777777773300} test format-13.5 {tcl_precision fuzzy comparison} { @@ -504,7 +513,7 @@ test format-13.5 {tcl_precision fuzzy comparison} { catch {unset c} set a 0.444444444444 set b 0.99999999999999 - set c [expr $a + $b] + set c [expr {$a + $b}] format {%0.10f %0.12f %0.15f} $c $c $c } {1.4444444444 1.444444444444 1.444444444443990} @@ -540,7 +549,7 @@ for {set i 0} {$i < 290} {incr i} { append b $a } for {set i 290} {$i < 400} {incr i} { - test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} { + test format-16.[expr {$i -289}] {testing MAX_FLOAT_SIZE} { format {%s} $b } $b append b "x" diff --git a/tests/get.test b/tests/get.test index e35b2cc..25f8d77 100644 --- a/tests/get.test +++ b/tests/get.test @@ -4,19 +4,19 @@ # file tclGet.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] testConstraint testdoubleobj [llength [info commands testdoubleobj]] @@ -109,6 +109,12 @@ test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj { set x } } {0.0 0.0 0.0 0.0 0.0 7.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0} +test get-3.5 {tcl_GetInt with numeric whitespace (i.e. '_')} testgetint { + lmap x {0_0 " 1_0" "0_2 " " 3_3 " 14__23__32___4 " 0x_a " 0b1111_1111 " 0_07 " " 0o_1_0 " " 0b_1_0 " " 0_b1_0 " _33 42_ 0_x15 0_o17 0_d19 } { + catch {testgetint $x} x + set x + } +} {0 10 2 33 1423324 10 255 7 8 2 {expected integer but got " 0_b1_0 "} {expected integer but got "_33"} {expected integer but got "42_"} {expected integer but got "0_x15"} {expected integer but got "0_o17"} {expected integer but got "0_d19"}} # cleanup ::tcltest::cleanupTests diff --git a/tests/history.test b/tests/history.test index 9ff41f2..557c856 100644 --- a/tests/history.test +++ b/tests/history.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -40,7 +40,7 @@ test history-1.1 {event option} history {history event -1} \ {set b [format {A test %s} string]} test history-1.2 {event option} history {history event $num} \ {set a 12345} -test history-1.3 {event option} history {history event [expr $num+2]} \ +test history-1.3 {event option} history {history event [expr {$num+2}]} \ {Another test} test history-1.4 {event option} history {history event set} \ {set b [format {A test %s} string]} @@ -149,11 +149,11 @@ test history-5.1 {info option} history {history info} [format {%6d set a {b %6d set b 1234 %6d set c {a b - c}} $num [expr $num+1] [expr $num+2]] + c}} $num [expr {$num+1}] [expr {$num+2}]] test history-5.2 {info option} history {history i 2} [format {%6d set b 1234 %6d set c {a b - c}} [expr $num+1] [expr $num+2]] + c}} [expr {$num+1}] [expr {$num+2}]] test history-5.3 {info option} history {catch {history i 2 3}} 1 test history-5.4 {info option} history { catch {history i 2 3} msg @@ -164,7 +164,7 @@ test history-5.5 {info option} history {history} [format {%6d set a {b %6d set b 1234 %6d set c {a b - c}} $num [expr $num+1] [expr $num+2]] + c}} $num [expr {$num+1}] [expr {$num+2}]] # "history keep" @@ -174,7 +174,9 @@ if {[testConstraint history]} { history add "foo3" history keep 2 } -test history-6.1 {keep option} history {history event [expr [history n]-1]} foo3 +test history-6.1 {keep option} history { + history event [expr {[history n]-1}] +} foo3 test history-6.2 {keep option} history {history event -1} foo2 test history-6.3 {keep option} history {catch {history event -3}} 1 test history-6.4 {keep option} history { @@ -216,7 +218,7 @@ if {[testConstraint history]} { history add "Testing2" } test history-7.1 {nextid option} history {history event} "Testing" -test history-7.2 {nextid option} history {history next} [expr $num+2] +test history-7.2 {nextid option} history {history next} [expr {$num+2}] test history-7.3 {nextid option} history {catch {history nextid garbage}} 1 test history-7.4 {nextid option} history { catch {history nextid garbage} msg @@ -262,7 +264,7 @@ test history-10.1 {references kept by history} -constraints history -setup { } -body { histtest eval { # A fresh object, refcount 1 from the variable we write it to - set obj [expr rand()] + set obj [expr {rand()}] set baseline [refcount $obj] lappend result [refcount $obj] history add [list list $obj] @@ -288,7 +290,7 @@ test history-10.2 {references kept by history} -constraints history -setup { } -body { histtest eval { # A fresh object, refcount 1 from the variable we write it to - set obj [expr rand()] + set obj [expr {rand()}] set baseline [refcount $obj] lappend result [refcount $obj] history add [list list $obj] diff --git a/tests/http.test b/tests/http.test index 8eac3c3..2fd5af4 100644 --- a/tests/http.test +++ b/tests/http.test @@ -4,22 +4,24 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} if {[catch {package require http 2} version]} { if {[info exists http2]} { catch {puts "Cannot load http 2.* package"} return } else { - catch {puts "Running http 2.* tests in slave interp"} + catch {puts "Running http 2.* tests in child interp"} set interp [interp create http2] $interp eval [list set http2 "running"] $interp eval [list set argv $argv] @@ -36,14 +38,11 @@ proc bgerror {args} { puts stderr $errorInfo } -if {$::tcl_platform(os) eq "Darwin"} { - # Name resolution often a problem on OSX; not focus of HTTP package anyway - set HOST localhost -} else { - set HOST [info hostname] -} - -set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" +# Do not use [info hostname]. +# Name resolution is often a problem on OSX; not focus of HTTP package anyway. +# Also a problem on other platforms for http-4.14 (test with bad port number). +set HOST localhost +set bindata "This is binary data\x0D\x0Amore\x0Dmore\x0Amore\x00null" catch {unset data} # Ensure httpd file exists @@ -122,7 +121,7 @@ test http-3.2 {http::geturl} -returnCodes error -body { http::geturl http:junk } -result {Unsupported URL: http:junk} set url //${::HOST}:$port -set badurl //${::HOST}:[expr $port+1] +set badurl //${::HOST}:[expr {$port+1}] test http-3.3 {http::geturl} -body { set token [http::geturl $url] http::data $token @@ -442,6 +441,9 @@ test http-3.33 {http::geturl application/xml is text} -body { } -cleanup { catch { http::cleanup $token } } -result {test 4660 /test} +test http-3.34 {http::geturl -headers not a dict} -returnCodes error -body { + http::geturl http://test/t -headers NoDict +} -result {Bad value for -headers (NoDict), must be dict} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] @@ -618,12 +620,12 @@ test http-5.3 {http::formatQuery} { http::formatQuery lines "line1\nline2\nline3" } {lines=line1%0D%0Aline2%0D%0Aline3} test http-5.4 {http::formatQuery} { - http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 + http::formatQuery name1 ~bwelch name2 ¡¢¢ } {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] + set res [http::formatQuery name1 ~bwelch name2 ¡¢¢] http::config -urlencoding $enc set res } {name1=~bwelch&name2=%A1%A2%A2} @@ -648,24 +650,24 @@ test http-7.1 {http::mapReply} { 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" + http::mapReply "∈" } {%E2%88%88} test http-7.3 {http::formatQuery} -setup { set enc [http::config -urlencoding] } -returnCodes error -body { # this would be reverting to http <=2.4 behavior http::config -urlencoding "" - http::mapReply "\u2208" + http::mapReply "∈" } -cleanup { http::config -urlencoding $enc -} -result "can't read \"formMap(\u2208)\": no such element in array" +} -result "can't read \"formMap(∈)\": no such element in array" test http-7.4 {http::formatQuery} -setup { set enc [http::config -urlencoding] } -body { # this would be reverting to http <=2.4 behavior w/o errors # (unknown chars become '?') http::config -urlencoding "iso8859-1" - http::mapReply "\u2208" + http::mapReply "∈" } -cleanup { http::config -urlencoding $enc } -result {%3F} @@ -713,37 +715,37 @@ test http-idna-2.1 {puny encode: functional test} { ::tcl::idna puny encode abc } abc- test http-idna-2.2 {puny encode: functional test} { - ::tcl::idna puny encode a\u20acb\u20acc + ::tcl::idna puny encode a€b€c } abc-k50ab test http-idna-2.3 {puny encode: functional test} { ::tcl::idna puny encode ABC } ABC- test http-idna-2.4 {puny encode: functional test} { - ::tcl::idna puny encode A\u20ACB\u20ACC + ::tcl::idna puny encode A€B€C } ABC-k50ab test http-idna-2.5 {puny encode: functional test} { ::tcl::idna puny encode ABC 0 } abc- test http-idna-2.6 {puny encode: functional test} { - ::tcl::idna puny encode A\u20ACB\u20ACC 0 + ::tcl::idna puny encode A€B€C 0 } abc-k50ab test http-idna-2.7 {puny encode: functional test} { ::tcl::idna puny encode ABC 1 } ABC- test http-idna-2.8 {puny encode: functional test} { - ::tcl::idna puny encode A\u20ACB\u20ACC 1 + ::tcl::idna puny encode A€B€C 1 } ABC-k50ab test http-idna-2.9 {puny encode: functional test} { ::tcl::idna puny encode abc 0 } abc- test http-idna-2.10 {puny encode: functional test} { - ::tcl::idna puny encode a\u20ACb\u20ACc 0 + ::tcl::idna puny encode a€b€c 0 } abc-k50ab test http-idna-2.11 {puny encode: functional test} { ::tcl::idna puny encode abc 1 } ABC- test http-idna-2.12 {puny encode: functional test} { - ::tcl::idna puny encode a\u20ACb\u20ACc 1 + ::tcl::idna puny encode a€b€c 1 } ABC-k50ab test http-idna-2.13 {puny encode: edge cases} { ::tcl::idna puny encode "" @@ -873,43 +875,43 @@ test http-idna-3.1 {puny decode: functional test} { } abc test http-idna-3.2 {puny decode: functional test} { ::tcl::idna puny decode abc-k50ab -} a\u20acb\u20acc +} a€b€c test http-idna-3.3 {puny decode: functional test} { ::tcl::idna puny decode ABC- } ABC test http-idna-3.4 {puny decode: functional test} { ::tcl::idna puny decode ABC-k50ab -} A\u20ACB\u20ACC +} A€B€C test http-idna-3.5 {puny decode: functional test} { ::tcl::idna puny decode ABC-K50AB -} A\u20ACB\u20ACC +} A€B€C test http-idna-3.6 {puny decode: functional test} { ::tcl::idna puny decode abc-K50AB -} a\u20ACb\u20ACc +} a€b€c test http-idna-3.7 {puny decode: functional test} { ::tcl::idna puny decode ABC- 0 } abc test http-idna-3.8 {puny decode: functional test} { ::tcl::idna puny decode ABC-K50AB 0 -} a\u20ACb\u20ACc +} a€b€c test http-idna-3.9 {puny decode: functional test} { ::tcl::idna puny decode ABC- 1 } ABC test http-idna-3.10 {puny decode: functional test} { ::tcl::idna puny decode ABC-K50AB 1 -} A\u20ACB\u20ACC +} A€B€C test http-idna-3.11 {puny decode: functional test} { ::tcl::idna puny decode abc- 0 } abc test http-idna-3.12 {puny decode: functional test} { ::tcl::idna puny decode abc-k50ab 0 -} a\u20ACb\u20ACc +} a€b€c test http-idna-3.13 {puny decode: functional test} { ::tcl::idna puny decode abc- 1 } ABC test http-idna-3.14 {puny decode: functional test} { ::tcl::idna puny decode abc-k50ab 1 -} A\u20ACB\u20ACC +} A€B€C test http-idna-3.15 {puny decode: edge cases and errors} { # Is this case actually correct? binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]] @@ -1043,16 +1045,16 @@ test http-idna-4.1 {IDNA encoding} { ::tcl::idna encode abc.def } abc.def test http-idna-4.2 {IDNA encoding} { - ::tcl::idna encode a\u20acb\u20acc.def + ::tcl::idna encode a€b€c.def } xn--abc-k50ab.def test http-idna-4.3 {IDNA encoding} { - ::tcl::idna encode def.a\u20acb\u20acc + ::tcl::idna encode def.a€b€c } def.xn--abc-k50ab test http-idna-4.4 {IDNA encoding} { ::tcl::idna encode ABC.DEF } ABC.DEF test http-idna-4.5 {IDNA encoding} { - ::tcl::idna encode A\u20acB\u20acC.def + ::tcl::idna encode A€B€C.def } xn--ABC-k50ab.def test http-idna-4.6 {IDNA encoding: invalid edge case} { # Should this be an error? @@ -1082,7 +1084,7 @@ test http-idna-4.9.1 {IDNA encoding: max lengths from RFC 5890} { } {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c} unset overlong test http-idna-4.10 {IDNA encoding: edge cases} { - ::tcl::idna encode pass\u00e9.example.com + ::tcl::idna encode passé.example.com } xn--pass-epa.example.com test http-idna-5.1 {IDNA decoding} { diff --git a/tests/http11.test b/tests/http11.test index 1e30802..f243e56 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -7,17 +7,19 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} -package require http 2.8 +package require http 2.9 # start the server variable httpd_output proc create_httpd {} { proc httpd_read {chan} { variable httpd_output - if {[gets $chan line] != -1} { + if {[gets $chan line] >= 0} { #puts stderr "read '$line'" set httpd_output $line } @@ -60,6 +62,20 @@ proc meta {tok {key ""}} { return $meta } +proc state {tok {key ""}} { + upvar 1 $tok state + if {$key ne ""} { + if {[array names state -exact $key] ne {}} { + return $state($key) + } else { + return "" + } + } + set res [array get state] + dict set res body <elided> + return $res +} + proc check_crc {tok args} { set crc [meta $tok x-crc32] set data [expr {[llength $args] ? [lindex $args 0] : [http::data $tok]}] @@ -241,8 +257,45 @@ test http11-1.12 "normal,identity,chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} chunked} +test http11-1.13 "normal, 1.1 and keepalive as server default, no zip" -setup { + variable httpd [create_httpd] + set zipTmp [http::config -zip] + http::config -zip 0 +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?transfer= \ + -protocol 1.1 -keepalive 1 -timeout 10000] + http::wait $tok + set res1 [list [http::status $tok] [http::code $tok] [check_crc $tok] \ + [meta $tok connection] [meta $tok transfer-encoding] [state $tok reusing] [state $tok connection]] + set toj [http::geturl http://localhost:$httpd_port/testdoc.html?transfer= \ + -protocol 1.1 -keepalive 1 -timeout 10000] + http::wait $toj + set res2 [list [http::status $toj] [http::code $toj] [check_crc $toj] \ + [meta $toj connection] [meta $toj transfer-encoding] [state $toj reusing] [state $toj connection]] + concat $res1 -- $res2 +} -cleanup { + http::cleanup $tok + http::cleanup $toj + halt_httpd + http::config -zip $zipTmp +} -result {ok {HTTP/1.1 200 OK} ok {} {} 0 keep-alive -- ok {HTTP/1.1 200 OK} ok {} {} 1 keep-alive} + # ------------------------------------------------------------------------- +proc progress {var token total current} { + upvar #0 $var log + set log [list $current $total] + return +} + +proc progressPause {var token total current} { + upvar #0 $var log + set log [list $current $total] + after 100 set ::WaitHere 0 + vwait ::WaitHere + return +} + test http11-2.0 "-channel" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] @@ -339,6 +392,58 @@ test http11-2.4 "-channel,encoding identity" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} chunked} +test http11-2.4.1 "-channel,encoding identity with -progress" -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -timeout 5000 -channel $chan \ + -headers {accept-encoding identity} \ + -progress [namespace code [list progress logdata]]] + + http::wait $tok + seek $chan 0 + set data [read $chan] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $data]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd + unset -nocomplain logdata data +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} + +test http11-2.4.2 "-channel,encoding identity with -progress progressPause enters event loop" -constraints knownBug -setup { + variable httpd [create_httpd] + set chan [open [makeFile {} testfile.tmp] wb+] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ + -timeout 5000 -channel $chan \ + -headers {accept-encoding identity} \ + -progress [namespace code [list progressPause logdata]]] + + http::wait $tok + seek $chan 0 + set data [read $chan] + list [http::status $tok] [http::code $tok] [check_crc $tok $data]\ + [meta $tok connection] [meta $tok content-encoding]\ + [meta $tok transfer-encoding] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $data]}] +} -cleanup { + http::cleanup $tok + close $chan + removeFile testfile.tmp + halt_httpd + unset -nocomplain logdata data ::WaitHere +} -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} + test http11-2.5 "-channel,encoding unsupported" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] @@ -518,6 +623,16 @@ proc handler {var sock token} { return [string length $chunk] } +proc handlerPause {var sock token} { + upvar #0 $var data + set chunk [read $sock] + append data $chunk + #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])" + after 100 set ::WaitHere 0 + vwait ::WaitHere + return [string length $chunk] +} + test http11-3.0 "-handler,close,identity" -setup { variable httpd [create_httpd] set testdata "" @@ -589,6 +704,135 @@ test http11-3.3 "-handler,keepalive,chunked" -setup { halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} +# http11-3.4 +# This test is a blatant attempt to confuse the client by instructing the server +# to send neither "Connection: close" nor "Content-Length" when in non-chunked +# mode. +# The client has no way to know the response-body is complete unless the +# server signals this by closing the connection. +# In an HTTP/1.1 response the absence of "Connection: close" means +# "Connection: keep-alive", i.e. the server will keep the connection +# open. In HTTP/1.0 this is not the case, and this is a test that +# the Tcl client assumes "Connection: close" by default in HTTP/1.0. +test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup { + variable httpd [create_httpd] + set testdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&nosendclose=any \ + -timeout 10000 -handler [namespace code [list handler testdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok {} {} {} 0} + +# It is not forbidden for a handler to enter the event loop. +test http11-3.5 "-handler,close,identity as http11-3.0 but handlerPause enters event loop" -setup { + variable httpd [create_httpd] + set testdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handlerPause testdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} + +test http11-3.6 "-handler,close,identity as http11-3.0 but with -progress" -setup { + variable httpd [create_httpd] + set testdata "" + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handler testdata]] \ + -progress [namespace code [list progress logdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} + +test http11-3.7 "-handler,close,identity as http11-3.0 but with -progress progressPause enters event loop" -setup { + variable httpd [create_httpd] + set testdata "" + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 -handler [namespace code [list handler testdata]] \ + -progress [namespace code [list progressPause logdata]]] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok $testdata]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length $testdata]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length $testdata]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain testdata logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} + +test http11-3.8 "close,identity no -handler but with -progress" -setup { + variable httpd [create_httpd] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 \ + -progress [namespace code [list progress logdata]] \ + -headers {accept-encoding {}}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length [http::data $tok]]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} + +test http11-3.9 "close,identity no -handler but with -progress progressPause enters event loop" -setup { + variable httpd [create_httpd] + set logdata "" +} -body { + set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ + -timeout 10000 \ + -progress [namespace code [list progressPause logdata]] \ + -headers {accept-encoding {}}] + http::wait $tok + list [http::status $tok] [http::code $tok] [check_crc $tok]\ + [meta $tok connection] [meta $tok content-encoding] \ + [meta $tok transfer-encoding] \ + [expr {[file size testdoc.html]-[string length [http::data $tok]]}] \ + [expr {[lindex $logdata 0] - [lindex $logdata 1]}] \ + [expr {[lindex $logdata 0] - [string length [http::data $tok]]}] +} -cleanup { + http::cleanup $tok + unset -nocomplain logdata ::WaitHere + halt_httpd +} -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} + test http11-4.0 "normal post request" -setup { variable httpd [create_httpd] } -body { diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index 8de79b9..4306149 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -8,10 +8,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} -package require http 2.8 +package require http 2.9 set sourcedir [file normalize [file dirname [info script]]] source [file join $sourcedir httpTest.tcl] diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl index 4345845..8a96d95 100644 --- a/tests/httpTest.tcl +++ b/tests/httpTest.tcl @@ -60,7 +60,7 @@ proc http::Log {args} { variable TestStartTimeInMs set time [expr {[clock milliseconds] - $TestStartTimeInMs}] set txt [list $time {*}$args] - if {[string first ^ $txt] != -1} { + if {[string first ^ $txt] >= 0} { ::httpTest::LogRecord $txt ::httpTest::Puts $txt } elseif {$::httpTest::testOptions(-verbose) > 1} { @@ -86,7 +86,7 @@ proc httpTest::LogRecord {txt} { puts stdout "Fix this call to Log in http-*.tm so it has ^ then\ a letter then a numeral." flush stdout - } elseif {$pos == -1} { + } elseif {$pos < 0} { # Called by mistake. } else { set letter [string index $txt [incr pos]] @@ -153,7 +153,7 @@ proc httpTest::TestOverlaps {someResults n term msg badTrans notPiped} { set myStart [lsearch -exact $someResults [list B $i]] set myEnd [lsearch -exact $someResults [list $term $i]] - if {($myStart == -1 || $myEnd == -1)} { + if {($myStart < 0 || $myEnd < 0)} { set res "Cannot find positions of transaction $i" append msg $res \n Puts $res @@ -374,7 +374,7 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip variable testOptions set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}] - if {$nextRetry == -1} { + if {$nextRetry < 0} { return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped] } set badTrans $notIncluded @@ -391,7 +391,7 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip for {set i 1} {$i <= $n} {incr i} { set first [lsearch -exact $beforeTry [list A $i]] set last [lsearch -exact $beforeTry [list F $i]] - if {$first == -1} { + if {$first < 0} { set res "Transaction $i was not started in connection number $tryCount" # So lappend it to badTrans and don't include it in the call below of MostAnalysis. # append msg $res \n @@ -400,7 +400,7 @@ proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPip lappend badTrans $i } else { } - } elseif {$last == -1} { + } elseif {$last < 0} { set res "Transaction $i was started but unfinished in connection number $tryCount" # So lappend it to badTrans and don't include it in the call below of MostAnalysis. # append msg $res \n diff --git a/tests/httpcookie.test b/tests/httpcookie.test index b3c5412..329330d 100644 --- a/tests/httpcookie.test +++ b/tests/httpcookie.test @@ -4,21 +4,20 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2014 Donal K. Fellows. +# Copyright © 2014 Donal K. Fellows. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands -testConstraint notOSXtravis [apply {{} { - upvar 1 env(TRAVIS_OSX_IMAGE) travis - return [expr {![info exists travis] || ![string match xcode* $travis]}] -}}] -testConstraint sqlite3 [expr {[testConstraint notOSXtravis] && ![catch { +testConstraint notMacCI [expr {![info exists ::env(MAC_CI)]}] +testConstraint sqlite3 [expr {[testConstraint notMacCI] && ![catch { package require sqlite3 }]}] testConstraint cookiejar [expr {[testConstraint sqlite3] && ![catch { diff --git a/tests/httpd b/tests/httpd index 982f3b8..43e9372 100644 --- a/tests/httpd +++ b/tests/httpd @@ -2,20 +2,18 @@ # # The httpd_ procedures implement a stub http server. # -# Copyright (c) 1997-1998 Sun Microsystems, Inc. -# Copyright (c) 1999-2000 Scriptics Corporation +# Copyright © 1997-1998 Sun Microsystems, Inc. +# Copyright © 1999-2000 Scriptics Corporation # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. #set httpLog 1 -if {$::tcl_platform(os) eq "Darwin"} { - # Name resolution often a problem on OSX; not focus of HTTP package anyway - set HOST localhost -} else { - set HOST [info hostname] -} +# Do not use [info hostname]. +# Name resolution is often a problem on OSX; not focus of HTTP package anyway. +# Also a problem on other platforms for http-4.14 (test with bad port number). +set HOST localhost proc httpd_init {{port 8015}} { set s [socket -server httpdAccept $port] diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index 7880494..c7dde43 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.6- +package require tcl proc ::tcl::dict::get? {dict key} { if {[dict exists $dict $key]} { @@ -170,14 +170,19 @@ proc Service {chan addr port} { set close 1 } + set nosendclose 0 foreach pair [split $query &] { if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""} switch -exact -- $key { + nosendclose {set nosendclose 1} close {set close 1 ; set transfer 0} transfer {set transfer $val} content-type {set type $val} } } + if {$protocol eq "HTTP/1.1"} { + set nosendclose 0 + } chan configure $chan -buffering line -encoding iso8859-1 -translation crlf Puts $chan "$protocol $code" @@ -186,12 +191,16 @@ proc Service {chan addr port} { if {$req eq "POST"} { Puts $chan [format "x-query-length: %d" [string length $query]] } - if {$close} { + if {$close && (!$nosendclose)} { Puts $chan "connection: close" } Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]" - if {$encoding eq "identity"} { + if {$encoding eq "identity" && (!$nosendclose)} { Puts $chan "content-length: [string length $data]" + } elseif {$encoding eq "identity"} { + # This is a blatant attempt to confuse the client by sending neither + # "Connection: close" nor "Content-Length" when in non-chunked mode. + # See test http11-3.4. } else { Puts $chan "content-encoding: $encoding" } @@ -228,7 +237,7 @@ proc Accept {chan addr port} { } proc Control {chan} { - if {[gets $chan line] != -1} { + if {[gets $chan line] >= 0} { if {[string trim $line] eq "quit"} { set ::forever 1 } diff --git a/tests/if-old.test b/tests/if-old.test index fbcf56c..378c8a6 100644 --- a/tests/if-old.test +++ b/tests/if-old.test @@ -6,15 +6,15 @@ # into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/if.test b/tests/if.test index 040364a..c5babdd 100644 --- a/tests/if.test +++ b/tests/if.test @@ -4,14 +4,14 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -142,7 +142,7 @@ test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 @@ -165,7 +165,7 @@ test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 @@ -239,7 +239,7 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 @@ -262,7 +262,7 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 @@ -287,7 +287,7 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 5 @@ -310,7 +310,7 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 6 @@ -389,7 +389,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 @@ -412,7 +412,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 @@ -437,7 +437,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 5 @@ -460,7 +460,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 6 @@ -485,7 +485,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 8 @@ -508,7 +508,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 9 @@ -713,7 +713,7 @@ test if-5.16 {if cmd with computed command names: test jumpFalse instruction rep set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 @@ -736,7 +736,7 @@ test if-5.16 {if cmd with computed command names: test jumpFalse instruction rep set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 @@ -816,7 +816,7 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 @@ -839,7 +839,7 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 @@ -864,7 +864,7 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 5 @@ -887,7 +887,7 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 6 @@ -975,7 +975,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 2 @@ -998,7 +998,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 3 @@ -1023,7 +1023,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 5 @@ -1046,7 +1046,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 6 @@ -1071,7 +1071,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 8 @@ -1094,7 +1094,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + incr i -1 } } set a 9 diff --git a/tests/incr-old.test b/tests/incr-old.test index ed457cf..818bccc 100644 --- a/tests/incr-old.test +++ b/tests/incr-old.test @@ -6,15 +6,15 @@ # into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/incr.test b/tests/incr.test index aa2872a..04c3652 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -4,14 +4,14 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/indexObj.test b/tests/indexObj.test index 126d062..bd6a2c2 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -2,19 +2,19 @@ # tkIndexObj.c, which implement indexed table lookups. The tests here are # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testindexobj [llength [info commands testindexobj]] testConstraint testparseargs [llength [info commands testparseargs]] diff --git a/tests/info.test b/tests/info.test index ce51523..d9a4f54 100644 --- a/tests/info.test +++ b/tests/info.test @@ -5,10 +5,10 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2006 ActiveState +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2006 ActiveState # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -16,11 +16,11 @@ # DO NOT DELETE THIS LINE if {{::tcltest} ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint zlib [llength [info commands zlib]] # Set up namespaces needed to test operation of "info args", "info body", @@ -325,7 +325,7 @@ test info-9.2 {info level option} { } {1 {t1 146 testString}} test info-9.3 {info level option} { proc t1 {a b} { - t2 [expr $a*2] $b + t2 [expr {$a*2}] $b } proc t2 {x y} { list [info level] [info level 1] [info level 2] [info level -1] \ @@ -657,7 +657,7 @@ test info-19.6 {info vars: Bug 1072654} -setup { set functions {abs acos asin atan atan2 bool ceil cos cosh double entier exp floor fmod hypot int isfinite isinf isnan isnormal isqrt issubnormal isunordered log log10 max min pow rand round sin sinh sqrt srand tan tanh wide} # Check whether the extra testing functions are defined... -if {!([catch {expr T1()} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"}))} { +if {!([catch {expr {T1()}} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"}))} { set functions "T1 T2 T3 $functions" ;# A lazy way of prepending! } test info-20.1 {info functions option} {info functions sin} sin @@ -2447,16 +2447,16 @@ test info-40.9 {info cmdtype: imports} -setup { rename ::testinfocmdtype::bar {} namespace delete ::testinfocmdtype::foo } -result import -test info-40.10 {info cmdtype: slaves} -setup { +test info-40.10 {info cmdtype: interps} -setup { apply {i { - rename $i ::testinfocmdtype::slave - variable ::testinfocmdtype::slave $i + rename $i ::testinfocmdtype::child + variable ::testinfocmdtype::child $i }} [interp create] } -body { - info cmdtype ::testinfocmdtype::slave + info cmdtype ::testinfocmdtype::child } -cleanup { - interp delete $::testinfocmdtype::slave -} -result slave + interp delete $::testinfocmdtype::child +} -result interp test info-40.11 {info cmdtype: objects} -setup { apply {{} { oo::object create obj @@ -2518,7 +2518,7 @@ test info-40.16 {info cmdtype: dynamic behavior} -setup { catch {rename bar {}} } } -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0} -test info-40.17 {info cmdtype: aliases in slave interpreters} -setup { +test info-40.17 {info cmdtype: aliases in child interpreters} -setup { set i [interp create] } -body { $i alias foo gorp @@ -2528,7 +2528,7 @@ test info-40.17 {info cmdtype: aliases in slave interpreters} -setup { } -cleanup { interp delete $i } -result alias -test info-40.18 {info cmdtype: aliases in slave interpreters} -setup { +test info-40.18 {info cmdtype: aliases in child interpreters} -setup { set safe [interp create -safe] } -body { $safe alias foo gorp @@ -2538,7 +2538,7 @@ test info-40.18 {info cmdtype: aliases in slave interpreters} -setup { } -returnCodes error -cleanup { interp delete $safe } -result {not allowed to invoke subcommand cmdtype of info} -test info-40.19 {info cmdtype: aliases in slave interpreters} -setup { +test info-40.19 {info cmdtype: aliases in child interpreters} -setup { set safe [interp create -safe] } -body { set inner [interp create [list $safe bar]] @@ -2551,7 +2551,7 @@ test info-40.19 {info cmdtype: aliases in slave interpreters} -setup { } -returnCodes error -cleanup { interp delete $safe } -result {not allowed to invoke subcommand cmdtype of info} -test info-40.20 {info cmdtype: aliases in slave interpreters} -setup { +test info-40.20 {info cmdtype: aliases in child interpreters} -setup { set safe [interp create -safe] } -body { $safe eval { diff --git a/tests/init.test b/tests/init.test index a241c0b..4acad3d 100644 --- a/tests/init.test +++ b/tests/init.test @@ -4,14 +4,14 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.3.4 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -19,16 +19,16 @@ if {"::tcltest" ni [namespace children]} { catch {namespace delete {*}[namespace children :: test_ns_*]} test init-0.1 {no error on initialization phase (init.tcl)} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { list [set v [info exists ::errorInfo]] \ [if {$v} {set ::errorInfo}] \ [set v [info exists ::errorCode]] \ [if {$v} {set ::errorCode}] } } -cleanup { - interp delete slave + interp delete child } -result {0 {} 0 {}} # Six cases - white box testing @@ -59,11 +59,11 @@ test init-1.8 {auto_qualify - multiple colons 2} { auto_qualify :::foo ::bar } foo -# We use a sub-interp and auto_reset and double the tests because there is 2 +# We use a child interp and auto_reset and double the tests because there is 2 # places where auto_loading occur (before loading the indexes files and after) set testInterp [interp create] -tcltest::loadIntoSlaveInterpreter $testInterp {*}$argv +tcltest::loadIntoChildInterpreter $testInterp {*}$argv interp eval $testInterp { namespace import -force ::tcltest::* customMatch pairwise {apply {{mode pair} { @@ -155,7 +155,7 @@ foreach arg [subst -nocommands -novariables { 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, €, 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]} -setup { diff --git a/tests/internals.tcl b/tests/internals.tcl index e859afe..ff6c42b 100644 --- a/tests/internals.tcl +++ b/tests/internals.tcl @@ -4,7 +4,7 @@ # # source [file join [file dirname [info script]] internals.tcl] # -# Copyright (c) 2020 Sergey G. Brester (sebres). +# Copyright © 2020 Sergey G. Brester (sebres). # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/tests/interp.test b/tests/interp.test index 599ac08..385d3e2 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -4,25 +4,25 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } @@ -32,7 +32,7 @@ test interp-1.1 {options for interp command} -returnCodes error -body { } -result {wrong # args: should be "interp cmd ?arg ...?"} test interp-1.2 {options for interp command} -returnCodes error -body { interp frobox -} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} test interp-1.3 {options for interp command} { interp delete } "" @@ -46,17 +46,17 @@ test interp-1.5 {options for interp command} -returnCodes error -body { # test interp-0.6 was removed # test interp-1.6 {options for interp command} -returnCodes error -body { - interp slaves foo bar zop -} -result {wrong # args: should be "interp slaves ?path?"} + interp children foo bar zop +} -result {wrong # args: should be "interp children ?path?"} test interp-1.7 {options for interp command} -returnCodes error -body { interp hello -} -result {bad option "hello": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} test interp-1.8 {options for interp command} -returnCodes error -body { interp -froboz -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} test interp-1.9 {options for interp command} -returnCodes error -body { interp -froboz -safe -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} test interp-1.10 {options for interp command} -returnCodes error -body { interp target } -result {wrong # args: should be "interp target path alias"} @@ -105,7 +105,7 @@ test interp-2.11 {anonymous interps vs existing procs} { proc interp$thenum {} {} set x [interp create] regexp "interp(\[0-9]+)" $x dummy anothernum - expr $anothernum > $thenum + expr {$anothernum > $thenum} } 1 test interp-2.12 {anonymous interps vs existing procs} { set x [interp create -safe] @@ -114,51 +114,51 @@ test interp-2.12 {anonymous interps vs existing procs} { proc interp$thenum {} {} set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy anothernum - expr $anothernum - $thenum + expr {$anothernum - $thenum} } 1 test interp-2.13 {correct default when no $path arg is given} -body { interp create -- } -match regexp -result {interp[0-9]+} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } -# Part 2: Testing "interp slaves" and "interp exists" -test interp-3.1 {testing interp exists and interp slaves} { - interp slaves +# Part 2: Testing "interp children" and "interp exists" +test interp-3.1 {testing interp exists and interp children} { + interp children } "" -test interp-3.2 {testing interp exists and interp slaves} { +test interp-3.2 {testing interp exists and interp children} { interp create a interp exists a } 1 -test interp-3.3 {testing interp exists and interp slaves} { +test interp-3.3 {testing interp exists and interp children} { interp exists nonexistent } 0 -test interp-3.4 {testing interp exists and interp slaves} -body { - interp slaves a b c -} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} -test interp-3.5 {testing interp exists and interp slaves} -body { +test interp-3.4 {testing interp exists and interp children} -body { + interp children a b c +} -returnCodes error -result {wrong # args: should be "interp children ?path?"} +test interp-3.5 {testing interp exists and interp children} -body { interp exists a b c } -returnCodes error -result {wrong # args: should be "interp exists ?path?"} -test interp-3.6 {testing interp exists and interp slaves} { +test interp-3.6 {testing interp exists and interp children} { interp exists } 1 -test interp-3.7 {testing interp exists and interp slaves} -setup { +test interp-3.7 {testing interp exists and interp children} -setup { catch {interp create a} } -body { - interp slaves + interp children } -result a -test interp-3.8 {testing interp exists and interp slaves} -body { - interp slaves a b c -} -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} -test interp-3.9 {testing interp exists and interp slaves} -setup { +test interp-3.8 {testing interp exists and interp children} -body { + interp children a b c +} -returnCodes error -result {wrong # args: should be "interp children ?path?"} +test interp-3.9 {testing interp exists and interp children} -setup { catch {interp create a} } -body { interp create {a a2} -safe - expr {"a2" in [interp slaves a]} + expr {"a2" in [interp children a]} } -result 1 -test interp-3.10 {testing interp exists and interp slaves} -setup { +test interp-3.10 {testing interp exists and interp children} -setup { catch {interp create a} catch {interp create {a a2}} } -body { @@ -186,7 +186,7 @@ test interp-4.5 {testing interp delete} { interp create a interp create {a x1} interp delete {a x1} - expr {"x1" in [interp slaves a]} + expr {"x1" in [interp children a]} } 0 test interp-4.6 {testing interp delete} { interp create c1 @@ -203,14 +203,14 @@ test interp-4.8 {testing interp delete} -returnCodes error -body { interp delete {} } -result {cannot delete the current interpreter} -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } # Part 4: Consistency checking - all nondeleted interpreters should be # there: test interp-5.1 {testing consistency} { - interp slaves + interp children } "" test interp-5.2 {testing consistency} { interp exists a @@ -224,22 +224,22 @@ interp create a # Part 5: Testing eval in interpreter object command and with interp command test interp-6.1 {testing eval} { - a eval expr 3 + 5 + a eval expr {{3 + 5}} } 8 test interp-6.2 {testing eval} -returnCodes error -body { a eval foo } -result {invalid command name "foo"} test interp-6.3 {testing eval} { - a eval {proc foo {} {expr 3 + 5}} + a eval {proc foo {} {expr {3 + 5}}} a eval foo } 8 -catch {a eval {proc foo {} {expr 3 + 5}}} +catch {a eval {proc foo {} {expr {3 + 5}}}} test interp-6.4 {testing eval} { interp eval a foo } 8 test interp-6.5 {testing eval} { interp create {a x2} - interp eval {a x2} {proc frob {} {expr 4 * 9}} + interp eval {a x2} {proc frob {} {expr {4 * 9}}} interp eval {a x2} frob } 36 catch {interp create {a x2}} @@ -247,27 +247,27 @@ test interp-6.6 {testing eval} -returnCodes error -body { interp eval {a x2} foo } -result {invalid command name "foo"} -# UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER: -proc in_master {args} { - return [list seen in master: $args] +# UTILITY PROCEDURE RUNNING IN PARENT INTERPRETER: +proc in_parent {args} { + return [list seen in parent: $args] } # Part 6: Testing basic alias creation test interp-7.1 {testing basic alias creation} { - a alias foo in_master + a alias foo in_parent } foo -catch {a alias foo in_master} +catch {a alias foo in_parent} test interp-7.2 {testing basic alias creation} { - a alias bar in_master a1 a2 a3 + a alias bar in_parent a1 a2 a3 } bar -catch {a alias bar in_master a1 a2 a3} +catch {a alias bar in_parent a1 a2 a3} # Test 6.3 has been deleted. test interp-7.3 {testing basic alias creation} { a alias foo -} in_master +} in_parent test interp-7.4 {testing basic alias creation} { a alias bar -} {in_master a1 a2 a3} +} {in_parent a1 a2 a3} test interp-7.5 {testing basic alias creation} { lsort [a aliases] } {bar foo} @@ -278,14 +278,14 @@ test interp-7.6 {testing basic aliases arg checking} -returnCodes error -body { # Part 7: testing basic alias invocation test interp-8.1 {testing basic alias invocation} { catch {interp create a} - a alias foo in_master + a alias foo in_parent a eval foo s1 s2 s3 -} {seen in master: {s1 s2 s3}} +} {seen in parent: {s1 s2 s3}} test interp-8.2 {testing basic alias invocation} { catch {interp create a} - a alias bar in_master a1 a2 a3 + a alias bar in_parent a1 a2 a3 a eval bar s1 s2 s3 -} {seen in master: {a1 a2 a3 s1 s2 s3}} +} {seen in parent: {a1 a2 a3 s1 s2 s3}} test interp-8.3 {testing basic alias invocation} -returnCodes error -body { catch {interp create a} a alias @@ -294,13 +294,13 @@ test interp-8.3 {testing basic alias invocation} -returnCodes error -body { # Part 8: Testing aliases for non-existent or hidden targets test interp-9.1 {testing aliases for non-existent targets} { catch {interp create a} - a alias zop nonexistent-command-in-master + a alias zop nonexistent-command-in-parent list [catch {a eval zop} msg] $msg -} {1 {invalid command name "nonexistent-command-in-master"}} +} {1 {invalid command name "nonexistent-command-in-parent"}} test interp-9.2 {testing aliases for non-existent targets} { catch {interp create a} - a alias zop nonexistent-command-in-master - proc nonexistent-command-in-master {} {return i_exist!} + a alias zop nonexistent-command-in-parent + proc nonexistent-command-in-parent {} {return i_exist!} a eval zop } i_exist! test interp-9.3 {testing aliases for hidden commands} { @@ -329,8 +329,8 @@ test interp-9.4 {testing aliases and namespace commands} { set res } {GLOBAL GLOBAL} -if {[info command nonexistent-command-in-master] != ""} { - rename nonexistent-command-in-master {} +if {[info command nonexistent-command-in-parent] != ""} { + rename nonexistent-command-in-parent {} } # Part 9: Aliasing between interpreters @@ -380,9 +380,9 @@ test interp-10.6 {testing aliasing between interpreters} { interp create a interp create b interp alias a a_command b b_command a1 a2 a3 - b alias b_command in_master b1 b2 b3 + b alias b_command in_parent b1 b2 b3 a eval a_command m1 m2 m3 -} {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} +} {seen in parent: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} test interp-10.7 {testing aliases between interpreters} { catch {interp delete a} interp create a @@ -513,7 +513,7 @@ test interp-14.3 {testing interp aliases} { interp alias {a x3} froboz "" puts interp aliases {a x3} } froboz -test interp-14.4 {testing interp alias - alias over master} { +test interp-14.4 {testing interp alias - alias over parent} { # SF Bug 641195 catch {interp delete a} interp create a @@ -746,7 +746,7 @@ test interp-16.5 {testing deletion order, bgerror} { xxx eval {proc bgerror {args} {exit}} xxx alias exit kill xxx proc kill {i} {interp delete $i} - xxx eval after 100 expr a + b + xxx eval after 100 expr {a + b} after 200 update interp exists xxx @@ -793,32 +793,32 @@ test interp-17.6 {alias loop prevention} { } {1 {cannot define or rename alias "b": would create a loop}} # -# Test robustness of Tcl_DeleteInterp when applied to a slave interpreter. +# Test robustness of Tcl_DeleteInterp when applied to a child interpreter. # If there are bugs in the implementation these tests are likely to expose # the bugs as a core dump. # -test interp-18.1 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.1 {testing Tcl_DeleteInterp vs children} testinterpdelete { list [catch {testinterpdelete} msg] $msg } {1 {wrong # args: should be "testinterpdelete path"}} -test interp-18.2 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.2 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a testinterpdelete a } "" -test interp-18.3 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.3 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete {a b} } "" -test interp-18.4 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.4 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} testinterpdelete a } "" -test interp-18.5 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.5 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} @@ -826,7 +826,7 @@ test interp-18.5 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { proc dodel {x} {testinterpdelete $x} list [catch {interp eval {a b} {dodel {a b}}} msg] $msg } {0 {}} -test interp-18.6 {testing Tcl_DeleteInterp vs slaves} testinterpdelete { +test interp-18.6 {testing Tcl_DeleteInterp vs children} testinterpdelete { catch {interp delete a} interp create a interp create {a b} @@ -966,7 +966,7 @@ test interp-19.9 {alias deletion, renaming} { interp create a interp alias a foo a bar interp eval a rename foo blotz - interp eval a {proc foo {} {expr 34 * 34}} + interp eval a {proc foo {} {expr {34 * 34}}} interp alias a foo {} set l [interp eval a foo] interp delete a @@ -1615,36 +1615,36 @@ test interp-20.49 {interp invokehidden -namespace} -setup { set script [makeFile { set x [namespace current] } script] - interp create -safe slave + interp create -safe child } -body { - slave invokehidden -namespace ::foo source $script - slave eval {set ::foo::x} + child invokehidden -namespace ::foo source $script + child eval {set ::foo::x} } -cleanup { - interp delete slave + interp delete child removeFile script } -result ::foo test interp-20.50 {Bug 2486550} -setup { - interp create slave + interp create child } -body { - slave hide coroutine - slave invokehidden coroutine + child hide coroutine + child invokehidden coroutine } -cleanup { - interp delete slave + interp delete child } -returnCodes error -match glob -result * test interp-20.50.1 {Bug 2486550} -setup { - interp create slave + interp create child } -body { - slave hide coroutine - catch {slave invokehidden coroutine} m o + child hide coroutine + catch {child invokehidden coroutine} m o dict get $o -errorinfo } -cleanup { unset -nocomplain m 0 - interp delete slave + interp delete child } -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" while executing "coroutine" invoked from within -"slave invokehidden coroutine"} +"child invokehidden coroutine"} test interp-21.1 {interp hidden} { interp hidden {} @@ -2058,8 +2058,8 @@ test interp-25.1 {testing aliasing of string commands} -setup { test interp-26.1 {result code transmission : interp eval direct} { # Test that all the possibles error codes from Tcl get passed up - # from the slave interp's context to the master, even though the - # slave nominally thinks the command is running at the root level. + # from the child interp's context to the parent, even though the + # child nominally thinks the command is running at the root level. catch {interp delete a} interp create a set res {} @@ -2085,7 +2085,7 @@ test interp-26.2 {result code transmission : interp eval indirect} { } {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} test interp-26.3 {result code transmission : aliases} { # Test that all the possibles error codes from Tcl get passed up from the - # slave interp's context to the master, even though the slave nominally + # child interp's context to the parent, even though the child nominally # thinks the command is running at the root level. catch {interp delete a} interp create a @@ -2180,7 +2180,7 @@ test interp-26.8 {errorInfo transmission: safe interps--bug 1637} -setup { } -constraints knownBug -body { # this test fails because the errorInfo is fully transmitted whether the # interp is safe or not. The errorInfo should never report data from the - # master interpreter because it could contain sensitive information. + # parent interpreter because it could contain sensitive information. proc MyError {secret} { return -code error "msg" } @@ -2275,22 +2275,22 @@ test interp-27.5 {interp hidden & namespaces} -setup { test interp-27.6 {interp hidden & aliases & namespaces} -setup { set i [interp create] } -constraints knownBug -body { - set v root-master + set v root-parent namespace eval foo { - variable v foo-master + variable v foo-parent proc bar {interp args} { variable v - list "master bar called ($v) ([namespace current]) ($args)"\ + list "parent bar called ($v) ([namespace current]) ($args)"\ [interp invokehidden $interp foo::bar $args] } } interp eval $i { namespace eval foo { namespace export * - variable v foo-slave + variable v foo-child proc bar {args} { variable v - return "slave bar called ($v) ([namespace current]) ($args)" + return "child bar called ($v) ([namespace current]) ($args)" } } } @@ -2298,7 +2298,7 @@ test interp-27.6 {interp hidden & aliases & namespaces} -setup { $i hide foo::bar $i alias foo::bar foo::bar $i set res [concat $res [interp eval $i { - set v root-slave + set v root-child namespace eval test { variable v foo-test namespace import ::foo::* @@ -2308,29 +2308,29 @@ test interp-27.6 {interp hidden & aliases & namespaces} -setup { } -cleanup { namespace delete foo interp delete $i -} -result {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}} +} -result {{child bar called (foo-child) (::foo) (test1)} {parent bar called (foo-parent) (::foo) (test2)} {child bar called (foo-child) (::foo) (test2)}} test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup { set i [interp create] } -constraints knownBug -body { - set v root-master + set v root-parent namespace eval mfoo { - variable v foo-master + variable v foo-parent proc bar {interp args} { variable v - list "master bar called ($v) ([namespace current]) ($args)"\ + list "parent bar called ($v) ([namespace current]) ($args)"\ [interp invokehidden $interp test::bar $args] } } interp eval $i { namespace eval foo { namespace export * - variable v foo-slave + variable v foo-child proc bar {args} { variable v - return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" + return "child bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" } } - set v root-slave + set v root-child namespace eval test { variable v foo-test namespace import ::foo::* @@ -2343,7 +2343,7 @@ test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup { } -cleanup { namespace delete mfoo interp delete $i -} -result {{slave bar called (foo-slave) (bar test1) (::tcltest) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}} +} -result {{child bar called (foo-child) (bar test1) (::tcltest) (::foo) (test1)} {parent bar called (foo-parent) (::mfoo) (test2)} {child bar called (foo-child) (test::bar test2) (::) (::foo) (test2)}} test interp-27.8 {hiding, namespaces and integrity} knownBug { namespace eval foo { variable v 3 @@ -2355,25 +2355,25 @@ test interp-27.8 {hiding, namespaces and integrity} knownBug { list [catch {interp invokehidden {} foo::bar} msg] $msg } {1 {invalid hidden command name "foo"}} -test interp-28.1 {getting fooled by slave's namespace ?} -setup { +test interp-28.1 {getting fooled by child's namespace ?} -setup { set i [interp create -safe] - proc master {interp args} {interp hide $interp list} + proc parent {interp args} {interp hide $interp list} } -body { - $i alias master master $i + $i alias parent parent $i set r [interp eval $i { namespace eval foo { proc list {args} { return "dummy foo::list" } - master + parent } info commands list }] } -cleanup { - rename master {} + rename parent {} interp delete $i } -result {} -test interp-28.2 {master's nsName cache should not cross} -setup { +test interp-28.2 {parent's nsName cache should not cross} -setup { set i [interp create] $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}} } -body { @@ -2432,31 +2432,31 @@ test interp-29.1.7 {interp recursionlimit argument checking} { interp delete moo list $result [string range $msg 0 35] } {1 {integer value too large to represent}} -test interp-29.1.8 {slave recursionlimit argument checking} { +test interp-29.1.8 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit foo bar} msg] interp delete moo list $result $msg } {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}} -test interp-29.1.9 {slave recursionlimit argument checking} { +test interp-29.1.9 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit foo} msg] interp delete moo list $result $msg } {1 {expected integer but got "foo"}} -test interp-29.1.10 {slave recursionlimit argument checking} { +test interp-29.1.10 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit 0} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} -test interp-29.1.11 {slave recursionlimit argument checking} { +test interp-29.1.11 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit -1} msg] interp delete moo list $result $msg } {1 {recursion limit must be > 0}} -test interp-29.1.12 {slave recursionlimit argument checking} { +test interp-29.1.12 {child recursionlimit argument checking} { interp create moo set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg] interp delete moo @@ -2549,8 +2549,8 @@ test interp-29.3.3 {recursion limit} { set r } {1 {too many nested evaluations (infinite loop?)} 49} test interp-29.3.4 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2564,13 +2564,13 @@ test interp-29.3.4 {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {falling back due to new recursion limit}} test interp-29.3.5 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2584,13 +2584,13 @@ test interp-29.3.5 {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {falling back due to new recursion limit}} test interp-29.3.6 {recursion limit error reporting} { - interp create slave - set r1 [slave eval { + interp create child + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2604,8 +2604,8 @@ test interp-29.3.6 {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} # @@ -2613,9 +2613,9 @@ test interp-29.3.6 {recursion limit error reporting} { # level will only be verified when it invokes a non-bcc'd command. # test interp-29.3.7a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2629,14 +2629,14 @@ test interp-29.3.7a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.7b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2650,14 +2650,14 @@ test interp-29.3.7b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.7c {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 5} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2672,14 +2672,14 @@ test interp-29.3.7c {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.8a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 4} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2693,14 +2693,14 @@ test interp-29.3.8a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.8b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 4} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2714,14 +2714,14 @@ test interp-29.3.8b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.9a {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 6} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2735,14 +2735,14 @@ test interp-29.3.9a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.9b {recursion limit error reporting} { - interp create slave - after 0 {interp recursionlimit slave 6} - set r1 [slave eval { + interp create child + after 0 {interp recursionlimit child 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2756,14 +2756,14 @@ test interp-29.3.9b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.10a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 4} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2777,14 +2777,14 @@ test interp-29.3.10a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.10b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 4} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 4} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2798,14 +2798,14 @@ test interp-29.3.10b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.11a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 5} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2819,14 +2819,14 @@ test interp-29.3.11a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.11b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 5} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 5} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2841,14 +2841,14 @@ test interp-29.3.11b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {1 {too many nested evaluations (infinite loop?)}} test interp-29.3.12a {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 6} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2862,14 +2862,14 @@ test interp-29.3.12a {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.3.12b {recursion limit error reporting} { - interp create slave - after 0 {slave recursionlimit 6} - set r1 [slave eval { + interp create child + after 0 {child recursionlimit 6} + set r1 [child eval { catch { # nesting level 1 eval { # 2 eval { # 3 @@ -2884,8 +2884,8 @@ test interp-29.3.12b {recursion limit error reporting} { } } msg }] - set r2 [slave eval { set msg }] - interp delete slave + set r2 [child eval { set msg }] + interp delete child list $r1 $r2 } {0 ok} test interp-29.4.1 {recursion limit inheritance} { @@ -2916,121 +2916,121 @@ test interp-29.4.2 {recursion limit inheritance} { interp delete $i set r } 50 -test interp-29.5.1 {does slave recursion limit affect master?} { +test interp-29.5.1 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] interp recursionlimit $i 20000 set after [interp recursionlimit {}] - set slavelimit [interp recursionlimit $i] + set childlimit [interp recursionlimit $i] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} -test interp-29.5.2 {does slave recursion limit affect master?} { +test interp-29.5.2 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] interp recursionlimit $i 20000 set after [interp recursionlimit {}] - set slavelimit [$i recursionlimit] + set childlimit [$i recursionlimit] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} -test interp-29.5.3 {does slave recursion limit affect master?} { +test interp-29.5.3 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] $i recursionlimit 20000 set after [interp recursionlimit {}] - set slavelimit [interp recursionlimit $i] + set childlimit [interp recursionlimit $i] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} -test interp-29.5.4 {does slave recursion limit affect master?} { +test interp-29.5.4 {does child recursion limit affect parent?} { set before [interp recursionlimit {}] set i [interp create] $i recursionlimit 20000 set after [interp recursionlimit {}] - set slavelimit [$i recursionlimit] + set childlimit [$i recursionlimit] interp delete $i - list [expr {$before == $after}] $slavelimit + list [expr {$before == $after}] $childlimit } {1 20000} test interp-29.6.1 {safe interpreter recursion limit} { - interp create slave -safe - set n [interp recursionlimit slave] - interp delete slave + interp create child -safe + set n [interp recursionlimit child] + interp delete child set n } 1000 test interp-29.6.2 {safe interpreter recursion limit} { - interp create slave -safe - set n [slave recursionlimit] - interp delete slave + interp create child -safe + set n [child recursionlimit] + interp delete child set n } 1000 test interp-29.6.3 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [interp recursionlimit slave 42] - set n2 [interp recursionlimit slave] - interp delete slave + interp create child -safe + set n1 [interp recursionlimit child 42] + set n2 [interp recursionlimit child] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.4 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [interp recursionlimit slave] - interp delete slave + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [interp recursionlimit child] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.5 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [interp recursionlimit slave 42] - set n2 [slave recursionlimit] - interp delete slave + interp create child -safe + set n1 [interp recursionlimit child 42] + set n2 [child recursionlimit] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.6 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [slave recursionlimit] - interp delete slave + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [child recursionlimit] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.7 {safe interpreter recursion limit} { - interp create slave -safe - set n1 [slave recursionlimit 42] - set n2 [slave recursionlimit] - interp delete slave + interp create child -safe + set n1 [child recursionlimit 42] + set n2 [child recursionlimit] + interp delete child list $n1 $n2 } {42 42} test interp-29.6.8 {safe interpreter recursion limit} { - interp create slave -safe - set n [catch {slave eval {interp recursionlimit {} 42}} msg] - interp delete slave + interp create child -safe + set n [catch {child eval {interp recursionlimit {} 42}} msg] + interp delete child list $n $msg } {1 {permission denied: safe interpreters cannot change recursion limit}} test interp-29.6.9 {safe interpreter recursion limit} { - interp create slave -safe + interp create child -safe set result [ - slave eval { - interp create slave2 -safe + child eval { + interp create child2 -safe set n [catch { - interp recursionlimit slave2 42 + interp recursionlimit child2 42 } msg] list $n $msg } ] - interp delete slave + interp delete child set result } {1 {permission denied: safe interpreters cannot change recursion limit}} test interp-29.6.10 {safe interpreter recursion limit} { - interp create slave -safe + interp create child -safe set result [ - slave eval { - interp create slave2 -safe + child eval { + interp create child2 -safe set n [catch { - slave2 recursionlimit 42 + child2 recursionlimit 42 } msg] list $n $msg } ] - interp delete slave + interp delete child set result } {1 {permission denied: safe interpreters cannot change recursion limit}} @@ -3171,7 +3171,7 @@ test interp-34.3.1 {basic test of limits - pure inside-command loop} -body { } } # We use a time limit here; command limits don't trap this case - $i limit time -seconds [expr {[clock seconds]+2}] + $i limit time -seconds [expr {[clock seconds] + 2}] $i eval foobar } -returnCodes error -result {time limit exceeded} -cleanup { interp delete $i @@ -3193,8 +3193,8 @@ test interp-34.4 {limits with callbacks: extending limits} -setup { } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command "cb2 [expr $curlim+100]" \ - -value [expr {$curlim+10}] + $i limit command -command "cb2 [expr {$curlim + 100}]" \ + -value [expr {$curlim + 10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { @@ -3222,7 +3222,7 @@ test interp-34.5 {limits with callbacks: removing limits} -setup { } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command "cb2 {}" -value [expr {$curlim+10}] + $i limit command -command "cb2 {}" -value [expr {$curlim + 10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { @@ -3247,7 +3247,7 @@ test interp-34.6 {limits with callbacks: removing limits and handlers} -setup { } -body { interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command cb2 -value [expr {$curlim+10}] + $i limit command -command cb2 -value [expr {$curlim + 10}] $i eval {for {set i 0} {$i<10} {incr i} {foo}} list $a $b $c } -result {6 4 b} -cleanup { @@ -3266,7 +3266,7 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { proc cb2 {args} { global c i curlim set c b - $i limit command -value [expr {$curlim+1000}] + $i limit command -value [expr {$curlim + 1000}] trapToParent } } @@ -3289,7 +3289,7 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { set c a interp alias $i foo {} cb1 set curlim [$i eval info cmdcount] - $i limit command -command cb2 -value [expr {$curlim+10}] + $i limit command -command cb2 -value [expr {$curlim + 10}] } $i eval { $i eval { @@ -3304,7 +3304,7 @@ test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { # Bug 1085023 test interp-34.8 {time limits trigger in vwaits} -body { set i [interp create] - interp limit $i time -seconds [expr {[clock seconds]+1}] -granularity 1 + interp limit $i time -seconds [expr {[clock seconds] + 1}] -granularity 1 $i eval { set x {} vwait x @@ -3352,8 +3352,8 @@ test interp-34.11 {time limit extension in callbacks} -setup { } -body { set i [interp create] set t0 [clock seconds] - $i limit time -seconds [expr {$t0+1}] -granularity 1 \ - -command "cb1 $i [expr {$t0+2}]" + $i limit time -seconds [expr {$t0 + 1}] -granularity 1 \ + -command "cb1 $i [expr {$t0 + 2}]" set ::result {} lappend ::result [catch { $i eval { @@ -3380,8 +3380,8 @@ test interp-34.12 {time limit extension in callbacks} -setup { } -body { set i [interp create] set t0 [clock seconds] - set ::times "[expr {$t0+2}] [expr {$t0+100}]" - $i limit time -seconds [expr {$t0+1}] -granularity 1 -command "cb1 $i" + set ::times "[expr {$t0 + 2}] [expr {$t0 + 100}]" + $i limit time -seconds [expr {$t0 + 1}] -granularity 1 -command "cb1 $i" set ::result {} lappend ::result [catch { $i eval { @@ -3524,7 +3524,7 @@ test interp-35.19 {interp limit syntax} -body { interp limit $i time -seconds -1 } -cleanup { interp delete $i -} -returnCodes error -result {seconds must be at least 0} +} -match glob -returnCodes error -result {seconds must be between 0 and *} test interp-35.20 {interp limit syntax} -body { set i [interp create] interp limit $i time -millis foobar @@ -3536,7 +3536,7 @@ test interp-35.21 {interp limit syntax} -body { interp limit $i time -millis -1 } -cleanup { interp delete $i -} -returnCodes error -result {milliseconds must be at least 0} +} -match glob -returnCodes error -result {milliseconds must be between 0 and *} test interp-35.22 {interp time limits normalize milliseconds} -body { set i [interp create] interp limit $i time -seconds 1 -millis 1500 @@ -3559,44 +3559,44 @@ test interp-36.2 {interp bgerror syntax} -body { interp bgerror x y z } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} test interp-36.3 {interp bgerror syntax} -setup { - interp create slave + interp create child } -body { - slave bgerror x y + child bgerror x y } -cleanup { - interp delete slave -} -returnCodes error -result {wrong # args: should be "slave bgerror ?cmdPrefix?"} -test interp-36.4 {SlaveBgerror syntax} -setup { - interp create slave + interp delete child +} -returnCodes error -result {wrong # args: should be "child bgerror ?cmdPrefix?"} +test interp-36.4 {ChildBgerror syntax} -setup { + interp create child } -body { - slave bgerror \{ + child bgerror \{ } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {cmdPrefix must be list of length >= 1} -test interp-36.5 {SlaveBgerror syntax} -setup { - interp create slave +test interp-36.5 {ChildBgerror syntax} -setup { + interp create child } -body { - slave bgerror {} + child bgerror {} } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {cmdPrefix must be list of length >= 1} -test interp-36.6 {SlaveBgerror returns handler} -setup { - interp create slave +test interp-36.6 {ChildBgerror returns handler} -setup { + interp create child } -body { - slave bgerror {foo bar soom} + child bgerror {foo bar soom} } -cleanup { - interp delete slave + interp delete child } -result {foo bar soom} -test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { - interp create slave - slave alias handler handler - slave bgerror handler +test interp-36.7 {ChildBgerror sets error handler of child [1999035]} -setup { + interp create child + child alias handler handler + child bgerror handler variable result {untouched} proc handler {args} { variable result set result [lindex $args 0] } } -body { - slave eval { + child eval { variable done {} after 0 error foo after 10 [list ::set [namespace which -variable done] {}] @@ -3606,7 +3606,7 @@ test interp-36.7 {SlaveBgerror sets error handler of slave [1999035]} -setup { } -cleanup { variable result {} unset -nocomplain result - interp delete slave + interp delete child } -result foo test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { @@ -3615,8 +3615,8 @@ test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { set result {} } -body { interp create {a b} -safe - lappend result [interp eval a {expr min(5,2,3)*max(7,13,11)}] - lappend result [interp eval {a b} {expr min(5,2,3)*max(7,13,11)}] + lappend result [interp eval a {expr {min(5,2,3)*max(7,13,11)}}] + lappend result [interp eval {a b} {expr {min(5,2,3)*max(7,13,11)}}] } -cleanup { unset -nocomplain result interp delete a @@ -3667,7 +3667,7 @@ test interp-38.8 {interp debug basic setup} -body { # cleanup unset -nocomplain hidden_cmds -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } ::tcltest::cleanupTests diff --git a/tests/io.test b/tests/io.test index 73481ca..e0a2389 100644 --- a/tests/io.test +++ b/tests/io.test @@ -6,15 +6,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 } namespace eval ::tcl::test::io { @@ -31,19 +31,23 @@ namespace eval ::tcl::test::io { catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] - set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [info loaded {} Tcltest] } package require tcltests testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint openpipe 1 testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] testConstraint testobj [llength [info commands testobj]] -testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] +testConstraint testservicemode [llength [info commands testservicemode]] +# Some things fail under Windows in Continuous Integration systems for subtle +# reasons such as CI often running with elevated privileges in a container. +testConstraint notWinCI [expr { + $::tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... @@ -73,7 +77,7 @@ set path(cat) [makeFile { if {$argv != ""} { set f [open [lindex $argv 0]] } - fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a + fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A fconfigure stdout -encoding binary -translation lf -buffering none fileevent $f readable "foo $f" proc foo {f} { @@ -104,17 +108,17 @@ set path(test1) [makeFile {} test1] test io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] fconfigure $f -encoding binary - puts -nonewline $f "a\u4e4d\0" + puts -nonewline $f "a乍\x00" close $f contents $path(test1) -} "a\x4d\x00" +} "a\x4D\x00" test io-1.7 {Tcl_WriteChars: WriteChars} { set f [open $path(test1) w] fconfigure $f -encoding shiftjis - puts -nonewline $f "a\u4e4d\0" + puts -nonewline $f "a乍\x00" close $f contents $path(test1) -} "a\x93\xe1\x00" +} "a\x93\xE1\x00" set path(test2) [makeFile {} test2] test io-1.8 {Tcl_WriteChars: WriteChars} { # This test written for SF bug #506297. @@ -128,7 +132,7 @@ test io-1.8 {Tcl_WriteChars: WriteChars} { puts -nonewline $f [format %s%c [string repeat " " 4] 12399] close $f contents $path(test2) -} " \x1b\$B\$O\x1b(B" +} " \x1B\$B\$O\x1B(B" test io-1.9 {Tcl_WriteChars: WriteChars} { # When closing a channel with an encoding that appends @@ -291,14 +295,14 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { # in src to the beginning of that UTF-8 character and try again. # # Translate the first 16 bytes, produce 14 bytes of output, 2 left over - # (first two bytes of \uff21 in UTF-8). Given those two bytes try + # (first two bytes of Ａ in UTF-8). Given those two bytes try # translating them again, find that no bytes are read produced, and break # to outer loop where those two bytes will have the remaining 4 bytes - # (the last byte of \uff21 plus the all of \uff22) appended. + # (the last byte of Ａ plus the all of Ｂ) appended. set f [open $path(test1) w] fconfigure $f -encoding shiftjis -buffersize 16 - puts -nonewline $f "12345678901234\uff21\uff22" + puts -nonewline $f "12345678901234ＡＢ" set x [list [contents $path(test1)]] close $f lappend x [contents $path(test1)] @@ -447,7 +451,7 @@ test io-6.3 {Tcl_GetsObj: how many have we used?} { test io-6.4 {Tcl_GetsObj: encoding == NULL} { set f [open $path(test1) w] fconfigure $f -translation binary - puts $f "\x81\u1234\0" + puts $f "\x81\u1234\x00" close $f set f [open $path(test1)] fconfigure $f -translation binary @@ -458,14 +462,14 @@ test io-6.4 {Tcl_GetsObj: encoding == NULL} { test io-6.5 {Tcl_GetsObj: encoding != NULL} { set f [open $path(test1) w] fconfigure $f -translation binary - puts $f "\x88\xea\x92\x9a" + puts $f "\x88\xEA\x92\x9A" close $f set f [open $path(test1)] fconfigure $f -encoding shiftjis set x [list [gets $f line] $line] close $f set x -} [list 2 "\u4e00\u4e01"] +} [list 2 "一丁"] set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a @@ -481,7 +485,7 @@ test io-6.6 {Tcl_GetsObj: loop test} { close $f set x } [list 256 $a] -test io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} { +test io-6.7 {Tcl_GetsObj: error in input} stdio { # if (FilterInputBytes(chanPtr, &gs) != 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -495,20 +499,20 @@ test io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} { } {-1} test io-6.8 {Tcl_GetsObj: remember if EOF is seen} { set f [open $path(test1) w] - puts $f "abcdef\x1aghijk\nwombat" + puts $f "abcdef\x1Aghijk\nwombat" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1a + fconfigure $f -eofchar \x1A set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {6 abcdef -1 {}} test io-6.9 {Tcl_GetsObj: remember if EOF is seen} { set f [open $path(test1) w] - puts $f "abcdefghijk\nwom\u001abat" + puts $f "abcdefghijk\nwom\x1Abat" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1a + fconfigure $f -eofchar \x1A set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -741,7 +745,7 @@ test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} { close $f set x } [list 15 "123456789012345" 15] -test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} { +test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel fileevent} { # (FilterInputBytes() != 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -880,7 +884,7 @@ test io-6.42 {Tcl_GetsObj: auto mode: several chars} { close $f set x } [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] -test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} { +test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel fileevent} { # if (chanPtr->flags & INPUT_SAW_CR) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -891,13 +895,13 @@ test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} fconfigure $f -blocking 0 lappend x [gets $f line] $line [testchannel queuedcr $f] fconfigure $f -blocking 1 - puts -nonewline $f "\nabcd\refg\x1a" + puts -nonewline $f "\nabcd\refg\x1A" lappend x [gets $f line] $line [testchannel queuedcr $f] lappend x [gets $f line] $line close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} { +test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel fileevent} { # not (*eol == '\n') set f [open "|[list [interpreter] $path(cat)]" w+] @@ -908,13 +912,13 @@ test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel fconfigure $f -blocking 0 lappend x [gets $f line] $line [testchannel queuedcr $f] fconfigure $f -blocking 1 - puts -nonewline $f "abcd\refg\x1a" + puts -nonewline $f "abcd\refg\x1A" lappend x [gets $f line] $line [testchannel queuedcr $f] lappend x [gets $f line] $line close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} { +test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel fileevent} { # Tcl_ExternalToUtf() set f [open "|[list [interpreter] $path(cat)]" w+] @@ -931,7 +935,7 @@ test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio test close $f set x } [list 15 "123456789abcdef" 1 4 "abcd" 0] -test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} { +test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel fileevent} { # memmove() set f [open "|[list [interpreter] $path(cat)]" w+] @@ -942,7 +946,7 @@ test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {s fconfigure $f -blocking 0 set x [list [gets $f line] $line [testchannel queuedcr $f]] fconfigure $f -blocking 1 - puts -nonewline $f "\n\x1a" + puts -nonewline $f "\n\x1A" lappend x [gets $f line] $line [testchannel queuedcr $f] close $f set x @@ -1014,10 +1018,10 @@ test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { set f [open $path(test1) w] fconfigure $f -translation lf - puts -nonewline $f "123456\x1ak9012345\r" + puts -nonewline $f "123456\x1Ak9012345\r" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1a + fconfigure $f -eofchar \x1A set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] close $f set x @@ -1048,15 +1052,15 @@ test io-6.55 {Tcl_GetsObj: overconverted} { set f [open $path(test1) w] fconfigure $f -encoding iso2022-jp - puts $f "there\u4e00ok\n\u4e01more bytes\nhere" + puts $f "there一ok\n丁more bytes\nhere" close $f set f [open $path(test1)] fconfigure $f -encoding iso2022-jp set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x -} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] -test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} { +} [list 8 "there一ok" 11 "丁more bytes" 4 "here"] +test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio fileevent} { update set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -buffering none @@ -1082,20 +1086,20 @@ test io-7.1 {FilterInputBytes: split up character at end of buffer} { set f [open $path(test1) w] fconfigure $f -encoding shiftjis - puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend" + puts $f "1234567890123０１２３４\nend" close $f set f [open $path(test1)] fconfigure $f -encoding shiftjis -buffersize 16 set x [gets $f] close $f set x -} "1234567890123\uff10\uff11\uff12\uff13\uff14" +} "1234567890123０１２３４" test io-7.2 {FilterInputBytes: split up character in middle of buffer} { # (bufPtr->nextAdded < bufPtr->bufLength) set f [open $path(test1) w] fconfigure $f -encoding binary - puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" + puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82" close $f set f [open $path(test1)] fconfigure $f -encoding shiftjis @@ -1106,7 +1110,7 @@ test io-7.2 {FilterInputBytes: split up character in middle of buffer} { test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { set f [open $path(test1) w] fconfigure $f -encoding binary - puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" close $f set f [open $path(test1)] fconfigure $f -encoding shiftjis @@ -1115,11 +1119,11 @@ test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { lappend x [gets $f line] $line close $f set x -} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] -test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} { +} [list 15 "1234567890123０１" 18 0 1 -1 ""] +test io-7.4 {FilterInputBytes: recover from split up character} {stdio fileevent} { set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -encoding binary -buffering none - puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" + puts -nonewline $f "1234567890123\x82\x4F\x82\x50\x82" fconfigure $f -encoding shiftjis -blocking 0 fileevent $f read [namespace code "ready $f"] variable x {} @@ -1134,7 +1138,7 @@ test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe vwait [namespace which -variable x] close $f set x -} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0] +} [list -1 "" 1 17 "1234567890123０１２３" 0] test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} { # (bufPtr->nextPtr == NULL) @@ -1151,7 +1155,7 @@ test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} close $f set x } "7" -test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} { +test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel fileevent} { # not (bufPtr->nextPtr == NULL) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1171,7 +1175,7 @@ test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testcha close $f set x } [list -1 "" 42 15 "123456789012345" 25] -test io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} { +test io-8.3 {PeekAhead: no cached data available} {stdio testchannel fileevent} { # (bytesLeft == 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1204,7 +1208,7 @@ test io-8.4 {PeekAhead: cached data available in this buffer} { set x } $a unset a -test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} { +test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel fileevent} { # (bufPtr->nextAdded < bufPtr->length) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1216,7 +1220,7 @@ test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel op close $f set x } {15 abcdefghijklmno 1} -test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} { +test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel fileevent} { # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1228,7 +1232,7 @@ test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe close $f set x } {15 abcdefghijklmno 1} -test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} { +test io-8.7 {PeekAhead: cleanup} {stdio testchannel fileevent} { # Make sure bytes are removed from buffer. set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1236,7 +1240,7 @@ test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} { puts -nonewline $f "abcdefghijklmno\r" # here set x [list [gets $f line] $line [testchannel queuedcr $f]] - puts -nonewline $f "\x1a" + puts -nonewline $f "\x1A" lappend x [gets $f line] $line close $f set x @@ -1393,7 +1397,7 @@ test io-12.3 {ReadChars: allocate more space} { close $f set x } {abcdefghijklmnopqrstuvwxyz} -test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} { +test io-12.4 {ReadChars: split-up char} {stdio testchannel fileevent} { # (srcRead == 0) set f [open "|[list [interpreter] $path(cat)]" w+] @@ -1411,19 +1415,19 @@ test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} { fconfigure $f -encoding shiftjis vwait [namespace which -variable x] fconfigure $f -encoding binary -blocking 1 - puts -nonewline $f "\x7b" + puts -nonewline $f "\x7B" after 500 ;# Give the cat process time to catch up fconfigure $f -encoding shiftjis -blocking 0 vwait [namespace which -variable x] close $f set x -} [list "123456789012345" 1 "\u672c" 0] -test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe fileevent} { +} [list "123456789012345" 1 "本" 0] +test io-12.5 {ReadChars: fileevents on partial characters} {stdio fileevent} { set path(test1) [makeFile { fconfigure stdout -encoding binary -buffering none - gets stdin; puts -nonewline "\xe7" + gets stdin; puts -nonewline "\xE7" gets stdin; puts -nonewline "\x89" - gets stdin; puts -nonewline "\xa6" + gets stdin; puts -nonewline "\xA6" } test1] set f [open "|[list [interpreter] $path(test1)]" r+] fileevent $f readable [namespace code { @@ -1450,7 +1454,7 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee vwait [namespace which -variable x] lappend x [catch {close $f} msg] $msg set x -} "{} timeout {} timeout \u7266 {} eof 0 {}" +} "{} timeout {} timeout 牦 {} eof 0 {}" test io-12.6 {ReadChars: too many chars read} { proc driver {cmd args} { variable buffer @@ -1460,7 +1464,7 @@ test io-12.6 {ReadChars: too many chars read} { initialize { set index($chan) 0 set buffer($chan) [encoding convertto utf-8 \ - [string repeat \uBEEF 20][string repeat . 20]] + [string repeat 뻯 20][string repeat . 20]] return {initialize finalize watch read} } finalize { @@ -1493,7 +1497,7 @@ test io-12.7 {ReadChars: too many chars read [bc5b790099]} { initialize { set index($chan) 0 set buffer($chan) [encoding convertto utf-8 \ - [string repeat \uBEEF 10]....\uBEEF] + [string repeat 뻯 10]....뻯] return {initialize finalize watch read} } finalize { @@ -1520,7 +1524,7 @@ test io-12.7 {ReadChars: too many chars read [bc5b790099]} { test io-12.8 {ReadChars: multibyte chars split} { set f [open $path(test1) w] fconfigure $f -translation binary - puts -nonewline $f [string repeat a 9]\xc2\xa0 + puts -nonewline $f [string repeat a 9]\xC2\xA0 close $f set f [open $path(test1)] fconfigure $f -encoding utf-8 -buffersize 10 @@ -1531,7 +1535,7 @@ test io-12.8 {ReadChars: multibyte chars split} { test io-12.9 {ReadChars: multibyte chars split} { set f [open $path(test1) w] fconfigure $f -translation binary - puts -nonewline $f [string repeat a 9]\xc2 + puts -nonewline $f [string repeat a 9]\xC2 close $f set f [open $path(test1)] fconfigure $f -encoding utf-8 -buffersize 10 @@ -1542,7 +1546,7 @@ test io-12.9 {ReadChars: multibyte chars split} { test io-12.10 {ReadChars: multibyte chars split} { set f [open $path(test1) w] fconfigure $f -translation binary - puts -nonewline $f [string repeat a 9]\xc2 + puts -nonewline $f [string repeat a 9]\xC2 close $f set f [open $path(test1)] fconfigure $f -encoding utf-8 -buffersize 11 @@ -1612,7 +1616,7 @@ test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { close $f set x } "abcd\ndef\nfgh" -test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} { +test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel fileevent} { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. @@ -1638,7 +1642,7 @@ test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testc close $f set x } [list "abcdefghj\n" 1 "01234" 0] -test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} { +test io-13.7 {TranslateInputEOL: auto mode: naked \r} testchannel { # (src >= srcMax) set f [open $path(test1) w] @@ -1728,7 +1732,7 @@ test io-13.10 {TranslateInputEOL: auto mode: \n} { set x } "abcd\ndef" test io-13.11 {TranslateInputEOL: EOF char} { - # (*chanPtr->inEofChar != '\0') + # (*chanPtr->inEofChar != '\x00') set f [open $path(test1) w] fconfigure $f -translation lf @@ -1741,7 +1745,7 @@ test io-13.11 {TranslateInputEOL: EOF char} { set x } "abcd\nd" test io-13.12 {TranslateInputEOL: find EOF char in src} { - # (*chanPtr->inEofChar != '\0') + # (*chanPtr->inEofChar != '\x00') set f [open $path(test1) w] fconfigure $f -translation lf @@ -1783,7 +1787,7 @@ test io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { set l } {line line none} set path(test3) [makeFile {} test3] -test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} { +test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} exec { set f [open $path(test1) w] puts -nonewline $f { close stdin @@ -1873,7 +1877,7 @@ test io-14.7 {Tcl_GetChannel: stdio name translation} { set result } {{} {} {can not find channel named "stderr"}} set path(script) [makeFile {} script] -test io-14.8 {reuse of stdio special channels} {stdio openpipe} { +test io-14.8 {reuse of stdio special channels} stdio { file delete $path(script) file delete $path(test1) set f [open $path(script) w] @@ -1895,7 +1899,7 @@ test io-14.8 {reuse of stdio special channels} {stdio openpipe} { close $f set c } hello -test io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} { +test io-14.9 {reuse of stdio special channels} {stdio fileevent} { file delete $path(script) file delete $path(test1) set f [open $path(script) w] @@ -1939,11 +1943,11 @@ test io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} eof stdin interp create x set l "" - lappend l [expr [testchannel refcount stdin] - $l1] + lappend l [expr {[testchannel refcount stdin] - $l1}] x eval {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] + lappend l [expr {[testchannel refcount stdin] - $l1}] set l } {0 1 0} test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { @@ -1951,11 +1955,11 @@ test io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} eof stdin interp create x set l "" - lappend l [expr [testchannel refcount stdout] - $l1] + lappend l [expr {[testchannel refcount stdout] - $l1}] x eval {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] + lappend l [expr {[testchannel refcount stdout] - $l1}] set l } {0 1 0} test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { @@ -1963,11 +1967,11 @@ test io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} eof stdin interp create x set l "" - lappend l [expr [testchannel refcount stderr] - $l1] + lappend l [expr {[testchannel refcount stderr] - $l1}] x eval {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] + lappend l [expr {[testchannel refcount stderr] - $l1}] set l } {0 1 0} @@ -2070,7 +2074,7 @@ test io-20.2 {Tcl_CreateChannel: initial settings} {win} { set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] close $f set x -} [list [list \x1a ""] {auto crlf}] +} [list [list \x1A ""] {auto crlf}] test io-20.3 {Tcl_CreateChannel: initial settings} {unix} { set f [open $path(test1) w+] set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] @@ -2078,7 +2082,7 @@ test io-20.3 {Tcl_CreateChannel: initial settings} {unix} { set x } {{{} {}} {auto lf}} set path(stdout) [makeFile {} stdout] -test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} { +test io-20.5 {Tcl_CreateChannel: install channel in empty slot} stdio { set f [open $path(script) w] puts -nonewline $f { close stdout @@ -2152,12 +2156,12 @@ test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} { set l } {6 6 0 6} -test io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} { +test io-26.1 {Tcl_GetChannelInstanceData} stdio { # "pid" command uses Tcl_GetChannelInstanceData # Don't care what pid is (but must be a number), just want to exercise it. set f [open "|[list [interpreter] << exit]"] - expr [pid $f] + expr {[pid $f]} close $f } {} @@ -2229,7 +2233,7 @@ test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \ set path(pipe) [makeFile {} pipe] set path(output) [makeFile {} output] test io-27.6 {FlushChannel, async flushing, async close} \ - {stdio asyncPipeClose openpipe knownMsvcBug} { + {stdio asyncPipeClose notWinCI} { # This test may fail on old Unix systems (seen on IRIX64 6.5) with # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) @@ -2298,7 +2302,7 @@ test io-28.2 {CloseChannel called when all references are dropped} { set l } abcdef test io-28.3 {CloseChannel, not called before output queue is empty} \ - {stdio asyncPipeClose nonPortable openpipe} { + {stdio asyncPipeClose nonPortable} { file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] @@ -2355,7 +2359,7 @@ test io-28.4 {Tcl_Close} {testchannel} { $consoleFileNames] string compare $l $x } 0 -test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel openpipe} { +test io-28.5 {Tcl_Close vs standard handles} {stdio unix testchannel} { file delete $path(script) set f [open $path(script) w] puts $f { @@ -2494,7 +2498,7 @@ test io-29.11 {Tcl_WriteChars, no newline, implicit flush} { close $f2 file size $path(test1) } 377 -test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { +test io-29.12 {Tcl_WriteChars on a pipe} stdio { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] @@ -2519,7 +2523,7 @@ test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { close $f2 set y } ok -test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} { +test io-29.13 {Tcl_WriteChars to a pipe, line buffered} stdio { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] @@ -2570,7 +2574,7 @@ test io-29.15 {Tcl_Flush, channel not open for writing} { string compare $x \ [list 1 "channel \"$fd\" wasn't opened for writing"] } 0 -test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} { +test io-29.16 {Tcl_Flush on pipe opened only for reading} stdio { set fd [open "|[list [interpreter] cat longfile]" r] set x [list [catch {flush $fd} msg] $msg] catch {close $fd} @@ -2644,7 +2648,7 @@ test io-29.20 {Implicit flush when buffer is full} { lappend z [file size $path(test1)] set z } {4096 12288 12600} -test io-29.21 {Tcl_Flush to pipe} {stdio openpipe} { +test io-29.21 {Tcl_Flush to pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {set x [read stdin 6]} @@ -2658,7 +2662,7 @@ test io-29.21 {Tcl_Flush to pipe} {stdio openpipe} { catch {close $f1} set x } "read 6 characters" -test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { +test io-29.22 {Tcl_Flush called at other end of pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { @@ -2681,7 +2685,7 @@ test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { close $f1 set x } {hello hello bye} -test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe} { +test io-29.23 {Tcl_Flush and line buffering at end of pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { @@ -2716,7 +2720,7 @@ test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} { close $f set x } "{} {Line 1\nLine 2}" -test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} { +test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio fileevent} { file delete $path(test3) set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w] puts $f "Line 1" @@ -2728,7 +2732,7 @@ test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpi close $f set x } "Line 1\nLine 2\n" -test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs openpipe} { +test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs} { set f [open "|[list cat -u]" r+] puts $f "Line1" flush $f @@ -2736,7 +2740,7 @@ test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs close $f set x } {Line1} -test io-29.27 {Tcl_Flush on closed pipeline} {stdio openpipe} { +test io-29.27 {Tcl_Flush on closed pipeline} stdio { file delete $path(pipe) set f [open $path(pipe) w] puts $f {exit} @@ -2790,7 +2794,7 @@ test io-29.30 {Tcl_WriteChars, crlf mode} { close $f file size $path(test1) } 25 -test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { +test io-29.31 {Tcl_WriteChars, background flush} stdio { # This test may fail on old Unix systems (seen on IRIX64 6.5) with # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) @@ -2827,13 +2831,13 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { set result ok } # allow a little time for the background process to close. - # otherwise, the following test fails on the [file delete $path(output) + # otherwise, the following test fails on the [file delete $path(output)] # on Windows because a process still has the file open. after 100 set v 1; vwait v set result } ok test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ - {stdio asyncPipeClose openpipe knownMsvcBug} { + {stdio asyncPipeClose notWinCI} { # This test may fail on old Unix systems (seen on IRIX64 6.5) with # obsolete gettimeofday() calls. See Tcl Bugs 3530533, 1942197. file delete $path(pipe) @@ -3158,7 +3162,7 @@ test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { set c [read $f] close $f string length $c -} [expr 700*15+1] +} [expr {700*15+1}] test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] @@ -3174,7 +3178,7 @@ test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { set c [read $f] close $f string length $c -} [expr 700*15+1] +} [expr {700*15+1}] test io-30.15 {Tcl_Write mixed, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] @@ -3195,10 +3199,10 @@ test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -translation lf - puts -nonewline $f hello\nthere\nand\rhere\n\x1a + puts -nonewline $f hello\nthere\nand\rhere\n\x1A close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -translation auto -eofchar \x1A set c [read $f] close $f set c @@ -3210,11 +3214,11 @@ here test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -eofchar \x1a -translation lf + fconfigure $f -translation lf -eofchar \x1A puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -translation auto -eofchar \x1A set c [read $f] close $f set c @@ -3231,7 +3235,7 @@ test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3251,7 +3255,7 @@ test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3284,7 +3288,7 @@ test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { lappend l [eof $f] close $f set l -} "abc def 0 \x1aghi 0 qrs 0 {} 1" +} "abc def 0 \x1Aghi 0 qrs 0 {} 1" test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { file delete $path(test1) set f [open $path(test1) w] @@ -3296,7 +3300,7 @@ test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { fconfigure $f -translation cr -eofchar {} set l "" set x [gets $f] - lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] + lappend l [string compare $x "abc\ndef\n\x1Aghi\nqrs\n"] lappend l [eof $f] lappend l [gets $f] lappend l [eof $f] @@ -3314,7 +3318,7 @@ test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { fconfigure $f -translation crlf -eofchar {} set l "" set x [gets $f] - lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] + lappend l [string compare $x "abc\ndef\n\x1Aghi\nqrs\n"] lappend l [eof $f] lappend l [gets $f] lappend l [eof $f] @@ -3329,7 +3333,7 @@ test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3343,7 +3347,7 @@ test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3357,7 +3361,7 @@ test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3371,7 +3375,7 @@ test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3385,7 +3389,7 @@ test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3399,7 +3403,7 @@ test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3732,7 +3736,7 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3747,11 +3751,11 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -eofchar \x1a -translation lf + fconfigure $f -translation lf -eofchar \x1A puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3771,8 +3775,7 @@ test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a - fconfigure $f -translation auto + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3790,7 +3793,7 @@ test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3821,7 +3824,7 @@ test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { lappend l [eof $f] close $f set l -} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +} "abc def 0 \x1Aqrs 0 tuv 0 {} 1" test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { file delete $path(test1) set f [open $path(test1) w] @@ -3843,7 +3846,7 @@ test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { lappend l [eof $f] close $f set l -} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +} "abc def 0 \x1Aqrs 0 tuv 0 {} 1" test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] @@ -3865,7 +3868,7 @@ test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { lappend l [eof $f] close $f set l -} "abc def 0 \x1aqrs 0 tuv 0 {} 1" +} "abc def 0 \x1Aqrs 0 tuv 0 {} 1" test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] @@ -3874,7 +3877,7 @@ test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3892,7 +3895,7 @@ test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3910,7 +3913,7 @@ test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3928,7 +3931,7 @@ test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3946,7 +3949,7 @@ test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3964,7 +3967,7 @@ test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3992,7 +3995,7 @@ test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { } close $f string length $c -} [expr 700*15+1] +} [expr {700*15+1}] test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] @@ -4011,7 +4014,7 @@ test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { } close $f string length $c -} [expr 700*15+1] +} [expr {700*15+1}] # Test Tcl_Read and buffering. @@ -4093,7 +4096,7 @@ test io-32.9 {Tcl_Read, read to end of file} { } set x } ok -test io-32.10 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.10 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {puts [gets stdin]} @@ -4105,7 +4108,7 @@ test io-32.10 {Tcl_Read from a pipe} {stdio openpipe} { close $f1 set x } "hello\n" -test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.11 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {puts [gets stdin]} @@ -4124,7 +4127,7 @@ test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} { } {{hello } {hello }} -test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.11.1 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {chan configure stdout -translation crlf} @@ -4144,7 +4147,7 @@ test io-32.11.1 {Tcl_Read from a pipe} {stdio openpipe} { } {{hello } {hello }} -test io-32.11.2 {Tcl_Read from a pipe} {stdio openpipe} { +test io-32.11.2 {Tcl_Read from a pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {chan configure stdout -translation crlf} @@ -4255,7 +4258,7 @@ test io-33.2 {Tcl_Gets into variable} { close $f1 set z } ok -test io-33.3 {Tcl_Gets from pipe} {stdio openpipe} { +test io-33.3 {Tcl_Gets from pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {puts [gets stdin]} @@ -4563,7 +4566,7 @@ test io-34.7 {Tcl_Seek to offset from end of file, then to current position} { close $f1 list $c1 $r1 $c2 } {44 rstuv 49} -test io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} { +test io-34.8 {Tcl_Seek on pipes: not supported} stdio { set f1 [open "|[list [interpreter]]" r+] set x [list [catch {seek $f1 0 current} msg] $msg] close $f1 @@ -4671,13 +4674,13 @@ test io-34.15 {Tcl_Tell combined with seeking} { close $f1 list $c1 $c2 } {10 20} -test io-34.16 {Tcl_Tell on pipe: always -1} {stdio openpipe} { +test io-34.16 {Tcl_Tell on pipe: always -1} stdio { set f1 [open "|[list [interpreter]]" r+] set c [tell $f1] close $f1 set c } -1 -test io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { +test io-34.17 {Tcl_Tell on pipe: always -1} stdio { set f1 [open "|[list [interpreter]]" r+] puts $f1 {puts hello} flush $f1 @@ -4776,7 +4779,7 @@ test io-35.1 {Tcl_Eof} { close $f set x } {0 0 0 0 1 1} -test io-35.2 {Tcl_Eof with pipe} {stdio openpipe} { +test io-35.2 {Tcl_Eof with pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {gets stdin} @@ -4794,7 +4797,7 @@ test io-35.2 {Tcl_Eof with pipe} {stdio openpipe} { close $f1 set x } {0 0 0 1} -test io-35.3 {Tcl_Eof with pipe} {stdio openpipe} { +test io-35.3 {Tcl_Eof with pipe} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 {gets stdin} @@ -4828,7 +4831,7 @@ test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { close $f set l } {{} 1} -test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} { +test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} stdio { file delete $path(pipe) set f [open $path(pipe) w] puts $f { @@ -4845,12 +4848,12 @@ test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} { test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4859,12 +4862,12 @@ test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4873,12 +4876,12 @@ test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4887,12 +4890,12 @@ test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4901,12 +4904,12 @@ test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4915,12 +4918,12 @@ test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4935,7 +4938,7 @@ test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4950,7 +4953,7 @@ test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4965,7 +4968,7 @@ test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4980,7 +4983,7 @@ test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -4995,7 +4998,7 @@ test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5010,7 +5013,7 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5033,12 +5036,12 @@ test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body { test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5047,12 +5050,12 @@ test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body { test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A puts $f {} close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5081,7 +5084,7 @@ test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5096,7 +5099,7 @@ test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5105,7 +5108,7 @@ test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} { # Test Tcl_InputBlocked -test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { +test io-36.1 {Tcl_InputBlocked on nonblocking pipe} stdio { set f1 [open "|[list [interpreter]]" r+] puts $f1 {puts hello_from_pipe} flush $f1 @@ -5124,7 +5127,7 @@ test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { close $f1 set x } {{} 1 hello 0 {} 1} -test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} {stdio openpipe} { +test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} stdio { set f1 [open "|[list [interpreter]]" r+] chan configure $f1 -encoding binary -translation lf -eofchar {} puts $f1 { @@ -5147,7 +5150,7 @@ test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} {stdio openpipe} { close $f1 set x } {{} 1 hello 0 {} 1} -test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} { +test io-36.2 {Tcl_InputBlocked on blocking pipe} stdio { set f1 [open "|[list [interpreter]]" r+] fconfigure $f1 -buffering line puts $f1 {puts hello_from_pipe} @@ -5411,7 +5414,7 @@ test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { close $f1 set x } {1 0 {} {} 0 1} -test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { +test io-39.10 {Tcl_SetChannelOption, blocking mode} stdio { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { @@ -5475,26 +5478,26 @@ test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -encoding {} - puts -nonewline $f \xe7\x89\xa6 + puts -nonewline $f \xE7\x89\xA6 close $f set f [open $path(test1) r] fconfigure $f -encoding utf-8 set x [read $f] close $f set x -} \u7266 +} 牦 test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] fconfigure $f -encoding binary - puts -nonewline $f \xe7\x89\xa6 + puts -nonewline $f \xE7\x89\xA6 close $f set f [open $path(test1) r] fconfigure $f -encoding utf-8 set x [read $f] close $f set x -} \u7266 +} 牦 test io-39.16 {Tcl_SetChannelOption: -encoding, errors} { file delete $path(test1) set f [open $path(test1) w] @@ -5502,10 +5505,10 @@ test io-39.16 {Tcl_SetChannelOption: -encoding, errors} { close $f set result } {1 {unknown encoding "foobar"}} -test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} { +test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio fileevent} { set f [open "|[list [interpreter] $path(cat)]" r+] fconfigure $f -encoding binary - puts -nonewline $f "\xe7" + puts -nonewline $f "\xE7" flush $f fconfigure $f -encoding utf-8 -blocking 0 variable x {} @@ -5523,7 +5526,7 @@ test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} vwait [namespace which -variable x] close $f set x -} "{} timeout {} timeout \xe7 timeout" +} "{} timeout {} timeout \xE7 timeout" test io-39.18 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} @@ -5637,7 +5640,7 @@ test io-40.2 {POSIX open access modes: CREAT} {unix} { file delete $path(test3) set f [open $path(test3) {WRONLY CREAT} 0o600] file stat $path(test3) stats - set x [format "%#o" [expr $stats(mode)&0o777]] + set x [format "%#o" [expr {$stats(mode)&0o777}]] puts $f "line 1" close $f set f [open $path(test3) r] @@ -5651,8 +5654,8 @@ test io-40.3 {POSIX open access modes: CREAT} {unix umask} { set f [open $path(test3) {WRONLY CREAT}] close $f file stat $path(test3) stats - format "%#o" [expr $stats(mode)&0o777] -} [format %#5o [expr {0o666 & ~ $umaskValue}]] + format 0o%03o [expr {$stats(mode)&0o777}] +} [format 0o%03o [expr {0o666 & ~ $umaskValue}]] test io-40.4 {POSIX open access modes: CREAT} { file delete $path(test3) set f [open $path(test3) w] @@ -5826,11 +5829,11 @@ test io-42.2 {Tcl_FileeventCmd: replacing} {fileevent} { } {{first script} {new script} {yet another} {}} test io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {fileevent} { set result {} - fileevent $f r "first scr\0ipt" + fileevent $f r "first scr\x00ipt" lappend result [string length [fileevent $f readable]] - fileevent $f r "new scr\0ipt" + fileevent $f r "new scr\x00ipt" lappend result [string length [fileevent $f readable]] - fileevent $f r "yet ano\0ther" + fileevent $f r "yet ano\x00ther" lappend result [string length [fileevent $f readable]] fileevent $f r "" lappend result [fileevent $f readable] @@ -5851,7 +5854,7 @@ test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs f test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { set result {} lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] fileevent $f r "read f" @@ -5872,7 +5875,7 @@ test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { test io-44.1 {FileEventProc procedure: normal read event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { fileevent $f2 readable [namespace code { set x [gets $f2]; fileevent $f2 readable {} }] @@ -5885,7 +5888,7 @@ test io-44.1 {FileEventProc procedure: normal read event} -setup { catch {close $f3} } -result {text} test io-44.2 {FileEventProc procedure: error in read event} -constraints { - stdio unixExecs fileevent openpipe + stdio unixExecs fileevent } -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] @@ -5908,7 +5911,7 @@ test io-44.2 {FileEventProc procedure: error in read event} -constraints { test io-44.3 {FileEventProc procedure: normal write event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] -} -constraints {stdio unixExecs fileevent openpipe} -body { +} -constraints {stdio unixExecs fileevent} -body { fileevent $f2 writable [namespace code { lappend x "triggered" incr count -1 @@ -5927,7 +5930,7 @@ test io-44.3 {FileEventProc procedure: normal write event} -setup { catch {close $f3} } -result {initial triggered triggered triggered} test io-44.4 {FileEventProc procedure: eror in write event} -constraints { - stdio unixExecs fileevent openpipe + stdio unixExecs fileevent } -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] @@ -5946,7 +5949,9 @@ test io-44.4 {FileEventProc procedure: eror in write event} -constraints { catch {close $f2} catch {close $f3} } -result {bad-write {}} -test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { +test io-44.5 {FileEventProc procedure: end of file} -constraints { + stdio unixExecs fileevent +} -body { set f4 [open "|[list [interpreter] $path(cat) << foo]" r] fileevent $f4 readable [namespace code { if {[gets $f4 line] < 0} { @@ -5959,9 +5964,10 @@ test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fi variable x initial vwait [namespace which -variable x] vwait [namespace which -variable x] - close $f4 set x -} {initial foo eof} +} -cleanup { + close $f4 +} -result {initial foo eof} close $f @@ -6084,7 +6090,7 @@ test io-45.3 {DeleteFileEvent, cleanup on close} {fileevent} { # Execute these tests only if the "testfevent" command is present. -test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { +test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent notOSX} { testfevent create set script "set f \[[list open $path(foo) r]]\n" append script { @@ -6094,9 +6100,10 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { fileevent $f readable {} }] } + set timer [after 10 lappend x timeout] testfevent cmd $script - after 1 ;# We must delay because Windows takes a little time to notice - update + vwait x + after cancel $timer testfevent cmd {close $f} list [testfevent cmd {set x}] [testfevent cmd {info commands after}] } {{f triggered: foo bar} after} @@ -6285,7 +6292,7 @@ test io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { list $x $l } {done {called called called called called called called}} set path(my_script) [makeFile {} my_script] -test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe fileevent} { +test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles fileevent} { set f [open $path(bar) w] puts $f abcdefg puts $f abcdefg @@ -6355,7 +6362,7 @@ test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6383,7 +6390,7 @@ test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6411,7 +6418,7 @@ test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6439,7 +6446,7 @@ test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6467,7 +6474,7 @@ test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} { set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6495,7 +6502,7 @@ test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6523,7 +6530,7 @@ test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation lf + fconfigure $f -translation lf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6551,7 +6558,7 @@ test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fil set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + fconfigure $f -translation lf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6579,7 +6586,7 @@ test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation cr + fconfigure $f -translation cr -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6607,7 +6614,7 @@ test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fil set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + fconfigure $f -translation cr -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6635,7 +6642,7 @@ test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {f set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation crlf + fconfigure $f -translation crlf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6663,7 +6670,7 @@ test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + fconfigure $f -translation crlf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6783,47 +6790,57 @@ test io-49.5 {testing crlf reading, leftover cr disgorgment} { set l } [list 7 a\rb\rc 7 {} 7 1] -test io-50.1 {testing handler deletion} {testchannelevent} { +test io-50.1 {testing handler deletion} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f]] + update proc delhandler {f} { variable z set z called testchannelevent $f delete 0 } set z not_called - update - close $f + set timer [after 50 lappend z timeout] + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f]] + testservicemode 1 + vwait z + after cancel $timer set z -} called -test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} { +} -cleanup { + close $f +} -result called +test io-50.2 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delhandler $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] proc delhandler {f i} { variable z - lappend z "called delhandler $f $i" + lappend z "called delhandler $i" testchannelevent $f delete 0 } set z "" - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delhandler $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z +} -cleanup { close $f - string compare [string tolower $z] \ - [list [list called delhandler $f 0] [list called delhandler $f 1]] -} 0 -test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} { +} -result {{called delhandler 0} {called delhandler 1}} +test io-50.3 {testing handler deletion with multiple handlers} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f 1]] - testchannelevent $f add readable [namespace code [list delhandler $f 0]] set z "" proc notcalled {f i} { variable z @@ -6832,23 +6849,30 @@ test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent proc delhandler {f i} { variable z testchannelevent $f delete 1 - lappend z "delhandler $f $i called" + lappend z "delhandler $i called" testchannelevent $f delete 0 - lappend z "delhandler $f $i deleted myself" + lappend z "delhandler $i deleted myself" } set z "" - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f 1]] + testchannelevent $f add readable [namespace code [list delhandler $f 0]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z +} -cleanup { close $f - string compare [string tolower $z] \ - [list [list delhandler $f 0 called] \ - [list delhandler $f 0 deleted myself]] -} 0 -test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -result {{delhandler 0 called} {delhandler 0 deleted myself}} +test io-50.4 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) + update +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list delrecursive $f]] + update proc delrecursive {f} { variable z variable u @@ -6863,18 +6887,22 @@ test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} { } variable u toplevel variable z "" - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list delrecursive $f]] + testservicemode 1 + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + set z +} -cleanup { close $f - string compare [string tolower $z] \ - {{delrecursive calling recursive} {delrecursive deleting recursive}} -} 0 -test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -result {{delrecursive calling recursive} {delrecursive deleting recursive}} +test io-50.5 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode notOSX} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list notcalled $f]] - testchannelevent $f add readable [namespace code [list del $f]] proc notcalled {f} { variable z lappend z "notcalled was called!! $f" @@ -6884,39 +6912,50 @@ test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} { variable z if {"$u" == "recursive"} { testchannelevent $f delete 1 - testchannelevent $f delete 0 lappend z "del deleted notcalled" + testchannelevent $f delete 0 lappend z "del deleted myself" } else { set u recursive lappend z "del calling recursive" - update - lappend z "del after update" + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + lappend z "del after recursive" } } set z "" set u toplevel - update + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list notcalled $f]] + testchannelevent $f add readable [namespace code [list del $f]] + testservicemode 1 + set timer [after 50 set z timeout] + vwait z + after cancel $timer + set z +} -cleanup { close $f - string compare [string tolower $z] \ - [list {del calling recursive} {del deleted notcalled} \ - {del deleted myself} {del after update}] -} 0 -test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} { +} -result [list {del calling recursive} {del deleted notcalled} \ + {del deleted myself} {del after recursive}] +test io-50.6 {testing handler deletion vs reentrant calls} -constraints {testchannelevent testservicemode} -setup { file delete $path(test1) +} -body { set f [open $path(test1) w] close $f - set f [open $path(test1) r] - testchannelevent $f add readable [namespace code [list second $f]] - testchannelevent $f add readable [namespace code [list first $f]] proc first {f} { variable u variable z + variable done if {"$u" == "toplevel"} { lappend z "first called" set u first - update - lappend z "first after update" + set timer [after 50 lappend z timeout] + vwait z + after cancel $timer + lappend z "first after toplevel" + set done 1 } else { lappend z "first called not toplevel" } @@ -6938,14 +6977,24 @@ test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} { } set z "" set u toplevel + set done 0 + testservicemode 0 + set f [open $path(test1) r] + testchannelevent $f add readable [namespace code [list second $f]] + testchannelevent $f add readable [namespace code [list first $f]] + testservicemode 1 update + if {!$done} { + set timer2 [after 200 set done 1] + vwait done + after cancel $timer2 + } + set z +} -cleanup { close $f - string compare [string tolower $z] \ - [list {first called} {first called not toplevel} \ - {second called, first time} {second called, second time} \ - {first after update}] -} 0 - +} -result [list {first called} {first called not toplevel} \ + {second called, first time} {second called, second time} \ + {first after toplevel}] test io-51.1 {Test old socket deletion on Macintosh} {socket} { set x 0 set result "" @@ -7107,7 +7156,7 @@ test io-52.6 {TclCopyChannel} {fcopy} { set f2 [open $path(test1) w] fconfigure $f1 -translation lf -blocking 0 fconfigure $f2 -translation lf -blocking 0 - set s0 [fcopy $f1 $f2 -size [expr [file size $thisScript] + 5]] + set s0 [fcopy $f1 $f2 -size [expr {[file size $thisScript] + 5}]] set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 close $f2 @@ -7135,7 +7184,7 @@ test io-52.7 {TclCopyChannel} {fcopy} { } set result } {0 0 ok} -test io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { +test io-52.8 {TclCopyChannel} {stdio fcopy} { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] @@ -7168,7 +7217,7 @@ set path(utf8-rp.txt) [makeFile {} utf8-rp.txt] # Create kyrillic file, use lf translation to avoid os eol issues set out [open $path(kyrillic.txt) w] fconfigure $out -encoding koi8-r -translation lf -puts $out "\u0410\u0410" +puts $out "АА" close $out test io-52.9 {TclCopyChannel & encodings} {fcopy} { # Copy kyrillic to UTF-8, using fcopy. @@ -7220,7 +7269,7 @@ test io-52.10 {TclCopyChannel & encodings} {fcopy} { test io-52.11 {TclCopyChannel & encodings} -setup { set out [open $path(utf8-fcopy.txt) w] fconfigure $out -encoding utf-8 -translation lf - puts $out "\u0410\u0410" + puts $out "АА" close $out } -constraints {fcopy} -body { # binary to encoding => the input has to be @@ -7415,7 +7464,7 @@ test io-53.2 {CopyData} {fcopy} { } set result } {0 0 ok} -test io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} { +test io-53.3 {CopyData: background read underflow} {stdio unix fcopy} { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] @@ -7447,7 +7496,7 @@ test io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} { close $f set result } "ready line1 line2 {done\n}" -test io-53.4 {CopyData: background write overflow} {stdio openpipe fileevent fcopy} { +test io-53.4 {CopyData: background write overflow} {stdio fileevent fcopy} { set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n variable x for {set x 0} {$x < 12} {incr x} { @@ -7531,14 +7580,14 @@ test io-53.5 {CopyData: error during fcopy} {socket fcopy} { close $listen ;# This means the socket open never really succeeds fcopy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g. } close $in close $out set fcopyTestDone ;# 1 for error condition } 1 -test io-53.6 {CopyData: error during fcopy} {stdio openpipe fcopy} { +test io-53.6 {CopyData: error during fcopy} {stdio fcopy} { variable fcopyTestDone file delete $path(pipe) file delete $path(test1) @@ -7550,7 +7599,7 @@ test io-53.6 {CopyData: error during fcopy} {stdio openpipe fcopy} { set out [open $path(test1) w] fcopy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] } catch {close $in} @@ -7571,7 +7620,7 @@ proc doFcopy {in out {bytes 0} {error {}}} { -command [namespace code [list doFcopy $in $out]]] } } -test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} { +test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} { variable fcopyTestDone file delete $path(pipe) catch {unset fcopyTestDone} @@ -7597,13 +7646,13 @@ test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} { set out [open $path(test1) w] doFcopy $in $out variable fcopyTestDone - if ![info exists fcopyTestDone] { + if {![info exists fcopyTestDone]} { vwait [namespace which -variable fcopyTestDone] } catch {close $in} close $out # -1=error 0=script error N=number of bytes - expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1 + expr {($fcopyTestDone == 0) ? $fcopyTestCount : -1} } {3450} test io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { # copy progress callback. errors out intentionally @@ -7623,7 +7672,7 @@ test io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. @@ -7664,7 +7713,7 @@ test io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Initialize and force eof on the input. seek $f 0 end ; read $f 1 set ::RES [eof $f] @@ -7704,7 +7753,7 @@ test io-53.8b {CopyData: async callback and -size 0} -setup { # Channels to copy between set f [open $foo r] ; fconfigure $f -translation binary set g [open $bar w] ; fconfigure $g -translation binary -buffering none -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { set ::RES {} # Run the copy. Should not invoke -command now. fcopy $f $g -size 0 -command ::cmd @@ -7761,7 +7810,7 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { } set ::forever {} set out [open $out w] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { fcopy $pipe $out -size 6 -command ::done set token [after 5000 { set ::forever {fcopy hangs} @@ -7831,7 +7880,7 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { fconfigure $b -translation binary -buffering none fileevent $a readable [list ::done $a] fileevent $b readable [list ::done $b] -} -constraints {stdio openpipe fcopy} -body { +} -constraints {stdio fcopy} -body { # Now pass data through the server in both directions. set ::forever {} puts $a AB @@ -7879,7 +7928,7 @@ test io-53.11 {Bug 2895565} -setup { removeFile out removeFile in } -result {40 bytes copied} -test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix openpipe fcopy} { +test io-53.12 {CopyData: foreground short reads, aka bug 3096275} {stdio unix fcopy} { file delete $path(pipe) set f1 [open $path(pipe) w] puts -nonewline $f1 { @@ -8085,7 +8134,7 @@ test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup { removeFile out } -result {line 100 line} -test io-54.1 {Recursive channel events} {socket fileevent knownMsvcBug} { +test io-54.1 {Recursive channel events} {socket fileevent notWinCI} { # This test checks to see if file events are delivered during recursive # event loops when there is buffered data on the channel. @@ -8294,7 +8343,7 @@ test io-57.2 {buffered data and file events, read} {fileevent} { set result } {1 readable 234567890 timer} -test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin openpipe fileevent} { +test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin fileevent} { set out [open $path(script) w] puts $out { puts "normal message from pipe" @@ -8334,13 +8383,13 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} { string equal $result [testmainthread] } {1} -test io-60.1 {writing illegal utf sequences} {openpipe fileevent testbytestring} { +test io-60.1 {writing illegal utf sequences} {fileevent testbytestring} { # This test will hang in older revisions of the core. set out [open $path(script) w] puts $out "catch {load $::tcltestlib Tcltest}" puts $out { - puts [testbytestring \xe2] + puts [testbytestring \xE2] exit 1 } proc readit {pipe} { @@ -8698,7 +8747,7 @@ test io-73.5 {effect of eof on encoding end flags} -setup { read $rfd } -body { set result [eof $rfd] - puts -nonewline $wfd "more\u00c2\u00a0data" + puts -nonewline $wfd "more\xC2\xA0data" lappend result [eof $rfd] lappend result [read $rfd] lappend result [eof $rfd] @@ -8706,22 +8755,22 @@ test io-73.5 {effect of eof on encoding end flags} -setup { close $wfd close $rfd removeFile io-73.5 -} -result [list 1 1 more\u00a0data 1] +} -result [list 1 1 more\xA0data 1] test io-74.1 {[104f2885bb] improper cache validity check} -setup { set fn [makeFile {} io-74.1] set rfd [open $fn r] testobj freeallvars - interp create slave + interp create child } -constraints testobj -body { teststringobj set 1 [string range $rfd 0 end] read [teststringobj get 1] testobj duplicate 1 2 - interp transfer {} $rfd slave + interp transfer {} $rfd child catch {read [teststringobj get 1]} read [teststringobj get 2] } -cleanup { - interp delete slave + interp delete child testobj freeallvars removeFile io-74.1 } -returnCodes error -match glob -result {can not find channel named "*"} diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 0e47d2f..dbca866 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -6,20 +6,20 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] package require tcltests @@ -494,14 +494,14 @@ test iocmd-12.10 {POSIX open access modes: BINARY} { } 5 test iocmd-12.11 {POSIX open access modes: BINARY} { set f [open $path(test1) {WRONLY BINARY TRUNC}] - puts $f \u0248 ;# gets truncated to \u0048 + puts $f Ɉ ;# gets truncated to H close $f set f [open $path(test1) r] fconfigure $f -translation binary set result [read -nonewline $f] close $f set result -} \u0048 +} H test iocmd-13.1 {errors in open command} { list [catch {open} msg] $msg @@ -2084,7 +2084,7 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb @@ -2122,7 +2122,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb @@ -2164,13 +2164,13 @@ test iocmd-32.2 {delete interp of reflected chan} { # Bug 3034840 # Run this test in an interp with memory debugging to panic # on the double free - interp create slave - slave eval { + interp create child + child eval { proc no-op args {} proc driver {sub args} {return {initialize finalize watch read}} chan event [chan create read driver] readable no-op } - interp delete slave + interp delete child } {} # ### ### ### ######### ######### ######### diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 0a335ff..79493e0 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -5,19 +5,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2007 Andreas Kupries <andreask@activestate.com> +# Copyright © 2007 Andreas Kupries <andreask@activestate.com> # <akupries@shaw.ca> # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Custom constraints used in this file testConstraint testchannel [llength [info commands testchannel]] @@ -36,8 +36,8 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # can access this variable. set helperscript { - if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -1162,7 +1162,7 @@ test iortrans-8.3 {chan flush, bug 2921116} -match glob -setup { test iortrans-11.0 {origin interpreter of moved transform gone} -setup { set ida [interp create]; #puts <<$ida>> set idb [interp create]; #puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb } -constraints {testchannel} -match glob -body { @@ -1205,7 +1205,7 @@ test iortrans-11.0 {origin interpreter of moved transform gone} -setup { test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup { set ida [interp create]; #puts <<$ida>> set idb [interp create]; #puts <<$idb>> - # Magic to get the test* commands in the slaves + # Magic to get the test* commands in the children load {} Tcltest $ida load {} Tcltest $idb } -constraints {testchannel} -match glob -body { @@ -1244,16 +1244,16 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces tempdone } -result {Owner lost} test iortrans-11.2 {delete interp of reflected transform} -setup { - interp create slave - # Magic to get the test* commands into the slave - load {} Tcltest slave + interp create child + # Magic to get the test* commands into the child + load {} Tcltest child } -constraints {testchannel} -body { - # Get base channel into the slave + # Get base channel into the child set c [tempchan] testchannel cut $c - interp eval slave [list testchannel splice $c] - interp eval slave [list set c $c] - slave eval { + interp eval child [list testchannel splice $c] + interp eval child [list set c $c] + child eval { proc no-op args {} proc driver {c sub args} { return {initialize finalize read write} @@ -1261,7 +1261,7 @@ test iortrans-11.2 {delete interp of reflected transform} -setup { set t [chan push $c [list driver $c]] chan event $c readable no-op } - interp delete slave + interp delete child } -cleanup { tempdone } -result {} diff --git a/tests/iogt.test b/tests/iogt.test index 3cac2cf..d397ccb 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -6,17 +6,17 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# Copyright (c) 2000 Ajuba Solutions. -# Copyright (c) 2000 Andreas Kupries. +# Copyright © 2000 Ajuba Solutions. +# Copyright © 2000 Andreas Kupries. # All rights reserved. -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] namespace eval ::tcl::test::iogt { namespace import ::tcltest::* diff --git a/tests/join.test b/tests/join.test index 4aeb093..3573fbd 100644 --- a/tests/join.test +++ b/tests/join.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lindex.test b/tests/lindex.test index 2b1742e..ffe0d9e 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -4,21 +4,21 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2001 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] set minus - testConstraint testevalex [llength [info commands testevalex]] @@ -449,6 +449,14 @@ test lindex-17.1 {Bug 1718580} -body { lindex a end foo } -match glob -result {bad index "foo"*} -returnCodes 1 +test lindex-18.0 {nested bytecode execution} -setup { + proc demo {i} {lindex {a b c} $i} +} -body { + demo 0+0x10000000000000000 +} -cleanup { + rename demo {} +} + catch { unset minus } # cleanup diff --git a/tests/link.test b/tests/link.test index 336634b..eba359c 100644 --- a/tests/link.test +++ b/tests/link.test @@ -4,20 +4,20 @@ # procedures. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testlink [llength [info commands testlink]] testConstraint testlinkarray [llength [info commands testlinkarray]] diff --git a/tests/linsert.test b/tests/linsert.test index 4939e5c..16ade39 100644 --- a/tests/linsert.test +++ b/tests/linsert.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/list.test b/tests/list.test index 2686bd7..905a3d3 100644 --- a/tests/list.test +++ b/tests/list.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -45,23 +45,23 @@ test list-1.24 {basic tests} {list} {} test list-1.25 {basic tests} {list # #} {{#} #} test list-1.26 {basic tests} {list #\{ #\{} {\#\{ #\{} test list-1.27 {basic null treatment} { - set l [list "" "\0" "\0\0"] - set e "{} \0 \0\0" + set l [list "" "\x00" "\x00\x00"] + set e "{} \x00 \x00\x00" string equal $l $e } 1 test list-1.28 {basic null treatment} { - set result "\0a\0b" + set result "\x00a\x00b" list $result [string length $result] -} "\0a\0b 4" +} "\x00a\x00b 4" test list-1.29 {basic null treatment} { - set result "\0a\0b" + set result "\x00a\x00b" set srep "$result 4" set lrep [list $result [string length $result]] string equal $srep $lrep } 1 test list-1.30 {basic null treatment} { - set l [list "\0abc" "xyz"] - set e "\0abc xyz" + set l [list "\x00abc" "xyz"] + set e "\x00abc xyz" string equal $l $e } 1 @@ -98,26 +98,26 @@ concat {} proc slowsort list { set result {} - set last [expr [llength $list] - 1] + set last [expr {[llength $list] - 1}] while {$last > 0} { - set minIndex [expr [llength $list] - 1] + set minIndex [expr {[llength $list] - 1}] set min [lindex $list $last] - set i [expr $minIndex-1] + set i [expr {$minIndex - 1}] while {$i >= 0} { if {[string compare [lindex $list $i] $min] < 0} { set minIndex $i set min [lindex $list $i] } - set i [expr $i-1] + incr i -1 } set result [concat $result [list $min]] if {$minIndex == 0} { set list [lrange $list 1 end] } else { - set list [concat [lrange $list 0 [expr $minIndex-1]] \ - [lrange $list [expr $minIndex+1] end]] + set list [concat [lrange $list 0 [expr {$minIndex - 1}]] \ + [lrange $list [expr {$minIndex + 1}] end]] } - set last [expr $last-1] + set last [expr {$last - 1}] } return [concat $result $list] } diff --git a/tests/listObj.test b/tests/listObj.test index d7fb46c..f17f085 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -5,19 +5,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] diff --git a/tests/llength.test b/tests/llength.test index 169c7ca..1122341 100644 --- a/tests/llength.test +++ b/tests/llength.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lmap.test b/tests/lmap.test index 641eac2..f1cbd4b 100644 --- a/tests/lmap.test +++ b/tests/lmap.test @@ -4,9 +4,9 @@ # 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 +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 2011 Trevor Davel # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -14,7 +14,7 @@ # RCS: @(#) $Id: $ if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -357,7 +357,7 @@ test lmap-7.2 {noncompiled lmap and shared variable or value list objects that a } -body { lmap {12.0} {a b c} { set x 12.0 - set x [expr $x + 1] + set x [expr {$x + 1}] } } -result {13.0 13.0 13.0} # Test for incorrect "double evaluation" semantics diff --git a/tests/load.test b/tests/load.test index 4cd1fcd..40901e5 100644 --- a/tests/load.test +++ b/tests/load.test @@ -4,19 +4,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Figure out what extension is used for shared libraries on this # platform. @@ -36,39 +36,39 @@ testConstraint $loaded [expr {![string match *pkga* $alreadyLoaded]}] set alreadyTotalLoaded [info loaded] -# Certain tests require the 'teststaticpkg' command from tcltest +# Certain tests require the 'teststaticlibrary' command from tcltest -testConstraint teststaticpkg [llength [info commands teststaticpkg]] +testConstraint teststaticlibrary [llength [info commands teststaticlibrary]] # Test load-10.1 requires the 'testsimplefilesystem' command from tcltest testConstraint testsimplefilesystem \ [llength [info commands testsimplefilesystem]] -test load-1.1 {basic errors} {} { - list [catch {load} msg] $msg -} "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 ?-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 -global {}} msg] $msg -} {1 {must specify either file name or package name}} -test load-1.5 {basic errors} {} { - 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-1.1 {basic errors} -returnCodes error -body { + load +} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"} +test load-1.2 {basic errors} -returnCodes error -body { + load a b c d +} -result {wrong # args: should be "load ?-global? ?-lazy? ?--? fileName ?prefix? ?interp?"} +test load-1.3 {basic errors} -returnCodes error -body { + load a b foobar +} -result {could not find interpreter "foobar"} +test load-1.4 {basic errors} -returnCodes error -body { + load -global {} +} -result {must specify either file name or prefix} +test load-1.5 {basic errors} -returnCodes error -body { + load -lazy {} {} +} -result {must specify either file name or prefix} +test load-1.6 {basic errors} -returnCodes error -body { + load {} Unknown +} -result {no library with prefix "Unknown" is loaded statically} +test load-1.7 {basic errors} -returnCodes error -body { + load -abc foo +} -result {bad option "-abc": must be -global, -lazy, or --} +test load-1.8 {basic errors} -returnCodes error -body { + load -global +} -result {couldn't figure out prefix for -global} test load-2.1 {basic loading, with guess for package name} \ [list $dll $loaded] { @@ -78,7 +78,7 @@ test load-2.1 {basic loading, with guess for package name} \ interp create -safe child test load-2.2 {loading into a safe interpreter, with package name conversion} \ [list $dll $loaded] { - load -lazy [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"}} @@ -90,7 +90,7 @@ test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] {TCL LOOKUP LOAD_SYMBOL *Foo_Init}] test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg -} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}} +} {1 {can't use library in a safe interpreter: no Pkga_SafeInit procedure}} test load-3.1 {error in _Init procedure, same interpreter} \ [list $dll $loaded] { @@ -103,7 +103,7 @@ test load-3.1 {error in _Init procedure, same interpreter} \ "if 44 {open non_existent}" invoked from within "load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} -test load-3.2 {error in _Init procedure, slave interpreter} \ +test load-3.2 {error in _Init procedure, child interpreter} \ [list $dll $loaded] { catch {interp delete x} interp create x @@ -125,21 +125,21 @@ test load-4.1 {reloading package into same interpreter} [list $dll $loaded] { list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg } {0 {}} test load-4.2 {reloading package into same interpreter} -setup { - catch {load [file join $testDir pkga$ext] pkga} + catch {load [file join $testDir pkga$ext] Pkga} } -constraints [list $dll $loaded] -returnCodes error -body { - load [file join $testDir pkga$ext] pkgb -} -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\"" + load [file join $testDir pkga$ext] Pkgb +} -result "file \"[file join $testDir pkga$ext]\" is already loaded for prefix \"Pkga\"" -test load-5.1 {file name not specified and no static package: pick default} \ - [list $dll $loaded] { +test load-5.1 {file name not specified and no static package: pick default} -setup { catch {interp delete x} interp create x - load -global [file join $testDir pkga$ext] pkga - load {} pkga x - set result [info loaded x] +} -constraints [list $dll $loaded] -body { + load -global [file join $testDir pkga$ext] Pkga + load {} Pkga x + info loaded x +} -cleanup { interp delete x - set result -} [list [list [file join $testDir pkga$ext] Pkga]] +} -result [list [list [file join $testDir pkga$ext] Pkga]] # On some platforms, like SunOS 4.1.3, these tests can't be run because # they cause the process to exit. @@ -150,94 +150,96 @@ test load-6.1 {errors loading file} [list $dll $loaded] { catch {load foo foo} } {1} -test load-7.1 {Tcl_StaticPackage procedure} [list teststaticpkg] { +test load-7.1 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" - teststaticpkg Test 1 0 - load {} Test - load {} Test child + teststaticlibrary Test 1 0 + load {} test + load {} test child list [set x] [child eval set x] } {loaded loaded} -test load-7.2 {Tcl_StaticPackage procedure} [list teststaticpkg] { +test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" - teststaticpkg Another 0 0 + teststaticlibrary Another 0 0 load {} Another child eval {set x "not loaded"} list [catch {load {} Another child} msg] $msg \ [child eval set x] [set x] -} {1 {can't use package in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} -test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] { +} {1 {can't use library in a safe interpreter: no Another_SafeInit procedure} {not loaded} loaded} +test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" - teststaticpkg More 0 1 - load {} More + teststaticlibrary More 0 1 + load {} more set x } {not loaded} -catch {load [file join $testDir pkga$ext] pkga} -catch {load [file join $testDir pkgb$ext] pkgb} -catch {load [file join $testDir pkge$ext] pkge} -set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] -test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup { - teststaticpkg Test 1 0 - teststaticpkg Another 0 0 - teststaticpkg More 0 1 -} -constraints [list teststaticpkg $dll $loaded] -body { - teststaticpkg Double 0 1 - teststaticpkg Double 0 1 +catch {load [file join $testDir pkga$ext] Pkga} +catch {load [file join $testDir pkgb$ext] Pkgb} +catch {load [file join $testDir pkge$ext] Pkge} +set currentRealLibraries [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] +test load-7.4 {Tcl_StaticLibrary procedure, redundant calls} -setup { + teststaticlibrary Test 1 0 + teststaticlibrary Another 0 0 + teststaticlibrary More 0 1 +} -constraints [list teststaticlibrary $dll $loaded] -body { + teststaticlibrary Double 0 1 + teststaticlibrary Double 0 1 info loaded -} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded] - -testConstraint teststaticpkg_8.x \ - [if {[testConstraint teststaticpkg]} { - teststaticpkg Test 1 1 - teststaticpkg Another 0 1 - teststaticpkg More 0 1 - teststaticpkg Double 0 1 - expr 1 - } else { - expr 0 - }] - -test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded] + +testConstraint teststaticlibrary_8.x 0 +if {[testConstraint teststaticlibrary]} { + catch { + teststaticlibrary Test 1 1 + teststaticlibrary Another 0 1 + teststaticlibrary More 0 1 + teststaticlibrary Double 0 1 + testConstraint teststaticlibrary_8.x 1 + } +} + +test load-8.1 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded] -} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]] -test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body { +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealLibraries {*}$alreadyTotalLoaded]] +test load-8.2 {TclGetLoadedLibraries procedure} -constraints {teststaticlibrary_8.x} -body { info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} -test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.3a {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded {}] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] -test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.3b {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded child] } [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] -test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { - load [file join $testDir pkgb$ext] pkgb +test load-8.4 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { + load [file join $testDir pkgb$ext] Pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] } [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child -test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \ - -constraints {teststaticpkg} \ - -setup { - interp create child1 - interp create child2 - load {} Tcltest child1 - load {} Tcltest child2 - } \ - -body { - child1 eval { teststaticpkg Loadninepointone 0 1 } - child2 eval { teststaticpkg Loadninepointone 0 1 } - list \ - [child1 eval { info loaded {} }] \ - [child2 eval { info loaded {} }] - } \ - -match glob -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} \ - -cleanup { interp delete child1 ; interp delete child2 } - -test load-10.1 {load from vfs} \ - -constraints [list $dll $loaded testsimplefilesystem] \ - -setup {set dir [pwd]; cd $testDir; testsimplefilesystem 1} \ - -body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \ - -result {0 {}} \ - -cleanup {testsimplefilesystem 0; cd $dir; unset dir} +test load-9.1 {Tcl_StaticLibrary, load already-loaded package into another interp} -setup { + interp create child1 + interp create child2 + load {} Tcltest child1 + load {} Tcltest child2 +} -constraints {teststaticlibrary} -body { + child1 eval { teststaticlibrary Loadninepointone 0 1 } + child2 eval { teststaticlibrary Loadninepointone 0 1 } + list [child1 eval { info loaded {} }] \ + [child2 eval { info loaded {} }] +} -match glob -cleanup { + interp delete child1 + interp delete child2 +} -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} + +test load-10.1 {load from vfs} -setup { + set dir [pwd] + cd $testDir + testsimplefilesystem 1 +} -constraints [list $dll $loaded testsimplefilesystem] -body { + list [catch {load simplefs:/pkgd$ext Pkgd} msg] $msg +} -result {0 {}} -cleanup { + testsimplefilesystem 0 + cd $dir + unset dir +} test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \ [list $dll $loaded] { diff --git a/tests/lpop.test b/tests/lpop.test index 3e28978..272c82f 100644 --- a/tests/lpop.test +++ b/tests/lpop.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lrange.test b/tests/lrange.test index 5798707..695c370 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -4,20 +4,20 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testpurebytesobj [llength [info commands testpurebytesobj]] diff --git a/tests/lrepeat.test b/tests/lrepeat.test index e89f1b7..c1c8b02 100644 --- a/tests/lrepeat.test +++ b/tests/lrepeat.test @@ -4,13 +4,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2003 by Simon Geard. +# Copyright © 2003 Simon Geard. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lreplace.test b/tests/lreplace.test index 4ce3ef4..0b26e86 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/lsearch.test b/tests/lsearch.test index b188924..7c1402d 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -102,13 +102,13 @@ test lsearch-3.7 {lsearch errors} -returnCodes error -body { } -result {-subindices cannot be used without -index option} test lsearch-4.1 {binary data} { - lsearch -exact [list foo one\000two bar] bar + lsearch -exact [list foo one\x00two bar] bar } 2 test lsearch-4.2 {binary data} { set x one append x \x00 append x two - lsearch -exact [list foo one\000two bar] $x + lsearch -exact [list foo one\x00two bar] $x } 1 # Make a sorted list @@ -149,14 +149,14 @@ test lsearch-5.2 {binary search} { } set res } $decreasingIntegers -test lsearch-5.3 {binary search finds leftmost occurances} { +test lsearch-5.3 {binary search finds leftmost occurrences} { set res {} for {set i 0} {$i < 10} {incr i} { lappend res [lsearch -integer -sorted $repeatingIncreasingIntegers $i] } set res } [list 0 5 10 15 20 25 30 35 40 45] -test lsearch-5.4 {binary search -decreasing finds leftmost occurances} { +test lsearch-5.4 {binary search -decreasing finds leftmost occurrences} { set res {} for {set i 9} {$i >= 0} {incr i -1} { lappend res [lsearch -sorted -integer -decreasing \ @@ -384,7 +384,7 @@ test lsearch-14.8 {combinations: -start, -inline and -not} { } {c4} test lsearch-15.1 {make sure no shimmering occurs} { - set x [expr int(sin(0))] + set x [expr {int(sin(0))}] lsearch -start $x $x $x } 0 diff --git a/tests/lset.test b/tests/lset.test index b1ed110..5093369 100644 --- a/tests/lset.test +++ b/tests/lset.test @@ -6,18 +6,18 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. +# Copyright © 2001 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] proc failTrace {name1 name2 op} { error "trace failed" diff --git a/tests/lsetComp.test b/tests/lsetComp.test index 32bfd5f..a719fe4 100644 --- a/tests/lsetComp.test +++ b/tests/lsetComp.test @@ -6,13 +6,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. +# Copyright © 2001 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index f1758f5..5a62a2a 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -4,13 +4,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2003 Tcl Core Team. +# Copyright © 2003 Tcl Core Team. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/macOSXLoad.test b/tests/macOSXLoad.test index 12c77e0..df35b8d 100644 --- a/tests/macOSXLoad.test +++ b/tests/macOSXLoad.test @@ -4,14 +4,14 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } set oldTSF $::tcltest::testSingleFile diff --git a/tests/main.test b/tests/main.test index 5b43b43..2d3f63c 100644 --- a/tests/main.test +++ b/tests/main.test @@ -1,8 +1,8 @@ # This file contains a collection of tests for generic/tclMain.c. -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcl::test::main { @@ -11,12 +11,10 @@ namespace eval ::tcl::test::main { # Is [exec] defined? testConstraint exec [llength [info commands exec]] - # Is the Tcltest package loaded? - # - that is, the special C-coded testing commands in tclTest.c - # - tests use testing commands introduced in Tcltest 8.4 - testConstraint Tcltest [expr { - [llength [package provide Tcltest]] - && [package vsatisfies [package provide Tcltest] 8.5-]}] + # Is the tcl::test package loaded? + testConstraint tcl::test [expr { + [llength [package provide tcl::test]] + && [package vsatisfies [package provide tcl::test] 8.5-]}] # Procedure to simulate interactive typing of commands, line by line proc type {chan script} { @@ -70,56 +68,56 @@ namespace eval ::tcl::test::main { stdio } -setup { makeFile {puts [list $argv0 $argv $tcl_interactive]} script - catch {set f [open "|[list [interpreter] script \u00c0]" r]} + catch {set f [open "|[list [interpreter] script À]" r]} } -body { read $f } -cleanup { close $f removeFile script } -result [list script [list [encoding convertfrom [encoding system] \ - [encoding convertto [encoding system] \u00c0]]] 0]\n + [encoding convertto [encoding system] À]]] 0]\n test Tcl_Main-1.4 { } -constraints { stdio } -setup { makeFile {puts [list $argv0 $argv $tcl_interactive]} script - catch {set f [open "|[list [interpreter] script \u20ac]" r]} + catch {set f [open "|[list [interpreter] script €]" r]} } -body { read $f } -cleanup { close $f removeFile script } -result [list script [list [encoding convertfrom [encoding system] \ - [encoding convertto [encoding system] \u20ac]]] 0]\n + [encoding convertto [encoding system] €]]] 0]\n test Tcl_Main-1.5 { } -constraints { stdio } -setup { - makeFile {puts [list $argv0 $argv $tcl_interactive]} \u00c0 - catch {set f [open "|[list [interpreter] \u00c0]" r]} + makeFile {puts [list $argv0 $argv $tcl_interactive]} À + catch {set f [open "|[list [interpreter] À]" r]} } -body { read $f } -cleanup { close $f - removeFile \u00c0 + removeFile À } -result [list [list [encoding convertfrom [encoding system] \ - [encoding convertto [encoding system] \u00c0]]] {} 0]\n + [encoding convertto [encoding system] À]]] {} 0]\n test Tcl_Main-1.6 { } -constraints { stdio } -setup { - makeFile {puts [list $argv0 $argv $tcl_interactive]} \u20ac - catch {set f [open "|[list [interpreter] \u20ac]" r]} + makeFile {puts [list $argv0 $argv $tcl_interactive]} € + catch {set f [open "|[list [interpreter] €]" r]} } -body { read $f } -cleanup { close $f - removeFile \u20ac + removeFile € } -result [list [list [encoding convertfrom [encoding system] \ - [encoding convertto [encoding system] \u20ac]]] {} 0]\n + [encoding convertto [encoding system] €]]] {} 0]\n test Tcl_Main-1.7 { Tcl_Main: startup script - -encoding option @@ -131,8 +129,8 @@ namespace eval ::tcl::test::main { set f [open $script w] chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} - puts -nonewline $f {puts [string equal \u20ac } - puts $f "\u20ac]" + puts -nonewline $f {puts [string equal € } + puts $f "€]" close $f catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]} } -body { @@ -153,7 +151,7 @@ namespace eval ::tcl::test::main { chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } - puts $f "\u20ac]" + puts $f "€]" close $f catch {set f [open "|[list [interpreter] -encoding ascii script]" r]} } -body { @@ -174,7 +172,7 @@ namespace eval ::tcl::test::main { chan configure $f -encoding utf-8 puts $f {puts [list $argv0 $argv $tcl_interactive]} puts -nonewline $f {puts [string equal \u20ac } - puts $f "\u20ac]" + puts $f "€]" close $f catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]} } -body { @@ -192,7 +190,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.1 { Tcl_Main: appInitProc returns error } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile {puts "In script"} script } -body { @@ -208,7 +206,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.2 { Tcl_Main: appInitProc returns error } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << {puts "In script"} -appinitprocerror >& result set f [open result] @@ -221,7 +219,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.3 { Tcl_Main: appInitProc deletes interp } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile {puts "In script"} script } -body { @@ -237,7 +235,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.4 { Tcl_Main: appInitProc deletes interp } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << {puts "In script"} \ -appinitprocdeleteinterp >& result @@ -251,7 +249,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-2.5 { Tcl_Main: appInitProc closes stderr } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << {puts "In script"} \ -appinitprocclosestderr >& result @@ -336,7 +334,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-3.5 { Tcl_Main: startup script sets main loop } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile { rename exit _exit @@ -364,7 +362,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-3.6 { Tcl_Main: startup script sets main loop and closes stdin } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile { close stdin @@ -393,7 +391,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-3.7 { Tcl_Main: startup script deletes interp } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile { rename exit _exit @@ -417,7 +415,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-3.8 { Tcl_Main: startup script deletes interp and sets mainloop } -constraints { - exec Tcltest + exec tcl::test } -setup { makeFile { testsetmainloop @@ -461,7 +459,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.1 { Tcl_Main: rcFile evaluation deletes interp } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile {testinterpdelete {}} rc] } -body { @@ -478,7 +476,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.2 { Tcl_Main: rcFile evaluation closes stdin } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile {close stdin} rc] } -body { @@ -495,7 +493,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.3 { Tcl_Main: rcFile evaluation closes stdin and sets main loop } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile { close stdin @@ -523,7 +521,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.4 { Tcl_Main: rcFile evaluation sets main loop } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile { testsetmainloop @@ -550,7 +548,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-4.5 { Tcl_Main: Bug 1481986 } -constraints { - exec Tcltest + exec tcl::test } -setup { set rc [makeFile { testsetmainloop @@ -608,12 +606,12 @@ namespace eval ::tcl::test::main { catch {set f [open "|[list [interpreter]]" w+]} catch {chan configure $f -blocking 0} } -body { - type $f "chan configure stdin -eofchar \\032 - if 1 \{\n\032" + type $f "chan configure stdin -eofchar \"\\x1A {}\" + if 1 \{\n\x1A" variable wait chan event $f readable \ [list set [namespace which -variable wait] "child exit"] - set id [after 2000 [list set [namespace which -variable wait] timeout]] + set id [after 5000 [list set [namespace which -variable wait] timeout]] vwait [namespace which -variable wait] after cancel $id set wait @@ -636,7 +634,7 @@ namespace eval ::tcl::test::main { variable wait chan event $f readable \ [list set [namespace which -variable wait] "child exit"] - set id [after 2000 [list set [namespace which -variable wait] timeout]] + set id [after 5000 [list set [namespace which -variable wait] timeout]] vwait [namespace which -variable wait] after cancel $id set wait @@ -698,7 +696,7 @@ namespace eval ::tcl::test::main { Tcl_Main: interactive mode: close stdin -> main loop & [exit] & exit handlers } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { rename exit _exit @@ -722,7 +720,7 @@ namespace eval ::tcl::test::main { Tcl_Main: interactive mode: delete interp -> main loop & exit handlers, but no [exit] } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { rename exit _exit @@ -745,7 +743,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-5.10 { Tcl_Main: exit main loop in mid-interactive command } -constraints { - exec Tcltest + exec tcl::test } -setup { catch {set f [open "|[list [interpreter]]" w+]} catch {chan configure $f -blocking 0} @@ -766,7 +764,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-5.11 { Tcl_Main: EOF in interactive main loop } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { rename exit _exit @@ -788,7 +786,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-5.12 { Tcl_Main: close stdin in interactive main loop } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { rename exit _exit @@ -841,7 +839,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-6.2 { Tcl_Main: prompt deletes interp } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { set tcl_prompt1 {testinterpdelete {}} @@ -893,7 +891,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-6.5 { Tcl_Main: interactive entry to main loop } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { set tcl_interactive 1 @@ -943,7 +941,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-7.1 { Tcl_Main: [exit] defined as no-op -> still have exithandlers } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { proc exit args {} @@ -959,7 +957,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-7.2 { Tcl_Main: [exit] defined as no-op -> still have exithandlers } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { proc exit args {} @@ -979,7 +977,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.1 { StdinProc: handles non-blocking stdin } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -996,7 +994,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.2 { StdinProc: handles stdin EOF } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1018,7 +1016,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.3 { StdinProc: handles interactive stdin EOF } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1039,7 +1037,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.4 { StdinProc: handles stdin close } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1062,7 +1060,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.5 { StdinProc: handles interactive stdin close } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1086,7 +1084,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.6 { StdinProc: handles event loop re-entry } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1105,7 +1103,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.7 { StdinProc: handling of errors } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1122,7 +1120,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.8 { StdinProc: handling of errors, closed stderr } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1140,7 +1138,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.9 { StdinProc: interactive output } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1156,7 +1154,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.10 { StdinProc: interactive output, closed stdout } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1174,7 +1172,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.11 { StdinProc: prompt deletes interp } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1190,7 +1188,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.12 { StdinProc: prompt closes stdin } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << { testsetmainloop @@ -1209,7 +1207,7 @@ namespace eval ::tcl::test::main { test Tcl_Main-8.13 { Bug 1775878 } -constraints { - exec Tcltest + exec tcl::test } -body { exec [interpreter] << "testsetmainloop\nputs \\\npwd\ntestexitmainloop" >& result set f [open result] diff --git a/tests/mathop.test b/tests/mathop.test index 958a56f..e38001d 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -4,14 +4,14 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 2006 Donal K. Fellows -# Copyright (c) 2006 Peter Spjuth +# Copyright © 2006 Donal K. Fellows +# Copyright © 2006 Peter Spjuth # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.1 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -901,10 +901,10 @@ test mathop-22.2 { bitwise ops on bignums } { set exp {} foreach d {5 7 2 1 D C 1 F E 0 -D -D 8 -9 -1 -0 -E E} { if {[string match "-*" $d]} { - set d [format %X [expr 15-0x[string range $d 1 end]]] - set val [expr -0x[string repeat $d $dig]-1] + set d [format %X [expr {15-"0x[string range $d 1 end]"}]] + set val [expr {-"0x[string repeat $d $dig]"-1}] } else { - set val [expr 0x[string repeat $d $dig]] + set val [expr {"0x[string repeat $d $dig]"}] } lappend exp $val } diff --git a/tests/misc.test b/tests/misc.test index db8b14a..3fce454 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -5,20 +5,20 @@ # tests are pathological cases that caused bugs in earlier Tcl # releases. # -# Copyright (c) 1992-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1992-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testhashsystemhash [llength [info commands testhashsystemhash]] diff --git a/tests/msgcat.test b/tests/msgcat.test index 4ab3622..4549cee 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -2,8 +2,8 @@ # Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1998 Mark Harrison. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998 Mark Harrison. +# Copyright © 1998-1999 Scriptics Corporation. # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # # See the file "license.terms" for information on usage and redistribution @@ -12,10 +12,9 @@ # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. -package require Tcl 8.5- -if {[catch {package require tcltest 2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } if {[catch {package require msgcat 1.6}]} { puts stderr "Skipping tests in [info script]. No msgcat 1.6 found to test." diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 1d6a805..06eedfd 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -7,15 +7,15 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1997 Lucent Technologies -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1997 Lucent Technologies +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -749,13 +749,13 @@ test namespace-old-9.14 {imported commands can be removed} { } {{} 1 {invalid command name "cmd1"}} test namespace-old-9.15 {existing commands can't be overwritten} { proc cmd1 {x y} { - return [expr $x+$y] + return [expr {$x+$y}] } list [catch {namespace import test_ns_import::cmd?} msg] $msg \ [cmd1 3 5] } {1 {can't import command "cmd1": already exists} 8} test namespace-old-9.16 {use "-force" option to override existing commands} { - proc cmd1 {x y} { return [expr $x+$y] } + proc cmd1 {x y} { return [expr {$x+$y}] } list [cmd1 3 5] \ [namespace import -force test_ns_import::cmd?] \ [cmd1 3 5] diff --git a/tests/namespace.test b/tests/namespace.test index 0d93092..efd00a8 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -6,18 +6,20 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-2000 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} testConstraint memory [llength [info commands memory]] ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # # REMARK: the tests for 'namespace upvar' are not done here. They are to be @@ -179,21 +181,21 @@ test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} namespace delete test_ns_2 } {} test namespace-7.7 {Bug 1655305} -setup { - interp create slave + interp create child # Can't invoke through the ensemble, since deleting the global namespace # (indirectly, via deleting ::tcl) deletes the ensemble. - slave eval {rename ::tcl::info::commands ::infocommands} - slave hide infocommands - slave eval { + child eval {rename ::tcl::info::commands ::infocommands} + child hide infocommands + child eval { proc foo {} { namespace delete :: } } } -body { - slave eval foo - slave invokehidden infocommands + child eval foo + child invokehidden infocommands } -cleanup { - interp delete slave + interp delete child } -result {} test namespace-7.8 {Bug ba1419303b4c} -setup { @@ -269,28 +271,28 @@ test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} [info commands test_ns_import::*] } [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p] test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add execution error leave {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add execution error leave {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorInfo } {bar invoked from within -"slave eval error foo bar baz"} +"child eval error foo bar baz"} test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add variable errorCode write {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add variable errorCode write {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorInfo } {bar invoked from within -"slave eval error foo bar baz"} +"child eval error foo bar baz"} test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave - slave eval {trace add execution error leave {namespace delete :: ;#}} - catch {slave eval error foo bar baz} - interp delete slave + interp create child + child eval {trace add execution error leave {namespace delete :: ;#}} + catch {child eval error foo bar baz} + interp delete child set ::errorCode } baz @@ -2797,9 +2799,9 @@ test namespace-51.15 {namespace resolution path control} -body { namespace delete ::test_ns_2 } test namespace-51.16 {Bug 1566526} { - interp create slave - slave eval namespace eval demo namespace path :: - interp delete slave + interp create child + child eval namespace eval demo namespace path :: + interp delete child } {} test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup { set result {} @@ -3000,19 +3002,19 @@ test namespace-52.11 {unknown: with TCL_EVAL_INVOKE} -setup { } } catch {rename ::noSuchCommand {}} - set ::slave [interp create] + set ::child [interp create] } -body { - $::slave alias bar noSuchCommand + $::child alias bar noSuchCommand namespace eval test_ns_1 { namespace unknown unknown proc unknown args { return FAIL } - $::slave eval bar + $::child eval bar } } -cleanup { - interp delete $::slave - unset ::slave + interp delete $::child + unset ::child namespace delete test_ns_1 rename ::unknown {} rename unknown.save ::unknown @@ -3337,6 +3339,49 @@ test namespace-56.5 {Bug 8b9854c3d8} -setup { namespace delete namespace-56.5 } -result 1 + + +test namespace-57.0 { + an imported alias should be usable in the deletion trace for the alias + + see 29e8848eb976 +} -body { + variable res {} + namespace eval ns2 { + namespace export * + proc p1 {oldname newname op} { + return success + } + + interp alias {} [namespace current]::p2 {} [namespace which p1] + } + + + namespace eval ns3 { + namespace import ::ns2::p2 + } + + + set ondelete [list apply [list {oldname newname op} { + variable res + catch { + ns3::p2 $oldname $newname $op + } cres + lappend res $cres + } [namespace current]]] + + + trace add command ::ns2::p2 delete $ondelete + rename ns2::p2 {} + return $res +} -cleanup { + unset res + namespace delete ns2 + namespace delete ns3 +} -result success + + + # cleanup catch {rename cmd1 {}} diff --git a/tests/notify.test b/tests/notify.test index d2b9123..840ad31 100644 --- a/tests/notify.test +++ b/tests/notify.test @@ -8,18 +8,18 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. +# Copyright © 2003 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testevent [llength [info commands testevent]] diff --git a/tests/nre.test b/tests/nre.test index 58f5511..8296569 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -4,18 +4,18 @@ # avoids recursive calls to TEBC. Only the NRE behaviour is tested here, the # actual command functionality is tested in the specific test file. # -# Copyright (c) 2008 by Miguel Sofer. +# Copyright © 2008 Miguel Sofer. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testnrelevels [llength [info commands testnrelevels]] diff --git a/tests/obj.test b/tests/obj.test index 5bcffa3..4fa8d3a 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -5,19 +5,19 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] @@ -34,7 +34,7 @@ test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} tes string } { set first [string first $t [testobj types]] - set r [expr {$r && ($first != -1)}] + set r [expr {$r && ($first >= 0)}] } set result $r } {1} @@ -251,10 +251,10 @@ test obj-13.7 {SetBooleanFromAny, error converting from "empty string"} testobj } {{} 1 {expected boolean value but got ""}} test obj-13.8 {SetBooleanFromAny, unicode strings} testobj { set result "" - lappend result [teststringobj set 1 1\u7777] + lappend result [teststringobj set 1 1睷] lappend result [catch {testbooleanobj not 1} msg] lappend result $msg -} "1\u7777 1 {expected boolean value but got \"1\u7777\"}" +} "1睷 1 {expected boolean value but got \"1睷\"}" test obj-14.1 {UpdateStringOfBoolean} testobj { set result "" diff --git a/tests/oo.test b/tests/oo.test index c73c36c..168baee 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2,14 +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-2013 Donal K. Fellows +# Copyright © 2006-2013 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0.3 -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +package require tcl::oo 1.0.3 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -38,14 +38,14 @@ if {[testConstraint memory]} { test oo-0.1 {basic test of OO's ability to clean up its initial state} { interp create t t eval { - package require TclOO + package require tcl::oo } interp delete t } {} test oo-0.2 {basic test of OO's ability to clean up its initial state} { set i [interp create] interp eval $i { - package require TclOO + package require tcl::oo namespace delete :: } interp delete $i @@ -79,7 +79,7 @@ test oo-0.6 {cleaning the core class pair; way #1} -setup { interp create t } -body { t eval { - package require TclOO + package require tcl::oo namespace path oo list [catch {class destroy} m] $m [catch {object destroy} m] $m } @@ -90,7 +90,7 @@ test oo-0.7 {cleaning the core class pair; way #2} -setup { interp create t } -body { t eval { - package require TclOO + package require tcl::oo namespace path oo list [catch {object destroy} m] $m [catch {class destroy} m] $m } @@ -109,10 +109,10 @@ test oo-0.8 {leak in variable management} -setup { } -cleanup { foo destroy } -result 0 -test oo-0.9 {various types of presence of the TclOO package} { - list [lsearch -nocase -all -inline [package names] tcloo] \ - [package present TclOO] [expr {$::oo::patchlevel in [package versions TclOO]}] -} [list TclOO $::oo::patchlevel 1] +test oo-0.9 {various types of presence of the tcl::oo package} { + list [lsearch -nocase -all -inline [package names] tcl::oo] \ + [package present tcl::oo] [expr {$::oo::patchlevel in [package versions tcl::oo]}] +} [list tcl::oo $::oo::patchlevel 1] test oo-1.1 {basic test of OO functionality: no classes} { set result {} @@ -304,19 +304,19 @@ test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup { rename test-oo-1.18 {} } -result 0 test oo-1.18.3 {Bug 21c144f0f5} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { oo::define [oo::class create foo] superclass oo::class oo::class destroy } } -cleanup { - interp delete slave + interp delete child } test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { oo::class create A oo::class create B { superclass oo::class @@ -328,12 +328,12 @@ test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup { [B create C] create d } } -returnCodes error -cleanup { - interp delete slave + interp delete child } -result {class should only be a direct superclass once} test oo-1.18.5 {correct handling of cleanup in superclass set error} -setup { - interp create slave + interp create child } -body { - slave eval { + child eval { oo::class create A oo::class create B { superclass oo::class @@ -345,7 +345,7 @@ test oo-1.18.5 {correct handling of cleanup in superclass set error} -setup { [B create C {B C}] create d } } -returnCodes error -cleanup { - interp delete slave + interp delete child } -result {attempt to form circular dependency graph} test oo-1.19 {basic test of OO functionality: teardown order} -body { oo::object create o @@ -383,7 +383,7 @@ test oo-2.1 {basic test of OO functionality: constructor} -setup { # we're modifying the root object class's constructor interp create subinterp subinterp eval { - package require TclOO + package require tcl::oo } } -body { subinterp eval { @@ -514,7 +514,7 @@ test oo-3.1 {basic test of OO functionality: destructor} -setup { # modifying the root object class's constructor interp create subinterp subinterp eval { - package require TclOO + package require tcl::oo } } -body { subinterp eval { @@ -534,7 +534,7 @@ test oo-3.2 {basic test of OO functionality: destructor} -setup { # we're modifying the root object class's constructor interp create subinterp subinterp eval { - package require TclOO + package require tcl::oo } } -body { subinterp eval { @@ -1439,16 +1439,16 @@ test oo-7.8 {OO: next at the end of the method chain} -setup { } -result {foo2 foo 1 {no next method implementation}} test oo-7.9 {OO: defining inheritance in namespaces} -setup { set ::result {} - oo::class create ::master + oo::class create ::parent namespace eval ::foo { - oo::class create mixin {superclass ::master} + oo::class create mixin {superclass ::parent} } } -cleanup { - ::master destroy + ::parent destroy namespace delete ::foo } -body { namespace eval ::foo { - oo::class create bar {superclass master} + oo::class create bar {superclass parent} oo::class create boo oo::define boo {superclass bar} oo::define boo {mixin mixin} @@ -1967,7 +1967,7 @@ test oo-13.5 {OO: changing an object's class: non-class to class} -setup { class oo::class } oo::define fooObj { - method x {} {expr 1+2+3} + method x {} {expr {1+2+3}} } [fooObj new] x } -cleanup { @@ -1979,7 +1979,7 @@ test oo-13.6 {OO: changing an object's class: class to non-class} -setup { } -body { set result dangling oo::define foo { - method x {} {expr 1+2+3} + method x {} {expr {1+2+3}} } oo::class create boo { superclass foo @@ -2002,7 +2002,7 @@ test oo-13.7 {OO: changing an object's class} -setup { } -body { oo::define bar method x {} {return ok} oo::define foo { - method x {} {expr 1+2+3} + method x {} {expr {1+2+3}} self mixin foo } lappend result [foo x] @@ -2016,7 +2016,7 @@ test oo-13.8 {OO: changing an object's class to itself} -setup { oo::class create foo } -body { oo::define foo { - method x {} {expr 1+2+3} + method x {} {expr {1+2+3}} } oo::objdefine foo class foo } -cleanup { @@ -2135,18 +2135,18 @@ test oo-14.5 {OO and mixins and filters - advanced case} -setup { mix destroy } -result >>foobar<< test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create A { - superclass master + superclass parent method egg {} { return chicken } } oo::class create B { - superclass master + superclass parent mixin A method bar {} { # mixin from A @@ -2154,7 +2154,7 @@ test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { } } oo::class create C { - superclass master + superclass parent mixin B method foo {} { # mixin from B @@ -2164,12 +2164,12 @@ test oo-14.6 {OO and mixins of mixins - Bug 1960703} -setup { [C new] foo } -result chicken test oo-14.7 {OO and filters from mixins of mixins} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create A { - superclass master + superclass parent method egg {} { return chicken } @@ -2180,7 +2180,7 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup { } } oo::class create B { - superclass master + superclass parent mixin A filter f method bar {} { @@ -2189,7 +2189,7 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup { } } oo::class create C { - superclass master + superclass parent mixin B filter f method foo {} { @@ -2201,18 +2201,18 @@ test oo-14.7 {OO and filters from mixins of mixins} -setup { } -result {(foo) (bar) (egg) chicken (egg) (bar) (foo)} test oo-14.8 {OO: class mixin order - Bug 1998221} -setup { set ::result {} - oo::class create master { + oo::class create parent { method test {} {} } } -cleanup { - master destroy + parent destroy } -body { oo::class create mix { - superclass master + superclass parent method test {} {lappend ::result mix; next; return $::result} } oo::class create cls { - superclass master + superclass parent mixin mix method test {} {lappend ::result cls; next; return $::result} } @@ -2915,13 +2915,13 @@ test oo-18.7 {OO: objdefine command support} -setup { invoked from within "oo::objdefine inst {rename ::inst ::INST;error foo}"}} test oo-18.8 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {foobar while executing "error foobar" @@ -2932,15 +2932,15 @@ test oo-18.8 {OO: define/self command support} -setup { invoked from within "oo::define foo {rename ::foo ::bar; self {error foobar}}"} test oo-18.9 {OO: define/self command support} -setup { - oo::class create master + oo::class create parent set c [oo::class create now_this_is_a_very_very_long_class_name_indeed { - superclass master + superclass parent }] } -body { catch {oo::define $c {error err}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {err while executing "error err" @@ -2948,13 +2948,13 @@ test oo-18.9 {OO: define/self command support} -setup { invoked from within "oo::define $c {error err}"} test oo-18.10 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {foobar while executing "error foobar" @@ -2965,13 +2965,13 @@ test oo-18.10 {OO: define/self command support} -setup { invoked from within "oo::define foo {self {rename ::foo {}; error foobar}}"} test oo-18.11 {OO: define/self command support} -setup { - oo::class create master - oo::class create ::foo {superclass master} + oo::class create parent + oo::class create ::foo {superclass parent} } -body { catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt dict get $opt -errorinfo } -cleanup { - master destroy + parent destroy } -result {this command cannot be called when the object has been deleted while executing "self {error foobar}" @@ -3594,12 +3594,12 @@ test oo-27.2 {variables declaration - object introspection} -setup { info object variables foo } -result {a b c} test oo-27.3 {variables declaration - basic behaviour} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -3609,13 +3609,13 @@ test oo-27.3 {variables declaration - basic behaviour} -setup { bar y } -result 3 test oo-27.4 {variables declaration - destructors too} -setup { - oo::class create master + oo::class create parent set result bad! } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -3640,12 +3640,12 @@ test oo-27.5 {variables declaration - object-bound variables} -setup { foo y } -result 2 test oo-27.6 {variables declaration - non-interference of levels} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -3660,12 +3660,12 @@ test oo-27.6 {variables declaration - non-interference of levels} -setup { list [bar y] [lsort [info object vars bar]] [bar eval {info vars *!}] } -result {{3 2 y! {}} {x! y!} {x! y!}} test oo-27.7 {variables declaration - one underlying variable space} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x! constructor {} {set x! 1} method y {} {incr x!} @@ -3692,12 +3692,12 @@ test oo-27.9 {variables declaration - error cases - arrays} -body { oo::define oo::object variable bad(var) } -returnCodes error -result {invalid declared variable name "bad(var)": must not refer to an array element} test oo-27.10 {variables declaration - no instance var leaks with class resolvers} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable clsvar constructor {} { set clsvar 0 @@ -3720,12 +3720,12 @@ test oo-27.10 {variables declaration - no instance var leaks with class resolver list [inst1 value] [inst2 value] } -result {3 2} test oo-27.11 {variables declaration - no instance var leaks with class resolvers} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable clsvar constructor {} { set clsvar 0 @@ -3793,12 +3793,12 @@ test oo-27.13 {variables declaration: Bug 3185009: require refcount management} foo destroy } -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}} test oo-27.14 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable y method boo {} { @@ -3809,12 +3809,12 @@ test oo-27.14 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 2,2} test oo-27.15 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable variable x y method boo {} { @@ -3825,12 +3825,12 @@ test oo-27.15 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 2,2} test oo-27.16 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -clear variable y @@ -3842,12 +3842,12 @@ test oo-27.16 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 1,2} test oo-27.17 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -set y method boo {} { @@ -3858,12 +3858,12 @@ test oo-27.17 {variables declaration - multiple use} -setup { list [bar boo] [bar boo] } -result {1,1 1,2} test oo-27.18 {variables declaration - multiple use} -setup { - oo::class create master + oo::class create parent } -cleanup { - master destroy + parent destroy } -body { oo::class create foo { - superclass master + superclass parent variable x variable -? y method boo {} { @@ -3961,12 +3961,12 @@ test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup { } -result {v t} test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { oo::class create Super - oo::class create Master { + oo::class create Parent { superclass Super variable member1 member2 constructor {} { - set member1 master1 - set member2 master2 + set member1 parent1 + set member2 parent2 } method getChild {} { Child new [self] @@ -3987,10 +3987,10 @@ test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { method result {} {return $result} } } -body { - [[Master new] getChild] result + [[Parent new] getChild] result } -cleanup { Super destroy -} -result {master1 master2 master1 master2 master1 master2 master1 master2} +} -result {parent1 parent2 parent1 parent2 parent1 parent2 parent1 parent2} # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... diff --git a/tests/ooNext2.test b/tests/ooNext2.test index 6a48d28..3d28f3f 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -2,14 +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-2011 Donal K. Fellows +# Copyright © 2006-2011 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0.3 -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +package require tcl::oo 1.0.3 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -882,9 +882,9 @@ test oo-call-3.4 {current call introspection: in destructors} -setup { # caller set testopts { -setup { - oo::class create Master + oo::class create Parent oo::class create Foo { - superclass Master + superclass Parent method bar {} { puts abc tailcall puts hi @@ -892,11 +892,11 @@ set testopts { } } oo::class create Foo2 { - superclass Master + superclass Parent } } -cleanup { - Master destroy + Parent destroy } } diff --git a/tests/ooUtil.test b/tests/ooUtil.test index ff7093f..9a28c46 100644 --- a/tests/ooUtil.test +++ b/tests/ooUtil.test @@ -3,15 +3,15 @@ # the tests and generates output for errors. No output means no errors were # found. # -# Copyright (c) 2014-2016 Andreas Kupries -# Copyright (c) 2018 Donal K. Fellows +# Copyright © 2014-2016 Andreas Kupries +# Copyright © 2018 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0.3 -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +package require tcl::oo 1.0.3 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -153,7 +153,7 @@ test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup { oo::class create Table { superclass ActiveRecord } - # This is confirming that this is not the master interpreter + # This is confirming that this is not the parent interpreter list [Table find foo bar] [info globals childinterp] } } -cleanup { diff --git a/tests/opt.test b/tests/opt.test index 14a6e04..2d304c6 100644 --- a/tests/opt.test +++ b/tests/opt.test @@ -4,20 +4,20 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } # the package we are going to test -package require opt 0.4.7 +package require opt 0.4.8 # we are using implementation specifics to test the package @@ -27,8 +27,8 @@ package require opt 0.4.7 set n $::tcl::OptDescN test opt-1.1 {OptKeyRegister / check that auto allocation is skipping existing keys} { - list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr $n+1]] [::tcl::OptKeyRegister {}] -} "$n [expr $n+1] [expr $n+2]" + list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr {$n+1}]] [::tcl::OptKeyRegister {}] +} "$n [expr {$n+1}] [expr {$n+2}]" test opt-2.1 {OptKeyDelete} { list [::tcl::OptKeyRegister {} testkey] \ diff --git a/tests/package.test b/tests/package.test index 2dca06b..134b4f7 100644 --- a/tests/package.test +++ b/tests/package.test @@ -5,24 +5,24 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2011 Donal K. Fellows +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2011 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.3.3 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] -# Do all this in a slave interp to avoid garbaging the package list +# Do all this in a child interp to avoid garbaging the package list set i [interp create] -tcltest::loadIntoSlaveInterpreter $i {*}$argv +tcltest::loadIntoChildInterpreter $i {*}$argv catch [list load {} Tcltest $i] interp eval $i { namespace import -force ::tcltest::* @@ -945,15 +945,15 @@ test package-4.56 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { # No tests for FindPackage; can't think up anything detectable errors. test package-5.1 {TclFreePackageInfo procedure} { - interp create slave - slave eval { + interp create child + child eval { package ifneeded t 2.3 x package ifneeded t 2.4 y package ifneeded x 3.1 z package provide q 4.3 package unknown "will this get freed?" } - interp delete slave + interp delete child } {} test package-5.2 {TclFreePackageInfo procedure} -body { interp create foo @@ -1340,7 +1340,7 @@ proc prefer {args} { test package-13.0 {package prefer defaults} -body { prefer -} -result [expr {[string match {*[ab]*} [package provide Tcl]] ? "latest" : "stable"}] +} -result [expr {[string match {*[ab]*} [package provide tcl]] ? "latest" : "stable"}] test package-13.1 {package prefer defaults} -body { set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! prefer diff --git a/tests/parse.test b/tests/parse.test index 287c392..b0c051b 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -2,22 +2,22 @@ # file tclParse.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcl::test::parse { namespace import ::tcltest::* ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testparser [llength [info commands testparser]] testConstraint testbytestring [llength [info commands testbytestring]] @@ -31,7 +31,7 @@ testConstraint testevent [llength [info commands testevent]] testConstraint memory [llength [info commands memory]] test parse-1.1 {Tcl_ParseCommand procedure, computing string length} {testparser testbytestring} { - testparser [testbytestring "foo\0 bar"] -1 + testparser [testbytestring "foo\x00 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-1.2 {Tcl_ParseCommand procedure, computing string length} testparser { testparser "foo bar" -1 @@ -278,7 +278,7 @@ test parse-6.9 {ParseTokens procedure, error in command substitution} { } {0} test parse-6.10 {ParseTokens procedure, incomplete sub-command} { info complete {puts [ - expr 1+1 + expr {1+1} #this is a comment ]} } {0} test parse-6.11 {ParseTokens procedure, memory allocation for big nested command} testparser { @@ -300,8 +300,8 @@ test parse-6.15 {ParseTokens procedure, backslash-newline} testparser { testparser "\"b\\\nc\"" 0 } {- \"b\\\nc\" 1 word \"b\\\nc\" 3 text b 0 backslash \\\n 0 text c 0 {}} test parse-6.16 {ParseTokens procedure, backslash substitution} testparser { - testparser {\n\a\x7f} 0 -} {- {\n\a\x7f} 1 word {\n\a\x7f} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7f} 0 {}} + testparser {\n\a\x7F} 0 +} {- {\n\a\x7F} 1 word {\n\a\x7F} 3 backslash {\n} 0 backslash {\a} 0 backslash {\x7F} 0 {}} test parse-6.17 {ParseTokens procedure, null characters} {testparser testbytestring} { expr {[testparser [testbytestring "foo\0zz"] 0] eq "- [testbytestring foo\0zz] 1 word [testbytestring foo\0zz] 3 text foo 0 text [testbytestring \0] 0 text zz 0 {}" @@ -405,14 +405,14 @@ test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv { proc ::unknown args {lappend ::info [info level]; uplevel 1 foo} proc ::foo args {lappend ::info global} catch {rename ::noSuchCommand {}} - set ::slave [interp create] - $::slave alias bar noSuchCommand + set ::child [interp create] + $::child alias bar noSuchCommand set ::info {} namespace eval test_ns_1 { proc foo args {lappend ::info namespace} - $::slave eval bar - testevalobjv 1 [list $::slave eval bar] - uplevel #0 [list $::slave eval bar] + $::child eval bar + testevalobjv 1 [list $::child eval bar] + uplevel #0 [list $::child eval bar] } namespace delete test_ns_1 rename ::foo {} @@ -429,14 +429,14 @@ test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} { lappend ::info ns }] catch {rename ::noSuchCommand {}} - set ::slave [interp create] - $::slave alias bar noSuchCommand + set ::child [interp create] + $::child alias bar noSuchCommand set ::info {} namespace eval test_ns_1 { - $::slave eval bar + $::child eval bar } namespace delete test_ns_1 - interp delete $::slave + interp delete $::child catch {rename ::noSuchCommand {}} set ::info } global @@ -481,11 +481,11 @@ test parse-10.2 {Tcl_EvalTokens, backslash sequences} testevalex { testevalex {concat test\063\062test} } {test32test} test parse-10.3 {Tcl_EvalTokens, nested commands} testevalex { - testevalex {concat [expr 2 + 6]} + testevalex {concat [expr {2 + 6}]} } {8} test parse-10.4 {Tcl_EvalTokens, nested commands} testevalex { unset -nocomplain a - list [catch {testevalex {concat xxx[expr $a]}} msg] $msg + list [catch {testevalex {concat xxx[expr {$a}]}} msg] $msg } {1 {can't read "a": no such variable}} test parse-10.5 {Tcl_EvalTokens, simple variables} testevalex { set a hello @@ -499,7 +499,7 @@ test parse-10.6 {Tcl_EvalTokens, array variables} testevalex { test parse-10.7 {Tcl_EvalTokens, array variables} testevalex { unset -nocomplain a set a(12) 46 - testevalex {concat $a(1[expr 3 - 1])} + testevalex {concat $a(1[expr {3 - 1}])} } {46} test parse-10.8 {Tcl_EvalTokens, array variables} testevalex { unset -nocomplain a @@ -518,7 +518,7 @@ test parse-10.11 {Tcl_EvalTokens, object values} testevalex { testevalex {concat $a$a$a} } {123123123} test parse-10.12 {Tcl_EvalTokens, object values} testevalex { - testevalex {concat [expr 2][expr 4][expr 6]} + testevalex {concat [expr {2}][expr {4}][expr {6}]} } {246} test parse-10.13 {Tcl_EvalTokens, string values} testevalex { testevalex {concat {a" b"}} @@ -685,7 +685,7 @@ test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar unset -nocomplain abc list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg } {1 {invalid command name "bogus"}} -test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup { +test parse-13.6 {Tcl_ParseVar memory leak} -constraints {testparsevar memory} -setup { proc getbytes {} { return [lindex [split [memory info] \n] 3 3] } @@ -707,7 +707,7 @@ test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup { } -result 0 test parse-14.1 {Tcl_ParseBraces procedure, computing string length} {testparser testbytestring} { - testparser [testbytestring "foo\0 bar"] -1 + testparser [testbytestring "foo\x00 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-14.2 {Tcl_ParseBraces procedure, computing string length} testparser { testparser "foo bar" -1 @@ -744,7 +744,7 @@ test parse-14.12 {Tcl_ParseBraces procedure, missing close brace} testparser { } {1 {missing close-brace} missing\ close-brace\n\ \ \ \ (remainder\ of\ script:\ \"\{xy\\\nz\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"foo\ \\\{xy\\\\\\nz\"\ 0\"} test parse-15.1 {Tcl_ParseQuotedString procedure, computing string length} {testparser testbytestring} { - testparser [testbytestring "foo\0 bar"] -1 + testparser [testbytestring "foo\x00 bar"] -1 } {- foo 1 simple foo 1 text foo 0 {}} test parse-15.2 {Tcl_ParseQuotedString procedure, computing string length} testparser { testparser "foo bar" -1 @@ -910,10 +910,10 @@ test parse-15.54 {CommandComplete procedure} " info complete \"foo bar;# \{\" " 1 test parse-15.55 {CommandComplete procedure} testbytestring { - info complete "set x [testbytestring \0]; puts hi" + info complete "set x [testbytestring \x00]; puts hi" } 1 test parse-15.56 {CommandComplete procedure} testbytestring { - info complete "set x [testbytestring \0]; \{" + info complete "set x [testbytestring \x00]; \{" } 0 test parse-15.57 {CommandComplete procedure} { info complete "# Comment should be complete command" @@ -984,26 +984,26 @@ test parse-18.14 {Tcl_SubstObj, exception handling} { subst {abc,[break],def} } {abc,} test parse-18.15 {Tcl_SubstObj, exception handling} { - subst {abc,[continue; expr 1+2],def} + subst {abc,[continue; expr {1+2}],def} } {abc,,def} test parse-18.16 {Tcl_SubstObj, exception handling} { - subst {abc,[return foo; expr 1+2],def} + subst {abc,[return foo; expr {1+2}],def} } {abc,foo,def} test parse-18.17 {Tcl_SubstObj, exception handling} { - subst {abc,[return -code 10 foo; expr 1+2],def} + subst {abc,[return -code 10 foo; expr {1+2}],def} } {abc,foo,def} test parse-18.18 {Tcl_SubstObj, exception handling} { subst {abc,[break; set {} {}{}],def} } {abc,} test parse-18.19 {Tcl_SubstObj, exception handling} { - list [catch {subst {abc,[continue; expr 1+2; set {} {}{}],def}} msg] $msg + list [catch {subst {abc,[continue; expr {1+2}; set {} {}{}],def}} msg] $msg } [list 1 "extra characters after close-brace"] test parse-18.20 {Tcl_SubstObj, exception handling} { - list [catch {subst {abc,[return foo; expr 1+2; set {} {}{}],def}} msg] $msg + list [catch {subst {abc,[return foo; expr {1+2}; set {} {}{}],def}} msg] $msg } [list 1 "extra characters after close-brace"] test parse-18.21 {Tcl_SubstObj, exception handling} { list [catch { - subst {abc,[return -code 10 foo; expr 1+2; set {} {}{}],def} + subst {abc,[return -code 10 foo; expr {1+2}; set {} {}{}],def} } msg] $msg } [list 1 "extra characters after close-brace"] diff --git a/tests/parseExpr.test b/tests/parseExpr.test index 47dbec5..c70c5e3 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -2,17 +2,19 @@ # file tclCompExpr.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Note that the Tcl expression parser (tclCompExpr.c) does not check # the semantic validity of the expressions it parses. It does not check, @@ -30,9 +32,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -42,19 +44,19 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -64,11 +66,11 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 @@ -83,7 +85,7 @@ testConstraint ieeeFloatingPoint [testIEEE] ###################################################################### test parseExpr-1.1 {Tcl_ParseExpr procedure, computing string length} {testexprparser testbytestring} { - testexprparser [testbytestring "1+2\0 +3"] -1 + testexprparser [testbytestring "1+2\x00 +3"] -1 } {- {} 0 subexpr 1+2 5 operator + 0 subexpr 1 1 text 1 0 subexpr 2 1 text 2 0 {}} test parseExpr-1.2 {Tcl_ParseExpr procedure, computing string length} testexprparser { testexprparser "1 + 2" -1 @@ -880,17 +882,17 @@ test parseExpr-21.36 {error messages} -body { } -returnCodes error -result {invalid character "@" in expression "...fghijklmnopqrstuvwxyz"@"abcdefghijklmnopqrstu..."} test parseExpr-21.37 {error messages} -body { - expr [format {"%s" @ 0} [string repeat \u00a7 25]] + expr [format {"%s" @ 0} [string repeat \xA7 25]] } -returnCodes error -result [format {invalid character "@" -in expression "...%s" @ 0"} [string repeat \u00a7 10]] +in expression "...%s" @ 0"} [string repeat \xA7 10]] test parseExpr-21.38 {error messages} -body { - expr [format {0 @ "%s"} [string repeat \u00a7 25]] + expr [format {0 @ "%s"} [string repeat \xA7 25]] } -returnCodes error -result [format {invalid character "@" -in expression "0 @ "%s..."} [string repeat \u00a7 10]] +in expression "0 @ "%s..."} [string repeat \xA7 10]] test parseExpr-21.39 {error messages} -body { - expr [format {"%s" @ "%s"} [string repeat \u00a7 25] [string repeat \u00a7 25]] + expr [format {"%s" @ "%s"} [string repeat \xA7 25] [string repeat \xA7 25]] } -returnCodes error -result [format {invalid character "@" -in expression "...%s" @ "%s..."} [string repeat \u00a7 10] [string repeat \u00a7 10]] +in expression "...%s" @ "%s..."} [string repeat \xA7 10] [string repeat \xA7 10]] test parseExpr-21.40 {error messages} -body { catch {expr {"abcdefghijklmnopqrstuvwxyz"@0}} m o dict get $o -errorinfo @@ -900,13 +902,13 @@ in expression "...fghijklmnopqrstuvwxyz"@0" invoked from within "expr {"abcdefghijklmnopqrstuvwxyz"@0}"} test parseExpr-21.41 {error messages} -body { - catch {expr [format {"%s" @ 0} [string repeat \u00a7 25]]} m o + catch {expr [format {"%s" @ 0} [string repeat \xA7 25]]} m o dict get $o -errorinfo } -result [format {invalid character "@" in expression "...%s" @ 0" (parsing expression ""%s...") invoked from within -"expr [format {"%%s" @ 0} [string repeat \u00a7 25]]"} [string repeat \u00a7 10] [string repeat \u00a7 10]] +"expr [format {"%%s" @ 0} [string repeat \xA7 25]]"} [string repeat \xA7 10] [string repeat \xA7 10]] test parseExpr-21.42 {error message} -body { expr {123456789012345678901234567890*"abcdefghijklmnopqrstuvwxyz} } -returnCodes error -result {missing " @@ -1064,15 +1066,23 @@ test parseExpr-22.18 {Bug 3401704} -constraints testexprparser -body { } -result {TCL PARSE EXPR BADNUMBER BINARY} test parseExpr-22.19 {Bug d2ffcca163} -constraints testexprparser -body { - testexprparser \u0433 -1 + testexprparser г -1 } -returnCodes error -match glob -result {*invalid character*} test parseExpr-22.20 {Bug d2ffcca163} -constraints testexprparser -body { - testexprparser \u043f -1 + testexprparser п -1 } -returnCodes error -match glob -result {*invalid character*} test parseExpr-22.21 {Bug d2ffcca163} -constraints testexprparser -body { - testexprparser in\u0433(0) -1 + testexprparser inг(0) -1 } -returnCodes error -match glob -result {missing operand*} +test parseExpr-23.1 {TIP 582: comments} -constraints testexprparser -body { + testexprparser "7 # * 8 " -1 +} -result {- {} 0 subexpr 7 1 text 7 0 {}} +test parseExpr-23.2 {TIP 582: comments} -constraints testexprparser -body { + testexprparser "7 #\n* 8 " -1 +} -result {- {} 0 subexpr {7 # +*} 5 operator # 0 subexpr 7 1 text 7 0 subexpr * 1 text * 0 {}} + # cleanup cleanupTests return diff --git a/tests/parseOld.test b/tests/parseOld.test index 504d063..853f5b5 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -6,18 +6,20 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testwordend [llength [info commands testwordend]] testConstraint testbytestring [llength [info commands testbytestring]] @@ -133,7 +135,7 @@ format %s $b } a22b test parseOld-4.4 {command substitution} { set a 7.7 - if [catch {expr int($a)}] {set a foo} + if {[catch {expr {int($a)}}]} {set a foo} set a } 7.7 @@ -262,14 +264,14 @@ test parseOld-7.10 {backslash substitution} { test parseOld-7.11 {backslash substitution} { eval "list a \"b c\"\\\nd e" } {a {b c} d e} -test parseOld-7.12 {backslash substitution} testbytestring { - expr {[list \ua2] eq [testbytestring "\xc2\xa2"]} +test parseOld-7.12 {backslash substitution} { + expr {[list \uA2] eq "¢"} } 1 -test parseOld-7.13 {backslash substitution} testbytestring { - expr {[list \u4e21] eq [testbytestring "\xe4\xb8\xa1"]} +test parseOld-7.13 {backslash substitution} { + expr {[list \u4E21] eq "両"} } 1 -test parseOld-7.14 {backslash substitution} testbytestring { - expr {[list \u4e2k] eq [testbytestring "\xd3\xa2k"]} +test parseOld-7.14 {backslash substitution} { + expr {[list \u4E2k] eq "Ӣk"} } 1 # Semi-colon. @@ -453,80 +455,14 @@ test parseOld-12.4 {comments} { test parseOld-13.1 {comments at the end of a bracketed script} { set x "[ -expr 1+1 +expr {1+1} # skip this! ]" } {2} -test parseOld-14.1 {TclWordEnd procedure} {testwordend} { - testwordend " \n abc" -} {c} -test parseOld-14.2 {TclWordEnd procedure} {testwordend} { - testwordend " \\\n" -} {} -test parseOld-14.3 {TclWordEnd procedure} {testwordend} { - testwordend " \\\n " -} { } -test parseOld-14.4 {TclWordEnd procedure} {testwordend} { - testwordend {"abc"} -} {"} -#" Emacs formatting :^( -test parseOld-14.5 {TclWordEnd procedure} {testwordend} { - testwordend {{xyz}} -} \} -test parseOld-14.6 {TclWordEnd procedure} {testwordend} { - testwordend {{a{}b{}\}} xyz} -} "\} xyz" -test parseOld-14.7 {TclWordEnd procedure} {testwordend} { - testwordend {abc[this is a]def ghi} -} {f ghi} -test parseOld-14.8 {TclWordEnd procedure} {testwordend} { - testwordend "puts\\\n\n " -} "s\\\n\n " -test parseOld-14.9 {TclWordEnd procedure} {testwordend} { - testwordend "puts\\\n " -} "s\\\n " -test parseOld-14.10 {TclWordEnd procedure} {testwordend} { - testwordend "puts\\\n xyz" -} "s\\\n xyz" -test parseOld-14.11 {TclWordEnd procedure} {testwordend} { - testwordend {a$x.$y(a long index) foo} -} ") foo" -test parseOld-14.12 {TclWordEnd procedure} {testwordend} { - testwordend {abc; def} -} {; def} -test parseOld-14.13 {TclWordEnd procedure} {testwordend} { - testwordend {abc def} -} {c def} -test parseOld-14.14 {TclWordEnd procedure} {testwordend} { - testwordend {abc def} -} {c def} -test parseOld-14.15 {TclWordEnd procedure} {testwordend} { - testwordend "abc\ndef" -} "c\ndef" -test parseOld-14.16 {TclWordEnd procedure} {testwordend} { - testwordend "abc" -} {c} -test parseOld-14.17 {TclWordEnd procedure} {testwordend} { - testwordend "a\000bc" -} {c} -test parseOld-14.18 {TclWordEnd procedure} {testwordend} { - testwordend \[a\000\] -} {]} -test parseOld-14.19 {TclWordEnd procedure} {testwordend} { - testwordend \"a\000\" -} {"} -#" Emacs formatting :^( -test parseOld-14.20 {TclWordEnd procedure} {testwordend} { - testwordend a{\000}b -} {b} -test parseOld-14.21 {TclWordEnd procedure} {testwordend} { - testwordend " \000b" -} {b} - test parseOld-15.1 {TclScriptEnd procedure} { info complete {puts [ - expr 1+1 + expr {1+1} #this is a comment ]} } {0} test parseOld-15.2 {TclScriptEnd procedure} { diff --git a/tests/pid.test b/tests/pid.test index af21f30..3f62457 100644 --- a/tests/pid.test +++ b/tests/pid.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 8ff806c..df49c32 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -5,11 +5,13 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} set fullPkgPath [makeDirectory pkg] @@ -72,11 +74,11 @@ proc pkgtest::parseArgs { args } { # of the command line. proc pkgtest::parseIndex { filePath } { - # create a slave interpreter, where we override "package ifneeded" + # create a child interpreter, where we override "package ifneeded" - set slave [interp create] + set child [interp create] if {[catch { - $slave eval { + $child eval { rename package package_original proc package { args } { if {[lindex $args 0] eq "ifneeded"} { @@ -91,17 +93,17 @@ proc pkgtest::parseIndex { filePath } { } set dir [file dirname $filePath] - $slave eval {set curdir [pwd]} - $slave eval [list cd $dir] - $slave eval [list set dir $dir] - $slave eval [list source [file tail $filePath]] - $slave eval {cd $curdir} + $child eval {set curdir [pwd]} + $child eval [list cd $dir] + $child eval [list set dir $dir] + $child eval [list source [file tail $filePath]] + $child eval {cd $curdir} # Create the list in sorted order, so that we don't get spurious # errors because the order has changed. array set P {} - foreach {k v} [$slave eval {array get ::PKGS}] { + foreach {k v} [$child eval {array get ::PKGS}] { set P($k) $v } @@ -113,12 +115,12 @@ proc pkgtest::parseIndex { filePath } { set ei [dict get $opts -errorinfo] set ec [dict get $opts -errorcode] - catch {interp delete $slave} + catch {interp delete $child} error $ei $ec } - interp delete $slave + interp delete $child return $PKGS } @@ -313,7 +315,7 @@ namespace eval pkg2 { namespace export p2-1 } proc pkg2::p2-1 { num } { - return [expr $num * 2] + return [expr {$num * 2}] } } [file join pkg pkg2_a.tcl] @@ -326,7 +328,7 @@ namespace eval pkg2 { namespace export p2-2 } proc pkg2::p2-2 { num } { - return [expr $num * 3] + return [expr {$num * 3}] } } [file join pkg pkg2_b.tcl] @@ -407,10 +409,10 @@ namespace eval pkg3 { namespace export p3-1 p3-2 } proc pkg3::p3-1 { num } { - return {[expr $num * 2]} + return {[expr {$num * 2}]} } proc pkg3::p3-2 { num } { - return {[expr $num * 3]} + return {[expr {$num * 3}]} } } [file join pkg pkg3.tcl] @@ -518,10 +520,10 @@ namespace eval circ2 { namespace export c2-1 c2-2 } proc circ2::c2-1 { num } { - return [expr $num * [circ3::c3-1]] + return [expr {$num * [circ3::c3-1]}] } proc circ2::c2-2 { num } { - return [expr $num * [circ3::c3-2]] + return [expr {$num * [circ3::c3-2]}] } } [file join pkg circ2.tcl] @@ -557,8 +559,8 @@ testConstraint $dll [file exists $x] if {[testConstraint $dll]} { makeFile { -# This package provides Pkga, which is also provided by a DLL. -package provide Pkga 1.0 +# This package provides pkga, which is also provided by a DLL. +package provide pkga 1.0 proc pkga_neq { x } { return [expr {! [pkgq_eq $x]}] } @@ -574,7 +576,7 @@ test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] { set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl] exec [interpreter] << $cmd pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl -} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" +} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] { # Do all [load]ing of shared libraries in another process, so we can # delete the file and not get stuck because we're holding a reference to diff --git a/tests/platform.test b/tests/platform.test index 53d534e..b5fd405 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -4,12 +4,12 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1999 by Scriptics Corporation +# Copyright © 1999 Scriptics Corporation # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 +package require tcltest 2.5 namespace eval ::tcl::test::platform { namespace import ::tcltest::testConstraint @@ -21,7 +21,7 @@ namespace eval ::tcl::test::platform { namespace upvar :: tcl_platform tcl_platform ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] package require tcltests testConstraint testCPUID [llength [info commands testcpuid]] diff --git a/tests/proc-old.test b/tests/proc-old.test index e45cf5c..ab93fca 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -7,15 +7,15 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -25,7 +25,7 @@ catch {rename foo ""} proc tproc {} {return a; return b} test proc-old-1.1 {simple procedure call and return} {tproc} a proc tproc x { - set x [expr $x+1] + set x [expr {$x + 1}] return $x } test proc-old-1.2 {simple procedure call and return} {tproc 2} 3 @@ -49,7 +49,7 @@ test proc-old-1.6 {simple procedure call and return (shared proc body string)} { test proc-old-2.1 {local and global variables} { proc tproc x { - set x [expr $x+1] + set x [expr {$x + 1}] return $x } set x 42 @@ -57,7 +57,7 @@ test proc-old-2.1 {local and global variables} { } {7 42} test proc-old-2.2 {local and global variables} { proc tproc x { - set y [expr $x+1] + set y [expr {$x + 1}] return $y } set y 18 @@ -66,7 +66,7 @@ test proc-old-2.2 {local and global variables} { test proc-old-2.3 {local and global variables} { proc tproc x { global y - set y [expr $x+1] + set y [expr {$x + 1}] return $y } set y 189 @@ -75,7 +75,7 @@ test proc-old-2.3 {local and global variables} { test proc-old-2.4 {local and global variables} { proc tproc x { global y - return [expr $x+$y] + return [expr {$x + $y}] } set y 189 list [tproc 6] $y @@ -504,7 +504,7 @@ test proc-old-10.1 {ByteCode epoch change during recursive proc execution} { set y 20 rename expr expr.old rename expr.old expr - if $x then {t1 0} ;# recursive call after foo's code is invalidated + if {$x} then {t1 0} ;# recursive call after foo's code is invalidated return 20 } t1 1 diff --git a/tests/proc.test b/tests/proc.test index 43d76d8..23aea28 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -7,18 +7,18 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } -testConstraint procbodytest [expr {![catch {package require procbodytest}]}] +testConstraint tcl::test [expr {![catch {package require tcl::test}]}] testConstraint memory [llength [info commands memory]] catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -100,7 +100,7 @@ test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array e catch {rename p ""} } -returnCodes error -body { proc p {a(1) a(2)} { - set z [expr $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} @@ -210,14 +210,14 @@ catch {rename p ""} catch {rename t ""} # Note that the test require that procedures whose body is used to create -# procbody objects must be executed before the procbodytest::proc command is +# procbody objects must be executed before the tcl::procbodytest::proc command is # executed, so that the Proc struct is populated correctly (CompiledLocals are # added at compile time). -test proc-4.1 {TclCreateProc, procbody obj} -constraints procbodytest -body { +test proc-4.1 {TclCreateProc, procbody obj} -constraints tcl::test -body { proc p x {return "$x:$x"} set rv [p P] - procbodytest::proc t x p + tcl::procbodytest::proc t x p lappend rv [t T] } -cleanup { catch {rename p ""} @@ -229,9 +229,9 @@ test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} -body { return "$x:$y" } set rv [p P] - procbodytest::proc t x p + tcl::procbodytest::proc t x p lappend rv [t T] -} -constraints procbodytest -cleanup { +} -constraints tcl::test -cleanup { catch {rename p ""} catch {rename t ""} } -result {P:p T:t} @@ -241,9 +241,9 @@ test proc-4.3 {TclCreateProc, procbody obj, too many args} -body { return "$x:$y" } set rv [p P] - procbodytest::proc t {x x1 x2} p + tcl::procbodytest::proc t {x x1 x2} p lappend rv [t T] -} -constraints procbodytest -returnCodes error -cleanup { +} -constraints tcl::test -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": arg list contains 3 entries, precompiled header expects 1} @@ -254,9 +254,9 @@ test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} -body { return "$v:$w" } set rv [p P Q R] - procbodytest::proc t {x x1 z} p + tcl::procbodytest::proc t {x x1 z} p lappend rv [t S T U] -} -constraints procbodytest -returnCodes error -cleanup { +} -constraints tcl::test -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter 1 is inconsistent with precompiled body} @@ -267,9 +267,9 @@ test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} -body return "$v:$w" } set rv [p P Q R] - procbodytest::proc t {x y z} p + tcl::procbodytest::proc t {x y z} p lappend rv [t S T U] -} -constraints procbodytest -returnCodes error -cleanup { +} -constraints tcl::test -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} @@ -280,9 +280,9 @@ test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} -body return "$v:$w" } set rv [p P Q R] - procbodytest::proc t {x y {z Z}} p + tcl::procbodytest::proc t {x y {z Z}} p lappend rv [t S T U] -} -returnCodes error -constraints procbodytest -cleanup { +} -returnCodes error -constraints tcl::test -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter 2 is inconsistent with precompiled body} @@ -293,9 +293,9 @@ test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} -bod return "$v:$w" } set rv [p P Q R] - procbodytest::proc t {x y {z ZZ}} p + tcl::procbodytest::proc t {x y {z ZZ}} p lappend rv [t S T U] -} -constraints procbodytest -returnCodes error -cleanup { +} -constraints tcl::test -returnCodes error -cleanup { catch {rename p ""} catch {rename t ""} } -result {procedure "t": formal parameter "z" has default value inconsistent with precompiled body} @@ -309,10 +309,10 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set return "$x:$y" } px x -} -constraints {procbodytest memory} -body { +} -constraints {tcl::test memory} -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { - procbodytest::proc tx x px + tcl::procbodytest::proc tx x px set tmp $end set end [getbytes] } @@ -321,8 +321,8 @@ test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -set rename getbytes {} unset -nocomplain end i tmp leakedBytes } -result 0 -test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} procbodytest { - procbodytest::check +test proc-4.9 {[39fed4dae5] Valid Tcl_PkgPresent return} tcl::test { + tcl::procbodytest::check } 1 test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body { @@ -389,9 +389,9 @@ test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} -body { test proc-7.4 {Proc struct outlives its interp: Bug 3532959} { set lambda x lappend lambda {set a 1} - interp create slave - slave eval [list apply $lambda foo] - interp delete slave + interp create child + child eval [list apply $lambda foo] + interp delete child unset lambda } {} diff --git a/tests/process.test b/tests/process.test index 229d33c..4533108 100644 --- a/tests/process.test +++ b/tests/process.test @@ -4,12 +4,12 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 2017 Frederic Bonnet +# Copyright © 2017 Frederic Bonnet # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/pwd.test b/tests/pwd.test index 175c852..c069eef 100644 --- a/tests/pwd.test +++ b/tests/pwd.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -20,9 +20,10 @@ test pwd-1.1 {simple pwd} { catch pwd } 0 test pwd-1.2 {simple pwd} { - expr [string length pwd]>0 + expr {[string length [pwd]]>0} } 1 -test pwd-1.3 {pwd takes no args} -body { + +test pwd-2.1 {pwd takes no args} -body { pwd foobar } -returnCodes error -result "wrong \# args: should be \"pwd\"" diff --git a/tests/reg.test b/tests/reg.test index dabd3bc..b6198d8 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -7,14 +7,15 @@ # and aren't using Tcl -- reg's own regression tester also knows how # to read this file, ignoring the Tcl-isms.) # -# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. +# Copyright © 1998, 1999 Henry Spencer. All rights reserved. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # All tests require the testregexp command, return if this # command doesn't exist @@ -287,7 +288,7 @@ namespace eval RETest { set infoflags [TestInfoFlags $flags] set ccmd [list testregexp -about {*}$f $re] set nsub [expr {[llength $args] - 1}] - if {$nsub == -1} { + if {$nsub < 0} { # didn't tell us number of subexps set ccmd "lreplace \[$ccmd\] 0 0" set info [list $infoflags] @@ -513,8 +514,8 @@ expectMatch 9.40 eE {a[\\]b} "a\\b" "a\\b" expectMatch 9.41 bE {a[\\]b} "a\\b" "a\\b" expectError 9.42 - {a[\Z]b} EESCAPE expectMatch 9.43 & {a[[b]c} "a\[c" "a\[c" -expectMatch 9.44 EMP* {a[\u00fe-\u0507][\u00ff-\u0300]b} \ - "a\u0102\u02ffb" "a\u0102\u02ffb" +expectMatch 9.44 EMP* {a[\xFE-\u0507][\xFF-\u0300]b} \ + "a\u0102\u02FFb" "a\u0102\u02FFb" doing 10 "anchors and newlines" @@ -642,8 +643,8 @@ 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" +expectMatch 13.33 P "a\\U1000000x" "a\uFFFD0x" "a\uFFFD0x" +expectMatch 13.34 P {a\U1000000x} "a\uFFFD0x" "a\uFFFD0x" doing 14 "back references" @@ -1220,6 +1221,10 @@ test reg-33.29 {} { test reg-33.30 {Bug 1080042} { regexp {(\Y)+} foo } 1 +test reg-33.31 {Bug 7c64aa5e1a} { + regexp -inline {(?b).\{1,10\}} {abcdef} +} abcdef + # cleanup ::tcltest::cleanupTests diff --git a/tests/regexp.test b/tests/regexp.test index bae1217..e788b7f 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -54,8 +54,8 @@ test regexp-1.6 {basic regexp operation} { } {0 1} test regexp-1.7 {regexp utf compliance} { # if not UTF-8 aware, result is "0 1" - set foo "\u4e4eb q" - regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar + set foo "乎b q" + regexp "乎b q" "a乎b qw幎N wq" bar list [string compare $foo $bar] [regexp 4 $bar] } {0 0} test regexp-1.8 {regexp ***= metasyntax} { @@ -192,6 +192,17 @@ test regexp-3.7 {getting substrings back from regexp} { set foo 1; set f2 1; set f3 1; set f4 1 list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4 } {1 {1 2} {1 1} {-1 -1} {2 2}} +test regexp-3.8a {-indices by multi-byte utf-8} { + regexp -inline -indices {(\w+)-(\w+)} \ + "grüß-привет" +} {{0 10} {0 3} {5 10}} +test regexp-3.8b {-indices by multi-byte utf-8, from -start position} { + list\ + [regexp -inline -indices -start 3 {(\w+)-(\w+)} \ + "grüß-привет"] \ + [regexp -inline -indices -start 4 {(\w+)-(\w+)} \ + "grüß-привет"] +} {{{3 10} {3 3} {5 10}} {}} test regexp-4.1 {-nocase option to regexp} { regexp -nocase foo abcFOo @@ -341,8 +352,8 @@ test regexp-7.16 {basic regsub operation} { } {0 {}} test regexp-7.17 {regsub utf compliance} { # if not UTF-8 aware, result is "0 1" - set foo "xyz555ijka\u4e4ebpqr" - regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar + set foo "xyz555ijka乎bpqr" + regsub a乎b xyza乎bijka乎bpqr 555 bar list [string compare $foo $bar] [regexp 4 $bar] } {0 0} test regexp-7.18 {basic regsub replacement} { diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 8819dd2..76e708d 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -62,8 +62,8 @@ test regexpComp-1.6 {basic regexp operation} { test regexpComp-1.7 {regexp utf compliance} { # if not UTF-8 aware, result is "0 1" evalInProc { - set foo "\u4e4eb q" - regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar + set foo "乎b q" + regexp "乎b q" "a乎b qw幎N wq" bar list [string compare $foo $bar] [regexp 4 $bar] } } {0 0} @@ -447,8 +447,8 @@ test regexpComp-7.16 {basic regsub operation} { test regexpComp-7.17 {regsub utf compliance} { evalInProc { # if not UTF-8 aware, result is "0 1" - set foo "xyz555ijka\u4e4ebpqr" - regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar + set foo "xyz555ijka乎bpqr" + regsub a乎b xyza乎bijka乎bpqr 555 bar list [string compare $foo $bar] [regexp 4 $bar] } } {0 0} diff --git a/tests/registry.test b/tests/registry.test index 8cfd5be..4fc96bf 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -7,11 +7,11 @@ # In order for these tests to run, the registry package must be on the # auto_path or the registry package must have been loaded already. # -# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. All rights reserved. +# Copyright © 1998-1999 Scriptics Corporation. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -19,11 +19,12 @@ testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::regver [package require registry 1.3.5] + set ::regver [package require registry 1.3.6] }]} { testConstraint reg 1 } } +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] # determine the current locale testConstraint english [expr { @@ -33,7 +34,7 @@ testConstraint english [expr { test registry-1.0 {check if we are testing the right dll} {win reg} { set ::regver -} {1.3.5} +} {1.3.6} test registry-1.1 {argument parsing for registry command} {win reg} { list [catch {registry} msg] $msg } {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} @@ -673,10 +674,10 @@ test registry-12.2 {BroadcastValue} -constraints {win reg} -body { test registry-12.3 {BroadcastValue} -constraints {win reg} -body { registry broadcast "" - 500 } -returnCodes error -result "wrong # args: should be \"registry broadcast keyName ?-timeout milliseconds?\"" -test registry-12.4 {BroadcastValue} -constraints {win reg} -body { +test registry-12.4 {BroadcastValue} -constraints {win reg notWine} -body { registry broadcast {Environment} } -result {1 0} -test registry-12.5 {BroadcastValue} -constraints {win reg} -body { +test registry-12.5 {BroadcastValue} -constraints {win reg notWine} -body { registry b {} } -result {1 0} diff --git a/tests/remote.tcl b/tests/remote.tcl index 097e41f..6bc4b17 100644 --- a/tests/remote.tcl +++ b/tests/remote.tcl @@ -4,7 +4,7 @@ # # Source this file in the remote server you are using to test Tcl against. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. +# Copyright © 1995-1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -91,8 +91,8 @@ if {![info exists serverPort]} { if {![info exists serverPort]} { for {set i 0} {$i < $argc} {incr i} { if {[string compare -port [lindex $argv $i]] == 0} { - if {$i < [expr $argc - 1]} { - set serverPort [lindex $argv [expr $i + 1]] + if {$i < $argc - 1} { + set serverPort [lindex $argv [expr {$i + 1}]] } break } @@ -110,8 +110,8 @@ if {![info exists serverAddress]} { if {![info exists serverAddress]} { for {set i 0} {$i < $argc} {incr i} { if {[string compare -address [lindex $argv $i]] == 0} { - if {$i < [expr $argc - 1]} { - set serverAddress [lindex $argv [expr $i + 1]] + if {$i < $argc - 1} { + set serverAddress [lindex $argv [expr {$i + 1}]] } break } diff --git a/tests/rename.test b/tests/rename.test index ebf5425..9b8f9a0 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -4,20 +4,20 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testdel [llength [info commands testdel]] diff --git a/tests/resolver.test b/tests/resolver.test index b0b395d..51df07c 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -4,19 +4,19 @@ # in the reusing context. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at> -# Copyright (c) 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at> +# Copyright © 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at> +# Copyright © 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at> # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -if {"::tcltest" in [namespace children]} { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testinterpresolver [llength [info commands testinterpresolver]] @@ -203,7 +203,7 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup { # resolver-agnostic). # # In order to make the test cases for the per-interpreter cmd literal pool -# reproducable and to minimize interactions between test cases, we use a slave +# reproducable and to minimize interactions between test cases, we use a child # interpreter per test-case. # # diff --git a/tests/result.test b/tests/result.test index 859e546..845c26e 100644 --- a/tests/result.test +++ b/tests/result.test @@ -4,17 +4,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Some tests require the testsaveresult command diff --git a/tests/safe-stock.test b/tests/safe-stock.test new file mode 100644 index 0000000..bfea85c --- /dev/null +++ b/tests/safe-stock.test @@ -0,0 +1,248 @@ +# safe-stock.test -- +# +# This file contains tests for safe Tcl that were previously in the file +# safe.test, and use files and packages of stock Tcl 8.7 to perform the tests. +# These files may be changed or disappear in future revisions of Tcl, for +# example package opt will eventually be removed. +# +# The tests are replaced in safe.tcl with tests that use files provided in the +# tests directory. Test numbering is for comparison with similar tests in +# safe.test. +# +# Sourcing this file into tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# The defunct package http 1.0 was convenient for testing package loading. +# - This file, safe-stock.test, uses packages opt and (from cookiejar) +# tcl::idna to provide alternative tests based on stock Tcl packages. +# - These are tests 7.1 7.2 7.4 9.11 9.13 +# - Tests 7.[124], 9.1[13] use "package require opt". +# - Tests 9.1[13] also use "package require tcl::idna". +# - The corresponding tests in safe.test use example packages provided in +# subdirectory auto0 of the tests directory, which are independent of any +# changes made to the packages provided with Tcl. +# +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +foreach i [interp children] { + interp delete $i +} + +# When using package opt for testing positive/negative package search: +# - The directory location and the error message depend on whether +# and how the package is installed. + +# Error message for test 7.2 for "package require opt". +if {[string match *zipfs:/* [info library]]} { + # pkgIndex.tcl is in [info library] + # file to be sourced is in [info library]/opt* + set pkgOptErrMsg {permission denied} +} else { + # pkgIndex.tcl and file to be sourced are + # both in [info library]/opt* + set pkgOptErrMsg {can't find package opt} +} + +# Directory of opt for tests 7.4, 9.10, 9.12 for "package require opt". +if {[file exists [file join [info library] opt0.4]]} { + # Installed files in lib8.7/opt0.4 + set pkgOptDir opt0.4 +} elseif {[file exists [file join [info library] opt]]} { + # Installed files in zipfs, or source files used by "make test" + set pkgOptDir opt +} else { + error {cannot find opt library} +} + +# Directory of cookiejar for tests 9.10, 9.12 for "package require tcl::idna". +if {[file exists [file join [info library] cookiejar0.2]]} { + # Installed files in lib8.7/cookiejar0.2 + set pkgJarDir cookiejar0.2 +} elseif {[file exists [file join [info library] cookiejar]]} { + # Installed files in zipfs, or source files used by "make test" + set pkgJarDir cookiejar +} else { + error {cannot find cookiejar library} +} + +set SaveAutoPath $::auto_path +set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] +set PathMapp {} +lappend PathMapp [file join [info library] $pkgOptDir] TCLLIB/OPTDIR +lappend PathMapp [file join [info library] $pkgJarDir] TCLLIB/JARDIR +lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR + +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} +proc mapAndSortList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + lsort $listOut +} + +# Force actual loading of the safe package because we use un-exported (and +# thus un-autoindexed) APIs in this test result arguments: +catch {safe::interpConfigure} + +# high level general test +test safe-stock-7.1 {tests that everything works at high level, uses pkg opt} -setup { + set i [safe::interpCreate] +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a child works like in the parent) + set v [interp eval $i {package require opt}] + # no error shall occur: + interp eval $i {::tcl::Lempty {a list}} + set v +} -cleanup { + safe::interpDelete $i +} -match glob -result 0.4.* +test safe-stock-7.2 {tests specific path and interpFind/AddToAccessPath, uses pkg opt} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # an error shall occur (opt is not anymore in the secure 0-level + # provided deep path) + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + list $token1 $token2 -- \ + [catch {interp eval $i {package require opt}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -cleanup { +} -match glob -result "{\$p(:0:)} {\$p(:*:)} -- 1 {$pkgOptErrMsg} --\ + {TCLLIB */dummy/unixlike/test/path} -- {}" +test safe-stock-7.4 {tests specific path and positive search, uses pkg opt} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-stock-7.2, opt should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require opt}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 0.4.* --\ + {TCLLIB * TCLLIB/OPTDIR} -- {}} + +# The following test checks whether the definition of tcl_endOfWord can be +# obtained from auto_loading. It was previously test "safe-5.1". +test safe-stock-9.8 {test auto-loading in safe interpreters, was safe-5.1} -setup { + catch {safe::interpDelete a} + safe::interpCreate a +} -body { + interp eval a {tcl_endOfWord "" 0} +} -cleanup { + safe::interpDelete a +} -result -1 +test safe-stock-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, uses pkg opt and tcl::idna} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $tcl_library $pkgOptDir] \ + [file join $tcl_library $pkgJarDir]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + # This has no effect because the records in Pkg of these directories were from access as children of {$p(:0:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $tcl_library $pkgJarDir] \ + [file join $tcl_library $pkgOptDir]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path4 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require tcl::idna}} msg3] + set code4 [catch {interp eval $i {package require opt}} msg4] + set code5 [catch {interp eval $i {::tcl::Lempty {a list}}} msg5] + set code6 [catch {interp eval $i {::tcl::idna::IDNAencode example.com}} msg6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 1.* 0 0.4.* --\ + {TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} --\ + {TCLLIB TCLLIB/JARDIR TCLLIB/OPTDIR*} --\ + 0 0 0 example.com} +test safe-stock-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, uses pkg opt and tcl::idna} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $tcl_library $pkgOptDir] \ + [file join $tcl_library $pkgJarDir]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require opt}} msg3] + set code6 [catch {interp eval $i {package require tcl::idna}} msg6] + + list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ + $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} -- {TCLLIB*}} + +set ::auto_path $SaveAutoPath +unset pkgOptErrMsg pkgOptDir pkgJarDir SaveAutoPath TestsDir PathMapp +rename mapList {} +rename mapAndSortList {} +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/tests/safe-stock86.test diff --git a/tests/safe-zipfs.test b/tests/safe-zipfs.test new file mode 100644 index 0000000..f67bc43 --- /dev/null +++ b/tests/safe-zipfs.test @@ -0,0 +1,727 @@ +# safe-zipfs.test -- +# +# This file contains tests for safe Tcl that test its compatibility with the +# zipfs facilities introduced in Tcl 8.7. Test numbering is for comparison +# with similar tests in safe.test that do not use the zipfs file system. +# +# Sourcing this file into tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +foreach i [interp children] { + interp delete $i +} + +set SaveAutoPath $::auto_path +set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] + +set ZipMountPoint [zipfs root]auto-files +zipfs mount $ZipMountPoint [file join $TestsDir auto-files.zip] + +set PathMapp {} +lappend PathMapp $tcl_library TCLLIB $TestsDir TESTSDIR $ZipMountPoint ZIPDIR + +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} +proc mapAndSortList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + lsort $listOut +} + +# Force actual loading of the safe package because we use un-exported (and +# thus un-autoindexed) APIs in this test result arguments: +catch {safe::interpConfigure} + +# testing that nested and statics do what is advertised (we use a +# package - tcl::test - but it might be absent if we're in standard tclsh) + +testConstraint tcl::test [expr {![catch {package require tcl::test}]}] + +# Tests 5.* test the example files before using them to test safe interpreters. + +test safe-zipfs-5.1 {example tclIndex commands, test in parent interpreter; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {0 ok1 0 ok2} +test safe-zipfs-5.2 {example tclIndex commands, negative test in parent interpreter; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} +test safe-zipfs-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-zipfs-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-zipfs-5.5 {example modules packages, test in parent interpreter, replace path; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} +test safe-zipfs-5.6 {example modules packages, test in parent interpreter, append to path; zipfs} -setup { + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + +# high level general test +# Use zipped example packages not http1.0 etc +test safe-zipfs-7.1 {tests that everything works at high level; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] + set i [safe::interpCreate] + set ::auto_path $tmpAutoPath +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a child works like in the parent) + set v [interp eval $i {package require SafeTestPackage1}] + # no error shall occur: + interp eval $i {HeresPackage1} + set v +} -cleanup { + safe::interpDelete $i +} -match glob -result 1.2.3 +test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath; zipfs} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # should add as p* (not p2 if parent has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 $token3 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ + 1 {can't find package SafeTestPackage1} --\ + {TCLLIB */dummy/unixlike/test/path ZIPDIR/auto0} -- {}} +test safe-zipfs-7.4 {tests specific path and positive search; zipfs} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-zipfs-7.2, SafeTestPackage1 should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ + {TCLLIB * ZIPDIR/auto0/auto1} -- {}} + +test safe-zipfs-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset); zipfs} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}} +test safe-zipfs-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset); zipfs} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 ok1 0 ok2 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}} +test safe-zipfs-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement; zipfs} -setup { +} -body { + # For complete correspondence to safe-stock87-9.11, include auto0 in access path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0] \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0] \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-zipfs-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0; zipfs} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 1.2.3 0 2.3.4 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ + {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-zipfs-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed; zipfs} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ + $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB*}} +test safe-zipfs-9.20 {check module loading; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} -- res0 res1 res2} +# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in +# tokenized form to the child's access path, and then adds all the +# descendants, discovered recursively by using glob. +# - The order of the directories in the list returned by glob is system-dependent, +# and therefore this is true also for (a) the order of token assignment to +# descendants of the [tcl::tm::list] roots; and (b) the order of those same +# directories in the access path. Both those things must be sorted before +# comparing with expected results. The test is therefore not totally strict, +# but will notice missing or surplus directories. +test safe-zipfs-9.21 {interpConfigure change the access path; check module loading; stale data case 1; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-zipfs-9.20. +test safe-zipfs-9.22 {interpConfigure change the access path; check module loading; stale data case 0; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-zipfs-9.20. +test safe-zipfs-9.23 {interpConfigure change the access path; check module loading; stale data case 3; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-zipfs-9.20. +test safe-zipfs-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case); zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB ZIPDIR/auto0/modules ZIPDIR/auto0/modules/mod1\ + ZIPDIR/auto0/modules/mod2} --\ + {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2 ZIPDIR/auto0/modules\ + ZIPDIR/auto0/modules/mod1 ZIPDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-zipfs-9.20. + +# cleanup +set ::auto_path $SaveAutoPath +zipfs unmount ${ZipMountPoint} +unset SaveAutoPath TestsDir ZipMountPoint PathMapp +rename mapList {} +rename mapAndSortList {} +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/safe.test b/tests/safe.test index 356e176..f3a6565 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -4,47 +4,72 @@ # using safe interpreters. Sourcing this file into tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# The defunct package http 1.0 was convenient for testing package loading. +# - Tests that used http are replaced here with tests that use example packages +# provided in subdirectory auto0 of the tests directory, which are independent +# of any changes made to the packages provided with Tcl itself. +# - These are tests 7.1 7.2 7.4 9.11 9.13 +# - Tests 5.* test the example packages themselves before they +# are used to test Safe Base interpreters. +# - Alternative tests using stock packages of Tcl 8.7 are in file +# safe-stock.test. +# +# Copyright © 1995-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.5- - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } -foreach i [interp slaves] { +foreach i [interp children] { interp delete $i } -set saveAutoPath $::auto_path +set SaveAutoPath $::auto_path set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] +set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR] + +proc mapList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + return $listOut +} +proc mapAndSortList {map listIn} { + set listOut {} + foreach element $listIn { + lappend listOut [string map $map $element] + } + lsort $listOut +} -# Force actual loading of the safe package because we use un exported (and +# Force actual loading of the safe package because we use un-exported (and # thus un-autoindexed) APIs in this test result arguments: catch {safe::interpConfigure} # testing that nested and statics do what is advertised (we use a static -# package - Tcltest - but it might be absent if we're in standard tclsh) +# package - tcl::test - but it might be absent if we're in standard tclsh) -testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] +testConstraint tcl::test [expr {![catch {package require tcl::test}]}] test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body { safe::interpConfigure -} -result {no value given for parameter "slave" (use -help for full usage) : - slave name () name of the slave} +} -result {no value given for parameter "child" (use -help for full usage) : + child name () name of the child} test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body { safe::interpCreate -help } -result {Usage information: Var/FlagName Type Value Help ------------ ---- ----- ---- (-help gives this help) - ?slave? name () name of the slave (optional) - -accessPath list () access path for the slave + ?child? name () name of the child (optional) + -accessPath list () access path for the child -noStatics boolflag (false) prevent loading of statically linked pkgs -statics boolean (true) loading of statically linked pkgs -nestedLoadOk boolflag (false) allow nested loading @@ -53,7 +78,7 @@ test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body { test safe-1.3 {safe::interpInit syntax} -returnCodes error -body { safe::interpInit -noStatics } -result {bad value "-noStatics" for parameter - slave name () name of the slave} + child name () name of the child} test safe-2.1 {creating interpreters, should have no aliases} emptyTest { # Disabled this test. It tests nothing sensible. [Bug 999612] @@ -66,6 +91,8 @@ test safe-2.2 {creating interpreters, should have no aliases} -setup { a aliases } -cleanup { safe::interpDelete a + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -setup { catch {safe::interpDelete a} @@ -115,6 +142,8 @@ test safe-4.1 {safe::interpDelete} -setup { } -body { interp create a safe::interpDelete a + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-4.2 {safe::interpDelete, indirectly} -setup { catch {safe::interpDelete a} @@ -122,6 +151,8 @@ test safe-4.2 {safe::interpDelete, indirectly} -setup { interp create a a alias exit safe::interpDelete a a eval exit + # This (ab)use of safe::interpDelete to delete non-Safe-Base interpreters + # is regrettable and should be removed at the next major revision. } -result "" test safe-4.5 {safe::interpDelete} -setup { catch {safe::interpDelete a} @@ -138,17 +169,120 @@ test safe-4.6 {safe::interpDelete, indirectly} -setup { a eval exit } -result "" -# The following test checks whether the definition of tcl_endOfWord can be -# obtained from auto_loading. +# The old test "safe-5.1" has been moved to "safe-stock-9.8". +# A replacement test using example files is "safe-9.8". +# Tests 5.* test the example files before using them to test safe interpreters. -test safe-5.1 {test auto-loading in safe interpreters} -setup { - catch {safe::interpDelete a} - safe::interpCreate a +unset -nocomplain path + +test safe-5.1 {example tclIndex commands, test in parent interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] [file join $TestsDir auto0 auto2] } -body { - interp eval a {tcl_endOfWord "" 0} + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 } -cleanup { - safe::interpDelete a -} -result -1 + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {0 ok1 0 ok2} +test safe-5.2 {example tclIndex commands, negative test in parent interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} +test safe-5.3 {example pkgIndex.tcl packages, test in parent interpreter, child directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-5.4 {example pkgIndex.tcl packages, test in parent interpreter, main directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-5.5 {example modules packages, test in parent interpreter, replace path} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} +test safe-5.6 {example modules packages, test in parent interpreter, append to path} -setup { + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} # test safe interps 'information leak' proc SafeEval {script} { @@ -176,59 +310,121 @@ test safe-6.3 {test safe interpreters knowledge of the world} { lsort $r } {byteOrder engine pathSeparator platform pointerSize wordSize} +rename SafeEval {} # More test should be added to check that hostname, nameofexecutable, aren't # leaking infos, but they still do... # high level general test -test safe-7.1 {tests that everything works at high level} -body { +# Use example packages not http1.0 etc +test safe-7.1 {tests that everything works at high level} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] set i [safe::interpCreate] + set ::auto_path $tmpAutoPath +} -body { # no error shall occur: # (because the default access_path shall include 1st level sub dirs so - # package require in a slave works like in the master) - set v [interp eval $i {package require http 2}] + # package require in a child works like in the parent) + set v [interp eval $i {package require SafeTestPackage1}] # no error shall occur: - interp eval $i {http::config} - safe::interpDelete $i + interp eval $i {HeresPackage1} set v -} -match glob -result 2.* -test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { +} -cleanup { + safe::interpDelete $i +} -match glob -result 1.2.3 +test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -setup { +} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p1 + # should add as p* (not p1 if parent has a module path) set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # an error shall occur (http is not anymore in the secure 0-level + # should add as p* (not p2 if parent has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level # provided deep path) - list $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ - [safe::interpConfigure $i]\ - [safe::interpDelete $i] -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" + list $token1 $token2 $token3 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ + 1 {can't find package SafeTestPackage1} --\ + {TCLLIB */dummy/unixlike/test/path TESTSDIR/auto0} -- {}} test safe-7.3 {check that safe subinterpreters work} { + set g [interp children] + if {$g ne {}} { + append g { -- residue of an earlier test} + } + set h [info vars ::safe::S*] + if {$h ne {}} { + append h { -- residue of an earlier test} + } set i [safe::interpCreate] set j [safe::interpCreate [list $i x]] - list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] -} {ok {} 0} + list $g $h [interp eval $j {join {o k} ""}] [safe::interpDelete $i] \ + [interp exists $j] [info vars ::safe::S*] +} {{} {} ok {} 0 {}} +test safe-7.3.1 {check that safe subinterpreters work with namespace names} -setup { +} -body { + set g [interp children] + if {$g ne {}} { + append g { -- residue of an earlier test} + } + set h [info vars ::safe::S*] + if {$h ne {}} { + append h { -- residue of an earlier test} + } + set i [safe::interpCreate foo::bar] + set j [safe::interpCreate [list $i hello::world]] + list $g $h [interp eval $j {join {o k} ""}] \ + [foo::bar eval {hello::world eval {join {o k} ""}}] \ + [safe::interpDelete $i] \ + [interp exists $j] [info vars ::safe::S*] +} -match glob -result {{} {} ok ok {} 0 {}} +test safe-7.4 {tests specific path and positive search} -setup { +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if parent has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + # this time, unlike test safe-7.2, SafeTestPackage1 should be found + list $token1 $token2 -- \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ + $mappA -- [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { +} -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ + {TCLLIB * TESTSDIR/auto0/auto1} -- {}} # test source control on file name -set i "a" test safe-8.1 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} } -body { safe::interpCreate $i $i eval {source} } -returnCodes error -cleanup { safe::interpDelete $i + unset i } -result {wrong # args: should be "source ?-encoding E? fileName"} test safe-8.2 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} } -body { safe::interpCreate $i $i eval {source a b c d e} } -returnCodes error -cleanup { safe::interpDelete $i + unset i } -result {wrong # args: should be "source ?-encoding E? fileName"} test safe-8.3 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {lappend ::log $str} @@ -239,10 +435,12 @@ test safe-8.3 {safe source control on file} -setup { list [catch {$i eval {source .}} msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i -} -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}} + rename safe-test-log {} + unset i log +} -result {1 {permission denied} {{ERROR for child a : ".": is a directory}}} test safe-8.4 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -253,10 +451,12 @@ test safe-8.4 {safe source control on file} -setup { list [catch {$i eval {source /abc/def}} msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i -} -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}} + rename safe-test-log {} + unset i log +} -result {1 {permission denied} {{ERROR for child a : "/abc/def": not in access_path}}} test safe-8.5 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -271,10 +471,12 @@ test safe-8.5 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i -} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]] + rename safe-test-log {} + unset i log +} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] blah]:no such file or directory"]] test safe-8.6 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -287,10 +489,12 @@ test safe-8.6 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i -} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]] + rename safe-test-log {} + unset i log +} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] blah.tcl]:no such file or directory"]] test safe-8.7 {safe source control on file} -setup { + set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -305,14 +509,16 @@ test safe-8.7 {safe source control on file} -setup { } msg] $msg $log } -cleanup { safe::setLogCmd $prevlog - unset log safe::interpDelete $i -} -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]] + rename safe-test-log {} + unset i log +} -result [list 1 {no such file or directory} [list "ERROR for child a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]] test safe-8.8 {safe source forbids -rsrc} emptyTest { # Disabled this test. It was only useful for long unsupported # Mac OS 9 systems. [Bug 860a9f1945] } {} test safe-8.9 {safe source and return} -setup { + set i "a" set returnScript [makeFile {return "ok"} return.tcl] catch {safe::interpDelete $i} } -body { @@ -322,8 +528,10 @@ test safe-8.9 {safe source and return} -setup { } -cleanup { catch {safe::interpDelete $i} removeFile $returnScript + unset i } -result ok test safe-8.10 {safe source and return} -setup { + set i "a" set returnScript [makeFile {return -level 2 "ok"} return.tcl] catch {safe::interpDelete $i} } -body { @@ -336,10 +544,11 @@ test safe-8.10 {safe source and return} -setup { } -cleanup { catch {safe::interpDelete $i} removeFile $returnScript + unset i } -result ok -set i "a" test safe-9.1 {safe interps' deleteHook} -setup { + set i "a" catch {safe::interpDelete $i} set res {} } -body { @@ -352,8 +561,12 @@ test safe-9.1 {safe interps' deleteHook} -setup { } safe::interpCreate $i -deleteHook "testDelHook arg1 arg2" list [interp eval $i exit] $res +} -cleanup { + catch {rename testDelHook {}} + unset i res } -result {{} {arg1 arg2 a}} test safe-9.2 {safe interps' error in deleteHook} -setup { + set i "a" catch {safe::interpDelete $i} set res {} set log {} @@ -374,8 +587,10 @@ test safe-9.2 {safe interps' error in deleteHook} -setup { list [safe::interpDelete $i] $res $log } -cleanup { safe::setLogCmd $prevlog - unset log -} -result {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}}} + catch {rename testDelHook {}} + rename safe-test-log {} + unset i log res +} -result {{} {arg1 arg2 a} {{NOTICE for child a : About to delete} {ERROR for child a : Delete hook error (being catched)} {NOTICE for child a : Deleted}}} test safe-9.3 {dual specification of statics} -returnCodes error -body { safe::interpCreate -stat true -nostat } -result {conflicting values given for -statics and -noStatics} @@ -403,60 +618,599 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i]\ [safe::interpConfigure $i -deleteHook toto -nosta -nested 0 safe::interpConfigure $i] -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +} -cleanup { + safe::interpDelete $i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { + # this test shall work, believed equivalent to 9.6 + set i [safe::interpCreate \ + -noStatics \ + -nestedLoadOk \ + -deleteHook {foo bar}] + safe::interpConfigure $i -accessPath /foo/bar + set a [safe::interpConfigure $i] + set b [safe::interpConfigure $i -aCCess] + set c [safe::interpConfigure $i -nested] + set d [safe::interpConfigure $i -statics] + set e [safe::interpConfigure $i -DEL] + safe::interpConfigure $i -accessPath /blah -statics 1 + set f [safe::interpConfigure $i] + safe::interpConfigure $i -deleteHook toto -nosta -nested 0 + set g [safe::interpConfigure $i] + + list $a $b $c $d $e $f $g +} -cleanup { + safe::interpDelete $i + unset -nocomplain a b c d e f g i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +test safe-9.8 {test autoloading commands indexed in tclIndex files} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}} +test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} +test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} +test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { +} -body { + # For complete correspondence to safe-9.10opt, include auto0 in access path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- \ + $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ + $mappA -- $mappB +} -cleanup { + safe::interpDelete $i +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}} +test safe-9.20 {check module loading} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] -catch {teststaticpkg Safepkg1 0 0} -test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} -- res0 res1 res2} +# - The command safe::InterpSetConfig adds the parent's [tcl::tm::list] in +# tokenized form to the child's access path, and then adds all the +# descendants, discovered recursively by using glob. +# - The order of the directories in the list returned by glob is system-dependent, +# and therefore this is true also for (a) the order of token assignment to +# descendants of the [tcl::tm::list] roots; and (b) the order of those same +# directories in the access path. Both those things must be sorted before +# comparing with expected results. The test is therefore not totally strict, +# but will notice missing or surplus directories. +test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. + +catch {teststaticlibrary Safepfx1 0 0} +test safe-10.1 {testing statics loading} -constraints tcl::test -setup { set i [safe::interpCreate] } -body { - interp eval $i {load {} Safepkg1} + interp eval $i {load {} Safepfx1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} -test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { +} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure} +test safe-10.1.1 {testing statics loading} -constraints tcl::test -setup { set i [safe::interpCreate] } -body { - catch {interp eval $i {load {} Safepkg1}} m o + catch {interp eval $i {load {} Safepfx1}} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure invoked from within -"load {} Safepkg1" +"load {} Safepfx1" invoked from within -"interp eval $i {load {} Safepkg1}"} -test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body { +"interp eval $i {load {} Safepfx1}"} +test safe-10.2 {testing statics loading / -nostatics} -constraints tcl::test -body { set i [safe::interpCreate -nostatics] - interp eval $i {load {} Safepkg1} + interp eval $i {load {} Safepfx1} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {permission denied (static package)} +} -result {permission denied (static library)} test safe-10.3 {testing nested statics loading / no nested by default} -setup { set i [safe::interpCreate] -} -constraints TcltestPackage -body { - interp eval $i {interp create x; load {} Safepkg1 x} +} -constraints tcl::test -body { + interp eval $i {interp create x; load {} Safepfx1 x} } -returnCodes error -cleanup { safe::interpDelete $i } -result {permission denied (nested load)} -test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { +test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body { set i [safe::interpCreate -nestedloadok] - interp eval $i {interp create x; load {} Safepkg1 x} + interp eval $i {interp create x; load {} Safepfx1 x} } -returnCodes error -cleanup { safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} -test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { +} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure} +test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints tcl::test -body { set i [safe::interpCreate -nestedloadok] - catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o + catch {interp eval $i {interp create x; load {} Safepfx1 x}} m o dict get $o -errorinfo } -returnCodes ok -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure +} -result {load of library for prefix Safepfx1 failed: can't use library in a safe interpreter: no Safepfx1_SafeInit procedure invoked from within -"load {} Safepkg1 x" +"load {} Safepfx1 x" invoked from within -"interp eval $i {interp create x; load {} Safepkg1 x}"} +"interp eval $i {interp create x; load {} Safepfx1 x}"} test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] @@ -608,6 +1362,15 @@ proc buildEnvironment {filename} { set testdir2 [makeDirectory deletemetoo $testdir] set testfile [makeFile {} $filename $testdir2] } +proc buildEnvironment2 {filename} { + upvar 1 testdir testdir testdir2 testdir2 testfile testfile + upvar 1 testdir3 testdir3 testfile2 testfile2 + set testdir [makeDirectory deletethisdir] + set testdir2 [makeDirectory deletemetoo $testdir] + set testfile [makeFile {} $filename $testdir2] + set testdir3 [makeDirectory deleteme $testdir] + set testfile2 [makeFile {} $filename $testdir3] +} #### New tests for Safe base glob, with patches @ Bug 2964715 test safe-13.1 {glob is restricted [Bug 2964715]} -setup { set i [safe::interpCreate] @@ -679,21 +1442,33 @@ test safe-13.6 {as 13.4 but test silent failure when result is outside access_pa safe::interpDelete $i removeDirectory $testdir } -result {} -test safe-13.7 {mimic the glob call by tclPkgUnknown which gives a deliberate error in a safe interpreter [Bug 2964715]} -setup { +test safe-13.7 {mimic the glob call by tclPkgUnknown in a safe interpreter [Bug 2964715]} -setup { set i [safe::interpCreate] buildEnvironment pkgIndex.tcl } -body { set safeTD [::safe::interpAddToAccessPath $i $testdir] ::safe::interpAddToAccessPath $i $testdir2 - string map [list $safeTD EXPECTED] [$i eval [list \ + mapList [list $safeTD EXPECTED] [$i eval [list \ + glob -directory $safeTD -join * pkgIndex.tcl]] +} -cleanup { + safe::interpDelete $i + removeDirectory $testdir +} -result {EXPECTED/deletemetoo/pkgIndex.tcl} +test safe-13.7.1 {mimic the glob call by tclPkgUnknown in a safe interpreter with multiple subdirectories} -setup { + set i [safe::interpCreate] + buildEnvironment2 pkgIndex.tcl +} -body { + set safeTD [::safe::interpAddToAccessPath $i $testdir] + ::safe::interpAddToAccessPath $i $testdir2 + ::safe::interpAddToAccessPath $i $testdir3 + mapAndSortList [list $safeTD EXPECTED] [$i eval [list \ glob -directory $safeTD -join * pkgIndex.tcl]] } -cleanup { safe::interpDelete $i removeDirectory $testdir -} -result {{EXPECTED/deletemetoo/pkgIndex.tcl}} -# Note the extra {} around the result above; that's *expected* because of the -# format of virtual path roots. -test safe-13.8 {mimic the glob call by tclPkgUnknown without the deliberate error that is specific to pkgIndex.tcl [Bug 2964715]} -setup { +} -result {EXPECTED/deleteme/pkgIndex.tcl EXPECTED/deletemetoo/pkgIndex.tcl} +# See comments on lsort after test safe-9.20. +test safe-13.8 {mimic the glob call by tclPkgUnknown without the special treatment that is specific to pkgIndex.tcl [Bug 2964715]} -setup { set i [safe::interpCreate] buildEnvironment notIndex.tcl } -body { @@ -731,9 +1506,10 @@ test safe-13.10 {as 13.8 but test silent failure when result is outside access_p removeDirectory $testdir } -result {} rename buildEnvironment {} +rename buildEnvironment2 {} #### Test for the module path -test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup { +test safe-14.1 {Check that module path is the same as in the parent interpreter [Bug 2964715]} -setup { set i [safe::interpCreate] } -body { set tm {} @@ -795,6 +1571,7 @@ test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { } -cleanup { safe::interpDelete $i set env(HOME) $savedHOME + unset savedHOME } -result {./~} test safe-16.2 {Bug 3529949: defang ~user in paths} -setup { set i [safe::interpCreate] @@ -804,6 +1581,7 @@ test safe-16.2 {Bug 3529949: defang ~user in paths} -setup { "file join \[file dirname ~$user\] \[file tail ~$user\]"] } -cleanup { safe::interpDelete $i + unset user } -result {./~USER} test safe-16.3 {Bug 3529949: defang ~ in globs} -setup { set syntheticHOME [makeDirectory foo] @@ -818,6 +1596,7 @@ test safe-16.3 {Bug 3529949: defang ~ in globs} -setup { safe::interpDelete $i set env(HOME) $savedHOME removeDirectory $syntheticHOME + unset savedHOME syntheticHOME } -result {} test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { set i [safe::interpCreate] @@ -827,9 +1606,59 @@ test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { } -cleanup { safe::interpDelete $i } -result {} +test safe-16.5 {Bug 3529949: defang ~ in paths used by AliasGlob (1)} -setup { + set savedHOME $env(HOME) + set env(HOME) /foo/bar + set i [safe::interpCreate] +} -body { + $i eval { + set d [format %c 126] + file join {$p(:0:)} $d + } +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME + unset savedHOME +} -result {~} +test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup { + set savedHOME $env(HOME) + set env(HOME) /foo/bar + set i [safe::interpCreate] +} -body { + $i eval { + set d [format %c 126] + file join {$p(:0:)/foo/bar} $d + } +} -cleanup { + safe::interpDelete $i + set env(HOME) $savedHOME + unset savedHOME +} -result {~} +test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -body { + string map [list $user USER] [$i eval [list file join {$p(:0:)} ~$user]] +} -cleanup { + safe::interpDelete $i + unset user +} -result {~USER} +test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup { + set i [safe::interpCreate] + set user $tcl_platform(user) +} -body { + string map [list $user USER] [$i eval [list file join {$p(:0:)/foo/bar} ~$user]] +} -cleanup { + safe::interpDelete $i + unset user +} -result {~USER} -set ::auto_path $saveAutoPath # cleanup +set ::auto_path $SaveAutoPath +unset SaveAutoPath TestsDir PathMapp +unset -nocomplain path +rename mapList {} +rename mapAndSortList {} ::tcltest::cleanupTests return diff --git a/tests/scan.test b/tests/scan.test index b488f68..c6e7922 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1994 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1994 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -32,9 +32,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -44,19 +44,19 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -66,11 +66,11 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) set ieeeValues(littleEndian) 0 return 1 @@ -555,6 +555,11 @@ test scan-5.19 {bigint scanning invalid} -setup { list [scan "207698809136909011942886895" \ %llu a] $a } -result {1 207698809136909011942886895} +test scan-5.20 {ignore digit separators} -setup { + set a {}; set b {}; set c {}; +} -body { + list [scan "10_23_45" %d_%d_%d a b c] $a $b $c +} -result {3 10 23 45} test scan-6.1 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} @@ -600,6 +605,11 @@ test scan-6.8 {floating-point scanning} -setup { } -body { list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d } -result {2 4.6 5.2 {} {}} +test scan-6.8 {disallow diget separator in floating-point} -setup { + set a {}; set b {}; set c {}; +} -body { + list [scan "3.14_2.35_98.6" %f_%f_%f a b c ] $a $b $c +} -result {3 3.14 2.35 98.6} test scan-7.1 {string and character scanning} -setup { set a {}; set b {}; set c {}; set d {} @@ -629,18 +639,18 @@ test scan-7.5 {string and character scanning} -setup { test scan-7.6 {string and character scanning, unicode} -setup { set a {}; set b {}; set c {}; set d {} } -body { - list [scan "abc d\u00c7fghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d -} -result "4 abc d\u00c7f ghijk dum" + list [scan "abc dÇfghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d +} -result "4 abc dÇf ghijk dum" test scan-7.7 {string and character scanning, unicode} -setup { set a {}; set b {} } -body { - list [scan "ab\u00c7cdef" "ab%c%c" a b] $a $b + list [scan "abÇcdef" "ab%c%c" a b] $a $b } -result "2 199 99" test scan-7.8 {string and character scanning, unicode} -setup { set a {}; set b {} } -body { - list [scan "ab\ufeffdef" "%\[ab\ufeff\]" a] $a -} -result "1 ab\ufeff" + list [scan "ab\uFEFFdef" "%\[ab\uFEFF\]" a] $a +} -result "1 ab\uFEFF" test scan-8.1 {error conditions} -body { scan a diff --git a/tests/security.test b/tests/security.test index eeabc9c..6aa7ccb 100644 --- a/tests/security.test +++ b/tests/security.test @@ -6,12 +6,12 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/set-old.test b/tests/set-old.test index ea5155b..052bd23 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -6,15 +6,15 @@ # into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/set.test b/tests/set.test index 3c87000..357e34b 100644 --- a/tests/set.test +++ b/tests/set.test @@ -4,19 +4,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testset2 [llength [info commands testset2]] diff --git a/tests/socket.test b/tests/socket.test index fbaade9..a1a66b5 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -4,8 +4,8 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 Ajuba Solutions. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -60,23 +60,28 @@ # listening at port 2048. If all fails, a message is printed and the tests # using the remote server are not performed. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] ::tcltest::loadTestedCommands -if {[expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(TRAVIS_OSX_IMAGE)]}]} { +# A bad interaction between socket creation, macOS, and unattended CI +# environments make this whole file impractical to run; too many weird hangs. +if {[info exists ::env(MAC_CI)]} { return } +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] # Some tests require the Thread package or exec command testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] testConstraint exec [llength [info commands exec]] -testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] +testConstraint knownMsvcBug [expr {![info exists ::env(CI_BUILD_WITH_MSVC)]}] +testConstraint notWinCI [expr { + $tcl_platform(platform) ne "windows" || ![info exists ::env(CI)]}] # Produce a random port number in the Dynamic/Private range # from 49152 through 65535. @@ -248,7 +253,7 @@ if {$doTestsWithRemoteServer} { # Some tests are run only if we are doing testing against a remote server. testConstraint doTestsWithRemoteServer $doTestsWithRemoteServer if {!$doTestsWithRemoteServer} { - if {[string first s $::tcltest::verbose] != -1} { + if {[string first s $::tcltest::verbose] >= 0} { puts "Skipping tests with remote server. See tests/socket.test for" puts "information on how to run remote server." puts "Reason for not doing remote tests: $noRemoteTestReason" @@ -291,6 +296,11 @@ proc getPort sock { lindex [fconfigure $sock -sockname] 2 } +# Some tests in this file are known to hang *occasionally* on OSX; stop the +# worst offenders. +testConstraint notOSX [expr {$::tcl_platform(os) ne "Darwin"}] +# Here "Windows" means derived platforms as Cygwin or Msys2 too. +testConstraint notWindows [expr {![regexp {^(Windows|MSYS|CYGWIN)} $::tcl_platform(os)]}] # ---------------------------------------------------------------------- @@ -731,7 +741,7 @@ test socket_$af-2.12 {} [list socket stdio supported_$af] { close $f set ::done } 0 -test socket_$af-2.13 {Bug 1758a0b603} {socket stdio} { +test socket_$af-2.13 {Bug 1758a0b603} {socket stdio notWine} { file delete $path(script) set f [open $path(script) w] puts $f { @@ -933,7 +943,7 @@ test socket_$af-5.1 {byte order problems, socket numbers, htons} -body { return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} -} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner} +} -constraints [list socket supported_$af unix notRoot notOSX notWindows] -result {couldn't open socket: not owner} test socket_$af-5.2 {byte order problems, socket numbers, htons} -body { if {![catch {socket -server dodo 0x10000} msg]} { close $msg @@ -947,7 +957,7 @@ test socket_$af-5.3 {byte order problems, socket numbers, htons} -body { return {htons problem, should be disallowed, are you running as SU?} } return {couldn't open socket: not owner} -} -constraints [list socket supported_$af unix notRoot] -result {couldn't open socket: not owner} +} -constraints [list socket supported_$af unix notRoot notOSX notWindows] -result {couldn't open socket: not owner} test socket_$af-6.1 {accept callback error} -constraints [list socket supported_$af stdio] -setup { proc myHandler {msg options} { @@ -965,7 +975,7 @@ test socket_$af-6.1 {accept callback error} -constraints [list socket supported_ } close $f set f [open "|[list [interpreter] $path(script)]" r+] - proc accept {s a p} {expr 10 / 0} + proc accept {s a p} {expr {10 / 0}} set s [socket -server accept -myaddr $localhost 0] puts $f [lindex [fconfigure $s -sockname] 2] close $f @@ -1540,7 +1550,7 @@ test socket_$af-11.11 {testing spurious events} -setup { after cancel $timer sendCommand {close $server} } -result {0 2690 1} -test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer] -setup { +test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket supported_$af doTestsWithRemoteServer notWine] -setup { set counter 0 set done 0 set port [sendCommand { @@ -1863,13 +1873,13 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations } } - tcltest::DebugPuts 1 "== test \[$::localhost\]:$port $testmode ==" - set ::master [thread::id] - # helper thread creating async connection and initiating transfer (detach) to master: + tcltest::DebugPuts 2 "== test \[$::localhost\]:$port $testmode ==" + set ::parent [thread::id] + # helper thread creating async connection and initiating transfer (detach) to parent: set ::helper [thread::create] thread::send -async $::helper [list \ - lassign [list $::master $::localhost $port $testmode] \ - ::master ::localhost ::port ::testmode + lassign [list $::parent $::localhost $port $testmode] \ + ::parent ::localhost ::port ::testmode ] thread::send -async $::helper { set ::helper [thread::id] @@ -1878,29 +1888,29 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { if {"helper-writable" in $::testmode} {;# to test both sides during connect fileevent $fd writable [list apply {{fd} { if {[thread::id] ne $::helper} { - thread::send -async $::master {set ::count "ERROR: invalid thread, $::helper is expecting"} + thread::send -async $::parent {set ::count "ERROR: invalid thread, $::helper is expecting"} close $fd return } }} $fd] };# thread::detach $fd - thread::send -async $::master [list transf_master $fd {*}$args] + thread::send -async $::parent [list transf_parent $fd {*}$args] } iteration first } - # master proc commiting transfer attempt (attach) and checking acquire was successful: - proc transf_master {fd args} { - tcltest::DebugPuts 1 "** trma / $::count ** $args **" + # parent proc commiting transfer attempt (attach) and checking acquire was successful: + proc transf_parent {fd args} { + tcltest::DebugPuts 2 "** trma / $::count ** $args **" thread::attach $fd - if {"master-close" in $::testmode} {;# to test close during connect + if {"parent-close" in $::testmode} {;# to test close during connect set ::count $::count close $fd return };# fileevent $fd writable [list apply {{fd} { - if {[thread::id] ne $::master} { - thread::send -async $::master {set ::count "ERROR: invalid thread, $::master is expecting"} + if {[thread::id] ne $::parent} { + thread::send -async $::parent {set ::count "ERROR: invalid thread, $::parent is expecting"} close $fd return } @@ -1918,7 +1928,7 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { break } if {[incr ::count] >= $maxIter} break - tcltest::DebugPuts 1 "** iter / $::count **" + tcltest::DebugPuts 2 "** iter / $::count **" thread::send -async $::helper [list iteration nr $::count] } update @@ -1927,8 +1937,8 @@ proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} { catch {after cancel $tout} if {$srvsock ne {}} {close $srvsock} if {[info exists ::helper]} {thread::release -wait $::helper} - tcltest::DebugPuts 1 "== stop / $::count ==" - unset -nocomplain ::count ::testmode ::master ::helper + tcltest::DebugPuts 2 "== stop / $::count ==" + unset -nocomplain ::count ::testmode ::parent ::helper } } test socket_$af-13.2.tr1 {Testing socket transfer between threads during async connect} -body { @@ -1938,12 +1948,12 @@ test socket_$af-13.2.tr2 {Testing socket transfer between threads during async c transf_test {transfer helper-writable} 100 } -result 100 -constraints [list socket supported_$af thread] test socket_$af-13.2.cl1 {Testing socket transfer between threads during async connect} -body { - transf_test {master-close} 100 + transf_test {parent-close} 100 } -result 100 -constraints [list socket supported_$af thread] test socket_$af-13.2.cl2 {Testing socket transfer between threads during async connect} -body { - transf_test {master-close helper-writable} 100 + transf_test {parent-close helper-writable} 100 } -result 100 -constraints [list socket supported_$af thread] -catch {rename transf_master {}} +catch {rename transf_parent {}} rename transf_test {} # ---------------------------------------------------------------------- @@ -2098,7 +2108,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ } -result {{} bye} # FIXME: we should also have an IPv6 counterpart of this test socket-14.5 {[socket -async] which fails before any connect() can be made} \ - -constraints {socket supported_inet} \ + -constraints {socket supported_inet notWine} \ -body { # address from rfc5737 socket -async -myaddr 192.0.2.42 127.0.0.1 [randport] @@ -2386,7 +2396,7 @@ test socket-14.10.1 {pending [socket -async] and nonblocking [puts], server is I removeFile script } -result {{} ok} test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener, no flush} \ - -constraints {socket knownMsvcBug} \ + -constraints {socket notWinCI} \ -body { set sock [socket -async localhost [randport]] fconfigure $sock -blocking 0 @@ -2433,7 +2443,7 @@ test socket-14.12 {[socket -async] background progress triggered by [fconfigure } -result {connection refused} test socket-14.13 {testing writable event when quick failure} \ - -constraints {socket win supported_inet} \ + -constraints {socket win supported_inet notWine} \ -body { # Test for bug 336441ed59 where a quick background fail was ignored @@ -2517,7 +2527,7 @@ test socket-14.18 {bug c6ed4acfd8: running async socket connect made other conne } -result {} test socket-14.19 {tip 456 -- introduce the -reuseport option} \ - -constraints {socket} \ + -constraints {socket notWine} \ -body { proc accept {channel address port} {} set port [randport] diff --git a/tests/source.test b/tests/source.test index c6cccd6..eee03ec 100644 --- a/tests/source.test +++ b/tests/source.test @@ -4,9 +4,9 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-2000 Scriptics Corporation. # Contributions from Don Porter, NIST, 2003. (not subject to US copyright) # # See the file "license.terms" for information on usage and redistribution @@ -111,7 +111,7 @@ test source-2.7 {utf-8 with BOM} -setup { } -body { set out [open $sourcefile w] fconfigure $out -encoding utf-8 - puts $out "\ufeffset y new-y" + puts $out "\uFEFFset y new-y" close $out set y old-y source -encoding utf-8 $sourcefile @@ -199,7 +199,7 @@ test source-4.1 {continuation line parsing} -setup { test source-6.1 {source is binary ok} -setup { # Note [makeFile] writes in the system encoding. # [source] defaults to reading in the system encoding. - set sourcefile [makeFile [list set x "a b\0c"] source.file] + set sourcefile [makeFile [list set x "a b\x00c"] source.file] } -body { set x {} source $sourcefile @@ -208,7 +208,7 @@ test source-6.1 {source is binary ok} -setup { removeFile source.file } -result 5 test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} -setup { - set sourcefile [makeFile "set x ab\32c" source.file] + set sourcefile [makeFile "set x ab\x1Ac" source.file] } -body { set x {} source $sourcefile @@ -222,7 +222,7 @@ test source-7.1 {source -encoding test} -setup { file delete $sourcefile set f [open $sourcefile w] fconfigure $f -encoding utf-8 - puts $f "set symbol(square-root) \u221A; set x correct" + puts $f "set symbol(square-root) √; set x correct" close $f } -body { set x unset @@ -233,15 +233,15 @@ test source-7.1 {source -encoding test} -setup { } -result correct test source-7.2 {source -encoding test} -setup { # This tests for bad interactions between [source -encoding] - # and use of the Control-Z character (\u001A) as a cross-platform + # and use of the Control-Z character (\x1A) as a cross-platform # EOF character by [source]. Here we write out and the [source] a - # file that contains the byte \x1A, although not the character \u001A in + # file that contains the byte \x1A, although not the character \x1A in # the indicated encoding. set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] fconfigure $f -encoding utf-16 - puts $f "set symbol(square-root) \u221A; set x correct" + puts $f "set symbol(square-root) √; set x correct" close $f } -body { set x unset @@ -266,25 +266,25 @@ test source-7.5 {source -encoding: correct operation} -setup { file delete $sourcefile set f [open $sourcefile w] fconfigure $f -encoding utf-8 - puts $f "proc \u20ac {} {return foo}" + puts $f "proc € {} {return foo}" close $f } -body { source -encoding utf-8 $sourcefile - \u20ac + € } -cleanup { removeFile source.file - rename \u20ac {} + rename € {} } -result foo test source-7.6 {source -encoding: mismatch encoding error} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] fconfigure $f -encoding utf-8 - puts $f "proc \u20ac {} {return foo}" + puts $f "proc € {} {return foo}" close $f } -body { source -encoding ascii $sourcefile - \u20ac + € } -cleanup { removeFile source.file } -returnCodes error -match glob -result {invalid command name*} diff --git a/tests/split.test b/tests/split.test index d00c452..a34c49d 100644 --- a/tests/split.test +++ b/tests/split.test @@ -4,15 +4,15 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -49,20 +49,20 @@ test split-1.8 {basic split commands} { } {]\n} test split-1.9 {basic split commands} { proc foo {} { - set x ab\000c + set x ab\x00c set y [split $x {}] return $y } foo -} "a b \000 c" +} "a b \x00 c" test split-1.10 {basic split commands} { - split "a0ab1b2bbb3\000c4" ab\000c + split "a0ab1b2bbb3\x00c4" ab\x00c } {{} 0 {} 1 2 {} {} 3 {} 4} test split-1.11 {basic split commands} { split "12,3,45" {,} } {12 3 45} test split-1.12 {basic split commands} { - split "\u0001ab\u0001cd\u0001\u0001ef\u0001" \1 + split "\x01ab\x01cd\x01\x01ef\x01" \x01 } {{} ab cd {} ef {}} test split-1.13 {basic split commands} { split "12,34,56," {,} @@ -71,10 +71,10 @@ test split-1.14 {basic split commands} { split ",12,,,34,56," {,} } {{} 12 {} {} 34 56 {}} test split-1.15 {basic split commands} -body { - split "a\U1F4A9b" {} -} -result "a \U1F4A9 b" + split "a💩b" {} +} -result "a 💩 b" test split-1.16 {basic split commands} -body { - split "a\U1F4A9b" \U1F4A9 + split "a💩b" 💩 } -result "a b" test split-2.1 {split errors} { diff --git a/tests/stack.test b/tests/stack.test index 4c50f74..461e8d3 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -4,13 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1998-2000 Ajuba Solutions. +# Copyright © 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} # Note that a failure in this test may result in a crash of the executable. diff --git a/tests/string.test b/tests/string.test index 98890f9..c703490 100644 --- a/tests/string.test +++ b/tests/string.test @@ -4,21 +4,21 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2001 Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Helper commands to test various optimizations, code paths, and special cases. proc makeByteArray {s} {binary format a* $s} @@ -31,7 +31,7 @@ proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s} testConstraint testobj [expr {[info commands testobj] ne {}}] testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] testConstraint testevalex [expr {[info commands testevalex] ne {}}] -testConstraint tip389 [expr {[string length \U010000] == 2}] +testConstraint utf16 [expr {[string length \U010000] == 2}] testConstraint testbytestring [llength [info commands testbytestring]] # Used for constraining memory leak tests @@ -88,7 +88,7 @@ test stringComp-1.3.$noComp {error condition - undefined method during compile} foo abc 0 } a -test string-2.1.$noComp {string compare, too few args} { +test string-2.1.$noComp {string compare, not enough args} { list [catch {run {string compare a}} msg] $msg } {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} test string-2.2.$noComp {string compare, bad args} { @@ -119,23 +119,23 @@ test string-2.10.$noComp {string compare with special index} { list [catch {run {string compare -length end-3 abcde abxyz}} msg] $msg } {1 {expected integer but got "end-3"}} test string-2.11.$noComp {string compare, unicode} { - run {string compare ab\u7266 ab\u7267} + run {string compare ab牦 ab牧} } -1 test string-2.11.1.$noComp {string compare, unicode} { - run {string compare \334 \xDC} + run {string compare Ü Ü} } 0 test string-2.11.2.$noComp {string compare, unicode} { - run {string compare \334 \xFC} + run {string compare Ü ü} } -1 test string-2.11.3.$noComp {string compare, unicode} { - run {string compare \334\334\334\374\374 \334\334\334\334\334} + run {string compare ÜÜÜüü ÜÜÜÜÜ} } 1 test string-2.12.$noComp {string compare, high bit} { - # This test will fail if the underlying comparaison + # This test will fail if the underlying comparison # is using signed chars instead of unsigned chars. # (like SunOS's default memcmp thus the compat/memcmp.c) run {string compare "\x80" "@"} - # Nb this tests works also in utf8 space because \x80 is + # Nb this tests works also in utf-8 space because \x80 is # translated into a 2 or more bytelength but whose first byte has # the high bit set. } 1 @@ -152,10 +152,10 @@ test string-2.15.$noComp {string compare -nocase} { run {string compare -nocase abcde abcde} } 0 test string-2.15.1.$noComp {string compare -nocase} { - run {string compare -nocase \334 \xDC} + run {string compare -nocase Ü Ü} } 0 test string-2.15.2.$noComp {string compare -nocase} { - run {string compare -nocase \334\334\334\374\xFC \334\334\334\334\334} + run {string compare -nocase ÜÜÜüü ÜÜÜÜÜ} } 0 test string-2.16.$noComp {string compare -nocase with length} { run {string compare -length 2 -nocase abcde Abxyz} @@ -172,7 +172,7 @@ test string-2.19.$noComp {string compare -nocase with excessive length} { test string-2.20.$noComp {string compare -len unicode} { # These are strings that are 6 BYTELENGTH long, but the length # shouldn't make a different because there are actually 3 CHARS long - run {string compare -len 5 \334\334\334 \334\334\374} + run {string compare -len 5 ÜÜÜ ÜÜü} } -1 test string-2.21.$noComp {string compare -nocase with special index} { list [catch {run {string compare -nocase -length end-3 Abcde abxyz}} msg] $msg @@ -237,7 +237,7 @@ test string-3.3.$noComp {string equal} { run {string equal abcde abcde} } 1 test string-3.4.$noComp {string equal -nocase} { - run {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334} + run {string equal -nocase ÜÜÜÜüüüü ÜÜÜÜÜÜÜÜ} } 1 test string-3.5.$noComp {string equal -nocase} { run {string equal -nocase abcde abdef} @@ -251,7 +251,7 @@ test string-3.7.$noComp {string equal -nocase} { test string-3.8.$noComp {string equal with length, unequal strings} { run {string equal -length 2 abc abde} } 1 -test string-3.9.$noComp {string equal, too few args} { +test string-3.9.$noComp {string equal, not enough args} { list [catch {run {string equal a}} msg] $msg } {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} test string-3.10.$noComp {string equal, bad args} { @@ -274,19 +274,19 @@ test string-3.15.$noComp {string equal with special index} { } {1 {expected integer but got "end-3"}} test string-3.16.$noComp {string equal, unicode} { - run {string equal ab\u7266 ab\u7267} + run {string equal ab牦 ab牧} } 0 test string-3.17.$noComp {string equal, unicode} { - run {string equal \334 \xDC} + run {string equal Ü Ü} } 1 test string-3.18.$noComp {string equal, unicode} { - run {string equal \334 \xFC} + run {string equal Ü ü} } 0 test string-3.19.$noComp {string equal, unicode} { - run {string equal \334\334\334\374\374 \334\334\334\334\334} + run {string equal ÜÜÜüü ÜÜÜÜÜ} } 0 test string-3.20.$noComp {string equal, high bit} { - # This test will fail if the underlying comparaison + # This test will fail if the underlying comparison # is using signed chars instead of unsigned chars. # (like SunOS's default memcmp thus the compat/memcmp.c) run {string equal "\x80" "@"} @@ -298,10 +298,10 @@ test string-3.21.$noComp {string equal -nocase} { run {string equal -nocase abcde Abdef} } 0 test string-3.22.$noComp {string equal, -nocase unicode} { - run {string equal -nocase \334 \xDC} + run {string equal -nocase Ü Ü} } 1 test string-3.23.$noComp {string equal, -nocase unicode} { - run {string equal -nocase \334\334\334\374\xFC \334\334\334\334\334} + run {string equal -nocase ÜÜÜüü ÜÜÜÜÜ} } 1 test string-3.24.$noComp {string equal -nocase with length} { run {string equal -length 2 -nocase abcde Abxyz} @@ -318,7 +318,7 @@ test string-3.27.$noComp {string equal -nocase with excessive length} { test string-3.28.$noComp {string equal -len unicode} { # These are strings that are 6 BYTELENGTH long, but the length # shouldn't make a different because there are actually 3 CHARS long - run {string equal -len 5 \334\334\334 \334\334\374} + run {string equal -len 5 ÜÜÜ ÜÜü} } 0 test string-3.29.$noComp {string equal -nocase with special index} { list [catch {run {string equal -nocase -length end-3 Abcde abxyz}} msg] $msg @@ -366,7 +366,7 @@ test string-3.42.$noComp {string equal, binary neq inequal length} { } 0 -test string-4.1.$noComp {string first, too few args} { +test string-4.1.$noComp {string first, not enough args} { list [catch {run {string first a}} msg] $msg } {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} test string-4.2.$noComp {string first, bad args} { @@ -391,19 +391,19 @@ test string-4.8.$noComp {string first} { run {string first "" x123xx345xxx789xxx012} } -1 test string-4.9.$noComp {string first, unicode} { - run {string first x abc\u7266x} + run {string first x abc牦x} } 4 test string-4.10.$noComp {string first, unicode} { - run {string first \u7266 abc\u7266x} + run {string first 牦 abc牦x} } 3 test string-4.11.$noComp {string first, start index} { - run {string first \u7266 abc\u7266x 3} + run {string first 牦 abc牦x 3} } 3 test string-4.12.$noComp {string first, start index} -body { - run {string first \u7266 abc\u7266x 4} + run {string first 牦 abc牦x 4} } -result -1 test string-4.13.$noComp {string first, start index} -body { - run {string first \u7266 abc\u7266x end-2} + run {string first 牦 abc牦x end-2} } -result 3 test string-4.14.$noComp {string first, negative start index} -body { run {string first b abc -1} @@ -412,7 +412,7 @@ test string-4.15.$noComp {string first, ability to two-byte encoded utf-8 chars} # Test for a bug in Tcl 8.3 where test for all-single-byte-encoded # strings was incorrect, leading to an index returned by [string first] # which pointed past the end of the string. - set uchar \u057E ;# character with two-byte encoding in utf-8 + set uchar վ ;# character with two-byte encoding in utf-8 run {string first % %#$uchar$uchar#$uchar$uchar#% 3} } -result 8 test string-4.16.$noComp {string first, normal string vs pure unicode string} -body { @@ -469,13 +469,13 @@ test string-5.9.$noComp {string index} { run {string index abc end-1} } b test string-5.10.$noComp {string index, unicode} { - run {string index abc\u7266d 4} + run {string index abc牦d 4} } d test string-5.11.$noComp {string index, unicode} { - run {string index abc\u7266d 3} -} \u7266 + run {string index abc牦d 3} +} 牦 test string-5.12.$noComp {string index, unicode over char length, under byte length} -body { - run {string index \334\374\334\374 6} + run {string index ÜüÜü 6} } -result {} test string-5.13.$noComp {string index, bytearray object} { run {string index [binary format a5 fuz] 0} @@ -506,24 +506,15 @@ test string-5.19.$noComp {string index, bytearray object out of bounds} { test string-5.20.$noComp {string index, bytearray object out of bounds} -body { run {string index [binary format I* {0x50515253 0x52}] 20} } -result {} -test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} -constraints {tip389} -body { +test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} -constraints utf16 -body { run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]} } -result [list \U100000 {} b] -proc largest_int {} { - # This will give us what the largest valid int on this machine is, - # so we can test for overflow properly below on >32 bit systems - set int 1 - set exp 7; # assume we get at least 8 bits - while {wide($int) > 0} { set int [expr {wide(1) << [incr exp]}] } - return [expr {$int-1}] -} - -test string-6.1.$noComp {string is, too few args} { +test string-6.1.$noComp {string is, not enough args} { list [catch {run {string is}} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.2.$noComp {string is, too few args} { +test string-6.2.$noComp {string is, not enough args} { list [catch {run {string is alpha}} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} test string-6.3.$noComp {string is, bad args} { @@ -560,7 +551,7 @@ test string-6.12.$noComp {string is alnum, true} { test string-6.13.$noComp {string is alnum, false} { list [run {string is alnum -failindex var abc1.23}] $var } {0 4} -test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abc\xFC}" 1 +test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abcü}" 1 test string-6.15.$noComp {string is alpha, true} { run {string is alpha abc} } 1 @@ -568,7 +559,7 @@ test string-6.16.$noComp {string is alpha, false} { list [run {string is alpha -fail var a1bcde}] $var } {0 1} test string-6.17.$noComp {string is alpha, unicode} { - run {string is alpha abc\374} + run {string is alpha abcü} } 1 test string-6.18.$noComp {string is ascii, true} { run {string is ascii abc\x7Fend\x00} @@ -592,7 +583,7 @@ test string-6.24.$noComp {string is digit, true} { run {string is digit 0123456789} } 1 test string-6.25.$noComp {string is digit, false} { - list [run {string is digit -fail var 0123\xDC567}] $var + list [run {string is digit -fail var 0123Ü567}] $var } {0 4} test string-6.26.$noComp {string is digit, false} { list [run {string is digit -fail var +123567}] $var @@ -601,7 +592,7 @@ test string-6.27.$noComp {string is double, true} { run {string is double 1} } 1 test string-6.28.$noComp {string is double, true} { - run {string is double [expr double(1)]} + run {string is double [expr {double(1)}]} } 1 test string-6.29.$noComp {string is double, true} { run {string is double 1.0} @@ -634,7 +625,7 @@ test string-6.37.$noComp {string is double, false on int overflow} -setup { # Since bignums arrived in Tcl 8.5, the sense of this test changed. # Now integer values that exceed native limits become bignums, and # bignums can convert to doubles without error. - list [run {string is double -fail var [largest_int]0}] $var + list [run {string is double -fail var 9223372036854775808}] $var } -result {1 priorValue} # string-6.38 removed, underflow on input is no longer an error. test string-6.39.$noComp {string is double, false} { @@ -676,7 +667,7 @@ test string-6.48.$noComp {string is integer, true} { run {string is integer +1234567890} } 1 test string-6.49.$noComp {string is integer, true on type} { - run {string is integer [expr int(50.0)]} + run {string is integer [expr {int(50.0)}]} } 1 test string-6.50.$noComp {string is integer, true} { run {string is integer [list -10]} @@ -694,10 +685,10 @@ test string-6.54.$noComp {string is integer, false} { list [run {string is integer -fail var 123abc}] $var } {0 3} test string-6.55.$noComp {string is integer, no overflow possible} { - run {string is integer +[largest_int]0} + run {string is integer +9223372036854775808} } 1 test string-6.56.$noComp {string is integer, false} { - list [run {string is integer -fail var [expr double(1)]}] $var + list [run {string is integer -fail var [expr {double(1)}]}] $var } {0 1} test string-6.57.$noComp {string is integer, false} { list [run {string is integer -fail var " "}] $var @@ -715,7 +706,7 @@ test string-6.60.$noComp {string is lower, true} { run {string is lower abc} } 1 test string-6.61.$noComp {string is lower, unicode true} { - run {string is lower abc\xFCue} + run {string is lower abcüue} } 1 test string-6.62.$noComp {string is lower, false} { list [run {string is lower -fail var aBc}] $var @@ -724,7 +715,7 @@ test string-6.63.$noComp {string is lower, false} { list [run {string is lower -fail var abc1}] $var } {0 3} test string-6.64.$noComp {string is lower, unicode false} { - list [run {string is lower -fail var ab\xDCUE}] $var + list [run {string is lower -fail var abÜUE}] $var } {0 2} test string-6.65.$noComp {string is space, true} { run {string is space " \t\n\v\f"} @@ -762,7 +753,7 @@ test string-6.75.$noComp {string is upper, true} { run {string is upper ABC} } 1 test string-6.76.$noComp {string is upper, unicode true} { - run {string is upper ABC\xDCUE} + run {string is upper ABCÜUE} } 1 test string-6.77.$noComp {string is upper, false} { list [run {string is upper -fail var AbC}] $var @@ -771,13 +762,13 @@ test string-6.78.$noComp {string is upper, false} { list [run {string is upper -fail var AB2C}] $var } {0 2} test string-6.79.$noComp {string is upper, unicode false} { - list [run {string is upper -fail var ABC\xFCue}] $var + list [run {string is upper -fail var ABCüue}] $var } {0 3} test string-6.80.$noComp {string is wordchar, true} { run {string is wordchar abc_123} } 1 test string-6.81.$noComp {string is wordchar, unicode true} { - run {string is wordchar abc\xFCab\xDCAB\u5001} + run {string is wordchar abcüabÜAB倁\U1D7CA} } 1 test string-6.82.$noComp {string is wordchar, false} { list [run {string is wordchar -fail var abcd.ef}] $var @@ -846,7 +837,7 @@ test string-6.95.$noComp {string is wideinteger, true} { run {string is wideinteger +1234567890} } 1 test string-6.96.$noComp {string is wideinteger, true on type} { - run {string is wideinteger [expr wide(50.0)]} + run {string is wideinteger [expr {wide(50.0)}]} } 1 test string-6.97.$noComp {string is wideinteger, true} { run {string is wideinteger [list -10]} @@ -864,10 +855,10 @@ test string-6.101.$noComp {string is wideinteger, false} { list [run {string is wideinteger -fail var 123abc}] $var } {0 3} test string-6.102.$noComp {string is wideinteger, false on overflow} { - list [run {string is wideinteger -fail var +[largest_int]0}] $var + list [run {string is wideinteger -fail var +9223372036854775808}] $var } {0 -1} test string-6.103.$noComp {string is wideinteger, false} { - list [run {string is wideinteger -fail var [expr double(1)]}] $var + list [run {string is wideinteger -fail var [expr {double(1)}]}] $var } {0 1} test string-6.104.$noComp {string is wideinteger, false} { list [run {string is wideinteger -fail var " "}] $var @@ -902,7 +893,7 @@ test string-6.110.$noComp {string is entier, true} { run {string is entier +1234567890} } 1 test string-6.111.$noComp {string is entier, true on type} { - run {string is entier [expr wide(50.0)]} + run {string is entier [expr {wide(50.0)}]} } 1 test string-6.112.$noComp {string is entier, true} { run {string is entier [list -10]} @@ -923,7 +914,7 @@ test string-6.117.$noComp {string is entier, false} { list [run {string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc}] $var } {0 84} test string-6.118.$noComp {string is entier, false} { - list [run {string is entier -fail var [expr double(1)]}] $var + list [run {string is entier -fail var [expr {double(1)}]}] $var } {0 1} test string-6.119.$noComp {string is entier, false} { list [run {string is entier -fail var " "}] $var @@ -971,9 +962,7 @@ test string-6.131.$noComp {string is entier, false on bad hex} { list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var } {0 88} -catch {rename largest_int {}} - -test string-7.1.$noComp {string last, too few args} { +test string-7.1.$noComp {string last, not enough args} { list [catch {run {string last a}} msg] $msg } {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} test string-7.2.$noComp {string last, bad args} { @@ -992,22 +981,22 @@ test string-7.6.$noComp {string last} { run {string las x xxxx123xx345x678} } 12 test string-7.7.$noComp {string last, unicode} { - run {string las x xxxx12\u7266xx345x678} + run {string las x xxxx12牦xx345x678} } 12 test string-7.8.$noComp {string last, unicode} { - run {string las \u7266 xxxx12\u7266xx345x678} + run {string las 牦 xxxx12牦xx345x678} } 6 test string-7.9.$noComp {string last, stop index} { - run {string las \u7266 xxxx12\u7266xx345x678} + run {string las 牦 xxxx12牦xx345x678} } 6 test string-7.10.$noComp {string last, unicode} { - run {string las \u7266 xxxx12\u7266xx345x678} + run {string las 牦 xxxx12牦xx345x678} } 6 test string-7.11.$noComp {string last, start index} { - run {string last \u7266 abc\u7266x 3} + run {string last 牦 abc牦x 3} } 3 test string-7.12.$noComp {string last, start index} { - run {string last \u7266 abc\u7266x 2} + run {string last 牦 abc牦x 2} } -1 test string-7.13.$noComp {string last, start index} { ## Constrain to last 'a' should work @@ -1018,10 +1007,10 @@ test string-7.14.$noComp {string last, start index} { run {string last ba badbad end-2} } 0 test string-7.15.$noComp {string last, start index} { - run {string last \334a \334ad\334ad 0} + run {string last Üa ÜadÜad 0} } -1 test string-7.16.$noComp {string last, start index} { - run {string last \334a \334ad\334ad end-1} + run {string last Üa ÜadÜad end-1} } 3 test string-8.1.$noComp {string bytelength} { @@ -1050,7 +1039,7 @@ test string-9.4.$noComp {string length} { run {string le ""} } 0 test string-9.5.$noComp {string length, unicode} { - run {string le "abcd\u7266"} + run {string le "abcd牦"} } 5 test string-9.6.$noComp {string length, bytearray object} { run {string length [binary format a5 foo]} @@ -1059,7 +1048,7 @@ test string-9.7.$noComp {string length, bytearray object} { run {string length [binary format I* {0x50515253 0x52}]} } 8 -test string-10.1.$noComp {string map, too few args} { +test string-10.1.$noComp {string map, not enough args} { list [catch {run {string map}} msg] $msg } {1 {wrong # args: should be "string map ?-nocase? charMap string"}} test string-10.2.$noComp {string map, bad args} { @@ -1093,11 +1082,11 @@ test string-10.11.$noComp {string map, nulls} { run {string map {\x00 NULL blah \x00nix} {qwerty}} } {qwerty} test string-10.12.$noComp {string map, unicode} { - run {string map [list \374 ue UE \334] "a\374ueUE\000EU"} -} aueue\334\0EU + run {string map [list ü ue UE Ü] "aüueUE\x00EU"} +} aueueÜ\x00EU test string-10.13.$noComp {string map, -nocase unicode} { - run {string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU"} -} aue\334\334\0EU + run {string map -nocase [list ü ue UE Ü] "aüueUE\x00EU"} +} aueÜÜ\x00EU test string-10.14.$noComp {string map, -nocase null arguments} { run {string map -nocase {{} abc} foo} } foo @@ -1159,7 +1148,7 @@ test string-10.31.$noComp {string map, nasty sharing crash from [Bug 1018562]} { run {string map $a $a} } {b b} -test string-11.1.$noComp {string match, too few args} { +test string-11.1.$noComp {string match, not enough args} { list [catch {run {string match a}} msg] $msg } {1 {wrong # args: should be "string match ?-nocase? pattern string"}} test string-11.2.$noComp {string match, too many args} { @@ -1301,7 +1290,7 @@ test string-11.32.$noComp {string match nocase} { run {string match -n a A} } 1 test string-11.33.$noComp {string match nocase} { - run {string match -nocase a\334 A\374} + run {string match -nocase aÜ Aü} } 1 test string-11.34.$noComp {string match nocase} { run {string match -nocase a*f ABCDEf} @@ -1468,11 +1457,11 @@ test string-12.16.$noComp {string range} { run {string range abcdefghijklmnop end end-1} } {} test string-12.17.$noComp {string range, unicode} { - run {string range ab\u7266cdefghijklmnop 5 5} + run {string range ab牦cdefghijklmnop 5 5} } e test string-12.18.$noComp {string range, unicode} { - run {string range ab\u7266cdefghijklmnop 2 3} -} \u7266c + run {string range ab牦cdefghijklmnop 2 3} +} 牦c test string-12.19.$noComp {string range, bytearray object} { set b [binary format I* {0x50515253 0x52}] set r1 [run {string range $b 1 end-1}] @@ -1503,9 +1492,23 @@ test string-12.22.$noComp {string range, shimmering binary/index} { binary scan $s a* x run {string range $s $s end} } 000000001 -test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} tip389 { +test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} utf16 { run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]} } [list \U100000 {} b] +test string-12.24.$noComp {bignum index arithmetic} -setup { + proc demo {i j} {string range fubar $i $j} +} -cleanup { + rename demo {} +} -body { + demo 2 0+0x10000000000000000 +} -result bar +test string-12.25.$noComp {bignum index arithmetic} -setup { + proc demo {i j} {string range fubar $i $j} +} -cleanup { + rename demo {} +} -body { + demo 0x10000000000000000-0xffffffffffffffff 3 +} -result uba test string-13.1.$noComp {string repeat} { list [catch {run {string repeat}} msg] $msg @@ -1541,15 +1544,15 @@ test string-13.11.$noComp {string repeat} { run {string repeat def 1} } def test string-13.12.$noComp {string repeat} { - run {string repeat ab\u7266cd 3} -} ab\u7266cdab\u7266cdab\u7266cd + run {string repeat ab牦cd 3} +} ab牦cdab牦cdab牦cd test string-13.13.$noComp {string repeat} { run {string repeat \x00 3} } \x00\x00\x00 test string-13.14.$noComp {string repeat} { # The string range will ensure us that string repeat gets a unicode string - run {string repeat [run {string range ab\u7266cd 2 3}] 3} -} \u7266c\u7266c\u7266c + run {string repeat [run {string range ab牦cd 2 3}] 3} +} 牦c牦c牦c test string-14.1.$noComp {string replace} { list [catch {run {string replace}} msg] $msg @@ -1611,6 +1614,12 @@ test string-14.20.$noComp {string replace} { run {string replace [makeByteArray abcdefghijklmnop] end-10 end-2\ [makeByteArray NEW]} } {abcdeNEWop} +test string-14.21.$noComp {string replace (surrogates)} { + run {string replace \uD83D? 1 end \uDE02} +} \uD83D\uDE02 +test string-14.22.$noComp {string replace (surrogates)} { + run {string replace ?\uDE02 0 end-1 \uD83D} +} \uD83D\uDE02 test stringComp-14.21.$noComp {Bug 82e7f67325} { @@ -1651,8 +1660,11 @@ test stringComp-14.24.$noComp {Bug 1af8de570511} { test stringComp-14.25.$noComp {} { string length [string replace [string repeat a\xFE 2] 3 end {}] } 3 +test stringComp-14.26.$noComp {} { + run {string replace abcd 0x10000000000000000-0xffffffffffffffff 2 e} +} aed -test string-15.1.$noComp {string tolower too few args} { +test string-15.1.$noComp {string tolower not enough args} { list [catch {run {string tolower}} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} test string-15.2.$noComp {string tolower bad args} { @@ -1744,7 +1756,7 @@ test string-17.7.$noComp {string totitle, unicode} { test string-17.8.$noComp {string totitle, compiled} { lindex [run {string totitle [list aa bb [list cc]]}] 0 } Aa -test string-17.9.$noComp {string totitle, surrogates, bug [11ae2be95dac9417]} tip389 { +test string-17.9.$noComp {string totitle, surrogates, bug [11ae2be95dac9417]} utf16 { run {list [string totitle a\U118c0c 1 1] [string totitle a\U118c0c 2 2] \ [string totitle a\U118c0c 3 3]} } [list a\U118a0c a\U118c0C a\U118c0C] @@ -1840,7 +1852,7 @@ test string-20.8.$noComp {[c61818e4c9] [string trimright] fails when UtfPrev is lappend result [string map $m [run {string trimright $b [testbytestring \xA0]}]] lappend result [string map $m [run {string trimright $b \xE8\xA0}]] lappend result [string map $m [run {string trimright $b [testbytestring \xE8\xA0]}]] - lappend result [string map $m [run {string trimright $b \u0000}]] + lappend result [string map $m [run {string trimright $b \x00}]] } [list {*}[lrepeat 4 fooUV] {*}[lrepeat 2 fooU] {*}[lrepeat 2 foo] fooUV] test string-21.1.$noComp {string wordend} -body { @@ -1888,9 +1900,36 @@ test string-21.14.$noComp {string wordend, unicode} -body { test string-21.15.$noComp {string wordend, unicode} -body { run {string wordend "\U1D7CA\U1D7CA abc" 0} } -result 2 -test string-21.16.$noComp {string wordend, unicode} -constraints tip389 -body { +test string-21.16.$noComp {string wordend, unicode} -constraints utf16 -body { run {string wordend "\U1D7CA\U1D7CA abc" 10} } -result 8 +test string-21.17.$noComp {string trim, unicode} { + run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02} +} "Hello world!" +test string-21.18.$noComp {string trimleft, unicode} { + run {string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02} +} "Hello world!\uD83D\uDE02" +test string-21.19.$noComp {string trimright, unicode} { + run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD83D\uDE02} +} "\uD83D\uDE02Hello world!" +test string-21.20.$noComp {string trim, unicode} { + run {string trim "\uF602Hello world!\uF602" \uD83D\uDE02} +} "\uF602Hello world!\uF602" +test string-21.21.$noComp {string trimleft, unicode} { + run {string trimleft "\uF602Hello world!\uF602" \uD83D\uDE02} +} "\uF602Hello world!\uF602" +test string-21.22.$noComp {string trimright, unicode} { + run {string trimright "\uF602Hello world!\uF602" \uD83D\uDE02} +} "\uF602Hello world!\uF602" +test string-21.23.$noComp {string trim, unicode} { + run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} +} "\uD83D\uDE02Hello world!\uD83D\uDE02" +test string-21.24.$noComp {string trimleft, unicode} { + run {string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} +} "\uD83D\uDE02Hello world!\uD83D\uDE02" +test string-21.25.$noComp {string trimright, unicode} { + run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} +} "\uD83D\uDE02Hello world!\uD83D\uDE02" test string-22.1.$noComp {string wordstart} -body { list [catch {run {string word a}} msg] $msg @@ -1939,7 +1978,7 @@ test string-22.14.$noComp {string wordstart, invalid UTF-8} -constraints testbyt test string-22.15.$noComp {string wordstart, unicode} -body { run {string wordstart "\U1D7CA\U1D7CA abc" 0} } -result 0 -test string-22.16.$noComp {string wordstart, unicode} -constraints tip389 -body { +test string-22.16.$noComp {string wordstart, unicode} -constraints utf16 -body { run {string wordstart "\U1D7CA\U1D7CA abc" 10} } -result 5 @@ -2053,6 +2092,24 @@ test string-24.15.$noComp {string reverse command - pure bytearray} { binary scan [run {tcl::string::reverse [binary format H* 010203]}] H* x set x } 030201 +test string-24.16.$noComp {string reverse command - surrogates} { + run {string reverse \u0444bulb\uD83D\uDE02} +} \uD83D\uDE02blub\u0444 +test string-24.17.$noComp {string reverse command - surrogates} { + run {string reverse \uD83D\uDE02hello\uD83D\uDE02} +} \uD83D\uDE02olleh\uD83D\uDE02 +test string-24.18.$noComp {string reverse command - surrogates} { + set s \u0444bulb\uD83D\uDE02 + # shim shimmery ... + string index $s 0 + run {string reverse $s} +} \uD83D\uDE02blub\u0444 +test string-24.19.$noComp {string reverse command - surrogates} { + set s \uD83D\uDE02hello\uD83D\uDE02 + # shim shimmery ... + string index $s 0 + run {string reverse $s} +} \uD83D\uDE02olleh\uD83D\uDE02 test string-25.1.$noComp {string is list} { run {string is list {a b c}} @@ -2103,7 +2160,7 @@ test string-25.14.$noComp {string is list} { list [run {string is list -failindex x "\uABCD {b c}d e"}] $x } {0 2} -test string-26.1.$noComp {tcl::prefix, too few args} -body { +test string-26.1.$noComp {tcl::prefix, not enough args} -body { tcl::prefix match a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix match ?options? table string"} test string-26.2.$noComp {tcl::prefix, bad args} -body { @@ -2230,7 +2287,7 @@ test string-26.13.$noComp {tcl::prefix: testing for leaks} -body { } } -constraints memory -result {0} -test string-27.1.$noComp {tcl::prefix all, too few args} -body { +test string-27.1.$noComp {tcl::prefix all, not enough args} -body { tcl::prefix all a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"} test string-27.2.$noComp {tcl::prefix all, bad args} -body { @@ -2261,7 +2318,7 @@ test string-27.10.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} {} } {apa aska appa} -test string-28.1.$noComp {tcl::prefix longest, too few args} -body { +test string-28.1.$noComp {tcl::prefix longest, not enough args} -body { tcl::prefix longest a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"} test string-28.2.$noComp {tcl::prefix longest, bad args} -body { @@ -2298,7 +2355,7 @@ test string-28.12.$noComp {tcl::prefix longest} { tcl::prefix longest {apa {} appa} {} } {} test string-28.13.$noComp {tcl::prefix longest} { - # Test UTF8 handling + # Test utf-8 handling tcl::prefix longest {ax\x90 bep ax\x91} a } ax @@ -2460,6 +2517,13 @@ test string-31.24.$noComp {string insert, string end, pure Uni, both shared} { test string-31.25.$noComp {string insert, neither byte array nor Unicode} { run {tcl::string::insert [makeList a b c] 1 zzzzzz} } {azzzzzz b c} +test string-31.26.$noComp {[11229bad5f] string insert, compiler} -setup { + set i 2 +} -body { + run {tcl::string::insert abcd $i xyz} +} -cleanup { + unset i +} -result abxyzcd test string-32.1.$noComp {string is dict} { string is dict {a b c d} diff --git a/tests/stringObj.test b/tests/stringObj.test index 3779bca..135830c 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -6,19 +6,19 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1995-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] testConstraint testbytestring [llength [info commands testbytestring]] @@ -29,8 +29,8 @@ testConstraint nodep [info exists tcl_precision] test stringObj-1.1 {string type registration} testobj { set t [testobj types] set first [string first "string" $t] - set result [expr {$first != -1}] -} {1} + set result [expr {$first >= 0}] +} 1 test stringObj-2.1 {Tcl_NewStringObj} testobj { set result "" @@ -208,19 +208,19 @@ test stringObj-8.1 {DupStringInternalRep procedure} testobj { [teststringobj maxchars 2] [teststringobj get 2] } {5 10 0 abcde 5 5 0 abcde} test stringObj-8.2 {DupUnicodeInternalRep, mixed width chars} testobj { - set x abc\u00ef\u00bf\u00aeghi + set x abc\xEF\xBF\xAEghi string length $x set y $x - list [testobj objtype $x] [testobj objtype $y] [append x "\u00ae\u00bf\u00ef"] \ + list [testobj objtype $x] [testobj objtype $y] [append x "\xAE\xBF\xEF"] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "string string abc\u00ef\u00bf\u00aeghi\u00ae\u00bf\u00ef abc\u00ef\u00bf\u00aeghi string string" +} "string string abc\xEF\xBF\xAEghi\xAE\xBF\xEF abc\xEF\xBF\xAEghi string string" test stringObj-8.3 {DupUnicodeInternalRep, mixed width chars} testobj { - set x abc\u00ef\u00bf\u00aeghi + set x abc\xEF\xBF\xAEghi set y $x string length $x - list [testobj objtype $x] [testobj objtype $y] [append x "\u00ae\u00bf\u00ef"] \ + list [testobj objtype $x] [testobj objtype $y] [append x "\xAE\xBF\xEF"] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "string string abc\u00ef\u00bf\u00aeghi\u00ae\u00bf\u00ef abc\u00ef\u00bf\u00aeghi string string" +} "string string abc\xEF\xBF\xAEghi\xAE\xBF\xEF abc\xEF\xBF\xAEghi string string" test stringObj-8.4 {DupUnicodeInternalRep, all byte-size chars} testobj { set x abcdefghi string length $x @@ -237,31 +237,31 @@ test stringObj-8.5 {DupUnicodeInternalRep, all byte-size chars} testobj { } {string string abcdefghijkl abcdefghi string string} test stringObj-9.1 {TclAppendObjToObj, mixed src & dest} {testobj testdstring} { - set x abc\u00ef\u00bf\u00aeghi + set x abc\xEF\xBF\xAEghi testdstring free - testdstring append \u00ae\u00bf\u00ef -1 + testdstring append \xAE\xBF\xEF -1 set y [testdstring get] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "string none abc\u00ef\u00bf\u00aeghi\u00ae\u00bf\u00ef \u00ae\u00bf\u00ef string none" +} "string none abc\xEF\xBF\xAEghi\xAE\xBF\xEF \xAE\xBF\xEF string none" test stringObj-9.2 {TclAppendObjToObj, mixed src & dest} testobj { - set x abc\u00ef\u00bf\u00aeghi + set x abc\xEF\xBF\xAEghi string length $x list [testobj objtype $x] [append x $x] [testobj objtype $x] \ [append x $x] [testobj objtype $x] -} "string abc\u00ef\u00bf\u00aeghiabc\u00ef\u00bf\u00aeghi string\ -abc\u00ef\u00bf\u00aeghiabc\u00ef\u00bf\u00aeghiabc\u00ef\u00bf\u00aeghiabc\u00ef\u00bf\u00aeghi\ +} "string abc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghi string\ +abc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghiabc\xEF\xBF\xAEghi\ string" test stringObj-9.3 {TclAppendObjToObj, mixed src & 1-byte dest} {testobj testdstring} { set x abcdefghi testdstring free - testdstring append \u00ae\u00bf\u00ef -1 + testdstring append \xAE\xBF\xEF -1 set y [testdstring get] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "string none abcdefghi\u00ae\u00bf\u00ef \u00ae\u00bf\u00ef string none" +} "string none abcdefghi\xAE\xBF\xEF \xAE\xBF\xEF string none" test stringObj-9.4 {TclAppendObjToObj, 1-byte src & dest} {testobj testdstring} { set x abcdefghi testdstring free @@ -279,14 +279,14 @@ test stringObj-9.5 {TclAppendObjToObj, 1-byte src & dest} testobj { } {string abcdefghiabcdefghi string abcdefghiabcdefghiabcdefghiabcdefghi\ string} test stringObj-9.6 {TclAppendObjToObj, 1-byte src & mixed dest} {testobj testdstring} { - set x abc\u00ef\u00bf\u00aeghi + set x abc\xEF\xBF\xAEghi testdstring free testdstring append jkl -1 set y [testdstring get] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "string none abc\u00ef\u00bf\u00aeghijkl jkl string none" +} "string none abc\xEF\xBF\xAEghijkl jkl string none" test stringObj-9.7 {TclAppendObjToObj, integer src & dest} testobj { set x [expr {4 * 5}] set y [expr {4 + 5}] @@ -307,19 +307,19 @@ test stringObj-9.9 {TclAppendObjToObj, integer src & 1-byte dest} testobj { [set y] [testobj objtype $x] [testobj objtype $y] } {string int abcdefghi9 9 string int} test stringObj-9.10 {TclAppendObjToObj, integer src & mixed dest} testobj { - set x abc\u00ef\u00bf\u00aeghi + set x abc\xEF\xBF\xAEghi set y [expr {4 + 5}] string length $x list [testobj objtype $x] [testobj objtype $y] [append x $y] \ [set y] [testobj objtype $x] [testobj objtype $y] -} "string int abc\u00ef\u00bf\u00aeghi9 9 string int" +} "string int abc\xEF\xBF\xAEghi9 9 string int" test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} testobj { # bug 2678, in <=8.2.0, the second obj (the one to append) in # Tcl_AppendObjToObj was not correctly checked to see if it was all one # byte chars, so a unicode string would be added as one byte chars. set x abcdef set len [string length $x] - set y a\u00fcb\u00e5c\u00ef + set y a\xFCb\xE5c\xEF set len [string length $y] append x $y string length $x @@ -328,7 +328,7 @@ test stringObj-9.11 {TclAppendObjToObj, mixed src & 1-byte dest index check} tes lappend q [string index $x $i] } set q -} "a b c d e f a \u00fc b \u00e5 c \u00ef" +} "a b c d e f a \xFC b \xE5 c \xEF" test stringObj-10.1 {Tcl_GetRange with all byte-size chars} {testobj testdstring} { testdstring free @@ -338,41 +338,30 @@ test stringObj-10.1 {Tcl_GetRange with all byte-size chars} {testobj testdstring [testobj objtype $x] [testobj objtype $y] } [list none bcde string string] test stringObj-10.2 {Tcl_GetRange with some mixed width chars} {testobj testdstring} { - # Because this test does not use \uXXXX notation below instead of - # hardcoding the values, it may fail in multibyte locales. However, we - # need to test that the parser produces untyped objects even when there - # are high-ASCII characters in the input (like "ï"). I don't know what - # else to do but inline those characters here. testdstring free - testdstring append "abc\u00ef\u00efdef" -1 + testdstring append "abcïïdef" -1 set x [testdstring get] list [testobj objtype $x] [set y [string range $x 1 end-1]] \ [testobj objtype $x] [testobj objtype $y] -} [list none "bc\u00EF\u00EFde" string string] +} [list none "bcïïde" string string] test stringObj-10.3 {Tcl_GetRange with some mixed width chars} testobj { - # set x "abcïïdef" - # Use \uXXXX notation below instead of hardcoding the values, otherwise - # the test will fail in multibyte locales. - set x "abc\u00EF\u00EFdef" + set x "abcïïdef" string length $x list [testobj objtype $x] [set y [string range $x 1 end-1]] \ [testobj objtype $x] [testobj objtype $y] -} [list string "bc\u00EF\u00EFde" string string] +} [list string "bcïïde" string string] test stringObj-10.4 {Tcl_GetRange with some mixed width chars} testobj { - # set a "ïa¿b®cï¿d®" - # Use \uXXXX notation below instead of hardcoding the values, otherwise - # the test will fail in multibyte locales. - set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" + set a "ïa¿b®cï¿d®" set result [list] while {[string length $a] > 0} { set a [string range $a 1 end-1] lappend result $a } set result -} [list a\u00BFb\u00AEc\u00EF\u00BFd \ - \u00BFb\u00AEc\u00EF\u00BF \ - b\u00AEc\u00EF \ - \u00AEc \ +} [list a\xBFb\xAEc\xEF\xBFd \ + \xBFb\xAEc\xEF\xBF \ + b\xAEc\xEF \ + \xAEc \ {}] test stringObj-11.1 {UpdateStringOfString} testobj { @@ -394,15 +383,15 @@ test stringObj-12.3 {Tcl_GetUniChar with byte-size chars} testobj { list [string index $x end] [string index $x end-1] } {i h} test stringObj-12.4 {Tcl_GetUniChar with mixed width chars} testobj { - string index "\u00efa\u00bfb\u00aec\u00ae\u00bfd\u00ef" 0 -} "\u00ef" + string index "\xEFa\xBFb\xAEc\xAE\xBFd\xEF" 0 +} "\xEF" test stringObj-12.5 {Tcl_GetUniChar} testobj { - set x "\u00efa\u00bfb\u00aec\u00ae\u00bfd\u00ef" + set x "\xEFa\xBFb\xAEc\xAE\xBFd\xEF" list [string index $x 4] [string index $x 0] -} "\u00ae \u00ef" +} "\xAE \xEF" test stringObj-12.6 {Tcl_GetUniChar} testobj { - string index "\u00efa\u00bfb\u00aec\u00ef\u00bfd\u00ae" end -} "\u00ae" + string index "\xEFa\xBFb\xAEc\xEF\xBFd\xAE" end +} "\xAE" test stringObj-13.1 {Tcl_GetCharLength with byte-size chars} testobj { set a "" @@ -416,19 +405,19 @@ test stringObj-13.3 {Tcl_GetCharLength with byte-size chars} testobj { list [string length $a] [string length $a] } {6 6} test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj { - string length "\u00ae" + string length "\xAE" } 1 test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj { # string length "￮￮" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. - string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE" + string length "\xEF\xBF\xAE\xEF\xBF\xAE" } 6 test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} testobj { # set a "ïa¿b®cï¿d®" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. - set a "\u00EFa\u00BFb\u00AEc\u00EF\u00BFd\u00AE" + set a "\xEFa\xBFb\xAEc\xEF\xBFd\xAE" list [string length $a] [string length $a] } {10 10} test stringObj-13.7 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} { diff --git a/tests/subst.test b/tests/subst.test index 1f3c22a..da59c3b 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -4,19 +4,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1994 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-2000 Ajuba Solutions. +# Copyright © 1994 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.1 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testbytestring [llength [info commands testbytestring]] @@ -48,7 +48,7 @@ test subst-3.2 {backslash substitutions with utf chars} { # 'j' is just a char that doesn't mean anything, and \344 is 'ä' # that also doesn't mean anything, but is multi-byte in UTF-8. list [subst \j] [subst \\j] [subst \\344] [subst \\\344] -} "j j \344 \344" +} "j j ä ä" test subst-4.1 {variable substitutions} { set a 44 @@ -132,20 +132,20 @@ test subst-7.3 {switches} -returnCodes error -body { } -result {bad option "-bogus": must be -nobackslashes, -nocommands, or -novariables} test subst-7.4 {switches} { set x 123 - subst -nobackslashes {abc $x [expr 1+2] \\\x41} + subst -nobackslashes {abc $x [expr {1 + 2}] \\\x41} } {abc 123 3 \\\x41} test subst-7.5 {switches} { set x 123 - subst -nocommands {abc $x [expr 1+2] \\\x41} -} {abc 123 [expr 1+2] \A} + subst -nocommands {abc $x [expr {1 + 2}] \\\x41} +} {abc 123 [expr {1 + 2}] \A} test subst-7.6 {switches} { set x 123 - subst -novariables {abc $x [expr 1+2] \\\x41} + subst -novariables {abc $x [expr {1 + 2}] \\\x41} } {abc $x 3 \A} test subst-7.7 {switches} { set x 123 - subst -nov -nob -noc {abc $x [expr 1+2] \\\x41} -} {abc $x [expr 1+2] \\\x41} + subst -nov -nob -noc {abc $x [expr {1 + 2}] \\\x41} +} {abc $x [expr {1 + 2}] \\\x41} test subst-8.1 {return in a subst} { subst {foo [return {x}; bogus code] bar} @@ -282,18 +282,18 @@ test subst-13.1 {Bug 3081065} -setup { demo name2 } subst13.tcl] } -body { - interp create slave - slave eval [list source $script] - interp delete slave - interp create slave - slave eval { + interp create child + child eval [list source $script] + interp delete child + interp create child + child eval { set count 400 while {[incr count -1]} { lappend bloat [expr {rand()}] } } - slave eval [list source $script] - interp delete slave + child eval [list source $script] + interp delete child } -cleanup { removeFile subst13.tcl } diff --git a/tests/switch.test b/tests/switch.test index 4d204bb..2fce108 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/tailcall.test b/tests/tailcall.test index 9174167..c738bb3 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -4,18 +4,18 @@ # found in ::tcl::unsupported. The tests will migrate to normal test files # if/when the commands find their way into the core. # -# Copyright (c) 2008 by Miguel Sofer. +# Copyright © 2008 Miguel Sofer. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testnrelevels [llength [info commands testnrelevels]] diff --git a/tests/tcltest.test b/tests/tcltest.test index c856209..3177580 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -2,8 +2,8 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2000 by Ajuba Solutions +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2000 Ajuba Solutions # All rights reserved. # Note that there are several places where the value of @@ -13,13 +13,13 @@ # testing to run the test itself. Ditto on things like [verbose]. # # It would be better to have the -body of the tests run the tcltest -# commands in a slave interp so the [test] being tested would not +# commands in a child interp so the [test] being tested would not # interfere with the [test] doing the testing. # -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } namespace eval ::tcltest::test { @@ -27,7 +27,7 @@ namespace eval ::tcltest::test { namespace import ::tcltest::* makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::test test a-1.0 {test a} { list 0 @@ -63,11 +63,11 @@ test tcltest-1.3 {tcltest -h} {exec} { } {1 0} # -verbose, implicit & explicit testing of [verbose] -proc slave {msgVar args} { +proc child {msgVar args} { upvar 1 $msgVar msg interp create [namespace current]::i - # Fake the slave interp into dumping output to a file + # Fake the child interp into dumping output to a file i eval {namespace eval ::tcltest {}} i eval "set tcltest::outputChannel\ \[[list open [set of [makeFile {} output]] w]]" @@ -99,44 +99,44 @@ proc slave {msgVar args} { return $code } test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} { - set result [slave msg test.tcl] + set result [child msg test.tcl] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} test tcltest-2.1 {tcltest -verbose 'b'} {unixOrWin} { - set result [slave msg test.tcl -verbose 'b'] + set result [child msg test.tcl -verbose 'b'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} test tcltest-2.2 {tcltest -verbose 'p'} {unixOrWin} { - set result [slave msg test.tcl -verbose 'p'] + set result [child msg test.tcl -verbose 'p'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 0 1} test tcltest-2.3 {tcltest -verbose 's'} {unixOrWin} { - set result [slave msg test.tcl -verbose 's'] + set result [child msg test.tcl -verbose 's'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 0 1 1} test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrWin} { - set result [slave msg test.tcl -verbose 'ps'] + set result [child msg test.tcl -verbose 'ps'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 1 1} test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrWin} { - set result [slave msg test.tcl -verbose 'psb'] + set result [child msg test.tcl -verbose 'psb'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 1 1} test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} { - set result [slave msg test.tcl -verbose "pass skip body"] + set result [child msg test.tcl -verbose "pass skip body"] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] @@ -145,7 +145,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} { test tcltest-2.6 {tcltest -verbose 't'} { -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose 't'] + set result [child msg test.tcl -verbose 't'] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} @@ -155,7 +155,7 @@ test tcltest-2.6 {tcltest -verbose 't'} { test tcltest-2.6a {tcltest -verbose 'start'} { -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose start] + set result [child msg test.tcl -verbose start] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} @@ -178,7 +178,7 @@ test tcltest-2.7 {tcltest::verbose} { test tcltest-2.8 {tcltest -verbose 'error'} { -constraints {unixOrWin} -body { - set result [slave msg test.tcl -verbose error] + set result [child msg test.tcl -verbose error] list $result $msg } -result {errorInfo: foo.*errorCode: 9} @@ -186,22 +186,22 @@ test tcltest-2.8 {tcltest -verbose 'error'} { } # -match, [match] test tcltest-3.1 {tcltest -match 'a*'} {unixOrWin} { - set result [slave msg test.tcl -match a* -verbose 'ps'] + set result [child msg test.tcl -match a* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} test tcltest-3.2 {tcltest -match 'b*'} {unixOrWin} { - set result [slave msg test.tcl -match b* -verbose 'ps'] + set result [child msg test.tcl -match b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 1 0 1} test tcltest-3.3 {tcltest -match 'c*'} {unixOrWin} { - set result [slave msg test.tcl -match c* -verbose 'ps'] + set result [child msg test.tcl -match c* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg] } {0 0 0 1 1} test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrWin} { - set result [slave msg test.tcl -match {a* b*} -verbose 'ps'] + set result [child msg test.tcl -match {a* b*} -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 1 0 1} @@ -221,27 +221,27 @@ test tcltest-3.5 {tcltest::match} { # -skip, [skip] test tcltest-4.1 {tcltest -skip 'a*'} {unixOrWin} { - set result [slave msg test.tcl -skip a* -verbose 'ps'] + set result [child msg test.tcl -skip a* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg] } {0 0 1 1 1} test tcltest-4.2 {tcltest -skip 'b*'} {unixOrWin} { - set result [slave msg test.tcl -skip b* -verbose 'ps'] + set result [child msg test.tcl -skip b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 0 1 1} test tcltest-4.3 {tcltest -skip 'c*'} {unixOrWin} { - set result [slave msg test.tcl -skip c* -verbose 'ps'] + set result [child msg test.tcl -skip c* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 0 1} test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrWin} { - set result [slave msg test.tcl -skip {a* b*} -verbose 'ps'] + set result [child msg test.tcl -skip {a* b*} -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 0 1 1} test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrWin} { - set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] + set result [child msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} @@ -262,12 +262,12 @@ test tcltest-4.6 {tcltest::skip} { # -constraints, -limitconstraints, [testConstraint], # $constraintsSpecified, [limitConstraints] test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrWin} { - set result [slave msg test.tcl -constraints knownBug -verbose 'ps'] + set result [child msg test.tcl -constraints knownBug -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg] } {0 1 1 1 1} test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrWin} { - set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] + set result [child msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 0 0 1 1} @@ -340,7 +340,7 @@ test tcltest-5.5 {InitConstraints: list of built-in constraints} \ # -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile] set printerror [makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::* puts [outputChannel] "a test" ::tcltest::PrintError "a really short string" @@ -357,28 +357,28 @@ set printerror [makeFile { test tcltest-6.1 {tcltest -outfile, -errfile defaults} { -constraints unixOrWin -body { - slave msg $printerror + child msg $printerror return $msg } -result {a test.*a really} -match regexp } test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} { - slave msg $printerror -outfile a.tmp + child msg $printerror -outfile a.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {0 1 0 1 1 {}} test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrWin unixExecs} { - slave msg $printerror -errfile a.tmp + child msg $printerror -errfile a.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {1 0 1 0 1 {}} test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrWin unixExecs} { - slave msg $printerror -outfile a.tmp -errfile b.tmp + child msg $printerror -outfile a.tmp -errfile b.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" b.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ @@ -463,7 +463,7 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { # -debug, [debug] # Must use child processes to test -debug because it always writes # messages to stdout, and we have no way to capture stdout of a -# slave interp +# child interp test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrWin} { catch {exec [interpreter] test.tcl -debug 0} msg regexp "Flags passed into tcltest" $msg @@ -510,7 +510,7 @@ removeFile test.tcl # directory tests set a [makeFile { - package require tcltest + package require tcltest 2.5 tcltest::makeFile {} a.tmp puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]" exit @@ -525,7 +525,7 @@ normalizePath normaldirectory test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup { file delete -force thisdirectorydoesnotexist } -body { - slave msg $a -tmpdir thisdirectorydoesnotexist + child msg $a -tmpdir thisdirectorydoesnotexist file exists [file join thisdirectorydoesnotexist a.tmp] } -cleanup { file delete -force thisdirectorydoesnotexist @@ -533,7 +533,7 @@ test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup { test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} { -constraints unixOrWin -body { - slave msg $a -tmpdir $tdiaf + child msg $a -tmpdir $tdiaf return $msg } -result {*not a directory*} @@ -546,8 +546,8 @@ makeDirectory notreadable makeDirectory notwriteable switch -- $::tcl_platform(platform) { unix { - file attributes $notReadableDir -permissions 00333 - file attributes $notWriteableDir -permissions 00555 + file attributes $notReadableDir -permissions 0o333 + file attributes $notWriteableDir -permissions 0o555 } default { # note in FAT/NTFS we won't be able to protect directory with read-only attribute... @@ -558,7 +558,7 @@ switch -- $::tcl_platform(platform) { test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { -constraints {unix notRoot} -body { - slave msg $a -tmpdir $notReadableDir + child msg $a -tmpdir $notReadableDir return $msg } -result {*not readable*} @@ -574,7 +574,7 @@ testConstraint notFAT [expr { test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} { -constraints {unixOrWin notRoot notFAT} -body { - slave msg $a -tmpdir $notWriteableDir + child msg $a -tmpdir $notWriteableDir return $msg } -result {*not writeable*} @@ -583,7 +583,7 @@ test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} { test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} { -constraints unixOrWin -body { - slave msg $a -tmpdir $normaldirectory + child msg $a -tmpdir $normaldirectory # The join is necessary because the message can be split on multiple # lines file exists [file join $normaldirectory a.tmp] @@ -629,7 +629,7 @@ test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { file delete -force thisdirectorydoesnotexist } -body { - slave msg $a -testdir thisdirectorydoesnotexist + child msg $a -testdir thisdirectorydoesnotexist return $msg } -match glob @@ -638,7 +638,7 @@ test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { -constraints unixOrWin -body { - slave msg $a -testdir $tdiaf + child msg $a -testdir $tdiaf return $msg } -match glob @@ -647,7 +647,7 @@ test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} { -constraints {unix notRoot} -body { - slave msg $a -testdir $notReadableDir + child msg $a -testdir $notReadableDir return $msg } -match glob @@ -656,7 +656,7 @@ test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} { test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} { -constraints unixOrWin -body { - slave msg $a -testdir $normaldirectory + child msg $a -testdir $normaldirectory # The join is necessary because the message can be split on multiple # lines list [string first "testdir: $normaldirectory" [join $msg]] \ @@ -735,7 +735,7 @@ test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - slave msg [file join [testsDirectory] all.tcl] -file d*.test + child msg [file join [testsDirectory] all.tcl] -file d*.test return $msg } -cleanup { testsDirectory $old @@ -745,7 +745,7 @@ test tcltest-9.2 {-file d*.tcl} -constraints {unixOrWin} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - slave msg [file join [testsDirectory] all.tcl] \ + child msg [file join [testsDirectory] all.tcl] \ -file d*.test -notfile dstring* regexp {dstring\.test} $msg } -cleanup { @@ -784,7 +784,7 @@ test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { makeFile {} fee $d file copy [file join [file dirname [info script]] all.tcl] $d } -body { - slave msg [file join [temporaryDirectory] all.tcl] -file f* + child msg [file join [temporaryDirectory] all.tcl] -file f* regexp {exiting with errors:} $msg } -cleanup { file delete [file join $d all.tcl] @@ -795,7 +795,7 @@ test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { # -preservecore, [preserveCore] set mc [makeFile { - package require tcltest + package require tcltest 2.5 namespace import ::tcltest::test test makecore {make a core file} { set f [open core w] @@ -807,23 +807,23 @@ set mc [makeFile { cd [temporaryDirectory] test tcltest-10.1 {-preservecore 0} {unixOrWin} { - slave msg $mc -preservecore 0 + child msg $mc -preservecore 0 file delete core regexp "Core file produced" $msg } {0} test tcltest-10.2 {-preservecore 1} {unixOrWin} { - slave msg $mc -preservecore 1 + child msg $mc -preservecore 1 file delete core regexp "Core file produced" $msg } {1} test tcltest-10.3 {-preservecore 2} {unixOrWin} { - slave msg $mc -preservecore 2 + child msg $mc -preservecore 2 file delete core list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] } {1 1 1 {}} test tcltest-10.4 {-preservecore 3} {unixOrWin} { - slave msg $mc -preservecore 3 + child msg $mc -preservecore 3 file delete core list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] @@ -846,7 +846,7 @@ removeFile makecore.tcl # -load, -loadfile, [loadScript], [loadFile] set contents { - package require tcltest + package require tcltest 2.5 namespace import tcltest::* puts [outputChannel] $::tcltest::loadScript exit @@ -854,7 +854,7 @@ set contents { set loadfile [makeFile $contents load.tcl] test tcltest-12.1 {-load xxx} {unixOrWin} { - slave msg $loadfile -load xxx + child msg $loadfile -load xxx return $msg } {xxx} @@ -942,7 +942,7 @@ makeFile { } single2.test $spd set allfile [makeFile { - package require tcltest + package require tcltest 2.5 namespace import tcltest::* testsDirectory [file join [temporaryDirectory] singleprocdir] runAllTests @@ -952,7 +952,7 @@ cd [workingDirectory] test tcltest-14.1 {-singleproc - single process} { -constraints {unixOrWin} -body { - slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] + child msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] return $msg } -result {Test file error: can't unset .foo.: no such variable} @@ -962,7 +962,7 @@ test tcltest-14.1 {-singleproc - single process} { test tcltest-14.2 {-singleproc - multiple process} { -constraints {unixOrWin} -body { - slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] + child msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] return $msg } -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0} @@ -999,25 +999,25 @@ set dtd1 [makeDirectory dirtestdir2.1 $dtd] set dtd2 [makeDirectory dirtestdir2.2 $dtd] set dtd3 [makeDirectory dirtestdir2.3 $dtd] makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir] runAllTests } all.tcl $dtd makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1] runAllTests } all.tcl $dtd1 makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2] runAllTests } all.tcl $dtd2 makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3] runAllTests @@ -1026,7 +1026,7 @@ makeFile { test tcltest-15.1 {basic directory walking} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -tmpdir [temporaryDirectory]] == 1} { error $msg @@ -1040,7 +1040,7 @@ test tcltest-15.1 {basic directory walking} { test tcltest-15.2 {-asidefromdir} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -asidefromdir dirtestdir2.3 \ -tmpdir [temporaryDirectory]] == 1} { @@ -1058,7 +1058,7 @@ Error: No test files remain after applying your match and skip patterns!$} test tcltest-15.3 {-relateddir, non-existent dir} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir [file join [temporaryDirectory] dirtestdir0] \ -tmpdir [temporaryDirectory]] == 1} { @@ -1073,7 +1073,7 @@ test tcltest-15.3 {-relateddir, non-existent dir} { test tcltest-15.4 {-relateddir, subdir} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} { error $msg @@ -1086,7 +1086,7 @@ test tcltest-15.4 {-relateddir, subdir} { test tcltest-15.5 {-relateddir, -asidefromdir} { -constraints {unixOrWin} -body { - if {[slave msg \ + if {[child msg \ [file join $dtd all.tcl] \ -relateddir "dirtestdir2.1 dirtestdir2.2" \ -asidefromdir dirtestdir2.2 \ @@ -1147,25 +1147,25 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { # set this to { } instead of just {} to get around quirk in # Windows env handling that removes empty elements from env array. set ::env(TCLTEST_OPTIONS) { } - interp create slave1 - slave1 eval [list set argv {-debug 2}] - slave1 alias puts puts - interp create slave2 - slave2 alias puts puts + interp create child1 + child1 eval [list set argv {-debug 2}] + child1 alias puts puts + interp create child2 + child2 alias puts puts } -cleanup { - interp delete slave2 - interp delete slave1 + interp delete child2 + interp delete child1 if {$oldoptions eq "none"} { unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } } -body { - slave1 eval [package ifneeded tcltest [package provide tcltest]] - slave1 eval tcltest::debug + child1 eval [package ifneeded tcltest [package provide tcltest]] + child1 eval tcltest::debug set ::env(TCLTEST_OPTIONS) "-debug 3" - slave2 eval [package ifneeded tcltest [package provide tcltest]] - slave2 eval tcltest::debug + child2 eval [package ifneeded tcltest [package provide tcltest]] + child2 eval tcltest::debug } -result {^3$} -match regexp -output\ {tcltest::debug\s+= 2.*tcltest::debug\s+= 3} @@ -1174,7 +1174,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { cd [temporaryDirectory] # PrintError test tcltest-20.1 {PrintError} {unixOrWin} { - set result [slave msg $printerror] + set result [child msg $printerror] list $result [regexp "Error: a really short string" $msg] \ [regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \ [regexp " \"Really" $msg] [regexp Problem $msg] @@ -1385,7 +1385,7 @@ test tcltest-21.12 { set atd [makeDirectory alltestdir] makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] alltestdir] runAllTests @@ -1397,7 +1397,7 @@ makeFile { error "throw an error" } error.test $atd makeFile { - package require tcltest + package require tcltest 2.5 namespace import -force tcltest::* test foo-1.1 {foo} { -body { return 1 } @@ -1407,7 +1407,7 @@ makeFile { } test.test $atd # Must use a child process because stdout/stderr parsing can't be -# duplicated in slave interp. +# duplicated in child interp. test tcltest-22.1 {runAllTests} { -constraints {unixOrWin} -body { @@ -1444,7 +1444,7 @@ test tcltest-23.2 {removeFile} { file mkdir $mfdir makeFile {} t1.tmp makeFile {} et1.tmp $mfdir - if {![file exists [file join [temporaryDirectory] t1.tmp]] || \ + if {![file exists [file join [temporaryDirectory] t1.tmp]] || \ ![file exists [file join $mfdir et1.tmp]]} { error "file creation didn't work" } @@ -1796,7 +1796,7 @@ test tcltest-25.3 { test tcltest-26.1 {Bug/RFE 1017151} -setup { makeFile { - package require tcltest + package require tcltest 2.5 set ::errorInfo "Should never see this" tcltest::test tcltest-26.1.0 { no errorInfo when only return code mismatch @@ -1806,7 +1806,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup { tcltest::cleanupTests } test.tcl } -body { - slave msg [file join [temporaryDirectory] test.tcl] + child msg [file join [temporaryDirectory] test.tcl] return $msg } -cleanup { removeFile test.tcl @@ -1816,7 +1816,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup { test tcltest-26.2 {Bug/RFE 1017151} -setup { makeFile { - package require tcltest + package require tcltest 2.5 set ::errorInfo "Should never see this" tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body { error "body error" @@ -1826,7 +1826,7 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup { tcltest::cleanupTests } test.tcl } -body { - slave msg [file join [temporaryDirectory] test.tcl] + child msg [file join [temporaryDirectory] test.tcl] return $msg } -cleanup { removeFile test.tcl diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index b0aa054..193ba0a 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -1,6 +1,6 @@ #! /usr/bin/env tclsh -package require tcltest 2.2 +package require tcltest 2.5 namespace import ::tcltest::* testConstraint exec [llength [info commands exec]] testConstraint fcopy [llength [info commands fcopy]] diff --git a/tests/thread.test b/tests/thread.test index 2524911..16e60ed 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -4,15 +4,15 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2006-2008 Joe Mistachkin. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -20,7 +20,7 @@ if {"::tcltest" ni [namespace children]} { # be fully finalized, which avoids valgrind "still reachable" reports. ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] package require tcltests # Some tests require the testthread command @@ -39,11 +39,11 @@ set threadSuperKillScript { proc getThreadErrorFromInfo { info } { set list [split $info \n] set idx [lsearch -glob $list "*eval*unwound*"] - if {$idx != -1} then { + if {$idx >= 0} then { return [lindex $list $idx] } set idx [lsearch -glob $list "*eval*canceled*"] - if {$idx != -1} then { + if {$idx >= 0} then { return [lindex $list $idx] } return ""; # some other error we do not care about. @@ -805,7 +805,7 @@ test thread-7.21 {cancel: subst -unwind} -constraints {thread drainEventQueue} - } -cleanup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -result {{} 1 1 {eval unwound}} -test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -setup { +test thread-7.22 {cancel: child interp} -constraints {thread drainEventQueue} -setup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ @@ -835,7 +835,7 @@ test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -s } -cleanup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -result {{} 1 1 {eval canceled}} -test thread-7.23 {cancel: slave interp -unwind} -constraints {thread drainEventQueue} -setup { +test thread-7.23 {cancel: child interp -unwind} -constraints {thread drainEventQueue} -setup { unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted } -body { set serverthread [thread::create -joinable \ diff --git a/tests/timer.test b/tests/timer.test index 740d05e..52c0b8a 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -7,14 +7,14 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -367,7 +367,7 @@ test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NUL} -setup { } } -body { set x "hello world" - after 1 "set x ab\0cd" + after 1 "set x ab\x00cd" after 10 update string length $x @@ -378,7 +378,7 @@ test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NUL} -setup { } } -body { set x "hello world" - after 1 set x ab\0cd + after 1 set x ab\x00cd after 10 update string length $x @@ -389,8 +389,8 @@ test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup } } -body { set x "hello world" - after 1 set x ab\0cd - after cancel "set x ab\0ef" + after 1 set x ab\x00cd + after cancel "set x ab\x00ef" llength [after info] } -cleanup { foreach i [after info] { @@ -403,8 +403,8 @@ test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup } } -body { set x "hello world" - after 1 set x ab\0cd - after cancel set x ab\0ef + after 1 set x ab\x00cd + after cancel set x ab\x00ef llength [after info] } -cleanup { foreach i [after info] { @@ -417,7 +417,7 @@ test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup { } } -body { set x "hello world" - after idle "set x ab\0cd" + after idle "set x ab\x00cd" update string length $x } -result {5} @@ -427,7 +427,7 @@ test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup { } } -body { set x "hello world" - after idle set x ab\0cd + after idle set x ab\x00cd update string length $x } -result {5} @@ -438,7 +438,7 @@ test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NUL} -setup { } -body { set x "hello world" set id junk - set id [after 10 set x ab\0cd] + set id [after 10 set x ab\x00cd] update string length [lindex [lindex [after info $id] 0] 2] } -cleanup { @@ -568,15 +568,15 @@ test timer-9.1 {AfterCleanupProc procedure} -setup { } -result {before after2 after4} test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup { - interp create slave - slave eval namespace export after - slave eval namespace eval foo namespace import ::after + interp create child + child eval namespace export after + child eval namespace eval foo namespace import ::after } -body { - slave eval foo::after 1 - slave eval namespace origin foo::after + child eval foo::after 1 + child eval namespace origin foo::after } -cleanup { # Bug will cause crash here; would cause failure otherwise - interp delete slave + interp delete child } -result ::after test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} -body { diff --git a/tests/tm.test b/tests/tm.test index 001b73e..a1959e6 100644 --- a/tests/tm.test +++ b/tests/tm.test @@ -3,12 +3,11 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 2004 by Donal K. Fellows. +# Copyright © 2004 Donal K. Fellows. # All rights reserved. -package require Tcl 8.5- if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -200,7 +199,7 @@ test tm-3.11 {tm: module path management, remove ignores unknown path} -setup { proc genpaths {base} { # Normalizing picks up drive letters on windows [Bug 1053568] set base [file normalize $base] - regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor + regexp {^(\d+)\.(\d+)} [package provide tcl] - major minor set results {} set base [file join $base tcl$major] lappend results [file join $base site-tcl] diff --git a/tests/trace.test b/tests/trace.test index 1099f48..3f30048 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -4,18 +4,20 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testevalobjv [llength [info commands testevalobjv]] @@ -2197,11 +2199,11 @@ foo {if {[catch {bar}]} { }} 2 error leavestep foo foo 0 error leave}} -test trace-28.4 {exec traces in slave with 'return -code error'} { - interp create slave - interp alias slave traceExecute {} traceExecute +test trace-28.4 {exec traces in child with 'return -code error'} { + interp create child + interp alias child traceExecute {} traceExecute set info {} - set res [interp eval slave { + set res [interp eval child { set info {} set res {} @@ -2229,7 +2231,7 @@ test trace-28.4 {exec traces in slave with 'return -code error'} { list $res }] - interp delete slave + interp delete child lappend res [join $info \n] } {{error error} {foo foo enter foo {if {[catch {bar}]} { @@ -2312,8 +2314,8 @@ test trace-28.10 {exec trace info nonsense} { } {1 {wrong # args: should be "trace remove execution name opList command"}} test trace-29.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { - testcmdtrace tracetest {set stuff [expr 14 + 16]} -} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}} + testcmdtrace tracetest {set stuff [expr {14 + 16}]} +} {{expr {14 + 16}} {expr {14 + 16}} {set stuff [expr {14 + 16}]} {set stuff 30}} test trace-29.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { testcmdtrace tracetest {set stuff [info tclversion]} } [concat {{info tclversion} {info tclversion} ::tcl::info::tclversion {::tcl::info::tclversion} {set stuff [info tclversion]}} [list "set stuff [info tclversion]"]] diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 08eb664..3eade4a 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -4,18 +4,18 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright © 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testchmod [llength [info commands testchmod]] @@ -96,10 +96,10 @@ test unixFCmd-1.1 {TclpRenameFile: EACCES} -setup { cleanup } -constraints {unix notRoot} -body { file mkdir td1/td2/td3 - file attributes td1/td2 -permissions 0000 + file attributes td1/td2 -permissions 0 file rename td1/td2/td3 td2 } -returnCodes error -cleanup { - file attributes td1/td2 -permissions 0755 + file attributes td1/td2 -permissions 0o755 cleanup } -result {error renaming "td1/td2/td3": permission denied} test unixFCmd-1.2 {TclpRenameFile: EEXIST} -setup { @@ -137,11 +137,11 @@ test unixFCmd-1.7 {TclpRenameFile: EXDEV} -setup { cleanup } -constraints {unix notRoot} -body { file mkdir foo/bar - file attr foo -perm 040555 + file attr foo -perm 0o40555 file rename foo/bar /tmp } -returnCodes error -cleanup { catch {file delete /tmp/bar} - catch {file attr foo -perm 040777} + catch {file attr foo -perm 0o40777} catch {file delete -force foo} } -match glob -result {*: permission denied} test unixFCmd-1.8 {Checking EINTR Bug} {unix notRoot nonPortable} { @@ -336,7 +336,7 @@ test unixFCmd-17.1 {SetPermissionsAttribute} -setup { catch {file delete -force -- foo.test} } -constraints {unix notRoot} -body { close [open foo.test w] - list [file attributes foo.test -permissions 0000] \ + list [file attributes foo.test -permissions 0] \ [file attributes foo.test -permissions] } -cleanup { file delete -force -- foo.test @@ -344,7 +344,7 @@ test unixFCmd-17.1 {SetPermissionsAttribute} -setup { test unixFCmd-17.2 {SetPermissionsAttribute} -setup { catch {file delete -force -- foo.test} } -constraints {unix notRoot} -returnCodes error -body { - file attributes foo.test -permissions 0000 + file attributes foo.test -permissions 0 } -result {could not set permissions for file "foo.test": no such file or directory} test unixFCmd-17.3 {SetPermissionsAttribute} -setup { catch {file delete -force -- foo.test} @@ -390,11 +390,11 @@ test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup { set nd $cd/tstdir file mkdir $nd cd $nd - file attributes $nd -permissions 0000 + file attributes $nd -permissions 0 pwd } -returnCodes error -cleanup { cd $cd - file attributes $nd -permissions 0755 + file attributes $nd -permissions 0o755 file delete $nd } -match glob -result {error getting working directory name:*} diff --git a/tests/unixFile.test b/tests/unixFile.test index 8147f48..e2a634a 100644 --- a/tests/unixFile.test +++ b/tests/unixFile.test @@ -4,18 +4,18 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testfindexecutable [llength [info commands testfindexecutable]] @@ -24,7 +24,7 @@ cd [temporaryDirectory] catch { set oldPath $env(PATH) - file attributes [makeFile "" junk] -perm 0777 + file attributes [makeFile "" junk] -perm 0o777 } set absPath [file join [temporaryDirectory] junk] diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test index d7b86fd..f321b10 100644 --- a/tests/unixForkEvent.test +++ b/tests/unixForkEvent.test @@ -2,14 +2,16 @@ # tclUnixNotify.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} testConstraint testfork [llength [info commands testfork]] diff --git a/tests/unixInit.test b/tests/unixInit.test index ab00b4e..2ea7d8e 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -4,14 +4,16 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2.2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C @@ -124,7 +126,7 @@ test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup { set oldlibrary $env(TCL_LIBRARY) } } -body { - # ((str != NULL) && (str[0] != '\0')) + # ((str != NULL) && (str[0] != '\x00')) set env(TCL_LIBRARY) sparkly lindex [getlibpath] 0 } -cleanup { @@ -156,7 +158,7 @@ test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup { } } -body { # Child process translates env variable from native encoding. - set env(TCL_LIBRARY) "\xa7" + set env(TCL_LIBRARY) "§" lindex [getlibpath] 0 } -cleanup { unset -nocomplain env(TCL_LIBRARY) env(LANG) @@ -164,7 +166,7 @@ test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup { set env(TCL_LIBRARY) $oldlibrary unset oldlibrary } -} -result "\xa7" +} -result "§" test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} { # cannot test } {} diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 0bd8c69..8ab0edb 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -4,14 +4,14 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/unknown.test b/tests/unknown.test index 6c31c3d..cb0a7c4 100644 --- a/tests/unknown.test +++ b/tests/unknown.test @@ -4,15 +4,17 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2 -namespace import ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} unset -nocomplain x catch {rename unknown unknown.old} diff --git a/tests/unload.test b/tests/unload.test index 73f1091..24b5e8d 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -4,20 +4,20 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# Copyright (c) 2003-2004 by Georgios Petasis +# Copyright © 1995 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. +# Copyright © 2003-2004 Georgios Petasis # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Figure out what extension is used for shared libraries on this # platform. @@ -38,9 +38,6 @@ testConstraint $loaded [expr {![string match *pkgua* $alreadyLoaded]}] set alreadyTotalLoaded [info loaded] -# Certain tests require the 'teststaticpkg' command from tcltest -testConstraint teststaticpkg [llength [info commands teststaticpkg]] - # Certain tests need the 'testsimplefilsystem' in tcltest testConstraint testsimplefilesystem \ [llength [info commands testsimplefilesystem]] @@ -56,22 +53,22 @@ proc loadIfNotPresent {pkg args} { # Basic tests: parameter testing... test unload-1.1 {basic errors} -returnCodes error -body { unload -} -result {wrong # args: should be "unload ?-switch ...? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "unload ?-switch ...? fileName ?prefix? ?interp?"} test unload-1.2 {basic errors} -returnCodes error -body { unload a b c d -} -result {wrong # args: should be "unload ?-switch ...? fileName ?packageName? ?interp?"} +} -result {wrong # args: should be "unload ?-switch ...? fileName ?prefix? ?interp?"} test unload-1.3 {basic errors} -returnCodes error -body { unload a b foobar } -result {could not find interpreter "foobar"} test unload-1.4 {basic errors} -returnCodes error -body { unload {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test unload-1.5 {basic errors} -returnCodes error -body { unload {} {} -} -result {must specify either file name or package name} +} -result {must specify either file name or prefix} test unload-1.6 {basic errors} -returnCodes error -body { unload {} Unknown -} -result {package "Unknown" is loaded statically and cannot be unloaded} +} -result {library with prefix "Unknown" is loaded statically and cannot be unloaded} test unload-1.7 {-nocomplain switch} { unload -nocomplain {} Unknown } {} @@ -80,22 +77,22 @@ set pkgua_loaded {} set pkgua_detached {} set pkgua_unloaded {} # Tests for loading/unloading in trusted (non-safe) interpreters... -test unload-2.1 {basic loading of non-unloadable package, with guess for package name} [list $dll $loaded] { +test unload-2.1 {basic loading of non-unloadable package, with guess for prefix} [list $dll $loaded] { loadIfNotPresent pkga list [pkga_eq abc def] [lsort [info commands pkga_*]] } {0 {pkga_eq pkga_quote}} -test unload-2.2 {basic loading of unloadable package, with guess for package name} [list $dll $loaded] { +test unload-2.2 {basic loading of unloadable package, with guess for prefix} [list $dll $loaded] { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ [load [file join $testDir pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } {{} {} {} {} 0 {pkgua_eq pkgua_quote} . {} {}} -test unload-2.3 {basic unloading of non-unloadable package, with guess for package name} -setup { +test unload-2.3 {basic unloading of non-unloadable package, with guess for prefix} -setup { loadIfNotPresent pkga } -constraints [list $dll $loaded] -returnCodes error -match glob -body { unload [file join $testDir pkga$ext] } -result {file "*" cannot be unloaded under a trusted interpreter} -test unload-2.4 {basic unloading of unloadable package, with guess for package name} -setup { +test unload-2.4 {basic unloading of unloadable package, with guess for prefix} -setup { loadIfNotPresent pkgua } -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ @@ -103,7 +100,7 @@ test unload-2.4 {basic unloading of unloadable package, with guess for package n [info commands pkgua_*] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } -result {. {} {} {} {} . . .} -test unload-2.5 {reloading of unloaded package, with guess for package name} -setup { +test unload-2.5 {reloading of unloaded package, with guess for prefix} -setup { if {$pkgua_loaded eq ""} { loadIfNotPresent pkgua unload [file join $testDir pkgua$ext] @@ -114,7 +111,7 @@ test unload-2.5 {reloading of unloaded package, with guess for package name} -se [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } -result {. . . {} 0 {pkgua_eq pkgua_quote} .. . .} -test unload-2.6 {basic unloading of re-loaded package, with guess for package name} -setup { +test unload-2.6 {basic unloading of re-loaded package, with guess for prefix} -setup { # Establish expected state if {$pkgua_loaded eq ""} { loadIfNotPresent pkgua @@ -135,17 +132,17 @@ child eval { set pkgua_detached {} set pkgua_unloaded {} } -test unload-3.1 {basic loading of non-unloadable package in a safe interpreter, with package name conversion} \ +test unload-3.1 {basic loading of non-unloadable package in a safe interpreter} \ [list $dll $loaded] { catch {rename pkgb_sub {}} - load [file join $testDir pkgb$ext] pKgB child + load [file join $testDir pkgb$ext] Pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} -test unload-3.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \ +test unload-3.2 {basic loading of unloadable package in a safe interpreter} \ [list $dll $loaded] { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pKgUA child] \ + [load [file join $testDir pkgua$ext] pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -155,16 +152,16 @@ test unload-3.3 {unloading of a package that has never been loaded from a safe i } -constraints [list $dll $loaded] -returnCodes error -match glob -body { unload [file join $testDir pkga$ext] {} child } -result {file "*" has never been loaded in this interpreter} -test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} -setup { - if {[lsearch -index 1 [info loaded child] Pkgb] == -1} { - load [file join $testDir pkgb$ext] pKgB child +test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for prefix} -setup { + if {[lsearch -index 1 [info loaded child] Pkgb] < 0} { + load [file join $testDir pkgb$ext] Pkgb child } } -constraints [list $dll $loaded] -returnCodes error -match glob -body { unload [file join $testDir pkgb$ext] {} child } -result {file "*" cannot be unloaded under a safe interpreter} -test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} -setup { - if {[lsearch -index 1 [info loaded child] Pkgua] == -1} { - load [file join $testDir pkgua$ext] pkgua child +test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for prefix} -setup { + if {[lsearch -index 1 [info loaded child] Pkgua] < 0} { + load [file join $testDir pkgua$ext] Pkgua child } } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ @@ -172,7 +169,7 @@ test unload-3.5 {basic unloading of an unloadable package from a safe interprete [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{. {} {}} {} {} {. . .}} -test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for package name} -setup { +test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for prefix} -setup { if {[child eval set pkgua_loaded] eq ""} { load [file join $testDir pkgua$ext] {} child unload [file join $testDir pkgua$ext] {} child @@ -184,7 +181,7 @@ test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}} -test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with package name conversion} -setup { +test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with prefix conversion} -setup { if {[child eval set pkgua_loaded] eq ""} { load [file join $testDir pkgua$ext] {} child unload [file join $testDir pkgua$ext] {} child @@ -206,7 +203,7 @@ child-trusted eval { } array set load {M 0 C 0 T 0} ## Load package in main trusted interpreter... -test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for package name} -setup { +test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for prefix} -setup { set pkgua_loaded "" set pkgua_detached "" set pkgua_unloaded "" @@ -218,7 +215,7 @@ test unload-4.1 {loading of unloadable package in trusted interpreter, with gues [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] } -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Load package in child-safe interpreter... -test unload-4.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} -setup { +test unload-4.2 {basic loading of unloadable package in a safe interpreter} -setup { child eval { set pkgua_loaded "" set pkgua_detached "" @@ -227,23 +224,23 @@ test unload-4.2 {basic loading of unloadable package in a safe interpreter, with incr load(C) } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pKgUA child] \ + [load [file join $testDir pkgua$ext] pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Load package in child-trusted interpreter... -test unload-4.3 {basic loading of unloadable package in a second trusted interpreter, with package name conversion} -setup { +test unload-4.3 {basic loading of unloadable package in a second trusted interpreter} -setup { incr load(T) } -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pkguA child-trusted] \ + [load [file join $testDir pkgua$ext] pkgua child-trusted] \ [child-trusted eval pkgua_eq abc def] \ [lsort [child-trusted eval info commands pkgua_*]] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Unload the package from the main trusted interpreter... -test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for package name} -setup { +test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for prefix} -setup { if {!$load(M)} { load [file join $testDir pkgua$ext] } @@ -262,7 +259,7 @@ test unload-4.4 {basic unloading of unloadable package from trusted interpreter, [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] } -result {{. {} {}} {} {} {. . {}}} ## Unload the package from the child safe interpreter... -test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for package name} -setup { +test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup { if {!$load(C)} { load [file join $testDir pkgua$ext] {} child } @@ -277,7 +274,7 @@ test unload-4.5 {basic unloading of unloadable package from a safe interpreter, [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{. {} {}} {} {} {. . {}}} ## Unload the package from the child trusted interpreter... -test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for package name} -setup { +test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup { if {!$load(T)} { load [file join $testDir pkgua$ext] {} child-trusted } diff --git a/tests/uplevel.test b/tests/uplevel.test index 2cbea1a..de21361 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -4,20 +4,20 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } proc a {x y} { - newset z [expr $x+$y] + newset z [expr {$x + $y}] return $z } proc newset {name value} { @@ -304,7 +304,24 @@ test uplevel-7.3 {var access, LVT in upper level} -setup { rename foo {} rename moo {} } -result {3 3 3} + + +test uplevel-8.0 { + string representation isn't generated when there is only one argument +} -body { + set res {} + set script [list lindex 5] + lappend res [apply {script { + uplevel $script + }} $script] + lappend res [string match {value is a list *no string representation*} [ + ::tcl::unsupported::representation $script]] +} -cleanup { + unset script + unset res +} -result {5 1} + # cleanup ::tcltest::cleanupTests return diff --git a/tests/upvar.test b/tests/upvar.test index a483569..82079b1 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -4,20 +4,20 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testupvar [llength [info commands testupvar]] diff --git a/tests/utf.test b/tests/utf.test index 3ff7d47..1974979 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -2,27 +2,28 @@ # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } -namespace path ::tcl::mathop - ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}] testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}] -testConstraint tip389 [expr {[string length \U010000] eq 2}] +testConstraint utf16 [expr {[string length [format %c 0x10000]] == 2}] +testConstraint ucs4 [expr {[testConstraint fullutf] + && [string length [format %c 0x10000]] == 1}] -testConstraint Uesc [eq \U0041 A] +testConstraint Uesc [expr {"\U0041" eq "A"}] +testConstraint pre388 [expr {"\x741" eq "A"}] testConstraint pairsTo4bytes [expr {[llength [info commands teststringbytes]] && [string length [teststringbytes \uD83D\uDCA9]] == 4}] @@ -34,49 +35,54 @@ testConstraint teststringobj [llength [info commands teststringobj]] testConstraint testutfnext [llength [info commands testutfnext]] testConstraint testutfprev [llength [info commands testutfprev]] +testConstraint tip413 [expr {[string trim \x00] eq {}}] + catch {unset x} test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring { - expr {"\x01" eq [testbytestring "\x01"]} + expr {"\x01" eq [testbytestring \x01]} } 1 test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { - expr {"\x00" eq [testbytestring "\xC0\x80"]} + expr {"\x00" eq [testbytestring \xC0\x80]} } 1 test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring { - expr {"\xE0" eq [testbytestring "\xC3\xA0"]} + expr {"\xE0" eq [testbytestring \xC3\xA0]} } 1 test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring { - expr {"\u4E4E" eq [testbytestring "\xE4\xB9\x8E"]} + expr {"乎" eq [testbytestring \xE4\xB9\x8E]} } 1 test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { - expr {[format %c 0x110000] eq [testbytestring "\xEF\xBF\xBD"]} + expr {[format %c 0x110000] eq [testbytestring \xEF\xBF\xBD]} } 1 test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { - expr {[format %c -1] eq [testbytestring "\xEF\xBF\xBD"]} + expr {[format %c -1] eq [testbytestring \xEF\xBF\xBD]} } 1 -test utf-1.7.0 {Tcl_UniCharToUtf: 4 byte sequences} {fullutf Uesc testbytestring} { - expr {"\U014E4E" eq [testbytestring "\xF0\x94\xB9\x8E"]} +test utf-1.7.0 {Tcl_UniCharToUtf: 4 byte sequences} {fullutf testbytestring} { + expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]} } 1 -test utf-1.7.1 {Tcl_UniCharToUtf: 4 byte sequences} {ucs2 Uesc testbytestring} { - expr {"\U014E4E" eq [testbytestring "\xF0\x94\xB9\x8E"]} +test utf-1.7.1 {Tcl_UniCharToUtf: 4 byte sequences} {Uesc ucs2 testbytestring} { + expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]} } 0 test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring { - expr {"\uD842" eq [testbytestring "\xED\xA1\x82"]} + expr {"\uD842" eq [testbytestring \xED\xA1\x82]} } 1 test utf-1.9 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring { - expr {"\uDC42" eq [testbytestring "\xED\xB1\x82"]} + expr {"\uDC42" eq [testbytestring \xED\xB1\x82]} } 1 test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring { - expr {[format %c 0xD842] eq [testbytestring "\xED\xA1\x82"]} + expr {[format %c 0xD842] eq [testbytestring \xED\xA1\x82]} } 1 test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring { - expr {[format %c 0xDC42] eq [testbytestring "\xED\xB1\x82"]} + expr {[format %c 0xDC42] eq [testbytestring \xED\xB1\x82]} } 1 test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} { - expr {"\uD842\uDC42" eq [testbytestring "\xF0\xA0\xA1\x82"]} + expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]} +} 1 +test utf-1.13.0 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc ucs2} { + expr {"\UD842" eq "\uD842"} } 1 -test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc testbytestring} { - expr {"\UD842" eq [testbytestring "\xEF\xBF\xBD"]} +test utf-1.13.1 {Tcl_UniCharToUtf: Invalid surrogate} {fullutf testbytestring} { + expr {"\UD842" eq [testbytestring \xEF\xBF\xBD]} } 1 test utf-1.14 {Tcl_UniCharToUtf: surrogate pairs from concat} {pairsTo4bytes testbytestring} { set hi \uD842 @@ -91,38 +97,50 @@ test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" } 3 test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} testbytestring { - string length [testbytestring "\x82\x83\x84"] + string length [testbytestring \x82\x83\x84] } 3 test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} testbytestring { - string length [testbytestring "\xC2"] + string length [testbytestring \xC2] } 1 -test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} testbytestring { - string length [testbytestring "\xC2\xA2"] +test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} { + string length \xA2 } 1 test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} testbytestring { - string length [testbytestring "\xE2"] + string length [testbytestring \xE2] } 1 test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestring { - string length [testbytestring "\xE2\xA2"] + string length [testbytestring \xE2\xA2] } 2 test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { - string length [testbytestring "\xE4\xB9\x8E"] + string length [testbytestring \xE4\xB9\x8E] +} 1 +test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {ucs2 testbytestring} { + string length [testbytestring \xF0\x90\x80\x80] +} 2 +test utf-2.8.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf16 { + string length 𐀀 +} 2 +test utf-2.8.2 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} ucs4 { + string length 𐀀 } 1 -test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {tip389 testbytestring} { - string length [testbytestring "\xF0\x90\x80\x80"] +test utf-2.9.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {ucs2 testbytestring} { + string length [testbytestring \xF4\x8F\xBF\xBF] } 2 -test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {tip389 testbytestring} { - string length [testbytestring "\xF4\x8F\xBF\xBF"] +test utf-2.9.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} utf16 { + string length \U10FFFF } 2 +test utf-2.9.2 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} ucs4 { + string length \U10FFFF +} 1 test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { - string length [testbytestring "\xF0\x8F\xBF\xBF"] + string length [testbytestring \xF0\x8F\xBF\xBF] } 4 test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring { # Would decode to U+110000 but that is outside the Unicode range. - string length [testbytestring "\xF4\x90\x80\x80"] + string length [testbytestring \xF4\x90\x80\x80] } 4 test utf-2.12 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring { - string length [testbytestring "\xF8\xA2\xA2\xA2\xA2"] + string length [testbytestring \xF8\xA2\xA2\xA2\xA2] } 5 test utf-3.1 {Tcl_UtfCharComplete} { @@ -131,328 +149,397 @@ test utf-3.1 {Tcl_UtfCharComplete} { test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars { testnumutfchars "" } 0 -test utf-4.2 {Tcl_NumUtfChars: length 1} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\xC2\xA2"] +test utf-4.2 {Tcl_NumUtfChars: length 1} testnumutfchars { + testnumutfchars \xA2 } 1 test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "abc\xC2\xA2\xE4\xB9\x8E\xA2\x4E"] + testnumutfchars abc\xA2[testbytestring \xE4\xB9\x8E\xA2\x4E] } 7 -test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\xC0\x80"] +test utf-4.4 {Tcl_NumUtfChars: #x00} testnumutfchars { + testnumutfchars \x00 } 1 test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars { testnumutfchars "" 0 } 0 test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\xC2\xA2"] end + testnumutfchars \xA2 end } 1 test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "abc\xC2\xA2\xE4\xB9\x8E\uA2\x4E"] end + testnumutfchars abc\xA2[testbytestring \xE4\xB9\x8E\xA2\x4E] end } 7 -test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\xC0\x80"] end +test utf-4.8 {Tcl_NumUtfChars: #x00, calc len} testnumutfchars { + testnumutfchars \x00 end } 1 # Bug [2738427]: Tcl_NumUtfChars(...) no overflow check test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\xE2\x82\xAC"] end-1 + testnumutfchars [testbytestring \xE2\x82\xAC] end-1 } 2 -test utf-4.10 {Tcl_NumUtfChars: #u0000, calc len, overcomplete} {testnumutfchars testbytestring} { - testnumutfchars [testbytestring "\x00"] end+1 +test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring \x00] end+1 } 2 test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1 } 3 -test utf-4.12 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring tip389} { +test utf-4.12.0 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs2} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end } 2 +test utf-4.12.1 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs4} { + testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end +} 1 +test utf-4.13 {Tcl_NumUtfChars: end of string} {testnumutfchars testbytestring} { + testnumutfchars foobar[testbytestring \xF2\xC2\xA0] end +} 8 +test utf-4.14 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { + testnumutfchars [testbytestring \xF4\x90\x80\x80] end-1 +} 3 test utf-5.1 {Tcl_UtfFindFirst} {testfindfirst testbytestring} { - testfindfirst [testbytestring "abcbc"] 98 + testfindfirst [testbytestring abcbc] 98 } bcbc test utf-5.2 {Tcl_UtfFindLast} {testfindlast testbytestring} { - testfindlast [testbytestring "abcbc"] 98 + testfindlast [testbytestring abcbc] 98 } bc -test utf-6.1 {Tcl_UtfNext} testutfnext { +test utf-6.1 {Tcl_UtfNext} {testutfnext testbytestring} { # This takes the pointer one past the terminating NUL. # This is really an invalid call. - testutfnext -bytestring {} + testutfnext [testbytestring \x00] } 1 test utf-6.2 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring A + testutfnext A } 1 test utf-6.3 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring AA + testutfnext AA } 1 -test utf-6.4 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring A\xA0 +test utf-6.4 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xA0] } 1 -test utf-6.5 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring A\xD0 +test utf-6.5 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xD0] } 1 -test utf-6.6 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring A\xE8 +test utf-6.6 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xE8] } 1 -test utf-6.7 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring A\xF2 +test utf-6.7 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xF2] } 1 -test utf-6.8 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring A\xF8 +test utf-6.8 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext A[testbytestring \xF8] } 1 -test utf-6.9 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xA0 +test utf-6.9 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\x00] } 1 -test utf-6.10 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xA0G +test utf-6.10 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0]G } 1 -test utf-6.11 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xA0\xA0 +test utf-6.11.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xA0\xA0\x00] +} 1 +test utf-6.11.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xA0\xA0\x00] } 2 -test utf-6.12 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xA0\xD0 +test utf-6.12 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xD0] } 1 -test utf-6.13 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xA0\xE8 +test utf-6.13 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xE8] } 1 -test utf-6.14 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xA0\xF2 +test utf-6.14 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xF2] } 1 -test utf-6.15 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xA0\xF8 +test utf-6.15 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xA0\xF8] } 1 -test utf-6.16 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0 +test utf-6.16 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\x00] } 1 -test utf-6.17 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0G +test utf-6.17 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0]G } 1 -test utf-6.18 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0\xA0 +test utf-6.18 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0] } 2 -test utf-6.19 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0\xD0 +test utf-6.19 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xD0] +} 1 +test utf-6.20 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xE8] +} 1 +test utf-6.21 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xF2] } 1 -test utf-6.20 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0\xE8 +test utf-6.22 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xF8] } 1 -test utf-6.21 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0\xF2 +test utf-6.23 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\x00] } 1 -test utf-6.22 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0\xF8 +test utf-6.24 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8]G } 1 -test utf-6.23 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8 +test utf-6.25 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\x00] } 1 -test utf-6.24 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8G +test utf-6.26 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xD0] } 1 -test utf-6.25 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0 +test utf-6.27 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xE8] } 1 -test utf-6.26 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xD0 +test utf-6.28 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xF2] } 1 -test utf-6.27 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xE8 +test utf-6.29 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xF8] } 1 -test utf-6.28 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xF2 +test utf-6.30.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2] } 1 -test utf-6.29 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xF8 +test utf-6.30.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\x00] } 1 -test utf-6.30 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2 +test utf-6.31 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2]G } 1 -test utf-6.31 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2G +test utf-6.32.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0] } 1 -test utf-6.32 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0 +test utf-6.32.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\x00] } 1 -test utf-6.33 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xD0 +test utf-6.33 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xD0] } 1 -test utf-6.34 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xE8 +test utf-6.34 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xE8] } 1 -test utf-6.35 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xF2 +test utf-6.35 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xF2] } 1 -test utf-6.36 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xF8 +test utf-6.36 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xF8] } 1 -test utf-6.37 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF8 +test utf-6.37 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8] } 1 -test utf-6.38 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF8G +test utf-6.38 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8]G } 1 -test utf-6.39 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF8\xA0 +test utf-6.39 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xA0] } 1 -test utf-6.40 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF8\xD0 +test utf-6.40 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xD0] } 1 -test utf-6.41 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF8\xE8 +test utf-6.41 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xE8] } 1 -test utf-6.42 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF8\xF2 +test utf-6.42 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xF2] } 1 -test utf-6.43 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF8\xF8 +test utf-6.43 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF8\xF8] } 1 -test utf-6.44 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0\xA0G +test utf-6.44 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0]G } 2 -test utf-6.45 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0\xA0\xA0 +test utf-6.45 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xA0] } 2 -test utf-6.46 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0\xA0\xD0 +test utf-6.46 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xD0] } 2 -test utf-6.47 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0\xA0\xE8 +test utf-6.47 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xE8] } 2 -test utf-6.48 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0\xA0\xF2 +test utf-6.48 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xF2] } 2 -test utf-6.49 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xD0\xA0\xF8 +test utf-6.49 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xD0\xA0\xF8] } 2 -test utf-6.50 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0G +test utf-6.50 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0]G } 1 test utf-6.51 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0\xA0 + testutfnext 蠠 } 3 -test utf-6.52 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0\xD0 +test utf-6.52 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\xD0] } 1 -test utf-6.53 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0\xE8 +test utf-6.53 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\xE8] } 1 -test utf-6.54 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0\xF2 +test utf-6.54 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\xF2] } 1 -test utf-6.55 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0\xF8 +test utf-6.55 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xE8\xA0\xF8] } 1 -test utf-6.56 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0G +test utf-6.56 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0]G } 1 -test utf-6.57 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0 +test utf-6.57 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\x00] } 1 -test utf-6.58 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xD0 +test utf-6.58 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xD0] } 1 -test utf-6.59 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xE8 +test utf-6.59 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xE8] } 1 -test utf-6.60 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xF2 +test utf-6.60 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xF2] } 1 -test utf-6.61 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xF8 +test utf-6.61 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xF8] } 1 test utf-6.62 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0\xA0G + testutfnext 蠠G } 3 -test utf-6.63 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0\xA0\xA0 +test utf-6.63 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext 蠠[testbytestring \xA0] } 3 -test utf-6.64 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0\xA0\xD0 +test utf-6.64 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext 蠠[testbytestring \xD0] } 3 -test utf-6.65 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0\xA0\xE8 +test utf-6.65 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext 蠠[testbytestring \xE8] } 3 -test utf-6.66 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0\xA0\xF2 +test utf-6.66 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext 蠠[testbytestring \xF2] } 3 -test utf-6.67 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xE8\xA0\xA0\xF8 +test utf-6.67 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext 蠠[testbytestring \xF8] } 3 -test utf-6.68 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0G +test utf-6.68 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0]G } 1 -test utf-6.69 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0\xA0 +test utf-6.69.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0] +} 1 +test utf-6.69.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0] } 4 -test utf-6.70 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0\xD0 +test utf-6.70 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xD0] +} 1 +test utf-6.71 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xE8] } 1 -test utf-6.71 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0\xE8 +test utf-6.72 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xF2] } 1 -test utf-6.72 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0\xF2 +test utf-6.73 {Tcl_UtfNext} {testutfnext testbytestring} { + testutfnext [testbytestring \xF2\xA0\xA0\xF8] } 1 -test utf-6.73 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0\xF8 +test utf-6.74.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0]G } 1 -test utf-6.74 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0\xA0G +test utf-6.74.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0]G } 4 -test utf-6.75 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0\xA0\xA0 +test utf-6.75.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] +} 1 +test utf-6.75.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0] } 4 -test utf-6.76 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0\xA0\xD0 +test utf-6.76.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0] +} 1 +test utf-6.76.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0] } 4 -test utf-6.77 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0\xA0\xE8 +test utf-6.77.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8] +} 1 +test utf-6.77.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8] } 4 -test utf-6.78 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0\xA0\xF2 +test utf-6.78.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2] +} 1 +test utf-6.78.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2] } 4 -test utf-6.79 {Tcl_UtfNext} testutfnext { - testutfnext -bytestring \xF2\xA0\xA0\xA0G\xF8 +test utf-6.79.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8] +} 1 +test utf-6.79.1 {Tcl_UtfNext} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8] } 4 test utf-6.80 {Tcl_UtfNext - overlong sequences} testutfnext { - testutfnext -bytestring \xC0\x80 + testutfnext \x00 } 2 -test utf-6.81 {Tcl_UtfNext - overlong sequences} testutfnext { - testutfnext -bytestring \xC0\x81 +test utf-6.81 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xC0\x81] } 1 -test utf-6.82 {Tcl_UtfNext - overlong sequences} testutfnext { - testutfnext -bytestring \xC1\x80 +test utf-6.82 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xC1\x80] } 1 -test utf-6.83 {Tcl_UtfNext - overlong sequences} testutfnext { - testutfnext -bytestring \xC2\x80 +test utf-6.83 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xC2\x80] } 2 -test utf-6.84 {Tcl_UtfNext - overlong sequences} testutfnext { - testutfnext -bytestring \xE0\x80\x80 +test utf-6.84 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xE0\x80\x80] } 1 -test utf-6.85 {Tcl_UtfNext - overlong sequences} testutfnext { - testutfnext -bytestring \xE0\xA0\x80 +test utf-6.85 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xE0\xA0\x80] } 3 -test utf-6.86 {Tcl_UtfNext - overlong sequences} testutfnext { - testutfnext -bytestring \xF0\x80\x80\x80 +test utf-6.86 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} { + testutfnext [testbytestring \xF0\x80\x80\x80] } 1 -test utf-6.87 {Tcl_UtfNext - overlong sequences} testutfnext { - testutfnext -bytestring \xF0\x90\x80\x80 +test utf-6.87.0 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF0\x90\x80\x80] +} 1 +test utf-6.87.1 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF0\x90\x80\x80] } 4 -test utf-6.88 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} testutfnext { - testutfnext -bytestring \xA0\xA0 +test utf-6.88.0 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xA0\xA0\x00] +} 1 +test utf-6.88.1 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xA0\xA0\x00] } 2 -test utf-6.89 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} testutfnext { - testutfnext -bytestring \x80\x80 +test utf-6.89.0 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \x80\x80\x00] +} 1 +test utf-6.89.1 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \x80\x80\x00] } 2 -test utf-6.90 {Tcl_UtfNext, validity check [493dccc2de]} testutfnext { - testutfnext -bytestring \xF4\x8F\xBF\xBF +test utf-6.90.0 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xF4\x8F\xBF\xBF] +} 1 +test utf-6.90.1 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xF4\x8F\xBF\xBF] } 4 -test utf-6.91 {Tcl_UtfNext, validity check [493dccc2de]} testutfnext { - testutfnext -bytestring \xF4\x90\x80\x80 +test utf-6.91 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring} { + testutfnext [testbytestring \xF4\x90\x80\x80] +} 1 +test utf-6.92.0 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xA0\xA0\xA0] } 1 -test utf-6.92 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} testutfnext { - testutfnext -bytestring \xA0\xA0\xA0 +test utf-6.92.1 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xA0\xA0\xA0] } 3 -test utf-6.93 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} testutfnext { - testutfnext -bytestring \x80\x80\x80 +test utf-6.93.0 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \x80\x80\x80] +} 1 +test utf-6.93.1 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \x80\x80\x80] +} 3 +test utf-6.94.0 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \xA0\xA0\xA0\xA0] +} 1 +test utf-6.94.1 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \xA0\xA0\xA0\xA0] +} 3 +test utf-6.95.0 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring ucs2} { + testutfnext [testbytestring \x80\x80\x80\x80] +} 1 +test utf-6.95.1 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring fullutf} { + testutfnext [testbytestring \x80\x80\x80\x80] } 3 test utf-7.1 {Tcl_UtfPrev} testutfprev { @@ -464,316 +551,456 @@ test utf-7.2 {Tcl_UtfPrev} testutfprev { test utf-7.3 {Tcl_UtfPrev} testutfprev { testutfprev AA } 1 -test utf-7.4 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF8 +test utf-7.4 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8] } 1 -test utf-7.4.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF8\xA0\xA0\xA0 2 +test utf-7.4.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 2 } 1 -test utf-7.4.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF8\xF8\xA0\xA0 2 +test utf-7.4.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xF8\xA0\xA0] 2 } 1 -test utf-7.5 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF2 +test utf-7.5 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF2] } 1 -test utf-7.5.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF2\xA0\xA0\xA0 2 +test utf-7.5.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 2 } 1 -test utf-7.5.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF2\xF8\xA0\xA0 2 +test utf-7.5.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF2\xF8\xA0\xA0] 2 } 1 -test utf-7.6 {Tcl_UtfPrev} testutfprev { - testutfprev A\xE8 +test utf-7.6 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8] } 1 -test utf-7.6.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xE8\xA0\xA0\xA0 2 +test utf-7.6.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A蠠[testbytestring \xA0] 2 } 1 -test utf-7.6.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xE8\xF8\xA0\xA0 2 +test utf-7.6.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xF8\xA0\xA0] 2 } 1 -test utf-7.7 {Tcl_UtfPrev} testutfprev { - testutfprev A\xD0 +test utf-7.7 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0] } 1 -test utf-7.7.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xD0\xA0\xA0\xA0 2 +test utf-7.7.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 2 } 1 -test utf-7.7.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xD0\xF8\xA0\xA0 2 +test utf-7.7.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xF8\xA0\xA0] 2 } 1 -test utf-7.8 {Tcl_UtfPrev} testutfprev { - testutfprev A\xA0 +test utf-7.8 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0] } 1 -test utf-7.8.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xA0\xA0\xA0\xA0 2 +test utf-7.8.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 2 } 1 -test utf-7.8.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xA0\xF8\xA0\xA0 2 +test utf-7.8.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xF8\xA0\xA0] 2 } 1 -test utf-7.9 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF8\xA0 +test utf-7.9 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0] } 2 -test utf-7.9.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF8\xA0\xA0\xA0 3 +test utf-7.9.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 3 } 2 -test utf-7.9.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF8\xA0\xF8\xA0 3 +test utf-7.9.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xF8\xA0] 3 } 2 -test utf-7.10 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF2\xA0 +test utf-7.10.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0] +} 2 +test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0] } 1 -test utf-7.10.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF2\xA0\xA0\xA0 3 +test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3 +} 2 +test utf-7.10.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3 } 1 -test utf-7.10.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF2\xA0\xF8\xA0 3 +test utf-7.10.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3 +} 2 +test utf-7.10.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3 } 1 -test utf-7.11 {Tcl_UtfPrev} testutfprev { - testutfprev A\xE8\xA0 +test utf-7.11 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xA0] } 1 -test utf-7.11.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xE8\xA0\xA0\xA0 3 +test utf-7.11.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A蠠[testbytestring \xA0] 3 } 1 -test utf-7.11.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xE8\xA0\xF8\xA0 3 +test utf-7.11.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xA0\xF8\xA0] 3 } 1 -test utf-7.11.3 {Tcl_UtfPrev} testutfprev { - testutfprev A\xE8\xA0\xF8 3 +test utf-7.11.3 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE8\xA0\xF8] 3 } 1 -test utf-7.12 {Tcl_UtfPrev} testutfprev { - testutfprev A\xD0\xA0 +test utf-7.12 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0] } 1 -test utf-7.12.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xD0\xA0\xA0\xA0 3 +test utf-7.12.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 3 } 1 -test utf-7.12.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xD0\xA0\xF8\xA0 3 +test utf-7.12.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xF8\xA0] 3 } 1 -test utf-7.13 {Tcl_UtfPrev} testutfprev { - testutfprev A\xA0\xA0 +test utf-7.13 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0] } 2 -test utf-7.13.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xA0\xA0\xA0\xA0 3 +test utf-7.13.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 3 } 2 -test utf-7.13.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xA0\xA0\xF8\xA0 3 +test utf-7.13.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xF8\xA0] 3 } 2 -test utf-7.14 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF8\xA0\xA0 +test utf-7.14 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0] } 3 -test utf-7.14.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF8\xA0\xA0\xA0 4 +test utf-7.14.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 4 } 3 -test utf-7.14.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF8\xA0\xA0\xF8 4 +test utf-7.14.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xF8] 4 } 3 -test utf-7.15 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF2\xA0\xA0 +test utf-7.15.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0] +} 3 +test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0] } 1 -test utf-7.15.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF2\xA0\xA0\xA0 4 +test utf-7.15.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4 +} 3 +test utf-7.15.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4 } 1 -test utf-7.15.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF2\xA0\xA0\xF8 4 +test utf-7.15.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4 +} 3 +test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4 } 1 test utf-7.16 {Tcl_UtfPrev} testutfprev { - testutfprev A\xE8\xA0\xA0 + testutfprev A蠠 } 1 -test utf-7.16.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xE8\xA0\xA0\xA0 4 +test utf-7.16.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A蠠[testbytestring \xA0] 4 } 1 -test utf-7.16.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xE8\xA0\xA0\xF8 4 +test utf-7.16.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A蠠[testbytestring \xF8] 4 } 1 -test utf-7.17 {Tcl_UtfPrev} testutfprev { - testutfprev A\xD0\xA0\xA0 +test utf-7.17 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0] } 3 -test utf-7.17.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xD0\xA0\xA0\xA0 4 +test utf-7.17.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 4 } 3 -test utf-7.17.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xD0\xA0\xA0\xF8 4 +test utf-7.17.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xF8] 4 } 3 -test utf-7.18 {Tcl_UtfPrev} testutfprev { - testutfprev A\xA0\xA0\xA0 +test utf-7.18.0 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0] } 3 -test utf-7.18.1 {Tcl_UtfPrev} testutfprev { - testutfprev A\xA0\xA0\xA0\xA0 4 +test utf-7.18.1 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 4 } 3 -test utf-7.18.2 {Tcl_UtfPrev} testutfprev { - testutfprev A\xA0\xA0\xA0\xF8 4 +test utf-7.18.2 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0\xF8] 4 } 3 -test utf-7.19 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF8\xA0\xA0\xA0 +test utf-7.19 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF8\xA0\xA0\xA0] +} 4 +test utf-7.20.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] } 4 -test utf-7.20 {Tcl_UtfPrev} testutfprev { - testutfprev A\xF2\xA0\xA0\xA0 +test utf-7.20.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF2\xA0\xA0\xA0] } 1 -test utf-7.21 {Tcl_UtfPrev} testutfprev { - testutfprev A\xE8\xA0\xA0\xA0 +test utf-7.21 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A蠠[testbytestring \xA0] } 4 -test utf-7.22 {Tcl_UtfPrev} testutfprev { - testutfprev A\xD0\xA0\xA0\xA0 +test utf-7.22 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xD0\xA0\xA0\xA0] } 4 -test utf-7.23 {Tcl_UtfPrev} testutfprev { - testutfprev A\xA0\xA0\xA0\xA0 +test utf-7.23 {Tcl_UtfPrev} {testutfprev testbytestring} { + testutfprev A[testbytestring \xA0\xA0\xA0\xA0] } 4 -test utf-7.24 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xC0\x81 +test utf-7.24 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xC0\x81] } 2 -test utf-7.25 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xC0\x81 2 +test utf-7.25 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xC0\x81] 2 } 1 -test utf-7.26 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xE0\x80\x80 +test utf-7.26 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\x80\x80] } 3 -test utf-7.27 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xE0\x80 +test utf-7.27 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\x80] } 2 -test utf-7.27.1 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xE0\x80\x80 3 +test utf-7.27.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\x80\x80] 3 } 2 -test utf-7.28 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xE0 +test utf-7.28 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0] } 1 -test utf-7.28.1 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xE0\x80\x80 2 +test utf-7.28.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\x80\x80] 2 } 1 -test utf-7.29 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xF0\x80\x80\x80 +test utf-7.29 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x80\x80\x80] } 4 -test utf-7.30 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xF0\x80\x80\x80 4 +test utf-7.30 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x80\x80\x80] 4 } 3 -test utf-7.31 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xF0\x80\x80\x80 3 +test utf-7.31 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x80\x80\x80] 3 } 2 -test utf-7.32 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xF0\x80\x80\x80 2 +test utf-7.32 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x80\x80\x80] 2 } 1 test utf-7.33 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xC0\x80 + testutfprev A\x00 } 1 -test utf-7.34 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xC1\x80 +test utf-7.34 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xC1\x80] } 2 -test utf-7.35 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xC2\x80 +test utf-7.35 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xC2\x80] } 1 -test utf-7.36 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xE0\xA0\x80 +test utf-7.36 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\xA0\x80] } 1 -test utf-7.37 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xE0\xA0\x80 3 +test utf-7.37 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\xA0\x80] 3 } 1 -test utf-7.38 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xE0\xA0\x80 2 +test utf-7.38 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xE0\xA0\x80] 2 } 1 -test utf-7.39 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xF0\x90\x80\x80 +test utf-7.39.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF0\x90\x80\x80] +} 4 +test utf-7.39.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF0\x90\x80\x80] } 1 -test utf-7.40 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xF0\x90\x80\x80 4 +test utf-7.40.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 4 +} 3 +test utf-7.40.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 4 } 1 -test utf-7.41 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xF0\x90\x80\x80 3 +test utf-7.41.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 3 +} 2 +test utf-7.41.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 3 } 1 -test utf-7.42 {Tcl_UtfPrev -- overlong sequence} testutfprev { - testutfprev A\xF0\x90\x80\x80 2 +test utf-7.42 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF0\x90\x80\x80] 2 } 1 -test utf-7.43 {Tcl_UtfPrev -- no lead byte at start} testutfprev { - testutfprev \xA0 +test utf-7.43 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { + testutfprev [testbytestring \xA0] } 0 -test utf-7.44 {Tcl_UtfPrev -- no lead byte at start} testutfprev { - testutfprev \xA0\xA0 +test utf-7.44 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { + testutfprev [testbytestring \xA0\xA0] } 1 -test utf-7.45 {Tcl_UtfPrev -- no lead byte at start} testutfprev { - testutfprev \xA0\xA0\xA0 +test utf-7.45 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { + testutfprev [testbytestring \xA0\xA0\xA0] } 2 -test utf-7.46 {Tcl_UtfPrev -- no lead byte at start} testutfprev { - testutfprev \xA0\xA0\xA0\xA0 +test utf-7.46 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} { + testutfprev [testbytestring \xA0\xA0\xA0\xA0] } 3 -test utf-7.47 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} testutfprev { - testutfprev \xE8\xA0 +test utf-7.47 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} {testutfprev testbytestring} { + testutfprev [testbytestring \xE8\xA0] } 0 test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} testutfprev { - testutfprev \xE8\xA0\xA0 2 + testutfprev 蠠 2 } 0 -test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} testutfprev { - testutfprev \xE8\xA0\x00 2 +test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} { + testutfprev [testbytestring \xE8\xA0\x00] 2 } 0 -test utf-7.48 {Tcl_UtfPrev, validity check [493dccc2de]} testutfprev { - testutfprev A\xF4\x8F\xBF\xBF +test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] +} 4 +test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] } 1 -test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} testutfprev { - testutfprev A\xF4\x8F\xBF\xBF 4 +test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4 +} 3 +test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4 } 1 -test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} testutfprev { - testutfprev A\xF4\x8F\xBF\xBF 3 +test utf-7.48.4 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3 +} 2 +test utf-7.48.5 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3 } 1 -test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} testutfprev { - testutfprev A\xF4\x8F\xBF\xBF 2 +test utf-7.48.6 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 2 } 1 -test utf-7.49 {Tcl_UtfPrev, validity check [493dccc2de]} testutfprev { - testutfprev A\xF4\x90\x80\x80 +test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x90\x80\x80] } 4 -test utf-7.49.1 {Tcl_UtfPrev, validity check [493dccc2de]} testutfprev { - testutfprev A\xF4\x90\x80\x80 4 +test utf-7.49.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x90\x80\x80] 4 } 3 -test utf-7.49.2 {Tcl_UtfPrev, validity check [493dccc2de]} testutfprev { - testutfprev A\xF4\x90\x80\x80 3 +test utf-7.49.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x90\x80\x80] 3 } 2 -test utf-7.49.3 {Tcl_UtfPrev, validity check [493dccc2de]} testutfprev { - testutfprev A\xF4\x90\x80\x80 2 +test utf-7.49.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { + testutfprev A[testbytestring \xF4\x90\x80\x80] 2 } 1 test utf-8.1 {Tcl_UniCharAtIndex: index = 0} { string index abcd 0 } a test utf-8.2 {Tcl_UniCharAtIndex: index = 0} { - string index \u4E4E\u25A 0 -} "\u4E4E" + string index 乎ɚ 0 +} 乎 test utf-8.3 {Tcl_UniCharAtIndex: index > 0} { string index abcd 2 } c test utf-8.4 {Tcl_UniCharAtIndex: index > 0} { - string index \u4E4E\u25A\xFF\u543 2 -} "\uFF" -test utf-8.5 {Tcl_UniCharAtIndex: high surrogate} { + string index 乎ɚÿՃ 2 +} ÿ +test utf-8.5.0 {Tcl_UniCharAtIndex: high surrogate} ucs2 { + string index \uD842 0 +} \uD842 +test utf-8.5.1 {Tcl_UniCharAtIndex: high surrogate} ucs4 { + string index \uD842 0 +} \uD842 +test utf-8.5.2 {Tcl_UniCharAtIndex: high surrogate} utf16 { string index \uD842 0 -} "\uD842" +} \uD842 test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} { string index \uDC42 0 -} "\uDC42" -test utf-8.7 {Tcl_UniCharAtIndex: Emoji} { - string index \U1F600 0 -} "\U1F600" -test utf-8.8 {Tcl_UniCharAtIndex: Emoji} { - string index \U1F600 1 +} \uDC42 +test utf-8.7.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index \uD83D\uDE00G 0 +} \uD83D +test utf-8.7.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index 😀G 0 +} 😀 +test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index 😀G 0 +} 😀 +test utf-8.8.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index \uD83D\uDE00G 1 +} \uDE00 +test utf-8.8.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index 😀G 1 +} G +test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index 😀G 1 } {} +test utf-8.9.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index \uD83D\uDE00G 2 +} G +test utf-8.9.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index 😀G 2 +} {} +test utf-8.9.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index 😀G 2 +} G +test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index 😀G 0 +} \uFFFD +test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index 😀G 0 +} 😀 +test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index 😀G 0 +} 😀 +test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index 😀G 1 +} G +test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index 😀G 1 +} G +test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index 😀G 1 +} {} +test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} ucs2 { + string index 😀G 2 +} {} +test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} ucs4 { + string index 😀G 2 +} {} +test utf-8.12.2 {Tcl_UniCharAtIndex: Emoji} utf16 { + string index 😀G 2 +} G test utf-9.1 {Tcl_UtfAtIndex: index = 0} { string range abcd 0 2 } abc test utf-9.2 {Tcl_UtfAtIndex: index > 0} { - string range \u4E4E\u25A\xFF\u543klmnop 1 5 -} "\u25A\xFF\u543kl" -test utf-9.3 {Tcl_UtfAtIndex: index = 0, Emoji} { - string range \U1F600G 0 0 -} "\U1F600" -test utf-9.4 {Tcl_UtfAtIndex: index > 0, Emoji} tip389 { - string range \U1F600G 1 1 + string range 乎ɚÿՃklmnop 1 5 +} ɚÿՃkl +test utf-9.3.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 { + string range \uD83D\uDE00G 0 0 +} \uD83D +test utf-9.3.1 {Tcl_UtfAtIndex: index = 0, Emoji} ucs4 { + string range 😀G 0 0 +} 😀 +test utf-9.3.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 { + string range 😀G 0 0 +} 😀 +test utf-9.4.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { + string range \uD83D\uDE00G 1 1 +} \uDE00 +test utf-9.4.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { + string range 😀G 1 1 +} G +test utf-9.4.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { + string range 😀G 1 1 } {} - +test utf-9.5.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { + string range \uD83D\uDE00G 2 2 +} G +test utf-9.5.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { + string range 😀G 2 2 +} {} +test utf-9.5.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { + string range 😀G 2 2 +} G +test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 { + string range 😀G 0 0 +} \uFFFD +test utf-9.6.1 {Tcl_UtfAtIndex: index = 0, Emoji} ucs4 { + string range 😀G 0 0 +} 😀 +test utf-9.6.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 { + string range 😀G 0 0 +} 😀 +test utf-9.7.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { + string range 😀G 1 1 +} G +test utf-9.7.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { + string range 😀G 1 1 +} G +test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { + string range 😀G 1 1 +} {} +test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 { + string range 😀G 2 2 +} {} +test utf-9.8.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 { + string range 😀G 2 2 +} {} +test utf-9.8.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 { + string range 😀G 2 2 +} G test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { set x \n } { } test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring { - expr {"\uA2" eq [testbytestring "\xC2\xA2"]} + expr {"\uA2" eq [testbytestring \xC2\xA2]} } 1 test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring { - expr {"\u4E21" eq [testbytestring "\xE4\xB8\xA1"]} + expr {"\u4E21" eq [testbytestring \xE4\xB8\xA1]} } 1 test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring { expr {"\u4E2k" eq "[testbytestring \xD3\xA2]k"} @@ -781,15 +1008,16 @@ test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring { test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring { expr {"\u4E216" eq "[testbytestring \xE4\xB8\xA1]6"} } 1 -test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} testbytestring { +test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} {fullutf testbytestring} { expr {"\U1E2165" eq "[testbytestring \xF0\x9E\x88\x96]5"} } 1 -test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} testbytestring { +test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} {fullutf testbytestring} { expr {"\U10E2165" eq "[testbytestring \xF4\x8E\x88\x96]5"} } 1 -proc bsCheck {char num} { + +proc bsCheck {char num {constraints {}}} { global errNum - test utf-10.$errNum {backslash substitution} { + test utf-10.$errNum {backslash substitution} $constraints { scan $char %c value set value } $num @@ -824,7 +1052,8 @@ bsCheck \x 120 bsCheck \xa 10 bsCheck \xA 10 bsCheck \x41 65 -bsCheck \x541 84 +bsCheck \x541 65 pre388 ;# == \x41 +bsCheck \x541 84 !pre388 ;# == \x54 1 bsCheck \u 117 bsCheck \uk 117 bsCheck \u41 65 @@ -833,24 +1062,25 @@ 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 \U0000004E21 78 -bsCheck \U00110000 69632 -bsCheck \U01100000 69632 -bsCheck \U11000000 69632 -bsCheck \U0010FFFF 1114111 -bsCheck \U010FFFF0 1114111 -bsCheck \U10FFFF00 1114111 -bsCheck \UFFFFFFFF 1048575 +bsCheck \741 225 pre388 ;# == \341 +bsCheck \741 60 !pre388 ;# == \74 1 +bsCheck \U 85 +bsCheck \Uk 85 +bsCheck \U41 65 Uesc +bsCheck \Ua 10 Uesc +bsCheck \UA 10 Uesc +bsCheck \UA1 161 Uesc +bsCheck \U4E21 20001 Uesc +bsCheck \U004E21 20001 Uesc +bsCheck \U00004E21 20001 Uesc +bsCheck \U0000004E21 78 Uesc +bsCheck \U00110000 69632 fullutf +bsCheck \U01100000 69632 fullutf +bsCheck \U11000000 69632 fullutf +bsCheck \U0010FFFF 1114111 fullutf +bsCheck \U010FFFF0 1114111 fullutf +bsCheck \U10FFFF00 1114111 fullutf +bsCheck \UFFFFFFFF 1048575 fullutf test utf-11.1 {Tcl_UtfToUpper} { string toupper {} @@ -862,12 +1092,18 @@ test utf-11.3 {Tcl_UtfToUpper} { string toupper \xE3gh } \xC3GH test utf-11.4 {Tcl_UtfToUpper} { - string toupper \u01E3gh -} \u01E2GH + string toupper ǣgh +} ǢGH test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} { - string toupper \u10D0\u1C90 -} \u1C90\u1C90 -test utf-11.6 {Tcl_UtfToUpper low/high surrogate)} { + string toupper აᲐ +} ᲐᲐ +test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} fullutf { + string toupper 𐐨 +} 𐐀 +test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} fullutf { + string toupper 𐐨 +} 𐐀 +test utf-11.8 {Tcl_UtfToUpper low/high surrogate)} { string toupper \uDC24\uD824 } \uDC24\uD824 @@ -878,17 +1114,23 @@ test utf-12.2 {Tcl_UtfToLower} { string tolower ABC } abc test utf-12.3 {Tcl_UtfToLower} { - string tolower \xC3GH -} \xE3gh + string tolower ÃGH +} ãgh test utf-12.4 {Tcl_UtfToLower} { - string tolower \u01E2GH -} \u01E3gh + string tolower ǢGH +} ǣgh test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} { - string tolower \u10D0\u1C90 -} \u10D0\u10D0 -test utf-12.6 {Tcl_UtfToUpper low/high surrogate)} { + string tolower აᲐ +} აა +test utf-12.6 {Tcl_UtfToLower low/high surrogate)} { string tolower \uDC24\uD824 } \uDC24\uD824 +test utf-12.7 {Tcl_UtfToLower beyond U+FFFF} fullutf { + string tolower 𐐀 +} 𐐨 +test utf-12.8 {Tcl_UtfToLower beyond U+FFFF} fullutf { + string tolower 𐐀 +} 𐐨 test utf-13.1 {Tcl_UtfToTitle} { string totitle {} @@ -897,20 +1139,26 @@ test utf-13.2 {Tcl_UtfToTitle} { string totitle abc } Abc test utf-13.3 {Tcl_UtfToTitle} { - string totitle \xE3GH -} \xC3gh + string totitle ãGH +} Ãgh test utf-13.4 {Tcl_UtfToTitle} { - string totitle \u01F3AB -} \u01F2ab + string totitle dzAB +} Dzab test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { - string totitle \u10D0\u1C90 -} \u10D0\u1C90 + string totitle აᲐ +} აᲐ test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { - string totitle \u1C90\u10D0 -} \u1C90\u10D0 + string totitle Აა +} Აა test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} { string totitle \uDC24\uD824 } \uDC24\uD824 +test utf-13.8 {Tcl_UtfToTitle beyond U+FFFF} fullutf { + string totitle 𐐨𐐀 +} 𐐀𐐨 +test utf-13.9 {Tcl_UtfToTitle beyond U+FFFF} fullutf { + string totitle 𐐨𐐀 +} 𐐀𐐨 test utf-14.1 {Tcl_UtfNcasecmp} { string compare -nocase a b @@ -929,8 +1177,8 @@ test utf-15.1 {Tcl_UniCharToUpper, negative delta} { string toupper aA } AA test utf-15.2 {Tcl_UniCharToUpper, positive delta} { - string toupper \u0178\xFF -} \u0178\u0178 + string toupper Ÿÿ +} ŸŸ test utf-15.3 {Tcl_UniCharToUpper, no delta} { string toupper ! } ! @@ -939,25 +1187,25 @@ test utf-16.1 {Tcl_UniCharToLower, negative delta} { string tolower aA } aa test utf-16.2 {Tcl_UniCharToLower, positive delta} { - string tolower \u0178\xFF\uA78D\u01C5\U10400 -} \xFF\xFF\u0265\u01C6\U10428 + string tolower ŸÿꞍDž +} ÿÿɥdž test utf-17.1 {Tcl_UniCharToLower, no delta} { string tolower ! } ! test utf-18.1 {Tcl_UniCharToTitle, add one for title} { - string totitle \u01C4 -} \u01C5 + string totitle DŽ +} Dž test utf-18.2 {Tcl_UniCharToTitle, subtract one for title} { - string totitle \u01C6 -} \u01C5 + string totitle dž +} Dž test utf-18.3 {Tcl_UniCharToTitle, subtract delta for title (positive)} { - string totitle \u017F -} \x53 + string totitle ſ +} S test utf-18.4 {Tcl_UniCharToTitle, subtract delta for title (negative)} { - string totitle \xFF -} \u0178 + string totitle ÿ +} Ÿ test utf-18.5 {Tcl_UniCharToTitle, no delta} { string totitle ! } ! @@ -968,28 +1216,38 @@ test utf-19.1 {TclUniCharLen} -body { unset -nocomplain foo } -result {1 4} -test utf-20.1 {TclUniCharNcmp} { -} {} +test utf-20.1 {TclUniCharNcmp} ucs4 { + string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0] +} -1 +test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} { + set one [format %c 0xFFFF] + set two [format %c 0x10000] + set first [string compare $one $two] + string range $one 0 0 + string range $two 0 0 + set second [string compare $one $two] + expr {($first == $second) ? "agree" : "disagree"} +} agree test utf-21.1 {TclUniCharIsAlnum} { # this returns 1 with Unicode 7 compliance - string is alnum \u1040\u021F\u0220 + string is alnum ၀ȟȠ } 1 test utf-21.2 {unicode alnum char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - list [regexp {^[[:alnum:]]+$} \u1040\u021F\u0220] [regexp {^\w+$} \u1040\u021F\u0220_\u203F\u2040\u2054\uFE33\uFE34\uFE4D\uFE4E\uFE4F\uFF3F] + list [regexp {^[[:alnum:]]+$} ၀ȟȠ] [regexp {^\w+$} ၀ȟȠ_‿⁀⁔︳︴﹍﹎﹏＿] } {1 1} test utf-21.3 {unicode print char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - regexp {^[[:print:]]+$} \uFBC1 + regexp {^[[:print:]]+$} ﯁ } 1 test utf-21.4 {TclUniCharIsGraph} { # [Bug 3464428] - string is graph \u0120 + string is graph Ġ } 1 test utf-21.5 {unicode graph char in regc_locale.c} { # [Bug 3464428] - regexp {^[[:graph:]]+$} \u0120 + regexp {^[[:graph:]]+$} Ġ } 1 test utf-21.6 {TclUniCharIsGraph} { # [Bug 3464428] @@ -1024,97 +1282,90 @@ test utf-22.1 {TclUniCharIsWordChar} { string wordend "xyz123_bar fg" 0 } 10 test utf-22.2 {TclUniCharIsWordChar} { - string wordend "x\u5080z123_bar\u203C fg" 0 + string wordend "x傀z123_bar‼ fg" 0 } 10 test utf-23.1 {TclUniCharIsAlpha} { # this returns 1 with Unicode 7 compliance - string is alpha \u021F\u0220\u037F\u052F + string is alpha ȟȠͿԯ } 1 test utf-23.2 {unicode alpha char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - regexp {^[[:alpha:]]+$} \u021F\u0220\u037F\u052F + regexp {^[[:alpha:]]+$} ȟȠͿԯ } 1 test utf-24.1 {TclUniCharIsDigit} { # this returns 1 with Unicode 7 compliance - string is digit \u1040\uABF0 + string is digit ၀꯰ } 1 test utf-24.2 {unicode digit char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - list [regexp {^[[:digit:]]+$} \u1040\uABF0] [regexp {^\d+$} \u1040\uABF0] + list [regexp {^[[:digit:]]+$} ၀꯰] [regexp {^\d+$} ၀꯰] } {1 1} test utf-24.3 {TclUniCharIsSpace} { + # this returns 1 with Unicode 7 compliance + string is space \u1680\u180E\u202F +} 1 +test utf-24.4 {unicode space char in regc_locale.c} { + # this returns 1 with Unicode 7 compliance + list [regexp {^[[:space:]]+$} \u1680\u180E\u202F] [regexp {^\s+$} \u1680\u180E\u202F] +} {1 1} +test utf-24.5 {TclUniCharIsSpace} tip413 { # this returns 1 with Unicode 7/TIP 413 compliance string is space \x85\u1680\u180E\u200B\u202F\u2060 } 1 -test utf-24.4 {unicode space char in regc_locale.c} { +test utf-24.6 {unicode space char in regc_locale.c} tip413 { # this returns 1 with Unicode 7/TIP 413 compliance list [regexp {^[[:space:]]+$} \x85\u1680\u180E\u200B\u202F\u2060] [regexp {^\s+$} \x85\u1680\u180E\u200B\u202F\u2060] } {1 1} -test utf-25.1 {Tcl_UniCharNcasecmp} -constraints teststringobj \ - -setup { - testobj freeallvars - } \ - -body { - teststringobj set 1 a - teststringobj set 2 b - teststringobj maxchars 1 - teststringobj maxchars 2 - string compare -nocase [teststringobj get 1] [teststringobj get 2] - } \ - -cleanup { - testobj freeallvars - } \ - -result -1 -test utf-25.2 {Tcl_UniCharNcasecmp} -constraints teststringobj \ - -setup { - testobj freeallvars - } \ - -body { - teststringobj set 1 b - teststringobj set 2 a - teststringobj maxchars 1 - teststringobj maxchars 2 - string compare -nocase [teststringobj get 1] [teststringobj get 2] - } \ - -cleanup { +proc UniCharCaseCmpTest {order one two {constraints {}}} { + variable count + test utf-25.$count {Tcl_UniCharNcasecmp} -setup { testobj freeallvars - } \ - -result 1 -test utf-25.3 {Tcl_UniCharNcasecmp} -constraints teststringobj \ - -setup { + } -constraints [linsert $constraints 0 teststringobj] -cleanup { testobj freeallvars - } \ - -body { - teststringobj set 1 B - teststringobj set 2 a + } -body { + teststringobj set 1 $one + teststringobj set 2 $two teststringobj maxchars 1 teststringobj maxchars 2 - string compare -nocase [teststringobj get 1] [teststringobj get 2] - } \ - -cleanup { - testobj freeallvars - } \ - -result 1 + set result [string compare -nocase [teststringobj get 1] [teststringobj get 2]] + if {$result eq [string map {< -1 = 0 > 1} $order]} { + set result ok + } else { + set result "'$one' should be $order '$two' (no case)" + } + set result + } -result ok + incr count +} +variable count 1 +UniCharCaseCmpTest < a b +UniCharCaseCmpTest > b a +UniCharCaseCmpTest > B a +UniCharCaseCmpTest > aBcB abca +UniCharCaseCmpTest < \uFFFF [format %c 0x10000] ucs4 +UniCharCaseCmpTest < \uFFFF \U10000 ucs4 +UniCharCaseCmpTest > [format %c 0x10000] \uFFFF ucs4 +UniCharCaseCmpTest > \U10000 \uFFFF ucs4 -test utf-25.4 {Tcl_UniCharNcasecmp} -constraints teststringobj \ - -setup { - testobj freeallvars - } \ - -body { - teststringobj set 1 aBcB - teststringobj set 2 abca - teststringobj maxchars 1 - teststringobj maxchars 2 - string compare -nocase [teststringobj get 1] [teststringobj get 2] - } \ - -cleanup { - testobj freeallvars - } \ - -result 1 + +test utf-26.1 {Tcl_UniCharDString} -setup { + testobj freeallvars +} -constraints {teststringobj testbytestring} -cleanup { + testobj freeallvars +} -body { + teststringobj set 1 foo + teststringobj maxchars 1 + teststringobj append 1 [testbytestring barsoom\xF2\xC2\x80] 10 + scan [string index [teststringobj get 1] 11] %c +} -result 128 + + +unset count +rename UniCharCaseCmpTest {} # cleanup ::tcltest::cleanupTests diff --git a/tests/util.test b/tests/util.test index 1d8162c..f610762 100644 --- a/tests/util.test +++ b/tests/util.test @@ -1,19 +1,19 @@ # This file is a Tcl script to test the code in the file tclUtil.c. # This file is organized in the standard fashion for Tcl tests. # -# Copyright (c) 1995-1998 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1995-1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint controversialNaN 1 testConstraint testbytestring [llength [info commands testbytestring]] @@ -33,9 +33,9 @@ proc testIEEE {} { switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xFF d \ ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\xBF d \ ieeeValues(-Normal) binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ ieeeValues(-Subnormal) @@ -45,23 +45,23 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x3F d \ ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF0\x7F d \ ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\x7F d \ ieeeValues(NaN) - binary scan \x00\x00\x00\x00\x00\x00\xf8\xff d \ + binary scan \x00\x00\x00\x00\x00\x00\xF8\xFF d \ ieeeValues(-NaN) - binary scan \xef\xcd\xab\x89\x67\x45\xfb\xff d \ + binary scan \xEF\xCD\xAB\x89\x67\x45\xFB\xFF d \ ieeeValues(-NaN(3456789abcdef)) set ieeeValues(littleEndian) 1 return 1 } {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \xBF\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Normal) binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-Subnormal) @@ -71,15 +71,15 @@ proc testIEEE {} { ieeeValues(+0) binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x3F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF0\x00\x00\x00\x00\x00\x00 d \ ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \x7F\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(NaN) - binary scan \xff\xf8\x00\x00\x00\x00\x00\x00 d \ + binary scan \xFF\xF8\x00\x00\x00\x00\x00\x00 d \ ieeeValues(-NaN) - binary scan \xff\xfb\x45\x67\x89\xab\xcd\xef d \ + binary scan \xFF\xFB\x45\x67\x89\xAB\xCD\xEF d \ ieeeValues(-NaN(3456789abcdef)) set ieeeValues(littleEndian) 0 return 1 @@ -105,7 +105,7 @@ 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] + set signum [expr {1<<63}] } else { set signum 0 } @@ -207,9 +207,9 @@ test util-4.5 {Tcl_ConcatObj - backslash-space at end of argument} { concat a { } c } {a c} test util-4.6 {Tcl_ConcatObj - utf-8 sequence with "whitespace" char} { - # Check for Bug #227512. If this violates C isspace, then it returns \xc3. - concat \xe0 -} \xe0 + # Check for Bug #227512. If this violates C isspace, then it returns \xC3. + concat \xE0 +} \xE0 test util-4.7 {Tcl_ConcatObj - refCount safety} testconcatobj { # Check for Bug #1447328 (actually, bugs in its original "fix"). One of the # symptoms was Bug #2055782. @@ -239,14 +239,14 @@ test util-5.6 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch *3*6*9 01234567890 } 0 test util-5.7 {Tcl_StringMatch: UTF-8} { - Wrapper_Tcl_StringMatch *u \u4e4fu + Wrapper_Tcl_StringMatch *u 乏u } 1 test util-5.8 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch a?c abc } 1 test util-5.9 {Tcl_StringMatch: UTF-8} { # skip one character in string - Wrapper_Tcl_StringMatch a?c a\u4e4fc + Wrapper_Tcl_StringMatch a?c a乏c } 1 test util-5.10 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch a??c abc @@ -259,15 +259,15 @@ test util-5.12 {Tcl_StringMatch} { } 1 test util-5.13 {Tcl_StringMatch: UTF-8} { # string += Tcl_UtfToUniChar(string, &ch); - Wrapper_Tcl_StringMatch "\[\u4e4fxy\]bc" "\u4e4fbc" + Wrapper_Tcl_StringMatch "\[乏xy\]bc" "乏bc" } 1 test util-5.14 {Tcl_StringMatch} { - # if ((*pattern == ']') || (*pattern == '\0')) + # if ((*pattern == ']') || (*pattern == '\x00')) # badly formed pattern Wrapper_Tcl_StringMatch {[]} {[]} } 0 test util-5.15 {Tcl_StringMatch} { - # if ((*pattern == ']') || (*pattern == '\0')) + # if ((*pattern == ']') || (*pattern == '\x00')) # badly formed pattern Wrapper_Tcl_StringMatch {[} {[} } 0 @@ -277,17 +277,17 @@ test util-5.16 {Tcl_StringMatch} { test util-5.17 {Tcl_StringMatch: UTF-8} { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # get 1 UTF-8 character - Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc" + Wrapper_Tcl_StringMatch "a\[a乏c]c" "a乏c" } 1 test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring { # pattern += Tcl_UtfToUniChar(pattern, &endChar); - # proper advance: wrong answer would match on UTF trail byte of \u4e4f - Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\x8fc] + # proper advance: wrong answer would match on UTF trail byte of 乏 + Wrapper_Tcl_StringMatch {a[a乏c]c} [testbytestring a\x8Fc] } 0 test util-5.19 {Tcl_StringMatch: UTF-8} { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # proper advance. - Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} "acc" + Wrapper_Tcl_StringMatch {a[a乏c]c} "acc" } 1 test util-5.20 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch {a[xyz]c} abc @@ -296,13 +296,13 @@ test util-5.21 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch {12[2-7]45} 12345 } 1 test util-5.22 {Tcl_StringMatch: UTF-8 range} { - Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "0" + Wrapper_Tcl_StringMatch "\[一-乏]" "0" } 0 test util-5.23 {Tcl_StringMatch: UTF-8 range} { - Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "\u4e33" + Wrapper_Tcl_StringMatch "\[一-乏]" "丳" } 1 test util-5.24 {Tcl_StringMatch: UTF-8 range} { - Wrapper_Tcl_StringMatch "\[\u4e00-\u4e4f]" "\uff08" + Wrapper_Tcl_StringMatch "\[一-乏]" "（" } 0 test util-5.25 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch {12[ab2-4cd]45} 12345 @@ -356,16 +356,16 @@ test util-5.41 {Tcl_StringMatch: skip correct number of ']'} { Wrapper_Tcl_StringMatch {[A-]]x} Ax } 1 test util-5.42 {Tcl_StringMatch: skip correct number of ']'} { - Wrapper_Tcl_StringMatch {[A-]]x} \ue1x + Wrapper_Tcl_StringMatch {[A-]]x} \xE1x } 0 test util-5.43 {Tcl_StringMatch: skip correct number of ']'} { - Wrapper_Tcl_StringMatch \[A-]\ue1]x \ue1x + Wrapper_Tcl_StringMatch \[A-]\xE1]x \xE1x } 1 test util-5.44 {Tcl_StringMatch: skip correct number of ']'} { Wrapper_Tcl_StringMatch {[A-]h]x} hx } 1 test util-5.45 {Tcl_StringMatch} { - # if (*pattern == '\0') + # if (*pattern == '\x00') # badly formed pattern, still treats as a set Wrapper_Tcl_StringMatch {[a} a } 1 @@ -388,7 +388,7 @@ test util-5.51 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch "" "" } 1 test util-5.52 {Tcl_StringMatch} { - Wrapper_Tcl_StringMatch \[a\u0000 a\x80 + Wrapper_Tcl_StringMatch \[a\x00 a\x80 } 0 @@ -396,7 +396,7 @@ test util-6.1 {Tcl_PrintDouble - using tcl_precision} -constraints precision -se set old_precision $::tcl_precision set ::tcl_precision 12 } -body { - concat x[expr 1.4] + concat x[expr {1.4}] } -cleanup { set ::tcl_precision $old_precision } -result {x1.4} @@ -404,7 +404,7 @@ test util-6.2 {Tcl_PrintDouble - using tcl_precision} -constraints precision -se set old_precision $::tcl_precision set ::tcl_precision 12 } -body { - concat x[expr 1.39999999999] + concat x[expr {1.39999999999}] } -cleanup { set ::tcl_precision $old_precision } -result {x1.39999999999} @@ -412,7 +412,7 @@ test util-6.3 {Tcl_PrintDouble - using tcl_precision} -constraints precision -se set old_precision $::tcl_precision set ::tcl_precision 12 } -body { - concat x[expr 1.399999999999] + concat x[expr {1.399999999999}] } -cleanup { set ::tcl_precision $old_precision } -result {x1.4} @@ -420,15 +420,15 @@ test util-6.4 {Tcl_PrintDouble - using tcl_precision} -constraints precision -se set old_precision $::tcl_precision set ::tcl_precision 5 } -body { - concat x[expr 1.123412341234] + concat x[expr {1.123412341234}] } -cleanup { set tcl_precision $old_precision } -result {x1.1234} test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} { - concat x[expr 2.0] + concat x[expr {2.0}] } {x2.0} test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} { - concat x[expr 3.0e98] + concat x[expr {3.0e98}] } {x3e+98} test util-7.1 {TclPrecTraceProc - unset callbacks} -constraints precision -setup { @@ -476,38 +476,38 @@ test util-7.4 {TclPrecTraceProc - write traces, bogus values} -constraints preci } -result {1 {can't set "tcl_precision": improper value for precision} 12} # This test always succeeded in the C locale anyway... -test util-8.1 {TclNeedSpace - correct UTF8 handling} { +test util-8.1 {TclNeedSpace - correct utf-8 handling} { # Bug 411825 # Note that this test relies on the fact that # [interp target] calls on Tcl_AppendElement() # which calls on TclNeedSpace(). If [interp target] # is ever updated, this test will no longer test # TclNeedSpace. - interp create \u5420 - interp create [list \u5420 foo] - interp alias {} fooset [list \u5420 foo] set + interp create 吠 + interp create [list 吠 foo] + interp alias {} fooset [list 吠 foo] set set result [interp target {} fooset] - interp delete \u5420 + interp delete 吠 set result -} "\u5420 foo" -test util-8.2 {TclNeedSpace - correct UTF8 handling} testdstring { +} "吠 foo" +test util-8.2 {TclNeedSpace - correct utf-8 handling} testdstring { # Bug 411825 # This tests the same bug as the previous test, but # should be more future-proof, as the DString # operations will likely continue to call TclNeedSpace testdstring free - testdstring append \u5420 -1 + testdstring append 吠 -1 testdstring element foo llength [testdstring get] } 2 -test util-8.3 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.3 {TclNeedSpace - correct utf-8 handling} testdstring { # Bug 411825 - new variant reported by Dossy Shiobara testdstring free - testdstring append \u00A0 -1 + testdstring append \xA0 -1 testdstring element foo llength [testdstring get] } 2 -test util-8.4 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.4 {TclNeedSpace - correct utf-8 handling} testdstring { # Another bug uncovered while fixing 411825 testdstring free testdstring append {\ } -1 @@ -515,13 +515,13 @@ test util-8.4 {TclNeedSpace - correct UTF8 handling} testdstring { testdstring element foo llength [testdstring get] } 2 -test util-8.5 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.5 {TclNeedSpace - correct utf-8 handling} testdstring { testdstring free testdstring append {\\ } -1 testdstring element foo list [llength [testdstring get]] [string length [testdstring get]] } {2 6} -test util-8.6 {TclNeedSpace - correct UTF8 handling} testdstring { +test util-8.6 {TclNeedSpace - correct utf-8 handling} testdstring { testdstring free testdstring append {\\ } -1 testdstring append \{ -1 @@ -529,7 +529,7 @@ test util-8.6 {TclNeedSpace - correct UTF8 handling} testdstring { testdstring append \} -1 list [llength [testdstring get]] [string length [testdstring get]] } {2 8} -test util-8.7 {TclNeedSpace - watch out for escaped space} { +test util-8.7 {TclNeedSpace - watch out for escaped space} testdstring { testdstring free testdstring append {\ } -1 testdstring start @@ -538,7 +538,7 @@ test util-8.7 {TclNeedSpace - watch out for escaped space} { # Should make {\ {}} list [llength [testdstring get]] [string index [testdstring get] 3] } {2 \{} -test util-8.8 {TclNeedSpace - watch out for escaped space} { +test util-8.8 {TclNeedSpace - watch out for escaped space} testdstring { testdstring free testdstring append {\\ } -1 testdstring start @@ -547,7 +547,7 @@ test util-8.8 {TclNeedSpace - watch out for escaped space} { # Should make {\\ {}} list [llength [testdstring get]] [string index [testdstring get] 3] } {2 \{} -test util-8.9 {TclNeedSpace - watch out for escaped space} { +test util-8.9 {TclNeedSpace - watch out for escaped space} testdstring { testdstring free testdstring append {\\\ } -1 testdstring start @@ -556,7 +556,7 @@ test util-8.9 {TclNeedSpace - watch out for escaped space} { # Should make {\\\ {}} list [llength [testdstring get]] [string index [testdstring get] 5] } {2 \{} -test util-8.10 {TclNeedSpace - watch out for escaped space} { +test util-8.10 {TclNeedSpace - watch out for escaped space} testdstring { testdstring free testdstring append {\\\\\\\ } -1 testdstring start @@ -565,7 +565,7 @@ test util-8.10 {TclNeedSpace - watch out for escaped space} { # Should make {\\\\\\\ {}} list [llength [testdstring get]] [string index [testdstring get] 9] } {2 \{} -test util-8.11 {TclNeedSpace - watch out for escaped space} { +test util-8.11 {TclNeedSpace - watch out for escaped space} testdstring { testdstring free testdstring append {\\\\\\\\ } -1 testdstring start @@ -818,6 +818,9 @@ test util-9.57 {Tcl_GetIntForIndex} { test util-9.58 {Tcl_GetIntForIndex} -body { string index abcd end--0x8000000000000000 } -result {} +test util-9.59 {Tcl_GetIntForIndex} { + string index abcd 0-0x10000000000000000 +} {} test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x0000000000000000 @@ -1187,73 +1190,73 @@ test util-10.122 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { } {5.20831059055e+36} test util-11.1 {Tcl_PrintDouble - scaling} { - expr 1.1e-5 + expr {1.1e-5} } {1.1e-5} test util-11.2 {Tcl_PrintDouble - scaling} { - expr 1.1e-4 + expr {1.1e-4} } {0.00011} test util-11.3 {Tcl_PrintDouble - scaling} { - expr 1.1e-3 + expr {1.1e-3} } {0.0011} test util-11.4 {Tcl_PrintDouble - scaling} { - expr 1.1e-2 + expr {1.1e-2} } {0.011} test util-11.5 {Tcl_PrintDouble - scaling} { - expr 1.1e-1 + expr {1.1e-1} } {0.11} test util-11.6 {Tcl_PrintDouble - scaling} { - expr 1.1e0 + expr {1.1e0} } {1.1} test util-11.7 {Tcl_PrintDouble - scaling} { - expr 1.1e1 + expr {1.1e1} } {11.0} test util-11.8 {Tcl_PrintDouble - scaling} { - expr 1.1e2 + expr {1.1e2} } {110.0} test util-11.9 {Tcl_PrintDouble - scaling} { - expr 1.1e3 + expr {1.1e3} } {1100.0} test util-11.10 {Tcl_PrintDouble - scaling} { - expr 1.1e4 + expr {1.1e4} } {11000.0} test util-11.11 {Tcl_PrintDouble - scaling} { - expr 1.1e5 + expr {1.1e5} } {110000.0} test util-11.12 {Tcl_PrintDouble - scaling} { - expr 1.1e6 + expr {1.1e6} } {1100000.0} test util-11.13 {Tcl_PrintDouble - scaling} { - expr 1.1e7 + expr {1.1e7} } {11000000.0} test util-11.14 {Tcl_PrintDouble - scaling} { - expr 1.1e8 + expr {1.1e8} } {110000000.0} test util-11.15 {Tcl_PrintDouble - scaling} { - expr 1.1e9 + expr {1.1e9} } {1100000000.0} test util-11.16 {Tcl_PrintDouble - scaling} { - expr 1.1e10 + expr {1.1e10} } {11000000000.0} test util-11.17 {Tcl_PrintDouble - scaling} { - expr 1.1e11 + expr {1.1e11} } {110000000000.0} test util-11.18 {Tcl_PrintDouble - scaling} { - expr 1.1e12 + expr {1.1e12} } {1100000000000.0} test util-11.19 {Tcl_PrintDouble - scaling} { - expr 1.1e13 + expr {1.1e13} } {11000000000000.0} test util-11.20 {Tcl_PrintDouble - scaling} { - expr 1.1e14 + expr {1.1e14} } {110000000000000.0} test util-11.21 {Tcl_PrintDouble - scaling} { - expr 1.1e15 + expr {1.1e15} } {1100000000000000.0} test util-11.22 {Tcl_PrintDouble - scaling} { - expr 1.1e16 + expr {1.1e16} } {11000000000000000.0} test util-11.23 {Tcl_PrintDouble - scaling} { - expr 1.1e17 + expr {1.1e17} } {1.1e+17} test util-12.1 {TclDoubleDigits - Inf} {testdoubledigits ieeeFloatingPoint} { @@ -2230,1869 +2233,1869 @@ test util-15.8 {smallest normal} {*}{ 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 + "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 + "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} precision \ - "expr 1.1e$e" 1.1e[format %+03d $e] + "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} \ + {expr {1.1e-4}} \ 0.00011 test util-16.1.$::tcl_precision.-3 {shortening of numbers} \ - {expr 1.1e-3} \ + {expr {1.1e-3}} \ 0.0011 test util-16.1.$::tcl_precision.-2 {shortening of numbers} \ - {expr 1.1e-2} \ + {expr {1.1e-2}} \ 0.011 test util-16.1.$::tcl_precision.-1 {shortening of numbers} \ - {expr 1.1e-1} \ + {expr {1.1e-1}} \ 0.11 test util-16.1.$::tcl_precision.0 {shortening of numbers} \ - {expr 1.1} \ + {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" \ + "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 + "expr {1.1e$e}" 1.1e+$e } } set tcl_precision 17 test util-16.1.17.-300 {8.4 compatible formatting of doubles} precision \ - {expr 1e-300} \ + {expr {1e-300}} \ 1e-300 test util-16.1.17.-299 {8.4 compatible formatting of doubles} precision \ - {expr 1e-299} \ + {expr {1e-299}} \ 9.9999999999999999e-300 test util-16.1.17.-298 {8.4 compatible formatting of doubles} precision \ - {expr 1e-298} \ + {expr {1e-298}} \ 9.9999999999999991e-299 test util-16.1.17.-297 {8.4 compatible formatting of doubles} precision \ - {expr 1e-297} \ + {expr {1e-297}} \ 1e-297 test util-16.1.17.-296 {8.4 compatible formatting of doubles} precision \ - {expr 1e-296} \ + {expr {1e-296}} \ 1e-296 test util-16.1.17.-295 {8.4 compatible formatting of doubles} precision \ - {expr 1e-295} \ + {expr {1e-295}} \ 1.0000000000000001e-295 test util-16.1.17.-294 {8.4 compatible formatting of doubles} precision \ - {expr 1e-294} \ + {expr {1e-294}} \ 1e-294 test util-16.1.17.-293 {8.4 compatible formatting of doubles} precision \ - {expr 1e-293} \ + {expr {1e-293}} \ 1.0000000000000001e-293 test util-16.1.17.-292 {8.4 compatible formatting of doubles} precision \ - {expr 1e-292} \ + {expr {1e-292}} \ 1.0000000000000001e-292 test util-16.1.17.-291 {8.4 compatible formatting of doubles} precision \ - {expr 1e-291} \ + {expr {1e-291}} \ 9.9999999999999996e-292 test util-16.1.17.-290 {8.4 compatible formatting of doubles} precision \ - {expr 1e-290} \ + {expr {1e-290}} \ 1.0000000000000001e-290 test util-16.1.17.-289 {8.4 compatible formatting of doubles} precision \ - {expr 1e-289} \ + {expr {1e-289}} \ 1e-289 test util-16.1.17.-288 {8.4 compatible formatting of doubles} precision \ - {expr 1e-288} \ + {expr {1e-288}} \ 1.0000000000000001e-288 test util-16.1.17.-287 {8.4 compatible formatting of doubles} precision \ - {expr 1e-287} \ + {expr {1e-287}} \ 1e-287 test util-16.1.17.-286 {8.4 compatible formatting of doubles} precision \ - {expr 1e-286} \ + {expr {1e-286}} \ 1.0000000000000001e-286 test util-16.1.17.-285 {8.4 compatible formatting of doubles} precision \ - {expr 1e-285} \ + {expr {1e-285}} \ 1.0000000000000001e-285 test util-16.1.17.-284 {8.4 compatible formatting of doubles} precision \ - {expr 1e-284} \ + {expr {1e-284}} \ 1e-284 test util-16.1.17.-283 {8.4 compatible formatting of doubles} precision \ - {expr 1e-283} \ + {expr {1e-283}} \ 9.9999999999999995e-284 test util-16.1.17.-282 {8.4 compatible formatting of doubles} precision \ - {expr 1e-282} \ + {expr {1e-282}} \ 1e-282 test util-16.1.17.-281 {8.4 compatible formatting of doubles} precision \ - {expr 1e-281} \ + {expr {1e-281}} \ 1e-281 test util-16.1.17.-280 {8.4 compatible formatting of doubles} precision \ - {expr 1e-280} \ + {expr {1e-280}} \ 9.9999999999999996e-281 test util-16.1.17.-279 {8.4 compatible formatting of doubles} precision \ - {expr 1e-279} \ + {expr {1e-279}} \ 1.0000000000000001e-279 test util-16.1.17.-278 {8.4 compatible formatting of doubles} precision \ - {expr 1e-278} \ + {expr {1e-278}} \ 9.9999999999999994e-279 test util-16.1.17.-277 {8.4 compatible formatting of doubles} precision \ - {expr 1e-277} \ + {expr {1e-277}} \ 9.9999999999999997e-278 test util-16.1.17.-276 {8.4 compatible formatting of doubles} precision \ - {expr 1e-276} \ + {expr {1e-276}} \ 1.0000000000000001e-276 test util-16.1.17.-275 {8.4 compatible formatting of doubles} precision \ - {expr 1e-275} \ + {expr {1e-275}} \ 9.9999999999999993e-276 test util-16.1.17.-274 {8.4 compatible formatting of doubles} precision \ - {expr 1e-274} \ + {expr {1e-274}} \ 9.9999999999999997e-275 test util-16.1.17.-273 {8.4 compatible formatting of doubles} precision \ - {expr 1e-273} \ + {expr {1e-273}} \ 1.0000000000000001e-273 test util-16.1.17.-272 {8.4 compatible formatting of doubles} precision \ - {expr 1e-272} \ + {expr {1e-272}} \ 9.9999999999999993e-273 test util-16.1.17.-271 {8.4 compatible formatting of doubles} precision \ - {expr 1e-271} \ + {expr {1e-271}} \ 9.9999999999999996e-272 test util-16.1.17.-270 {8.4 compatible formatting of doubles} precision \ - {expr 1e-270} \ + {expr {1e-270}} \ 1e-270 test util-16.1.17.-269 {8.4 compatible formatting of doubles} precision \ - {expr 1e-269} \ + {expr {1e-269}} \ 9.9999999999999996e-270 test util-16.1.17.-268 {8.4 compatible formatting of doubles} precision \ - {expr 1e-268} \ + {expr {1e-268}} \ 9.9999999999999996e-269 test util-16.1.17.-267 {8.4 compatible formatting of doubles} precision \ - {expr 1e-267} \ + {expr {1e-267}} \ 9.9999999999999998e-268 test util-16.1.17.-266 {8.4 compatible formatting of doubles} precision \ - {expr 1e-266} \ + {expr {1e-266}} \ 9.9999999999999998e-267 test util-16.1.17.-265 {8.4 compatible formatting of doubles} precision \ - {expr 1e-265} \ + {expr {1e-265}} \ 9.9999999999999998e-266 test util-16.1.17.-264 {8.4 compatible formatting of doubles} precision \ - {expr 1e-264} \ + {expr {1e-264}} \ 1e-264 test util-16.1.17.-263 {8.4 compatible formatting of doubles} precision \ - {expr 1e-263} \ + {expr {1e-263}} \ 1e-263 test util-16.1.17.-262 {8.4 compatible formatting of doubles} precision \ - {expr 1e-262} \ + {expr {1e-262}} \ 1e-262 test util-16.1.17.-261 {8.4 compatible formatting of doubles} precision \ - {expr 1e-261} \ + {expr {1e-261}} \ 9.9999999999999998e-262 test util-16.1.17.-260 {8.4 compatible formatting of doubles} precision \ - {expr 1e-260} \ + {expr {1e-260}} \ 9.9999999999999996e-261 test util-16.1.17.-259 {8.4 compatible formatting of doubles} precision \ - {expr 1e-259} \ + {expr {1e-259}} \ 1.0000000000000001e-259 test util-16.1.17.-258 {8.4 compatible formatting of doubles} precision \ - {expr 1e-258} \ + {expr {1e-258}} \ 9.9999999999999995e-259 test util-16.1.17.-257 {8.4 compatible formatting of doubles} precision \ - {expr 1e-257} \ + {expr {1e-257}} \ 9.9999999999999998e-258 test util-16.1.17.-256 {8.4 compatible formatting of doubles} precision \ - {expr 1e-256} \ + {expr {1e-256}} \ 9.9999999999999998e-257 test util-16.1.17.-255 {8.4 compatible formatting of doubles} precision \ - {expr 1e-255} \ + {expr {1e-255}} \ 1e-255 test util-16.1.17.-254 {8.4 compatible formatting of doubles} precision \ - {expr 1e-254} \ + {expr {1e-254}} \ 9.9999999999999991e-255 test util-16.1.17.-253 {8.4 compatible formatting of doubles} precision \ - {expr 1e-253} \ + {expr {1e-253}} \ 1.0000000000000001e-253 test util-16.1.17.-252 {8.4 compatible formatting of doubles} precision \ - {expr 1e-252} \ + {expr {1e-252}} \ 9.9999999999999994e-253 test util-16.1.17.-251 {8.4 compatible formatting of doubles} precision \ - {expr 1e-251} \ + {expr {1e-251}} \ 1e-251 test util-16.1.17.-250 {8.4 compatible formatting of doubles} precision \ - {expr 1e-250} \ + {expr {1e-250}} \ 1.0000000000000001e-250 test util-16.1.17.-249 {8.4 compatible formatting of doubles} precision \ - {expr 1e-249} \ + {expr {1e-249}} \ 1.0000000000000001e-249 test util-16.1.17.-248 {8.4 compatible formatting of doubles} precision \ - {expr 1e-248} \ + {expr {1e-248}} \ 9.9999999999999998e-249 test util-16.1.17.-247 {8.4 compatible formatting of doubles} precision \ - {expr 1e-247} \ + {expr {1e-247}} \ 1e-247 test util-16.1.17.-246 {8.4 compatible formatting of doubles} precision \ - {expr 1e-246} \ + {expr {1e-246}} \ 9.9999999999999996e-247 test util-16.1.17.-245 {8.4 compatible formatting of doubles} precision \ - {expr 1e-245} \ + {expr {1e-245}} \ 9.9999999999999993e-246 test util-16.1.17.-244 {8.4 compatible formatting of doubles} precision \ - {expr 1e-244} \ + {expr {1e-244}} \ 9.9999999999999993e-245 test util-16.1.17.-243 {8.4 compatible formatting of doubles} precision \ - {expr 1e-243} \ + {expr {1e-243}} \ 1e-243 test util-16.1.17.-242 {8.4 compatible formatting of doubles} precision \ - {expr 1e-242} \ + {expr {1e-242}} \ 9.9999999999999997e-243 test util-16.1.17.-241 {8.4 compatible formatting of doubles} precision \ - {expr 1e-241} \ + {expr {1e-241}} \ 9.9999999999999997e-242 test util-16.1.17.-240 {8.4 compatible formatting of doubles} precision \ - {expr 1e-240} \ + {expr {1e-240}} \ 9.9999999999999997e-241 test util-16.1.17.-239 {8.4 compatible formatting of doubles} precision \ - {expr 1e-239} \ + {expr {1e-239}} \ 1.0000000000000001e-239 test util-16.1.17.-238 {8.4 compatible formatting of doubles} precision \ - {expr 1e-238} \ + {expr {1e-238}} \ 9.9999999999999999e-239 test util-16.1.17.-237 {8.4 compatible formatting of doubles} precision \ - {expr 1e-237} \ + {expr {1e-237}} \ 9.9999999999999999e-238 test util-16.1.17.-236 {8.4 compatible formatting of doubles} precision \ - {expr 1e-236} \ + {expr {1e-236}} \ 1e-236 test util-16.1.17.-235 {8.4 compatible formatting of doubles} precision \ - {expr 1e-235} \ + {expr {1e-235}} \ 9.9999999999999996e-236 test util-16.1.17.-234 {8.4 compatible formatting of doubles} precision \ - {expr 1e-234} \ + {expr {1e-234}} \ 9.9999999999999996e-235 test util-16.1.17.-233 {8.4 compatible formatting of doubles} precision \ - {expr 1e-233} \ + {expr {1e-233}} \ 9.9999999999999996e-234 test util-16.1.17.-232 {8.4 compatible formatting of doubles} precision \ - {expr 1e-232} \ + {expr {1e-232}} \ 1e-232 test util-16.1.17.-231 {8.4 compatible formatting of doubles} precision \ - {expr 1e-231} \ + {expr {1e-231}} \ 9.9999999999999999e-232 test util-16.1.17.-230 {8.4 compatible formatting of doubles} precision \ - {expr 1e-230} \ + {expr {1e-230}} \ 1e-230 test util-16.1.17.-229 {8.4 compatible formatting of doubles} precision \ - {expr 1e-229} \ + {expr {1e-229}} \ 1.0000000000000001e-229 test util-16.1.17.-228 {8.4 compatible formatting of doubles} precision \ - {expr 1e-228} \ + {expr {1e-228}} \ 1e-228 test util-16.1.17.-227 {8.4 compatible formatting of doubles} precision \ - {expr 1e-227} \ + {expr {1e-227}} \ 9.9999999999999994e-228 test util-16.1.17.-226 {8.4 compatible formatting of doubles} precision \ - {expr 1e-226} \ + {expr {1e-226}} \ 9.9999999999999992e-227 test util-16.1.17.-225 {8.4 compatible formatting of doubles} precision \ - {expr 1e-225} \ + {expr {1e-225}} \ 9.9999999999999996e-226 test util-16.1.17.-224 {8.4 compatible formatting of doubles} precision \ - {expr 1e-224} \ + {expr {1e-224}} \ 1e-224 test util-16.1.17.-223 {8.4 compatible formatting of doubles} precision \ - {expr 1e-223} \ + {expr {1e-223}} \ 9.9999999999999997e-224 test util-16.1.17.-222 {8.4 compatible formatting of doubles} precision \ - {expr 1e-222} \ + {expr {1e-222}} \ 1e-222 test util-16.1.17.-221 {8.4 compatible formatting of doubles} precision \ - {expr 1e-221} \ + {expr {1e-221}} \ 1e-221 test util-16.1.17.-220 {8.4 compatible formatting of doubles} precision \ - {expr 1e-220} \ + {expr {1e-220}} \ 9.9999999999999999e-221 test util-16.1.17.-219 {8.4 compatible formatting of doubles} precision \ - {expr 1e-219} \ + {expr {1e-219}} \ 1e-219 test util-16.1.17.-218 {8.4 compatible formatting of doubles} precision \ - {expr 1e-218} \ + {expr {1e-218}} \ 1e-218 test util-16.1.17.-217 {8.4 compatible formatting of doubles} precision \ - {expr 1e-217} \ + {expr {1e-217}} \ 1.0000000000000001e-217 test util-16.1.17.-216 {8.4 compatible formatting of doubles} precision \ - {expr 1e-216} \ + {expr {1e-216}} \ 1e-216 test util-16.1.17.-215 {8.4 compatible formatting of doubles} precision \ - {expr 1e-215} \ + {expr {1e-215}} \ 1e-215 test util-16.1.17.-214 {8.4 compatible formatting of doubles} precision \ - {expr 1e-214} \ + {expr {1e-214}} \ 9.9999999999999991e-215 test util-16.1.17.-213 {8.4 compatible formatting of doubles} precision \ - {expr 1e-213} \ + {expr {1e-213}} \ 9.9999999999999995e-214 test util-16.1.17.-212 {8.4 compatible formatting of doubles} precision \ - {expr 1e-212} \ + {expr {1e-212}} \ 9.9999999999999995e-213 test util-16.1.17.-211 {8.4 compatible formatting of doubles} precision \ - {expr 1e-211} \ + {expr {1e-211}} \ 1.0000000000000001e-211 test util-16.1.17.-210 {8.4 compatible formatting of doubles} precision \ - {expr 1e-210} \ + {expr {1e-210}} \ 1e-210 test util-16.1.17.-209 {8.4 compatible formatting of doubles} precision \ - {expr 1e-209} \ + {expr {1e-209}} \ 1e-209 test util-16.1.17.-208 {8.4 compatible formatting of doubles} precision \ - {expr 1e-208} \ + {expr {1e-208}} \ 1.0000000000000001e-208 test util-16.1.17.-207 {8.4 compatible formatting of doubles} precision \ - {expr 1e-207} \ + {expr {1e-207}} \ 9.9999999999999993e-208 test util-16.1.17.-206 {8.4 compatible formatting of doubles} precision \ - {expr 1e-206} \ + {expr {1e-206}} \ 1e-206 test util-16.1.17.-205 {8.4 compatible formatting of doubles} precision \ - {expr 1e-205} \ + {expr {1e-205}} \ 1e-205 test util-16.1.17.-204 {8.4 compatible formatting of doubles} precision \ - {expr 1e-204} \ + {expr {1e-204}} \ 1e-204 test util-16.1.17.-203 {8.4 compatible formatting of doubles} precision \ - {expr 1e-203} \ + {expr {1e-203}} \ 1e-203 test util-16.1.17.-202 {8.4 compatible formatting of doubles} precision \ - {expr 1e-202} \ + {expr {1e-202}} \ 1e-202 test util-16.1.17.-201 {8.4 compatible formatting of doubles} precision \ - {expr 1e-201} \ + {expr {1e-201}} \ 9.9999999999999995e-202 test util-16.1.17.-200 {8.4 compatible formatting of doubles} precision \ - {expr 1e-200} \ + {expr {1e-200}} \ 9.9999999999999998e-201 test util-16.1.17.-199 {8.4 compatible formatting of doubles} precision \ - {expr 1e-199} \ + {expr {1e-199}} \ 9.9999999999999998e-200 test util-16.1.17.-198 {8.4 compatible formatting of doubles} precision \ - {expr 1e-198} \ + {expr {1e-198}} \ 9.9999999999999991e-199 test util-16.1.17.-197 {8.4 compatible formatting of doubles} precision \ - {expr 1e-197} \ + {expr {1e-197}} \ 9.9999999999999999e-198 test util-16.1.17.-196 {8.4 compatible formatting of doubles} precision \ - {expr 1e-196} \ + {expr {1e-196}} \ 1e-196 test util-16.1.17.-195 {8.4 compatible formatting of doubles} precision \ - {expr 1e-195} \ + {expr {1e-195}} \ 1.0000000000000001e-195 test util-16.1.17.-194 {8.4 compatible formatting of doubles} precision \ - {expr 1e-194} \ + {expr {1e-194}} \ 1e-194 test util-16.1.17.-193 {8.4 compatible formatting of doubles} precision \ - {expr 1e-193} \ + {expr {1e-193}} \ 1e-193 test util-16.1.17.-192 {8.4 compatible formatting of doubles} precision \ - {expr 1e-192} \ + {expr {1e-192}} \ 1.0000000000000001e-192 test util-16.1.17.-191 {8.4 compatible formatting of doubles} precision \ - {expr 1e-191} \ + {expr {1e-191}} \ 1e-191 test util-16.1.17.-190 {8.4 compatible formatting of doubles} precision \ - {expr 1e-190} \ + {expr {1e-190}} \ 1e-190 test util-16.1.17.-189 {8.4 compatible formatting of doubles} precision \ - {expr 1e-189} \ + {expr {1e-189}} \ 1.0000000000000001e-189 test util-16.1.17.-188 {8.4 compatible formatting of doubles} precision \ - {expr 1e-188} \ + {expr {1e-188}} \ 9.9999999999999995e-189 test util-16.1.17.-187 {8.4 compatible formatting of doubles} precision \ - {expr 1e-187} \ + {expr {1e-187}} \ 1e-187 test util-16.1.17.-186 {8.4 compatible formatting of doubles} precision \ - {expr 1e-186} \ + {expr {1e-186}} \ 9.9999999999999991e-187 test util-16.1.17.-185 {8.4 compatible formatting of doubles} precision \ - {expr 1e-185} \ + {expr {1e-185}} \ 9.9999999999999999e-186 test util-16.1.17.-184 {8.4 compatible formatting of doubles} precision \ - {expr 1e-184} \ + {expr {1e-184}} \ 1.0000000000000001e-184 test util-16.1.17.-183 {8.4 compatible formatting of doubles} precision \ - {expr 1e-183} \ + {expr {1e-183}} \ 1e-183 test util-16.1.17.-182 {8.4 compatible formatting of doubles} precision \ - {expr 1e-182} \ + {expr {1e-182}} \ 1e-182 test util-16.1.17.-181 {8.4 compatible formatting of doubles} precision \ - {expr 1e-181} \ + {expr {1e-181}} \ 1e-181 test util-16.1.17.-180 {8.4 compatible formatting of doubles} precision \ - {expr 1e-180} \ + {expr {1e-180}} \ 1e-180 test util-16.1.17.-179 {8.4 compatible formatting of doubles} precision \ - {expr 1e-179} \ + {expr {1e-179}} \ 1e-179 test util-16.1.17.-178 {8.4 compatible formatting of doubles} precision \ - {expr 1e-178} \ + {expr {1e-178}} \ 9.9999999999999995e-179 test util-16.1.17.-177 {8.4 compatible formatting of doubles} precision \ - {expr 1e-177} \ + {expr {1e-177}} \ 9.9999999999999995e-178 test util-16.1.17.-176 {8.4 compatible formatting of doubles} precision \ - {expr 1e-176} \ + {expr {1e-176}} \ 1e-176 test util-16.1.17.-175 {8.4 compatible formatting of doubles} precision \ - {expr 1e-175} \ + {expr {1e-175}} \ 1e-175 test util-16.1.17.-174 {8.4 compatible formatting of doubles} precision \ - {expr 1e-174} \ + {expr {1e-174}} \ 1e-174 test util-16.1.17.-173 {8.4 compatible formatting of doubles} precision \ - {expr 1e-173} \ + {expr {1e-173}} \ 1e-173 test util-16.1.17.-172 {8.4 compatible formatting of doubles} precision \ - {expr 1e-172} \ + {expr {1e-172}} \ 1e-172 test util-16.1.17.-171 {8.4 compatible formatting of doubles} precision \ - {expr 1e-171} \ + {expr {1e-171}} \ 9.9999999999999998e-172 test util-16.1.17.-170 {8.4 compatible formatting of doubles} precision \ - {expr 1e-170} \ + {expr {1e-170}} \ 9.9999999999999998e-171 test util-16.1.17.-169 {8.4 compatible formatting of doubles} precision \ - {expr 1e-169} \ + {expr {1e-169}} \ 1e-169 test util-16.1.17.-168 {8.4 compatible formatting of doubles} precision \ - {expr 1e-168} \ + {expr {1e-168}} \ 1e-168 test util-16.1.17.-167 {8.4 compatible formatting of doubles} precision \ - {expr 1e-167} \ + {expr {1e-167}} \ 1e-167 test util-16.1.17.-166 {8.4 compatible formatting of doubles} precision \ - {expr 1e-166} \ + {expr {1e-166}} \ 1e-166 test util-16.1.17.-165 {8.4 compatible formatting of doubles} precision \ - {expr 1e-165} \ + {expr {1e-165}} \ 1e-165 test util-16.1.17.-164 {8.4 compatible formatting of doubles} precision \ - {expr 1e-164} \ + {expr {1e-164}} \ 9.9999999999999996e-165 test util-16.1.17.-163 {8.4 compatible formatting of doubles} precision \ - {expr 1e-163} \ + {expr {1e-163}} \ 9.9999999999999992e-164 test util-16.1.17.-162 {8.4 compatible formatting of doubles} precision \ - {expr 1e-162} \ + {expr {1e-162}} \ 9.9999999999999995e-163 test util-16.1.17.-161 {8.4 compatible formatting of doubles} precision \ - {expr 1e-161} \ + {expr {1e-161}} \ 1e-161 test util-16.1.17.-160 {8.4 compatible formatting of doubles} precision \ - {expr 1e-160} \ + {expr {1e-160}} \ 9.9999999999999999e-161 test util-16.1.17.-159 {8.4 compatible formatting of doubles} precision \ - {expr 1e-159} \ + {expr {1e-159}} \ 9.9999999999999999e-160 test util-16.1.17.-158 {8.4 compatible formatting of doubles} precision \ - {expr 1e-158} \ + {expr {1e-158}} \ 1.0000000000000001e-158 test util-16.1.17.-157 {8.4 compatible formatting of doubles} precision \ - {expr 1e-157} \ + {expr {1e-157}} \ 9.9999999999999994e-158 test util-16.1.17.-156 {8.4 compatible formatting of doubles} precision \ - {expr 1e-156} \ + {expr {1e-156}} \ 1e-156 test util-16.1.17.-155 {8.4 compatible formatting of doubles} precision \ - {expr 1e-155} \ + {expr {1e-155}} \ 1e-155 test util-16.1.17.-154 {8.4 compatible formatting of doubles} precision \ - {expr 1e-154} \ + {expr {1e-154}} \ 9.9999999999999997e-155 test util-16.1.17.-153 {8.4 compatible formatting of doubles} precision \ - {expr 1e-153} \ + {expr {1e-153}} \ 1e-153 test util-16.1.17.-152 {8.4 compatible formatting of doubles} precision \ - {expr 1e-152} \ + {expr {1e-152}} \ 1.0000000000000001e-152 test util-16.1.17.-151 {8.4 compatible formatting of doubles} precision \ - {expr 1e-151} \ + {expr {1e-151}} \ 9.9999999999999994e-152 test util-16.1.17.-150 {8.4 compatible formatting of doubles} precision \ - {expr 1e-150} \ + {expr {1e-150}} \ 1e-150 test util-16.1.17.-149 {8.4 compatible formatting of doubles} precision \ - {expr 1e-149} \ + {expr {1e-149}} \ 9.9999999999999998e-150 test util-16.1.17.-148 {8.4 compatible formatting of doubles} precision \ - {expr 1e-148} \ + {expr {1e-148}} \ 9.9999999999999994e-149 test util-16.1.17.-147 {8.4 compatible formatting of doubles} precision \ - {expr 1e-147} \ + {expr {1e-147}} \ 9.9999999999999997e-148 test util-16.1.17.-146 {8.4 compatible formatting of doubles} precision \ - {expr 1e-146} \ + {expr {1e-146}} \ 1e-146 test util-16.1.17.-145 {8.4 compatible formatting of doubles} precision \ - {expr 1e-145} \ + {expr {1e-145}} \ 9.9999999999999991e-146 test util-16.1.17.-144 {8.4 compatible formatting of doubles} precision \ - {expr 1e-144} \ + {expr {1e-144}} \ 9.9999999999999995e-145 test util-16.1.17.-143 {8.4 compatible formatting of doubles} precision \ - {expr 1e-143} \ + {expr {1e-143}} \ 9.9999999999999995e-144 test util-16.1.17.-142 {8.4 compatible formatting of doubles} precision \ - {expr 1e-142} \ + {expr {1e-142}} \ 1e-142 test util-16.1.17.-141 {8.4 compatible formatting of doubles} precision \ - {expr 1e-141} \ + {expr {1e-141}} \ 1e-141 test util-16.1.17.-140 {8.4 compatible formatting of doubles} precision \ - {expr 1e-140} \ + {expr {1e-140}} \ 9.9999999999999998e-141 test util-16.1.17.-139 {8.4 compatible formatting of doubles} precision \ - {expr 1e-139} \ + {expr {1e-139}} \ 1e-139 test util-16.1.17.-138 {8.4 compatible formatting of doubles} precision \ - {expr 1e-138} \ + {expr {1e-138}} \ 1.0000000000000001e-138 test util-16.1.17.-137 {8.4 compatible formatting of doubles} precision \ - {expr 1e-137} \ + {expr {1e-137}} \ 9.9999999999999998e-138 test util-16.1.17.-136 {8.4 compatible formatting of doubles} precision \ - {expr 1e-136} \ + {expr {1e-136}} \ 1e-136 test util-16.1.17.-135 {8.4 compatible formatting of doubles} precision \ - {expr 1e-135} \ + {expr {1e-135}} \ 1e-135 test util-16.1.17.-134 {8.4 compatible formatting of doubles} precision \ - {expr 1e-134} \ + {expr {1e-134}} \ 1e-134 test util-16.1.17.-133 {8.4 compatible formatting of doubles} precision \ - {expr 1e-133} \ + {expr {1e-133}} \ 1.0000000000000001e-133 test util-16.1.17.-132 {8.4 compatible formatting of doubles} precision \ - {expr 1e-132} \ + {expr {1e-132}} \ 9.9999999999999999e-133 test util-16.1.17.-131 {8.4 compatible formatting of doubles} precision \ - {expr 1e-131} \ + {expr {1e-131}} \ 9.9999999999999999e-132 test util-16.1.17.-130 {8.4 compatible formatting of doubles} precision \ - {expr 1e-130} \ + {expr {1e-130}} \ 1.0000000000000001e-130 test util-16.1.17.-129 {8.4 compatible formatting of doubles} precision \ - {expr 1e-129} \ + {expr {1e-129}} \ 9.9999999999999993e-130 test util-16.1.17.-128 {8.4 compatible formatting of doubles} precision \ - {expr 1e-128} \ + {expr {1e-128}} \ 1.0000000000000001e-128 test util-16.1.17.-127 {8.4 compatible formatting of doubles} precision \ - {expr 1e-127} \ + {expr {1e-127}} \ 1e-127 test util-16.1.17.-126 {8.4 compatible formatting of doubles} precision \ - {expr 1e-126} \ + {expr {1e-126}} \ 9.9999999999999995e-127 test util-16.1.17.-125 {8.4 compatible formatting of doubles} precision \ - {expr 1e-125} \ + {expr {1e-125}} \ 1e-125 test util-16.1.17.-124 {8.4 compatible formatting of doubles} precision \ - {expr 1e-124} \ + {expr {1e-124}} \ 9.9999999999999993e-125 test util-16.1.17.-123 {8.4 compatible formatting of doubles} precision \ - {expr 1e-123} \ + {expr {1e-123}} \ 1.0000000000000001e-123 test util-16.1.17.-122 {8.4 compatible formatting of doubles} precision \ - {expr 1e-122} \ + {expr {1e-122}} \ 1.0000000000000001e-122 test util-16.1.17.-121 {8.4 compatible formatting of doubles} precision \ - {expr 1e-121} \ + {expr {1e-121}} \ 9.9999999999999998e-122 test util-16.1.17.-120 {8.4 compatible formatting of doubles} precision \ - {expr 1e-120} \ + {expr {1e-120}} \ 9.9999999999999998e-121 test util-16.1.17.-119 {8.4 compatible formatting of doubles} precision \ - {expr 1e-119} \ + {expr {1e-119}} \ 1e-119 test util-16.1.17.-118 {8.4 compatible formatting of doubles} precision \ - {expr 1e-118} \ + {expr {1e-118}} \ 9.9999999999999999e-119 test util-16.1.17.-117 {8.4 compatible formatting of doubles} precision \ - {expr 1e-117} \ + {expr {1e-117}} \ 1e-117 test util-16.1.17.-116 {8.4 compatible formatting of doubles} precision \ - {expr 1e-116} \ + {expr {1e-116}} \ 9.9999999999999999e-117 test util-16.1.17.-115 {8.4 compatible formatting of doubles} precision \ - {expr 1e-115} \ + {expr {1e-115}} \ 1.0000000000000001e-115 test util-16.1.17.-114 {8.4 compatible formatting of doubles} precision \ - {expr 1e-114} \ + {expr {1e-114}} \ 1.0000000000000001e-114 test util-16.1.17.-113 {8.4 compatible formatting of doubles} precision \ - {expr 1e-113} \ + {expr {1e-113}} \ 9.9999999999999998e-114 test util-16.1.17.-112 {8.4 compatible formatting of doubles} precision \ - {expr 1e-112} \ + {expr {1e-112}} \ 9.9999999999999995e-113 test util-16.1.17.-111 {8.4 compatible formatting of doubles} precision \ - {expr 1e-111} \ + {expr {1e-111}} \ 1.0000000000000001e-111 test util-16.1.17.-110 {8.4 compatible formatting of doubles} precision \ - {expr 1e-110} \ + {expr {1e-110}} \ 1.0000000000000001e-110 test util-16.1.17.-109 {8.4 compatible formatting of doubles} precision \ - {expr 1e-109} \ + {expr {1e-109}} \ 9.9999999999999999e-110 test util-16.1.17.-108 {8.4 compatible formatting of doubles} precision \ - {expr 1e-108} \ + {expr {1e-108}} \ 1e-108 test util-16.1.17.-107 {8.4 compatible formatting of doubles} precision \ - {expr 1e-107} \ + {expr {1e-107}} \ 1e-107 test util-16.1.17.-106 {8.4 compatible formatting of doubles} precision \ - {expr 1e-106} \ + {expr {1e-106}} \ 9.9999999999999994e-107 test util-16.1.17.-105 {8.4 compatible formatting of doubles} precision \ - {expr 1e-105} \ + {expr {1e-105}} \ 9.9999999999999997e-106 test util-16.1.17.-104 {8.4 compatible formatting of doubles} precision \ - {expr 1e-104} \ + {expr {1e-104}} \ 9.9999999999999993e-105 test util-16.1.17.-103 {8.4 compatible formatting of doubles} precision \ - {expr 1e-103} \ + {expr {1e-103}} \ 9.9999999999999996e-104 test util-16.1.17.-102 {8.4 compatible formatting of doubles} precision \ - {expr 1e-102} \ + {expr {1e-102}} \ 9.9999999999999993e-103 test util-16.1.17.-101 {8.4 compatible formatting of doubles} precision \ - {expr 1e-101} \ + {expr {1e-101}} \ 1.0000000000000001e-101 test util-16.1.17.-100 {8.4 compatible formatting of doubles} precision \ - {expr 1e-100} \ + {expr {1e-100}} \ 1e-100 test util-16.1.17.-99 {8.4 compatible formatting of doubles} precision \ - {expr 1e-99} \ + {expr {1e-99}} \ 1e-99 test util-16.1.17.-98 {8.4 compatible formatting of doubles} precision \ - {expr 1e-98} \ + {expr {1e-98}} \ 9.9999999999999994e-99 test util-16.1.17.-97 {8.4 compatible formatting of doubles} precision \ - {expr 1e-97} \ + {expr {1e-97}} \ 1e-97 test util-16.1.17.-96 {8.4 compatible formatting of doubles} precision \ - {expr 1e-96} \ + {expr {1e-96}} \ 9.9999999999999991e-97 test util-16.1.17.-95 {8.4 compatible formatting of doubles} precision \ - {expr 1e-95} \ + {expr {1e-95}} \ 9.9999999999999999e-96 test util-16.1.17.-94 {8.4 compatible formatting of doubles} precision \ - {expr 1e-94} \ + {expr {1e-94}} \ 9.9999999999999996e-95 test util-16.1.17.-93 {8.4 compatible formatting of doubles} precision \ - {expr 1e-93} \ + {expr {1e-93}} \ 9.999999999999999e-94 test util-16.1.17.-92 {8.4 compatible formatting of doubles} precision \ - {expr 1e-92} \ + {expr {1e-92}} \ 9.9999999999999999e-93 test util-16.1.17.-91 {8.4 compatible formatting of doubles} precision \ - {expr 1e-91} \ + {expr {1e-91}} \ 1e-91 test util-16.1.17.-90 {8.4 compatible formatting of doubles} precision \ - {expr 1e-90} \ + {expr {1e-90}} \ 9.9999999999999999e-91 test util-16.1.17.-89 {8.4 compatible formatting of doubles} precision \ - {expr 1e-89} \ + {expr {1e-89}} \ 1e-89 test util-16.1.17.-88 {8.4 compatible formatting of doubles} precision \ - {expr 1e-88} \ + {expr {1e-88}} \ 9.9999999999999993e-89 test util-16.1.17.-87 {8.4 compatible formatting of doubles} precision \ - {expr 1e-87} \ + {expr {1e-87}} \ 1e-87 test util-16.1.17.-86 {8.4 compatible formatting of doubles} precision \ - {expr 1e-86} \ + {expr {1e-86}} \ 1.0000000000000001e-86 test util-16.1.17.-85 {8.4 compatible formatting of doubles} precision \ - {expr 1e-85} \ + {expr {1e-85}} \ 9.9999999999999998e-86 test util-16.1.17.-84 {8.4 compatible formatting of doubles} precision \ - {expr 1e-84} \ + {expr {1e-84}} \ 1e-84 test util-16.1.17.-83 {8.4 compatible formatting of doubles} precision \ - {expr 1e-83} \ + {expr {1e-83}} \ 1e-83 test util-16.1.17.-82 {8.4 compatible formatting of doubles} precision \ - {expr 1e-82} \ + {expr {1e-82}} \ 9.9999999999999996e-83 test util-16.1.17.-81 {8.4 compatible formatting of doubles} precision \ - {expr 1e-81} \ + {expr {1e-81}} \ 9.9999999999999996e-82 test util-16.1.17.-80 {8.4 compatible formatting of doubles} precision \ - {expr 1e-80} \ + {expr {1e-80}} \ 9.9999999999999996e-81 test util-16.1.17.-79 {8.4 compatible formatting of doubles} precision \ - {expr 1e-79} \ + {expr {1e-79}} \ 1e-79 test util-16.1.17.-78 {8.4 compatible formatting of doubles} precision \ - {expr 1e-78} \ + {expr {1e-78}} \ 1e-78 test util-16.1.17.-77 {8.4 compatible formatting of doubles} precision \ - {expr 1e-77} \ + {expr {1e-77}} \ 9.9999999999999993e-78 test util-16.1.17.-76 {8.4 compatible formatting of doubles} precision \ - {expr 1e-76} \ + {expr {1e-76}} \ 9.9999999999999993e-77 test util-16.1.17.-75 {8.4 compatible formatting of doubles} precision \ - {expr 1e-75} \ + {expr {1e-75}} \ 9.9999999999999996e-76 test util-16.1.17.-74 {8.4 compatible formatting of doubles} precision \ - {expr 1e-74} \ + {expr {1e-74}} \ 9.9999999999999996e-75 test util-16.1.17.-73 {8.4 compatible formatting of doubles} precision \ - {expr 1e-73} \ + {expr {1e-73}} \ 1e-73 test util-16.1.17.-72 {8.4 compatible formatting of doubles} precision \ - {expr 1e-72} \ + {expr {1e-72}} \ 9.9999999999999997e-73 test util-16.1.17.-71 {8.4 compatible formatting of doubles} precision \ - {expr 1e-71} \ + {expr {1e-71}} \ 9.9999999999999992e-72 test util-16.1.17.-70 {8.4 compatible formatting of doubles} precision \ - {expr 1e-70} \ + {expr {1e-70}} \ 1e-70 test util-16.1.17.-69 {8.4 compatible formatting of doubles} precision \ - {expr 1e-69} \ + {expr {1e-69}} \ 9.9999999999999996e-70 test util-16.1.17.-68 {8.4 compatible formatting of doubles} precision \ - {expr 1e-68} \ + {expr {1e-68}} \ 1.0000000000000001e-68 test util-16.1.17.-67 {8.4 compatible formatting of doubles} precision \ - {expr 1e-67} \ + {expr {1e-67}} \ 9.9999999999999994e-68 test util-16.1.17.-66 {8.4 compatible formatting of doubles} precision \ - {expr 1e-66} \ + {expr {1e-66}} \ 9.9999999999999998e-67 test util-16.1.17.-65 {8.4 compatible formatting of doubles} precision \ - {expr 1e-65} \ + {expr {1e-65}} \ 9.9999999999999992e-66 test util-16.1.17.-64 {8.4 compatible formatting of doubles} precision \ - {expr 1e-64} \ + {expr {1e-64}} \ 9.9999999999999997e-65 test util-16.1.17.-63 {8.4 compatible formatting of doubles} precision \ - {expr 1e-63} \ + {expr {1e-63}} \ 1.0000000000000001e-63 test util-16.1.17.-62 {8.4 compatible formatting of doubles} precision \ - {expr 1e-62} \ + {expr {1e-62}} \ 1e-62 test util-16.1.17.-61 {8.4 compatible formatting of doubles} precision \ - {expr 1e-61} \ + {expr {1e-61}} \ 1e-61 test util-16.1.17.-60 {8.4 compatible formatting of doubles} precision \ - {expr 1e-60} \ + {expr {1e-60}} \ 9.9999999999999997e-61 test util-16.1.17.-59 {8.4 compatible formatting of doubles} precision \ - {expr 1e-59} \ + {expr {1e-59}} \ 1e-59 test util-16.1.17.-58 {8.4 compatible formatting of doubles} precision \ - {expr 1e-58} \ + {expr {1e-58}} \ 1e-58 test util-16.1.17.-57 {8.4 compatible formatting of doubles} precision \ - {expr 1e-57} \ + {expr {1e-57}} \ 9.9999999999999995e-58 test util-16.1.17.-56 {8.4 compatible formatting of doubles} precision \ - {expr 1e-56} \ + {expr {1e-56}} \ 1e-56 test util-16.1.17.-55 {8.4 compatible formatting of doubles} precision \ - {expr 1e-55} \ + {expr {1e-55}} \ 9.9999999999999999e-56 test util-16.1.17.-54 {8.4 compatible formatting of doubles} precision \ - {expr 1e-54} \ + {expr {1e-54}} \ 1e-54 test util-16.1.17.-53 {8.4 compatible formatting of doubles} precision \ - {expr 1e-53} \ + {expr {1e-53}} \ 1e-53 test util-16.1.17.-52 {8.4 compatible formatting of doubles} precision \ - {expr 1e-52} \ + {expr {1e-52}} \ 1e-52 test util-16.1.17.-51 {8.4 compatible formatting of doubles} precision \ - {expr 1e-51} \ + {expr {1e-51}} \ 1e-51 test util-16.1.17.-50 {8.4 compatible formatting of doubles} precision \ - {expr 1e-50} \ + {expr {1e-50}} \ 1e-50 test util-16.1.17.-49 {8.4 compatible formatting of doubles} precision \ - {expr 1e-49} \ + {expr {1e-49}} \ 9.9999999999999994e-50 test util-16.1.17.-48 {8.4 compatible formatting of doubles} precision \ - {expr 1e-48} \ + {expr {1e-48}} \ 9.9999999999999997e-49 test util-16.1.17.-47 {8.4 compatible formatting of doubles} precision \ - {expr 1e-47} \ + {expr {1e-47}} \ 9.9999999999999997e-48 test util-16.1.17.-46 {8.4 compatible formatting of doubles} precision \ - {expr 1e-46} \ + {expr {1e-46}} \ 1e-46 test util-16.1.17.-45 {8.4 compatible formatting of doubles} precision \ - {expr 1e-45} \ + {expr {1e-45}} \ 9.9999999999999998e-46 test util-16.1.17.-44 {8.4 compatible formatting of doubles} precision \ - {expr 1e-44} \ + {expr {1e-44}} \ 9.9999999999999995e-45 test util-16.1.17.-43 {8.4 compatible formatting of doubles} precision \ - {expr 1e-43} \ + {expr {1e-43}} \ 1.0000000000000001e-43 test util-16.1.17.-42 {8.4 compatible formatting of doubles} precision \ - {expr 1e-42} \ + {expr {1e-42}} \ 1e-42 test util-16.1.17.-41 {8.4 compatible formatting of doubles} precision \ - {expr 1e-41} \ + {expr {1e-41}} \ 1e-41 test util-16.1.17.-40 {8.4 compatible formatting of doubles} precision \ - {expr 1e-40} \ + {expr {1e-40}} \ 9.9999999999999993e-41 test util-16.1.17.-39 {8.4 compatible formatting of doubles} precision \ - {expr 1e-39} \ + {expr {1e-39}} \ 9.9999999999999993e-40 test util-16.1.17.-38 {8.4 compatible formatting of doubles} precision \ - {expr 1e-38} \ + {expr {1e-38}} \ 9.9999999999999996e-39 test util-16.1.17.-37 {8.4 compatible formatting of doubles} precision \ - {expr 1e-37} \ + {expr {1e-37}} \ 1.0000000000000001e-37 test util-16.1.17.-36 {8.4 compatible formatting of doubles} precision \ - {expr 1e-36} \ + {expr {1e-36}} \ 9.9999999999999994e-37 test util-16.1.17.-35 {8.4 compatible formatting of doubles} precision \ - {expr 1e-35} \ + {expr {1e-35}} \ 1e-35 test util-16.1.17.-34 {8.4 compatible formatting of doubles} precision \ - {expr 1e-34} \ + {expr {1e-34}} \ 9.9999999999999993e-35 test util-16.1.17.-33 {8.4 compatible formatting of doubles} precision \ - {expr 1e-33} \ + {expr {1e-33}} \ 1.0000000000000001e-33 test util-16.1.17.-32 {8.4 compatible formatting of doubles} precision \ - {expr 1e-32} \ + {expr {1e-32}} \ 1.0000000000000001e-32 test util-16.1.17.-31 {8.4 compatible formatting of doubles} precision \ - {expr 1e-31} \ + {expr {1e-31}} \ 1.0000000000000001e-31 test util-16.1.17.-30 {8.4 compatible formatting of doubles} precision \ - {expr 1e-30} \ + {expr {1e-30}} \ 1.0000000000000001e-30 test util-16.1.17.-29 {8.4 compatible formatting of doubles} precision \ - {expr 1e-29} \ + {expr {1e-29}} \ 9.9999999999999994e-30 test util-16.1.17.-28 {8.4 compatible formatting of doubles} precision \ - {expr 1e-28} \ + {expr {1e-28}} \ 9.9999999999999997e-29 test util-16.1.17.-27 {8.4 compatible formatting of doubles} precision \ - {expr 1e-27} \ + {expr {1e-27}} \ 1e-27 test util-16.1.17.-26 {8.4 compatible formatting of doubles} precision \ - {expr 1e-26} \ + {expr {1e-26}} \ 1e-26 test util-16.1.17.-25 {8.4 compatible formatting of doubles} precision \ - {expr 1e-25} \ + {expr {1e-25}} \ 1e-25 test util-16.1.17.-24 {8.4 compatible formatting of doubles} precision \ - {expr 1e-24} \ + {expr {1e-24}} \ 9.9999999999999992e-25 test util-16.1.17.-23 {8.4 compatible formatting of doubles} precision \ - {expr 1e-23} \ + {expr {1e-23}} \ 9.9999999999999996e-24 test util-16.1.17.-22 {8.4 compatible formatting of doubles} precision \ - {expr 1e-22} \ + {expr {1e-22}} \ 1e-22 test util-16.1.17.-21 {8.4 compatible formatting of doubles} precision \ - {expr 1e-21} \ + {expr {1e-21}} \ 9.9999999999999991e-22 test util-16.1.17.-20 {8.4 compatible formatting of doubles} precision \ - {expr 1e-20} \ + {expr {1e-20}} \ 9.9999999999999995e-21 test util-16.1.17.-19 {8.4 compatible formatting of doubles} precision \ - {expr 1e-19} \ + {expr {1e-19}} \ 9.9999999999999998e-20 test util-16.1.17.-18 {8.4 compatible formatting of doubles} precision \ - {expr 1e-18} \ + {expr {1e-18}} \ 1.0000000000000001e-18 test util-16.1.17.-17 {8.4 compatible formatting of doubles} precision \ - {expr 1e-17} \ + {expr {1e-17}} \ 1.0000000000000001e-17 test util-16.1.17.-16 {8.4 compatible formatting of doubles} precision \ - {expr 1e-16} \ + {expr {1e-16}} \ 9.9999999999999998e-17 test util-16.1.17.-15 {8.4 compatible formatting of doubles} precision \ - {expr 1e-15} \ + {expr {1e-15}} \ 1.0000000000000001e-15 test util-16.1.17.-14 {8.4 compatible formatting of doubles} precision \ - {expr 1e-14} \ + {expr {1e-14}} \ 1e-14 test util-16.1.17.-13 {8.4 compatible formatting of doubles} precision \ - {expr 1e-13} \ + {expr {1e-13}} \ 1e-13 test util-16.1.17.-12 {8.4 compatible formatting of doubles} precision \ - {expr 1e-12} \ + {expr {1e-12}} \ 9.9999999999999998e-13 test util-16.1.17.-11 {8.4 compatible formatting of doubles} precision \ - {expr 1e-11} \ + {expr {1e-11}} \ 9.9999999999999994e-12 test util-16.1.17.-10 {8.4 compatible formatting of doubles} precision \ - {expr 1e-10} \ + {expr {1e-10}} \ 1e-10 test util-16.1.17.-9 {8.4 compatible formatting of doubles} precision \ - {expr 1e-9} \ + {expr {1e-9}} \ 1.0000000000000001e-09 test util-16.1.17.-8 {8.4 compatible formatting of doubles} precision \ - {expr 1e-8} \ + {expr {1e-8}} \ 1e-08 test util-16.1.17.-7 {8.4 compatible formatting of doubles} precision \ - {expr 1e-7} \ + {expr {1e-7}} \ 9.9999999999999995e-08 test util-16.1.17.-6 {8.4 compatible formatting of doubles} precision \ - {expr 1e-6} \ + {expr {1e-6}} \ 9.9999999999999995e-07 test util-16.1.17.-5 {8.4 compatible formatting of doubles} precision \ - {expr 1e-5} \ + {expr {1e-5}} \ 1.0000000000000001e-05 test util-16.1.17.-4 {8.4 compatible formatting of doubles} precision \ - {expr 1e-4} \ + {expr {1e-4}} \ 0.0001 test util-16.1.17.-3 {8.4 compatible formatting of doubles} precision \ - {expr 1e-3} \ + {expr {1e-3}} \ 0.001 test util-16.1.17.-2 {8.4 compatible formatting of doubles} precision \ - {expr 1e-2} \ + {expr {1e-2}} \ 0.01 test util-16.1.17.-1 {8.4 compatible formatting of doubles} precision \ - {expr 1e-1} \ + {expr {1e-1}} \ 0.10000000000000001 test util-16.1.17.0 {8.4 compatible formatting of doubles} precision \ - {expr 1e0} \ + {expr {1e0}} \ 1.0 test util-16.1.17.1 {8.4 compatible formatting of doubles} precision \ - {expr 1e1} \ + {expr {1e1}} \ 10.0 test util-16.1.17.2 {8.4 compatible formatting of doubles} precision \ - {expr 1e2} \ + {expr {1e2}} \ 100.0 test util-16.1.17.3 {8.4 compatible formatting of doubles} precision \ - {expr 1e3} \ + {expr {1e3}} \ 1000.0 test util-16.1.17.4 {8.4 compatible formatting of doubles} precision \ - {expr 1e4} \ + {expr {1e4}} \ 10000.0 test util-16.1.17.5 {8.4 compatible formatting of doubles} precision \ - {expr 1e5} \ + {expr {1e5}} \ 100000.0 test util-16.1.17.6 {8.4 compatible formatting of doubles} precision \ - {expr 1e6} \ + {expr {1e6}} \ 1000000.0 test util-16.1.17.7 {8.4 compatible formatting of doubles} precision \ - {expr 1e7} \ + {expr {1e7}} \ 10000000.0 test util-16.1.17.8 {8.4 compatible formatting of doubles} precision \ - {expr 1e8} \ + {expr {1e8}} \ 100000000.0 test util-16.1.17.9 {8.4 compatible formatting of doubles} precision \ - {expr 1e9} \ + {expr {1e9}} \ 1000000000.0 test util-16.1.17.10 {8.4 compatible formatting of doubles} precision \ - {expr 1e10} \ + {expr {1e10}} \ 10000000000.0 test util-16.1.17.11 {8.4 compatible formatting of doubles} precision \ - {expr 1e11} \ + {expr {1e11}} \ 100000000000.0 test util-16.1.17.12 {8.4 compatible formatting of doubles} precision \ - {expr 1e12} \ + {expr {1e12}} \ 1000000000000.0 test util-16.1.17.13 {8.4 compatible formatting of doubles} precision \ - {expr 1e13} \ + {expr {1e13}} \ 10000000000000.0 test util-16.1.17.14 {8.4 compatible formatting of doubles} precision \ - {expr 1e14} \ + {expr {1e14}} \ 100000000000000.0 test util-16.1.17.15 {8.4 compatible formatting of doubles} precision \ - {expr 1e15} \ + {expr {1e15}} \ 1000000000000000.0 test util-16.1.17.16 {8.4 compatible formatting of doubles} precision \ - {expr 1e16} \ + {expr {1e16}} \ 10000000000000000.0 test util-16.1.17.17 {8.4 compatible formatting of doubles} precision \ - {expr 1e17} \ + {expr {1e17}} \ 1e+17 test util-16.1.17.18 {8.4 compatible formatting of doubles} precision \ - {expr 1e18} \ + {expr {1e18}} \ 1e+18 test util-16.1.17.19 {8.4 compatible formatting of doubles} precision \ - {expr 1e19} \ + {expr {1e19}} \ 1e+19 test util-16.1.17.20 {8.4 compatible formatting of doubles} precision \ - {expr 1e20} \ + {expr {1e20}} \ 1e+20 test util-16.1.17.21 {8.4 compatible formatting of doubles} precision \ - {expr 1e21} \ + {expr {1e21}} \ 1e+21 test util-16.1.17.22 {8.4 compatible formatting of doubles} precision \ - {expr 1e22} \ + {expr {1e22}} \ 1e+22 test util-16.1.17.23 {8.4 compatible formatting of doubles} precision \ - {expr 1e23} \ + {expr {1e23}} \ 9.9999999999999992e+22 test util-16.1.17.24 {8.4 compatible formatting of doubles} precision \ - {expr 1e24} \ + {expr {1e24}} \ 9.9999999999999998e+23 test util-16.1.17.25 {8.4 compatible formatting of doubles} precision \ - {expr 1e25} \ + {expr {1e25}} \ 1.0000000000000001e+25 test util-16.1.17.26 {8.4 compatible formatting of doubles} precision \ - {expr 1e26} \ + {expr {1e26}} \ 1e+26 test util-16.1.17.27 {8.4 compatible formatting of doubles} precision \ - {expr 1e27} \ + {expr {1e27}} \ 1e+27 test util-16.1.17.28 {8.4 compatible formatting of doubles} precision \ - {expr 1e28} \ + {expr {1e28}} \ 9.9999999999999996e+27 test util-16.1.17.29 {8.4 compatible formatting of doubles} precision \ - {expr 1e29} \ + {expr {1e29}} \ 9.9999999999999991e+28 test util-16.1.17.30 {8.4 compatible formatting of doubles} precision \ - {expr 1e30} \ + {expr {1e30}} \ 1e+30 test util-16.1.17.31 {8.4 compatible formatting of doubles} precision \ - {expr 1e31} \ + {expr {1e31}} \ 9.9999999999999996e+30 test util-16.1.17.32 {8.4 compatible formatting of doubles} precision \ - {expr 1e32} \ + {expr {1e32}} \ 1.0000000000000001e+32 test util-16.1.17.33 {8.4 compatible formatting of doubles} precision \ - {expr 1e33} \ + {expr {1e33}} \ 9.9999999999999995e+32 test util-16.1.17.34 {8.4 compatible formatting of doubles} precision \ - {expr 1e34} \ + {expr {1e34}} \ 9.9999999999999995e+33 test util-16.1.17.35 {8.4 compatible formatting of doubles} precision \ - {expr 1e35} \ + {expr {1e35}} \ 9.9999999999999997e+34 test util-16.1.17.36 {8.4 compatible formatting of doubles} precision \ - {expr 1e36} \ + {expr {1e36}} \ 1e+36 test util-16.1.17.37 {8.4 compatible formatting of doubles} precision \ - {expr 1e37} \ + {expr {1e37}} \ 9.9999999999999995e+36 test util-16.1.17.38 {8.4 compatible formatting of doubles} precision \ - {expr 1e38} \ + {expr {1e38}} \ 9.9999999999999998e+37 test util-16.1.17.39 {8.4 compatible formatting of doubles} precision \ - {expr 1e39} \ + {expr {1e39}} \ 9.9999999999999994e+38 test util-16.1.17.40 {8.4 compatible formatting of doubles} precision \ - {expr 1e40} \ + {expr {1e40}} \ 1e+40 test util-16.1.17.41 {8.4 compatible formatting of doubles} precision \ - {expr 1e41} \ + {expr {1e41}} \ 1e+41 test util-16.1.17.42 {8.4 compatible formatting of doubles} precision \ - {expr 1e42} \ + {expr {1e42}} \ 1e+42 test util-16.1.17.43 {8.4 compatible formatting of doubles} precision \ - {expr 1e43} \ + {expr {1e43}} \ 1e+43 test util-16.1.17.44 {8.4 compatible formatting of doubles} precision \ - {expr 1e44} \ + {expr {1e44}} \ 1.0000000000000001e+44 test util-16.1.17.45 {8.4 compatible formatting of doubles} precision \ - {expr 1e45} \ + {expr {1e45}} \ 9.9999999999999993e+44 test util-16.1.17.46 {8.4 compatible formatting of doubles} precision \ - {expr 1e46} \ + {expr {1e46}} \ 9.9999999999999999e+45 test util-16.1.17.47 {8.4 compatible formatting of doubles} precision \ - {expr 1e47} \ + {expr {1e47}} \ 1e+47 test util-16.1.17.48 {8.4 compatible formatting of doubles} precision \ - {expr 1e48} \ + {expr {1e48}} \ 1e+48 test util-16.1.17.49 {8.4 compatible formatting of doubles} precision \ - {expr 1e49} \ + {expr {1e49}} \ 9.9999999999999995e+48 test util-16.1.17.50 {8.4 compatible formatting of doubles} precision \ - {expr 1e50} \ + {expr {1e50}} \ 1.0000000000000001e+50 test util-16.1.17.51 {8.4 compatible formatting of doubles} precision \ - {expr 1e51} \ + {expr {1e51}} \ 9.9999999999999999e+50 test util-16.1.17.52 {8.4 compatible formatting of doubles} precision \ - {expr 1e52} \ + {expr {1e52}} \ 9.9999999999999999e+51 test util-16.1.17.53 {8.4 compatible formatting of doubles} precision \ - {expr 1e53} \ + {expr {1e53}} \ 9.9999999999999999e+52 test util-16.1.17.54 {8.4 compatible formatting of doubles} precision \ - {expr 1e54} \ + {expr {1e54}} \ 1.0000000000000001e+54 test util-16.1.17.55 {8.4 compatible formatting of doubles} precision \ - {expr 1e55} \ + {expr {1e55}} \ 1e+55 test util-16.1.17.56 {8.4 compatible formatting of doubles} precision \ - {expr 1e56} \ + {expr {1e56}} \ 1.0000000000000001e+56 test util-16.1.17.57 {8.4 compatible formatting of doubles} precision \ - {expr 1e57} \ + {expr {1e57}} \ 1e+57 test util-16.1.17.58 {8.4 compatible formatting of doubles} precision \ - {expr 1e58} \ + {expr {1e58}} \ 9.9999999999999994e+57 test util-16.1.17.59 {8.4 compatible formatting of doubles} precision \ - {expr 1e59} \ + {expr {1e59}} \ 9.9999999999999997e+58 test util-16.1.17.60 {8.4 compatible formatting of doubles} precision \ - {expr 1e60} \ + {expr {1e60}} \ 9.9999999999999995e+59 test util-16.1.17.61 {8.4 compatible formatting of doubles} precision \ - {expr 1e61} \ + {expr {1e61}} \ 9.9999999999999995e+60 test util-16.1.17.62 {8.4 compatible formatting of doubles} precision \ - {expr 1e62} \ + {expr {1e62}} \ 1e+62 test util-16.1.17.63 {8.4 compatible formatting of doubles} precision \ - {expr 1e63} \ + {expr {1e63}} \ 1.0000000000000001e+63 test util-16.1.17.64 {8.4 compatible formatting of doubles} precision \ - {expr 1e64} \ + {expr {1e64}} \ 1e+64 test util-16.1.17.65 {8.4 compatible formatting of doubles} precision \ - {expr 1e65} \ + {expr {1e65}} \ 9.9999999999999999e+64 test util-16.1.17.66 {8.4 compatible formatting of doubles} precision \ - {expr 1e66} \ + {expr {1e66}} \ 9.9999999999999995e+65 test util-16.1.17.67 {8.4 compatible formatting of doubles} precision \ - {expr 1e67} \ + {expr {1e67}} \ 9.9999999999999998e+66 test util-16.1.17.68 {8.4 compatible formatting of doubles} precision \ - {expr 1e68} \ + {expr {1e68}} \ 9.9999999999999995e+67 test util-16.1.17.69 {8.4 compatible formatting of doubles} precision \ - {expr 1e69} \ + {expr {1e69}} \ 1.0000000000000001e+69 test util-16.1.17.70 {8.4 compatible formatting of doubles} precision \ - {expr 1e70} \ + {expr {1e70}} \ 1.0000000000000001e+70 test util-16.1.17.71 {8.4 compatible formatting of doubles} precision \ - {expr 1e71} \ + {expr {1e71}} \ 1e+71 test util-16.1.17.72 {8.4 compatible formatting of doubles} precision \ - {expr 1e72} \ + {expr {1e72}} \ 9.9999999999999994e+71 test util-16.1.17.73 {8.4 compatible formatting of doubles} precision \ - {expr 1e73} \ + {expr {1e73}} \ 9.9999999999999998e+72 test util-16.1.17.74 {8.4 compatible formatting of doubles} precision \ - {expr 1e74} \ + {expr {1e74}} \ 9.9999999999999995e+73 test util-16.1.17.75 {8.4 compatible formatting of doubles} precision \ - {expr 1e75} \ + {expr {1e75}} \ 9.9999999999999993e+74 test util-16.1.17.76 {8.4 compatible formatting of doubles} precision \ - {expr 1e76} \ + {expr {1e76}} \ 1e+76 test util-16.1.17.77 {8.4 compatible formatting of doubles} precision \ - {expr 1e77} \ + {expr {1e77}} \ 9.9999999999999998e+76 test util-16.1.17.78 {8.4 compatible formatting of doubles} precision \ - {expr 1e78} \ + {expr {1e78}} \ 1e+78 test util-16.1.17.79 {8.4 compatible formatting of doubles} precision \ - {expr 1e79} \ + {expr {1e79}} \ 9.9999999999999997e+78 test util-16.1.17.80 {8.4 compatible formatting of doubles} precision \ - {expr 1e80} \ + {expr {1e80}} \ 1e+80 test util-16.1.17.81 {8.4 compatible formatting of doubles} precision \ - {expr 1e81} \ + {expr {1e81}} \ 9.9999999999999992e+80 test util-16.1.17.82 {8.4 compatible formatting of doubles} precision \ - {expr 1e82} \ + {expr {1e82}} \ 9.9999999999999996e+81 test util-16.1.17.83 {8.4 compatible formatting of doubles} precision \ - {expr 1e83} \ + {expr {1e83}} \ 1e+83 test util-16.1.17.84 {8.4 compatible formatting of doubles} precision \ - {expr 1e84} \ + {expr {1e84}} \ 1.0000000000000001e+84 test util-16.1.17.85 {8.4 compatible formatting of doubles} precision \ - {expr 1e85} \ + {expr {1e85}} \ 1e+85 test util-16.1.17.86 {8.4 compatible formatting of doubles} precision \ - {expr 1e86} \ + {expr {1e86}} \ 1e+86 test util-16.1.17.87 {8.4 compatible formatting of doubles} precision \ - {expr 1e87} \ + {expr {1e87}} \ 9.9999999999999996e+86 test util-16.1.17.88 {8.4 compatible formatting of doubles} precision \ - {expr 1e88} \ + {expr {1e88}} \ 9.9999999999999996e+87 test util-16.1.17.89 {8.4 compatible formatting of doubles} precision \ - {expr 1e89} \ + {expr {1e89}} \ 9.9999999999999999e+88 test util-16.1.17.90 {8.4 compatible formatting of doubles} precision \ - {expr 1e90} \ + {expr {1e90}} \ 9.9999999999999997e+89 test util-16.1.17.91 {8.4 compatible formatting of doubles} precision \ - {expr 1e91} \ + {expr {1e91}} \ 1.0000000000000001e+91 test util-16.1.17.92 {8.4 compatible formatting of doubles} precision \ - {expr 1e92} \ + {expr {1e92}} \ 1e+92 test util-16.1.17.93 {8.4 compatible formatting of doubles} precision \ - {expr 1e93} \ + {expr {1e93}} \ 1e+93 test util-16.1.17.94 {8.4 compatible formatting of doubles} precision \ - {expr 1e94} \ + {expr {1e94}} \ 1e+94 test util-16.1.17.95 {8.4 compatible formatting of doubles} precision \ - {expr 1e95} \ + {expr {1e95}} \ 1e+95 test util-16.1.17.96 {8.4 compatible formatting of doubles} precision \ - {expr 1e96} \ + {expr {1e96}} \ 1e+96 test util-16.1.17.97 {8.4 compatible formatting of doubles} precision \ - {expr 1e97} \ + {expr {1e97}} \ 1.0000000000000001e+97 test util-16.1.17.98 {8.4 compatible formatting of doubles} precision \ - {expr 1e98} \ + {expr {1e98}} \ 1e+98 test util-16.1.17.99 {8.4 compatible formatting of doubles} precision \ - {expr 1e99} \ + {expr {1e99}} \ 9.9999999999999997e+98 test util-16.1.17.100 {8.4 compatible formatting of doubles} precision \ - {expr 1e100} \ + {expr {1e100}} \ 1e+100 test util-16.1.17.101 {8.4 compatible formatting of doubles} precision \ - {expr 1e101} \ + {expr {1e101}} \ 9.9999999999999998e+100 test util-16.1.17.102 {8.4 compatible formatting of doubles} precision \ - {expr 1e102} \ + {expr {1e102}} \ 9.9999999999999998e+101 test util-16.1.17.103 {8.4 compatible formatting of doubles} precision \ - {expr 1e103} \ + {expr {1e103}} \ 1e+103 test util-16.1.17.104 {8.4 compatible formatting of doubles} precision \ - {expr 1e104} \ + {expr {1e104}} \ 1e+104 test util-16.1.17.105 {8.4 compatible formatting of doubles} precision \ - {expr 1e105} \ + {expr {1e105}} \ 9.9999999999999994e+104 test util-16.1.17.106 {8.4 compatible formatting of doubles} precision \ - {expr 1e106} \ + {expr {1e106}} \ 1.0000000000000001e+106 test util-16.1.17.107 {8.4 compatible formatting of doubles} precision \ - {expr 1e107} \ + {expr {1e107}} \ 9.9999999999999997e+106 test util-16.1.17.108 {8.4 compatible formatting of doubles} precision \ - {expr 1e108} \ + {expr {1e108}} \ 1e+108 test util-16.1.17.109 {8.4 compatible formatting of doubles} precision \ - {expr 1e109} \ + {expr {1e109}} \ 9.9999999999999998e+108 test util-16.1.17.110 {8.4 compatible formatting of doubles} precision \ - {expr 1e110} \ + {expr {1e110}} \ 1e+110 test util-16.1.17.111 {8.4 compatible formatting of doubles} precision \ - {expr 1e111} \ + {expr {1e111}} \ 9.9999999999999996e+110 test util-16.1.17.112 {8.4 compatible formatting of doubles} precision \ - {expr 1e112} \ + {expr {1e112}} \ 9.9999999999999993e+111 test util-16.1.17.113 {8.4 compatible formatting of doubles} precision \ - {expr 1e113} \ + {expr {1e113}} \ 1e+113 test util-16.1.17.114 {8.4 compatible formatting of doubles} precision \ - {expr 1e114} \ + {expr {1e114}} \ 1e+114 test util-16.1.17.115 {8.4 compatible formatting of doubles} precision \ - {expr 1e115} \ + {expr {1e115}} \ 1e+115 test util-16.1.17.116 {8.4 compatible formatting of doubles} precision \ - {expr 1e116} \ + {expr {1e116}} \ 1e+116 test util-16.1.17.117 {8.4 compatible formatting of doubles} precision \ - {expr 1e117} \ + {expr {1e117}} \ 1.0000000000000001e+117 test util-16.1.17.118 {8.4 compatible formatting of doubles} precision \ - {expr 1e118} \ + {expr {1e118}} \ 9.9999999999999997e+117 test util-16.1.17.119 {8.4 compatible formatting of doubles} precision \ - {expr 1e119} \ + {expr {1e119}} \ 9.9999999999999994e+118 test util-16.1.17.120 {8.4 compatible formatting of doubles} precision \ - {expr 1e120} \ + {expr {1e120}} \ 9.9999999999999998e+119 test util-16.1.17.121 {8.4 compatible formatting of doubles} precision \ - {expr 1e121} \ + {expr {1e121}} \ 1e+121 test util-16.1.17.122 {8.4 compatible formatting of doubles} precision \ - {expr 1e122} \ + {expr {1e122}} \ 1e+122 test util-16.1.17.123 {8.4 compatible formatting of doubles} precision \ - {expr 1e123} \ + {expr {1e123}} \ 9.9999999999999998e+122 test util-16.1.17.124 {8.4 compatible formatting of doubles} precision \ - {expr 1e124} \ + {expr {1e124}} \ 9.9999999999999995e+123 test util-16.1.17.125 {8.4 compatible formatting of doubles} precision \ - {expr 1e125} \ + {expr {1e125}} \ 9.9999999999999992e+124 test util-16.1.17.126 {8.4 compatible formatting of doubles} precision \ - {expr 1e126} \ + {expr {1e126}} \ 9.9999999999999992e+125 test util-16.1.17.127 {8.4 compatible formatting of doubles} precision \ - {expr 1e127} \ + {expr {1e127}} \ 9.9999999999999995e+126 test util-16.1.17.128 {8.4 compatible formatting of doubles} precision \ - {expr 1e128} \ + {expr {1e128}} \ 1.0000000000000001e+128 test util-16.1.17.129 {8.4 compatible formatting of doubles} precision \ - {expr 1e129} \ + {expr {1e129}} \ 1e+129 test util-16.1.17.130 {8.4 compatible formatting of doubles} precision \ - {expr 1e130} \ + {expr {1e130}} \ 1.0000000000000001e+130 test util-16.1.17.131 {8.4 compatible formatting of doubles} precision \ - {expr 1e131} \ + {expr {1e131}} \ 9.9999999999999991e+130 test util-16.1.17.132 {8.4 compatible formatting of doubles} precision \ - {expr 1e132} \ + {expr {1e132}} \ 9.9999999999999999e+131 test util-16.1.17.133 {8.4 compatible formatting of doubles} precision \ - {expr 1e133} \ + {expr {1e133}} \ 1e+133 test util-16.1.17.134 {8.4 compatible formatting of doubles} precision \ - {expr 1e134} \ + {expr {1e134}} \ 9.9999999999999992e+133 test util-16.1.17.135 {8.4 compatible formatting of doubles} precision \ - {expr 1e135} \ + {expr {1e135}} \ 9.9999999999999996e+134 test util-16.1.17.136 {8.4 compatible formatting of doubles} precision \ - {expr 1e136} \ + {expr {1e136}} \ 1.0000000000000001e+136 test util-16.1.17.137 {8.4 compatible formatting of doubles} precision \ - {expr 1e137} \ + {expr {1e137}} \ 1e+137 test util-16.1.17.138 {8.4 compatible formatting of doubles} precision \ - {expr 1e138} \ + {expr {1e138}} \ 1e+138 test util-16.1.17.139 {8.4 compatible formatting of doubles} precision \ - {expr 1e139} \ + {expr {1e139}} \ 1e+139 test util-16.1.17.140 {8.4 compatible formatting of doubles} precision \ - {expr 1e140} \ + {expr {1e140}} \ 1.0000000000000001e+140 test util-16.1.17.141 {8.4 compatible formatting of doubles} precision \ - {expr 1e141} \ + {expr {1e141}} \ 1e+141 test util-16.1.17.142 {8.4 compatible formatting of doubles} precision \ - {expr 1e142} \ + {expr {1e142}} \ 1.0000000000000001e+142 test util-16.1.17.143 {8.4 compatible formatting of doubles} precision \ - {expr 1e143} \ + {expr {1e143}} \ 1e+143 test util-16.1.17.144 {8.4 compatible formatting of doubles} precision \ - {expr 1e144} \ + {expr {1e144}} \ 1e+144 test util-16.1.17.145 {8.4 compatible formatting of doubles} precision \ - {expr 1e145} \ + {expr {1e145}} \ 9.9999999999999999e+144 test util-16.1.17.146 {8.4 compatible formatting of doubles} precision \ - {expr 1e146} \ + {expr {1e146}} \ 9.9999999999999993e+145 test util-16.1.17.147 {8.4 compatible formatting of doubles} precision \ - {expr 1e147} \ + {expr {1e147}} \ 9.9999999999999998e+146 test util-16.1.17.148 {8.4 compatible formatting of doubles} precision \ - {expr 1e148} \ + {expr {1e148}} \ 1e+148 test util-16.1.17.149 {8.4 compatible formatting of doubles} precision \ - {expr 1e149} \ + {expr {1e149}} \ 1e+149 test util-16.1.17.150 {8.4 compatible formatting of doubles} precision \ - {expr 1e150} \ + {expr {1e150}} \ 9.9999999999999998e+149 test util-16.1.17.151 {8.4 compatible formatting of doubles} precision \ - {expr 1e151} \ + {expr {1e151}} \ 1e+151 test util-16.1.17.152 {8.4 compatible formatting of doubles} precision \ - {expr 1e152} \ + {expr {1e152}} \ 1e+152 test util-16.1.17.153 {8.4 compatible formatting of doubles} precision \ - {expr 1e153} \ + {expr {1e153}} \ 1e+153 test util-16.1.17.154 {8.4 compatible formatting of doubles} precision \ - {expr 1e154} \ + {expr {1e154}} \ 1e+154 test util-16.1.17.155 {8.4 compatible formatting of doubles} precision \ - {expr 1e155} \ + {expr {1e155}} \ 1e+155 test util-16.1.17.156 {8.4 compatible formatting of doubles} precision \ - {expr 1e156} \ + {expr {1e156}} \ 9.9999999999999998e+155 test util-16.1.17.157 {8.4 compatible formatting of doubles} precision \ - {expr 1e157} \ + {expr {1e157}} \ 9.9999999999999998e+156 test util-16.1.17.158 {8.4 compatible formatting of doubles} precision \ - {expr 1e158} \ + {expr {1e158}} \ 9.9999999999999995e+157 test util-16.1.17.159 {8.4 compatible formatting of doubles} precision \ - {expr 1e159} \ + {expr {1e159}} \ 9.9999999999999993e+158 test util-16.1.17.160 {8.4 compatible formatting of doubles} precision \ - {expr 1e160} \ + {expr {1e160}} \ 1e+160 test util-16.1.17.161 {8.4 compatible formatting of doubles} precision \ - {expr 1e161} \ + {expr {1e161}} \ 1e+161 test util-16.1.17.162 {8.4 compatible formatting of doubles} precision \ - {expr 1e162} \ + {expr {1e162}} \ 9.9999999999999994e+161 test util-16.1.17.163 {8.4 compatible formatting of doubles} precision \ - {expr 1e163} \ + {expr {1e163}} \ 9.9999999999999994e+162 test util-16.1.17.164 {8.4 compatible formatting of doubles} precision \ - {expr 1e164} \ + {expr {1e164}} \ 1e+164 test util-16.1.17.165 {8.4 compatible formatting of doubles} precision \ - {expr 1e165} \ + {expr {1e165}} \ 9.999999999999999e+164 test util-16.1.17.166 {8.4 compatible formatting of doubles} precision \ - {expr 1e166} \ + {expr {1e166}} \ 9.9999999999999994e+165 test util-16.1.17.167 {8.4 compatible formatting of doubles} precision \ - {expr 1e167} \ + {expr {1e167}} \ 1e+167 test util-16.1.17.168 {8.4 compatible formatting of doubles} precision \ - {expr 1e168} \ + {expr {1e168}} \ 9.9999999999999993e+167 test util-16.1.17.169 {8.4 compatible formatting of doubles} precision \ - {expr 1e169} \ + {expr {1e169}} \ 9.9999999999999993e+168 test util-16.1.17.170 {8.4 compatible formatting of doubles} precision \ - {expr 1e170} \ + {expr {1e170}} \ 1e+170 test util-16.1.17.171 {8.4 compatible formatting of doubles} precision \ - {expr 1e171} \ + {expr {1e171}} \ 9.9999999999999995e+170 test util-16.1.17.172 {8.4 compatible formatting of doubles} precision \ - {expr 1e172} \ + {expr {1e172}} \ 1.0000000000000001e+172 test util-16.1.17.173 {8.4 compatible formatting of doubles} precision \ - {expr 1e173} \ + {expr {1e173}} \ 1e+173 test util-16.1.17.174 {8.4 compatible formatting of doubles} precision \ - {expr 1e174} \ + {expr {1e174}} \ 1.0000000000000001e+174 test util-16.1.17.175 {8.4 compatible formatting of doubles} precision \ - {expr 1e175} \ + {expr {1e175}} \ 9.9999999999999994e+174 test util-16.1.17.176 {8.4 compatible formatting of doubles} precision \ - {expr 1e176} \ + {expr {1e176}} \ 1e+176 test util-16.1.17.177 {8.4 compatible formatting of doubles} precision \ - {expr 1e177} \ + {expr {1e177}} \ 1e+177 test util-16.1.17.178 {8.4 compatible formatting of doubles} precision \ - {expr 1e178} \ + {expr {1e178}} \ 1.0000000000000001e+178 test util-16.1.17.179 {8.4 compatible formatting of doubles} precision \ - {expr 1e179} \ + {expr {1e179}} \ 9.9999999999999998e+178 test util-16.1.17.180 {8.4 compatible formatting of doubles} precision \ - {expr 1e180} \ + {expr {1e180}} \ 1e+180 test util-16.1.17.181 {8.4 compatible formatting of doubles} precision \ - {expr 1e181} \ + {expr {1e181}} \ 9.9999999999999992e+180 test util-16.1.17.182 {8.4 compatible formatting of doubles} precision \ - {expr 1e182} \ + {expr {1e182}} \ 1.0000000000000001e+182 test util-16.1.17.183 {8.4 compatible formatting of doubles} precision \ - {expr 1e183} \ + {expr {1e183}} \ 9.9999999999999995e+182 test util-16.1.17.184 {8.4 compatible formatting of doubles} precision \ - {expr 1e184} \ + {expr {1e184}} \ 1e+184 test util-16.1.17.185 {8.4 compatible formatting of doubles} precision \ - {expr 1e185} \ + {expr {1e185}} \ 9.9999999999999998e+184 test util-16.1.17.186 {8.4 compatible formatting of doubles} precision \ - {expr 1e186} \ + {expr {1e186}} \ 9.9999999999999998e+185 test util-16.1.17.187 {8.4 compatible formatting of doubles} precision \ - {expr 1e187} \ + {expr {1e187}} \ 9.9999999999999991e+186 test util-16.1.17.188 {8.4 compatible formatting of doubles} precision \ - {expr 1e188} \ + {expr {1e188}} \ 1e+188 test util-16.1.17.189 {8.4 compatible formatting of doubles} precision \ - {expr 1e189} \ + {expr {1e189}} \ 1e+189 test util-16.1.17.190 {8.4 compatible formatting of doubles} precision \ - {expr 1e190} \ + {expr {1e190}} \ 1.0000000000000001e+190 test util-16.1.17.191 {8.4 compatible formatting of doubles} precision \ - {expr 1e191} \ + {expr {1e191}} \ 1.0000000000000001e+191 test util-16.1.17.192 {8.4 compatible formatting of doubles} precision \ - {expr 1e192} \ + {expr {1e192}} \ 1e+192 test util-16.1.17.193 {8.4 compatible formatting of doubles} precision \ - {expr 1e193} \ + {expr {1e193}} \ 1.0000000000000001e+193 test util-16.1.17.194 {8.4 compatible formatting of doubles} precision \ - {expr 1e194} \ + {expr {1e194}} \ 9.9999999999999994e+193 test util-16.1.17.195 {8.4 compatible formatting of doubles} precision \ - {expr 1e195} \ + {expr {1e195}} \ 9.9999999999999998e+194 test util-16.1.17.196 {8.4 compatible formatting of doubles} precision \ - {expr 1e196} \ + {expr {1e196}} \ 9.9999999999999995e+195 test util-16.1.17.197 {8.4 compatible formatting of doubles} precision \ - {expr 1e197} \ + {expr {1e197}} \ 9.9999999999999995e+196 test util-16.1.17.198 {8.4 compatible formatting of doubles} precision \ - {expr 1e198} \ + {expr {1e198}} \ 1e+198 test util-16.1.17.199 {8.4 compatible formatting of doubles} precision \ - {expr 1e199} \ + {expr {1e199}} \ 1.0000000000000001e+199 test util-16.1.17.200 {8.4 compatible formatting of doubles} precision \ - {expr 1e200} \ + {expr {1e200}} \ 9.9999999999999997e+199 test util-16.1.17.201 {8.4 compatible formatting of doubles} precision \ - {expr 1e201} \ + {expr {1e201}} \ 1e+201 test util-16.1.17.202 {8.4 compatible formatting of doubles} precision \ - {expr 1e202} \ + {expr {1e202}} \ 9.999999999999999e+201 test util-16.1.17.203 {8.4 compatible formatting of doubles} precision \ - {expr 1e203} \ + {expr {1e203}} \ 9.9999999999999999e+202 test util-16.1.17.204 {8.4 compatible formatting of doubles} precision \ - {expr 1e204} \ + {expr {1e204}} \ 9.9999999999999999e+203 test util-16.1.17.205 {8.4 compatible formatting of doubles} precision \ - {expr 1e205} \ + {expr {1e205}} \ 1e+205 test util-16.1.17.206 {8.4 compatible formatting of doubles} precision \ - {expr 1e206} \ + {expr {1e206}} \ 1e+206 test util-16.1.17.207 {8.4 compatible formatting of doubles} precision \ - {expr 1e207} \ + {expr {1e207}} \ 1e+207 test util-16.1.17.208 {8.4 compatible formatting of doubles} precision \ - {expr 1e208} \ + {expr {1e208}} \ 9.9999999999999998e+207 test util-16.1.17.209 {8.4 compatible formatting of doubles} precision \ - {expr 1e209} \ + {expr {1e209}} \ 1.0000000000000001e+209 test util-16.1.17.210 {8.4 compatible formatting of doubles} precision \ - {expr 1e210} \ + {expr {1e210}} \ 9.9999999999999993e+209 test util-16.1.17.211 {8.4 compatible formatting of doubles} precision \ - {expr 1e211} \ + {expr {1e211}} \ 9.9999999999999996e+210 test util-16.1.17.212 {8.4 compatible formatting of doubles} precision \ - {expr 1e212} \ + {expr {1e212}} \ 9.9999999999999991e+211 test util-16.1.17.213 {8.4 compatible formatting of doubles} precision \ - {expr 1e213} \ + {expr {1e213}} \ 9.9999999999999998e+212 test util-16.1.17.214 {8.4 compatible formatting of doubles} precision \ - {expr 1e214} \ + {expr {1e214}} \ 9.9999999999999995e+213 test util-16.1.17.215 {8.4 compatible formatting of doubles} precision \ - {expr 1e215} \ + {expr {1e215}} \ 9.9999999999999991e+214 test util-16.1.17.216 {8.4 compatible formatting of doubles} precision \ - {expr 1e216} \ + {expr {1e216}} \ 1e+216 test util-16.1.17.217 {8.4 compatible formatting of doubles} precision \ - {expr 1e217} \ + {expr {1e217}} \ 9.9999999999999996e+216 test util-16.1.17.218 {8.4 compatible formatting of doubles} precision \ - {expr 1e218} \ + {expr {1e218}} \ 1.0000000000000001e+218 test util-16.1.17.219 {8.4 compatible formatting of doubles} precision \ - {expr 1e219} \ + {expr {1e219}} \ 9.9999999999999997e+218 test util-16.1.17.220 {8.4 compatible formatting of doubles} precision \ - {expr 1e220} \ + {expr {1e220}} \ 1e+220 test util-16.1.17.221 {8.4 compatible formatting of doubles} precision \ - {expr 1e221} \ + {expr {1e221}} \ 1e+221 test util-16.1.17.222 {8.4 compatible formatting of doubles} precision \ - {expr 1e222} \ + {expr {1e222}} \ 1e+222 test util-16.1.17.223 {8.4 compatible formatting of doubles} precision \ - {expr 1e223} \ + {expr {1e223}} \ 1e+223 test util-16.1.17.224 {8.4 compatible formatting of doubles} precision \ - {expr 1e224} \ + {expr {1e224}} \ 9.9999999999999997e+223 test util-16.1.17.225 {8.4 compatible formatting of doubles} precision \ - {expr 1e225} \ + {expr {1e225}} \ 9.9999999999999993e+224 test util-16.1.17.226 {8.4 compatible formatting of doubles} precision \ - {expr 1e226} \ + {expr {1e226}} \ 9.9999999999999996e+225 test util-16.1.17.227 {8.4 compatible formatting of doubles} precision \ - {expr 1e227} \ + {expr {1e227}} \ 1.0000000000000001e+227 test util-16.1.17.228 {8.4 compatible formatting of doubles} precision \ - {expr 1e228} \ + {expr {1e228}} \ 9.9999999999999992e+227 test util-16.1.17.229 {8.4 compatible formatting of doubles} precision \ - {expr 1e229} \ + {expr {1e229}} \ 9.9999999999999999e+228 test util-16.1.17.230 {8.4 compatible formatting of doubles} precision \ - {expr 1e230} \ + {expr {1e230}} \ 1.0000000000000001e+230 test util-16.1.17.231 {8.4 compatible formatting of doubles} precision \ - {expr 1e231} \ + {expr {1e231}} \ 1.0000000000000001e+231 test util-16.1.17.232 {8.4 compatible formatting of doubles} precision \ - {expr 1e232} \ + {expr {1e232}} \ 1.0000000000000001e+232 test util-16.1.17.233 {8.4 compatible formatting of doubles} precision \ - {expr 1e233} \ + {expr {1e233}} \ 9.9999999999999997e+232 test util-16.1.17.234 {8.4 compatible formatting of doubles} precision \ - {expr 1e234} \ + {expr {1e234}} \ 1e+234 test util-16.1.17.235 {8.4 compatible formatting of doubles} precision \ - {expr 1e235} \ + {expr {1e235}} \ 1.0000000000000001e+235 test util-16.1.17.236 {8.4 compatible formatting of doubles} precision \ - {expr 1e236} \ + {expr {1e236}} \ 1.0000000000000001e+236 test util-16.1.17.237 {8.4 compatible formatting of doubles} precision \ - {expr 1e237} \ + {expr {1e237}} \ 9.9999999999999994e+236 test util-16.1.17.238 {8.4 compatible formatting of doubles} precision \ - {expr 1e238} \ + {expr {1e238}} \ 1e+238 test util-16.1.17.239 {8.4 compatible formatting of doubles} precision \ - {expr 1e239} \ + {expr {1e239}} \ 9.9999999999999999e+238 test util-16.1.17.240 {8.4 compatible formatting of doubles} precision \ - {expr 1e240} \ + {expr {1e240}} \ 1e+240 test util-16.1.17.241 {8.4 compatible formatting of doubles} precision \ - {expr 1e241} \ + {expr {1e241}} \ 1.0000000000000001e+241 test util-16.1.17.242 {8.4 compatible formatting of doubles} precision \ - {expr 1e242} \ + {expr {1e242}} \ 1.0000000000000001e+242 test util-16.1.17.243 {8.4 compatible formatting of doubles} precision \ - {expr 1e243} \ + {expr {1e243}} \ 1.0000000000000001e+243 test util-16.1.17.244 {8.4 compatible formatting of doubles} precision \ - {expr 1e244} \ + {expr {1e244}} \ 1.0000000000000001e+244 test util-16.1.17.245 {8.4 compatible formatting of doubles} precision \ - {expr 1e245} \ + {expr {1e245}} \ 1e+245 test util-16.1.17.246 {8.4 compatible formatting of doubles} precision \ - {expr 1e246} \ + {expr {1e246}} \ 1.0000000000000001e+246 test util-16.1.17.247 {8.4 compatible formatting of doubles} precision \ - {expr 1e247} \ + {expr {1e247}} \ 9.9999999999999995e+246 test util-16.1.17.248 {8.4 compatible formatting of doubles} precision \ - {expr 1e248} \ + {expr {1e248}} \ 1e+248 test util-16.1.17.249 {8.4 compatible formatting of doubles} precision \ - {expr 1e249} \ + {expr {1e249}} \ 9.9999999999999992e+248 test util-16.1.17.250 {8.4 compatible formatting of doubles} precision \ - {expr 1e250} \ + {expr {1e250}} \ 9.9999999999999992e+249 test util-16.1.17.251 {8.4 compatible formatting of doubles} precision \ - {expr 1e251} \ + {expr {1e251}} \ 1e+251 test util-16.1.17.252 {8.4 compatible formatting of doubles} precision \ - {expr 1e252} \ + {expr {1e252}} \ 1.0000000000000001e+252 test util-16.1.17.253 {8.4 compatible formatting of doubles} precision \ - {expr 1e253} \ + {expr {1e253}} \ 9.9999999999999994e+252 test util-16.1.17.254 {8.4 compatible formatting of doubles} precision \ - {expr 1e254} \ + {expr {1e254}} \ 9.9999999999999994e+253 test util-16.1.17.255 {8.4 compatible formatting of doubles} precision \ - {expr 1e255} \ + {expr {1e255}} \ 9.9999999999999999e+254 test util-16.1.17.256 {8.4 compatible formatting of doubles} precision \ - {expr 1e256} \ + {expr {1e256}} \ 1e+256 test util-16.1.17.257 {8.4 compatible formatting of doubles} precision \ - {expr 1e257} \ + {expr {1e257}} \ 1e+257 test util-16.1.17.258 {8.4 compatible formatting of doubles} precision \ - {expr 1e258} \ + {expr {1e258}} \ 1.0000000000000001e+258 test util-16.1.17.259 {8.4 compatible formatting of doubles} precision \ - {expr 1e259} \ + {expr {1e259}} \ 9.9999999999999993e+258 test util-16.1.17.260 {8.4 compatible formatting of doubles} precision \ - {expr 1e260} \ + {expr {1e260}} \ 1.0000000000000001e+260 test util-16.1.17.261 {8.4 compatible formatting of doubles} precision \ - {expr 1e261} \ + {expr {1e261}} \ 9.9999999999999993e+260 test util-16.1.17.262 {8.4 compatible formatting of doubles} precision \ - {expr 1e262} \ + {expr {1e262}} \ 1e+262 test util-16.1.17.263 {8.4 compatible formatting of doubles} precision \ - {expr 1e263} \ + {expr {1e263}} \ 1e+263 test util-16.1.17.264 {8.4 compatible formatting of doubles} precision \ - {expr 1e264} \ + {expr {1e264}} \ 1e+264 test util-16.1.17.265 {8.4 compatible formatting of doubles} precision \ - {expr 1e265} \ + {expr {1e265}} \ 1.0000000000000001e+265 test util-16.1.17.266 {8.4 compatible formatting of doubles} precision \ - {expr 1e266} \ + {expr {1e266}} \ 1e+266 test util-16.1.17.267 {8.4 compatible formatting of doubles} precision \ - {expr 1e267} \ + {expr {1e267}} \ 9.9999999999999997e+266 test util-16.1.17.268 {8.4 compatible formatting of doubles} precision \ - {expr 1e268} \ + {expr {1e268}} \ 9.9999999999999997e+267 test util-16.1.17.269 {8.4 compatible formatting of doubles} precision \ - {expr 1e269} \ + {expr {1e269}} \ 1e+269 test util-16.1.17.270 {8.4 compatible formatting of doubles} precision \ - {expr 1e270} \ + {expr {1e270}} \ 1e+270 test util-16.1.17.271 {8.4 compatible formatting of doubles} precision \ - {expr 1e271} \ + {expr {1e271}} \ 9.9999999999999995e+270 test util-16.1.17.272 {8.4 compatible formatting of doubles} precision \ - {expr 1e272} \ + {expr {1e272}} \ 1.0000000000000001e+272 test util-16.1.17.273 {8.4 compatible formatting of doubles} precision \ - {expr 1e273} \ + {expr {1e273}} \ 9.9999999999999995e+272 test util-16.1.17.274 {8.4 compatible formatting of doubles} precision \ - {expr 1e274} \ + {expr {1e274}} \ 9.9999999999999992e+273 test util-16.1.17.275 {8.4 compatible formatting of doubles} precision \ - {expr 1e275} \ + {expr {1e275}} \ 9.9999999999999996e+274 test util-16.1.17.276 {8.4 compatible formatting of doubles} precision \ - {expr 1e276} \ + {expr {1e276}} \ 1.0000000000000001e+276 test util-16.1.17.277 {8.4 compatible formatting of doubles} precision \ - {expr 1e277} \ + {expr {1e277}} \ 1e+277 test util-16.1.17.278 {8.4 compatible formatting of doubles} precision \ - {expr 1e278} \ + {expr {1e278}} \ 9.9999999999999996e+277 test util-16.1.17.279 {8.4 compatible formatting of doubles} precision \ - {expr 1e279} \ + {expr {1e279}} \ 1.0000000000000001e+279 test util-16.1.17.280 {8.4 compatible formatting of doubles} precision \ - {expr 1e280} \ + {expr {1e280}} \ 1e+280 test util-16.1.17.281 {8.4 compatible formatting of doubles} precision \ - {expr 1e281} \ + {expr {1e281}} \ 1e+281 test util-16.1.17.282 {8.4 compatible formatting of doubles} precision \ - {expr 1e282} \ + {expr {1e282}} \ 1e+282 test util-16.1.17.283 {8.4 compatible formatting of doubles} precision \ - {expr 1e283} \ + {expr {1e283}} \ 9.9999999999999996e+282 test util-16.1.17.284 {8.4 compatible formatting of doubles} precision \ - {expr 1e284} \ + {expr {1e284}} \ 1.0000000000000001e+284 test util-16.1.17.285 {8.4 compatible formatting of doubles} precision \ - {expr 1e285} \ + {expr {1e285}} \ 9.9999999999999998e+284 test util-16.1.17.286 {8.4 compatible formatting of doubles} precision \ - {expr 1e286} \ + {expr {1e286}} \ 1e+286 test util-16.1.17.287 {8.4 compatible formatting of doubles} precision \ - {expr 1e287} \ + {expr {1e287}} \ 1.0000000000000001e+287 test util-16.1.17.288 {8.4 compatible formatting of doubles} precision \ - {expr 1e288} \ + {expr {1e288}} \ 1e+288 test util-16.1.17.289 {8.4 compatible formatting of doubles} precision \ - {expr 1e289} \ + {expr {1e289}} \ 1.0000000000000001e+289 test util-16.1.17.290 {8.4 compatible formatting of doubles} precision \ - {expr 1e290} \ + {expr {1e290}} \ 1.0000000000000001e+290 test util-16.1.17.291 {8.4 compatible formatting of doubles} precision \ - {expr 1e291} \ + {expr {1e291}} \ 9.9999999999999996e+290 test util-16.1.17.292 {8.4 compatible formatting of doubles} precision \ - {expr 1e292} \ + {expr {1e292}} \ 1e+292 test util-16.1.17.293 {8.4 compatible formatting of doubles} precision \ - {expr 1e293} \ + {expr {1e293}} \ 9.9999999999999992e+292 test util-16.1.17.294 {8.4 compatible formatting of doubles} precision \ - {expr 1e294} \ + {expr {1e294}} \ 1.0000000000000001e+294 test util-16.1.17.295 {8.4 compatible formatting of doubles} precision \ - {expr 1e295} \ + {expr {1e295}} \ 9.9999999999999998e+294 test util-16.1.17.296 {8.4 compatible formatting of doubles} precision \ - {expr 1e296} \ + {expr {1e296}} \ 9.9999999999999998e+295 test util-16.1.17.297 {8.4 compatible formatting of doubles} precision \ - {expr 1e297} \ + {expr {1e297}} \ 1e+297 test util-16.1.17.298 {8.4 compatible formatting of doubles} precision \ - {expr 1e298} \ + {expr {1e298}} \ 9.9999999999999996e+297 test util-16.1.17.299 {8.4 compatible formatting of doubles} precision \ - {expr 1e299} \ + {expr {1e299}} \ 1.0000000000000001e+299 test util-16.1.17.300 {8.4 compatible formatting of doubles} precision \ - {expr 1e300} \ + {expr {1e300}} \ 1.0000000000000001e+300 test util-16.1.17.301 {8.4 compatible formatting of doubles} precision \ - {expr 1e301} \ + {expr {1e301}} \ 1.0000000000000001e+301 test util-16.1.17.302 {8.4 compatible formatting of doubles} precision \ - {expr 1e302} \ + {expr {1e302}} \ 1.0000000000000001e+302 test util-16.1.17.303 {8.4 compatible formatting of doubles} precision \ - {expr 1e303} \ + {expr {1e303}} \ 1e+303 test util-16.1.17.304 {8.4 compatible formatting of doubles} precision \ - {expr 1e304} \ + {expr {1e304}} \ 9.9999999999999994e+303 test util-16.1.17.305 {8.4 compatible formatting of doubles} precision \ - {expr 1e305} \ + {expr {1e305}} \ 9.9999999999999994e+304 test util-16.1.17.306 {8.4 compatible formatting of doubles} precision \ - {expr 1e306} \ + {expr {1e306}} \ 1e+306 test util-16.1.17.307 {8.4 compatible formatting of doubles} precision \ - {expr 1e307} \ + {expr {1e307}} \ 9.9999999999999999e+306 test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { @@ -4107,9 +4110,9 @@ test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { 0x1fffffffffffff000 0x1fffffffffffff800 } { - binary scan [binary format q [expr double($input)]] wu x + 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 + binary scan [binary format q [expr {double(-$input)}]] wu x lappend r [format %#llx $x] } set r @@ -4125,39 +4128,39 @@ test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { }] test util-18.1 {Tcl_ObjPrintf} {testprint} { - testprint %lld [expr 2**63-1] + testprint %lld [expr {2**63-1}] } {9223372036854775807} test util-18.2 {Tcl_ObjPrintf} {testprint} { - testprint %I64d [expr 2**63-1] + testprint %I64d [expr {2**63-1}] } {9223372036854775807} test util-18.3 {Tcl_ObjPrintf} {testprint} { - testprint %qd [expr 2**63-1] + testprint %qd [expr {2**63-1}] } {9223372036854775807} test util-18.4 {Tcl_ObjPrintf} {testprint} { - testprint %jd [expr 2**63-1] + testprint %jd [expr {2**63-1}] } {9223372036854775807} test util-18.5 {Tcl_ObjPrintf} {testprint} { - testprint %lld [expr -2**63] + testprint %lld [expr {-2**63}] } {-9223372036854775808} test util-18.6 {Tcl_ObjPrintf} {testprint} { - testprint %I64d [expr -2**63] + testprint %I64d [expr {-2**63}] } {-9223372036854775808} test util-18.7 {Tcl_ObjPrintf} {testprint} { - testprint %qd [expr -2**63] + testprint %qd [expr {-2**63}] } {-9223372036854775808} test util-18.8 {Tcl_ObjPrintf} {testprint} { - testprint %jd [expr -2**63] + testprint %jd [expr {-2**63}] } {-9223372036854775808} test util-18.9 {Tcl_ObjPrintf} {testprint} { - testprint "%I64d %I32d" [expr -2**63+2] + testprint "%I64d %I32d" [expr {-2**63+2}] } {-9223372036854775806 2} test util-18.10 {Tcl_ObjPrintf} {testprint} { diff --git a/tests/var.test b/tests/var.test index a5b91f8..3ca1a76 100644 --- a/tests/var.test +++ b/tests/var.test @@ -8,19 +8,19 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testupvar [llength [info commands testupvar]] testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] @@ -203,27 +203,27 @@ test var-1.19 {TclLookupVar, right error message when parsing variable name} -bo [format set] thisvar(doesntexist) } -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable} test var-1.20 {TclLookupVar, regression on utf-8 variable names} -setup { - proc p [list \u20ac \xe4] {info vars} + proc p [list € ä] {info vars} } -body { # test variable with non-ascii name is available (euro and a-uml chars here): list \ [p 1 2] \ - [apply [list [list \u20ac \xe4] {info vars}] 1 2] \ - [apply [list [list [list \u20ac \u20ac] [list \xe4 \xe4]] {info vars}]] \ + [apply [list [list € ä] {info vars}] 1 2] \ + [apply [list [list [list € €] [list ä ä]] {info vars}]] \ } -cleanup { rename p {} -} -result [lrepeat 3 [list \u20ac \xe4]] +} -result [lrepeat 3 [list € ä]] test var-1.21 {TclLookupVar, regression on utf-8 variable names} -setup { - proc p [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]} + proc p [list [list € v€] [list ä vä]] {list [set €] [set ä]} } -body { # test variable with non-ascii name (and default) is resolvable (euro and a-uml chars here): list \ [p] \ - [apply [list [list \u20ac \xe4] {list [set \u20ac] [set \xe4]}] v\u20ac v\xe4] \ - [apply [list [list [list \u20ac v\u20ac] [list \xe4 v\xe4]] {list [set \u20ac] [set \xe4]}]] \ + [apply [list [list € ä] {list [set €] [set ä]}] v€ vä] \ + [apply [list [list [list € v€] [list ä vä]] {list [set €] [set ä]}]] \ } -cleanup { rename p {} -} -result [lrepeat 3 [list v\u20ac v\xe4]] +} -result [lrepeat 3 [list v€ vä]] test var-2.1 {Tcl_LappendObjCmd, create var if new} { catch {unset x} @@ -452,7 +452,7 @@ test var-7.4 {Tcl_VariableObjCmd, list of vars} -setup { variable three 3 four 4 } list [lsort [info vars test_ns_var::*]] \ - [namespace eval test_ns_var {expr $three+$four}] + [namespace eval test_ns_var {expr {$three+$four}}] } -result [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { catch {unset a} @@ -1040,15 +1040,15 @@ test var-22.0 {leak in array element unset: Bug a3309d01db} -setup { } -result 0 test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup { proc doit {} { - interp create slave - slave eval { + interp create child + child eval { proc doit script { eval $script set foo bar } doit {foreach foo baz {}} } - interp delete slave + interp delete child } } -constraints memory -body { set end [getbytes] diff --git a/tests/while-old.test b/tests/while-old.test index ee17d0b..9c8cacc 100644 --- a/tests/while-old.test +++ b/tests/while-old.test @@ -6,21 +6,21 @@ # into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } test while-old-1.1 {basic while loops} { set count 0 - while {$count < 10} {set count [expr $count+1]} + while {$count < 10} {set count [expr {$count + 1}]} set count } 10 test while-old-1.2 {basic while loops} { @@ -58,9 +58,9 @@ test while-old-2.1 {continue in while loop} { set index 0 set result {} while {$index < 5} { - if {$index == 2} {set index [expr $index+1]; continue} + if {$index == 2} {set index [expr {$index + 1}]; continue} set result [concat $result [lindex $list $index]] - set index [expr $index+1] + set index [expr {$index + 1}] } set result } {1 2 4 5} @@ -72,7 +72,7 @@ test while-old-3.1 {break in while loop} { while {$index < 5} { if {$index == 3} break set result [concat $result [lindex $list $index]] - set index [expr $index+1] + set index [expr {$index + 1}] } set result } {1 2 3} diff --git a/tests/while.test b/tests/while.test index 642ec93..6ea8548 100644 --- a/tests/while.test +++ b/tests/while.test @@ -4,14 +4,14 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -77,7 +77,7 @@ test while-1.9 {TclCompileWhileCmd: simple command body} -body { set a {} set i 1 while {$i<6} { - if $i==4 break + if {$i==4} break set a [concat $a $i] incr i } @@ -112,8 +112,8 @@ test while-1.12 {TclCompileWhileCmd: long command body} -body { set a {} set i 1 while {$i<6} { - if $i==4 break - if $i>5 continue + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -155,7 +155,7 @@ test while-1.13 {TclCompileWhileCmd: while command result} -body { } -result {} test while-1.14 {TclCompileWhileCmd: while command result} -body { set i 0 - set a [while {$i < 5} {if $i==3 break; incr i}] + set a [while {$i < 5} {if {$i==3} break; incr i}] return $a } -cleanup { unset a i @@ -207,9 +207,9 @@ test while-2.4 {continue tests, long command body} -body { set a {} set i 1 while {$i<6} { - if $i==2 {incr i; continue} - if $i==4 break - if $i>5 continue + if {$i==2} {incr i; continue} + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -277,9 +277,9 @@ test while-3.3 {break tests, long command body} -body { set a {} set i 1 while {$i<6} { - if $i==2 {incr i; continue} - if $i==5 break - if $i>5 continue + if {$i==2} {incr i; continue} + if {$i==5} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -295,7 +295,7 @@ test while-3.3 {break tests, long command body} -body { catch {incr i 5} msg catch {incr i -5} msg } - if $i==4 break + if {$i==4} break if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -401,7 +401,7 @@ test while-4.10 {while (not compiled): simple command body} -body { set i 1 set z while $z {$i<6} { - if $i==4 break + if {$i==4} break set a [concat $a $i] incr i } @@ -439,8 +439,8 @@ test while-4.13 {while (not compiled): long command body} -body { set z while set i 1 $z {$i<6} { - if $i==4 break - if $i>5 continue + if {$i==4} break + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -484,7 +484,7 @@ test while-4.14 {while (not compiled): while command result} -body { test while-4.15 {while (not compiled): while command result} -body { set i 0 set z while - set a [$z {$i < 5} {if $i==3 break; incr i}] + set a [$z {$i < 5} {if {$i==3} break; incr i}] return $a } -cleanup { unset a i z @@ -538,9 +538,9 @@ test while-5.4 {break tests, long command body with computed command names} -bod set i 1 set z break while {$i<6} { - if $i==2 {incr i; continue} - if $i==5 $z - if $i>5 continue + if {$i==2} {incr i; continue} + if {$i==5} $z + if {$i>5} continue if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -556,7 +556,7 @@ test while-5.4 {break tests, long command body with computed command names} -bod catch {incr i 5} msg catch {incr i -5} msg } - if $i==4 $z + if {$i==4} $z if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg @@ -637,9 +637,9 @@ test while-6.5 {continue tests, long command body with computed command names} - set i 1 set z continue while {$i<6} { - if $i==2 {incr i; continue} - if $i==4 break - if $i>5 $z + if {$i==2} {incr i; continue} + if {$i==4} break + if {$i>5} $z if {$i>6 && $tcl_platform(machine)=="xxx"} { catch {set a $a} msg catch {incr i 5} msg diff --git a/tests/winConsole.test b/tests/winConsole.test index fdde41c..8ca1457 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -4,13 +4,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1999 by Scriptics Corporation. +# Copyright © 1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } diff --git a/tests/winDde.test b/tests/winDde.test index acba304..f57a226 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -4,14 +4,13 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1999 by Scriptics Corporation. +# Copyright © 1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2 - #tcltest::configure -verbose {pass start} + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -20,11 +19,12 @@ testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::ddever [package require dde 1.4.3] - set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} { + set ::ddever [package require dde 1.4.4] + set ::ddelib [info loaded {} Dde]}]} { testConstraint dde 1 } } +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] # ------------------------------------------------------------------------- @@ -38,12 +38,12 @@ proc createChildProcess {ddeServerName args} { set f [open $::scriptName w+] puts $f [list set ddeServerName $ddeServerName] - puts $f [list load $::ddelib dde] + puts $f [list load $::ddelib Dde] puts $f { # DDE child server - # if {"::tcltest" ni [namespace children]} { - package require tcltest + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -104,14 +104,14 @@ proc createChildProcess {ddeServerName args} { # ------------------------------------------------------------------------- test winDde-1.0 {check if we are testing the right dll} {win dde} { set ::ddever -} {1.4.3} +} {1.4.4} test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] } -result {foobar foobar self} test winDde-2.1 {Checking for other services} -constraints dde -body { - expr [llength [dde services {} {}]] >= 0 + expr {[llength [dde services {} {}]] >= 0} } -result 1 test winDde-2.2 {Checking for existence, with service and topic specified} \ -constraints dde -body { @@ -119,11 +119,11 @@ test winDde-2.2 {Checking for existence, with service and topic specified} \ } -result 1 test winDde-2.3 {Checking for existence, with only the service specified} \ -constraints dde -body { - expr [llength [dde services TclEval {}]] >= 1 + expr {[llength [dde services TclEval {}]] >= 1} } -result 1 test winDde-2.4 {Checking for existence, with only the topic specified} \ -constraints dde -body { - expr [llength [dde services {} self]] >= 1 + expr {[llength [dde services {} self]] >= 1} } -result 1 # ------------------------------------------------------------------------- @@ -154,15 +154,15 @@ test winDde-3.5 {DDE request locally} -constraints dde -body { dde request -binary TclEval self \xe1 } -result "foo\x00" # Set variable a to A with diaeresis (unicode C4) by relying on the fact -# that utf8 is sent (e.g. "c3 84" on the wire) -test winDde-3.6 {DDE request utf8} -constraints dde -body { +# that utf-8 is sent (e.g. "c3 84" on the wire) +test winDde-3.6 {DDE request utf-8} -constraints dde -body { set \xe1 "not set" dde execute TclEval self "set \xe1 \xc4" scan [set \xe1] %c } -result 196 # Set variable a to A with diaeresis (unicode C4) using binary execute # and compose utf-8 (e.g. "c3 84" ) manualy -test winDde-3.7 {DDE request binary} -constraints dde -body { +test winDde-3.7 {DDE request binary} -constraints {dde notWine} -body { set \xe1 "not set" dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00] scan [set \xe1] %c @@ -279,19 +279,19 @@ test winDde-6.6 {DDE remote servername collision force} -constraints {dde stdio} # ------------------------------------------------------------------------- -test winDde-7.1 {Load DDE in slave interpreter} -constraints dde -setup { - interp create slave +test winDde-7.1 {Load DDE in child interpreter} -constraints dde -setup { + interp create child } -body { - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.1] + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.1] } -cleanup { - interp delete slave + interp delete child } -result {dde-interp-7.1} -test winDde-7.2 {DDE slave cleanup} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.5] - interp delete slave +test winDde-7.2 {DDE child cleanup} -constraints dde -setup { + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.5] + interp delete child } -body { dde services TclEval {} set s [dde services TclEval {}] @@ -300,128 +300,128 @@ test winDde-7.2 {DDE slave cleanup} -constraints dde -setup { set s } } -result {} -test winDde-7.3 {DDE present in slave interp} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.3] +test winDde-7.3 {DDE present in child interp} -constraints dde -setup { + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.3] } -body { dde services TclEval dde-interp-7.3 } -cleanup { - interp delete slave + interp delete child } -result {{TclEval dde-interp-7.3}} test winDde-7.4 {interp name collision with -force} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.4] + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.4] } -body { dde servername -force -- dde-interp-7.4 } -cleanup { - interp delete slave + interp delete child } -result {dde-interp-7.4} test winDde-7.5 {interp name collision without -force} -constraints dde -setup { - interp create slave - slave eval [list load $::ddelib Dde] - slave eval [list dde servername -- dde-interp-7.5] + interp create child + child eval [list load $::ddelib Dde] + child eval [list dde servername -- dde-interp-7.5] } -body { dde servername -- dde-interp-7.5 } -cleanup { - interp delete slave + interp delete child } -result "dde-interp-7.5 #2" # ------------------------------------------------------------------------- test winDde-8.1 {Safe DDE load} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde + interp create -safe child + child invokehidden load $::ddelib Dde } -body { - slave eval dde servername slave + child eval dde servername child } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {invalid command name "dde"} test winDde-8.2 {Safe DDE set servername} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde + interp create -safe child + child invokehidden load $::ddelib Dde } -body { - slave invokehidden dde servername slave -} -cleanup {interp delete slave} -result {slave} + child invokehidden dde servername child +} -cleanup {interp delete child} -result {child} test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - catch {dde eval slave set a 1} msg -} -cleanup {interp delete slave} -result {1} + catch {dde eval child set a 1} msg +} -cleanup {interp delete child} -result {1} test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - slave eval set a 1 - dde execute TclEval slave {set a 2} - slave eval set a -} -cleanup {interp delete slave} -result 1 + child eval set a 1 + dde execute TclEval child {set a 2} + child eval set a +} -cleanup {interp delete child} -result 1 test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave invokehidden dde servername slave + interp create -safe child + child invokehidden load $::ddelib Dde + child invokehidden dde servername child } -body { - slave eval set a 1 - dde request TclEval slave a + child eval set a 1 + dde request TclEval child a } -cleanup { - interp delete slave + interp delete child } -returnCodes error -result {remote server cannot handle this command} test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} } -body { - slave invokehidden dde servername -handler DDEACCEPT slave -} -cleanup {interp delete slave} -result slave + child invokehidden dde servername -handler DDEACCEPT child +} -cleanup {interp delete child} -result child test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave set x 1 -} -cleanup {interp delete slave} -result {set x 1} + dde eval child set x 1 +} -cleanup {interp delete child} -result {set x 1} test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} + child invokehidden dde servername -handler DDEACCEPT child } -body { set s "c:\\Program Files\\Microsoft Visual Studio\\" - dde eval slave $s - string equal [slave eval set DDECMD] $s -} -cleanup {interp delete slave} -result 1 + dde eval child $s + string equal [child eval set DDECMD] $s +} -cleanup {interp delete child} -result 1 test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave set \xe1 1 - slave eval set \xe1 -} -cleanup {interp delete slave} -result 1 + dde eval child set \xe1 1 + child eval set \xe1 +} -cleanup {interp delete child} -result 1 test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave [list set x 1] - slave eval set x -} -cleanup {interp delete slave} -result 1 + dde eval child [list set x 1] + child eval set x +} -cleanup {interp delete child} -result 1 test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup { - interp create -safe slave - slave invokehidden load $::ddelib Dde - slave eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} - slave invokehidden dde servername -handler DDEACCEPT slave + interp create -safe child + child invokehidden load $::ddelib Dde + child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} + child invokehidden dde servername -handler DDEACCEPT child } -body { - dde eval slave [list [list set x 1]] - slave eval set x -} -cleanup {interp delete slave} -returnCodes error -result {invalid command name "set x 1"} + dde eval child [list [list set x 1]] + child eval set x +} -cleanup {interp delete child} -returnCodes error -result {invalid command name "set x 1"} # ------------------------------------------------------------------------- @@ -481,7 +481,7 @@ test winDde-9.4 {External safe DDE check null data passing} -constraints {dde st # ------------------------------------------------------------------------- #cleanup -#catch {interp delete $slave}; # ensure we clean up the slave. +#catch {interp delete $child}; # ensure we clean up the child. file delete -force $::scriptName ::tcltest::cleanupTests return diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 2bce77c..d118725 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -4,31 +4,32 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1996-1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] # Initialise the test constraints -testConstraint winVista 0 -testConstraint winXP 0 testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint testfile [llength [info commands testfile]] testConstraint testchmod [llength [info commands testchmod]] testConstraint cdrom 0 testConstraint exdev 0 testConstraint longFileNames 0 -testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] +# Some things fail under all Continuous Integration systems for subtle reasons +# such as CI often running with elevated privileges in a container. +testConstraint notInCIenv [expr {![info exists ::env(CI)]}] +testConstraint knownMsvcBug [expr {![info exists ::env(CI_BUILD_WITH_MSVC)]}] proc createfile {file {string a}} { set f [open $file w] @@ -56,14 +57,6 @@ proc cleanup {args} { } } -if {[testConstraint win]} { - if {$::tcl_platform(osVersion) >= 5.0} { - testConstraint winVista 1 - } else { - testConstraint winXP 1 - } -} - # find a CD-ROM so we can test read-only filesystems. proc findfile {dir} { @@ -132,25 +125,25 @@ test winFCmd-1.1 {TclpRenameFile: errno: EACCES} -body { } -constraints {win cdrom testfile} -returnCodes error -result EACCES test winFCmd-1.2 {TclpRenameFile: errno: EEXIST} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1/td2/td3 file mkdir td2 testfile mv td2 td1/td2 } -returnCodes error -result EEXIST test winFCmd-1.3 {TclpRenameFile: errno: EINVAL} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { testfile mv / td1 } -returnCodes error -result EINVAL test winFCmd-1.4 {TclpRenameFile: errno: EINVAL} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1 testfile mv td1 td1/td2 } -returnCodes error -result EINVAL test winFCmd-1.5 {TclpRenameFile: errno: EISDIR} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1 createfile tf1 testfile mv tf1 td1 @@ -203,11 +196,6 @@ test winFCmd-1.12 {TclpRenameFile: errno: EACCES} -setup { } -cleanup { catch {close $fd} } -returnCodes error -result EACCES -test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup { - cleanup -} -constraints {win winXP testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EINVAL test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup { cleanup } -constraints {win testfile} -body { @@ -231,11 +219,6 @@ test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} -setup { } -constraints {win testfile} -body { testfile mv tf1 tf2 } -returnCodes error -result ENOENT -test winFCmd-1.19 {TclpRenameFile: errno == EACCES} -setup { - cleanup -} -constraints {win winXP testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EINVAL test winFCmd-1.20 {TclpRenameFile: src is dir} -setup { cleanup } -constraints {win testfile} -body { @@ -255,7 +238,7 @@ test winFCmd-1.22 {TclpRenameFile: long dst} -setup { } -returnCodes error -result ENAMETOOLONG test winFCmd-1.23 {TclpRenameFile: move dir into self} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1 testfile mv [pwd]/td1 td1/td2 } -returnCodes error -result EINVAL @@ -300,21 +283,21 @@ test winFCmd-1.29 {TclpRenameFile: src is dir} -setup { } -returnCodes error -result ENOTDIR test winFCmd-1.30 {TclpRenameFile: dst is dir} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1 file mkdir td2/td2 testfile mv td1 td2 } -returnCodes error -result EEXIST test winFCmd-1.31 {TclpRenameFile: TclpRemoveDirectory fails} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1 file mkdir td2/td2 testfile mv td1 td2 } -returnCodes error -result EEXIST test winFCmd-1.32 {TclpRenameFile: TclpRemoveDirectory succeeds} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1/td2 file mkdir td2 testfile mv td1 td2 @@ -343,7 +326,7 @@ test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} -setup { } -returnCodes error -result ENOTDIR test winFCmd-1.35 {TclpRenameFile: src is not dir, dst is} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { file mkdir td1 createfile tf1 testfile mv tf1 td1 @@ -384,7 +367,7 @@ proc MakeFiles {dirname} { set f [open $filename w] close $f file stat $filename stat - if {[set n [lsearch -exact -integer $inodes $stat(ino)]] != -1} { + if {[set n [lsearch -exact -integer $inodes $stat(ino)]] >= 0} { return [list [file join $dirname Test$n] $filename] } lappend inodes $stat(ino) @@ -394,7 +377,7 @@ proc MakeFiles {dirname} { test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup { cleanup -} -constraints {win winNonZeroInodes knownMsvcBug} -body { +} -constraints {win winNonZeroInodes knownMsvcBug notInCIenv} -body { file mkdir td1 foreach {a b} [MakeFiles td1] break file rename -force $a $b @@ -444,11 +427,6 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} -setup { } -cleanup { cleanup } -returnCodes error -result ENOENT -test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup { - cleanup -} -constraints {win winXP testfile} -body { - testfile cp nul tf1 -} -returnCodes error -result EINVAL test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup { cleanup } -constraints {win testfile} -body { @@ -639,7 +617,7 @@ test winFCmd-5.1 {TclpCopyDirectory: calls TraverseWinTree} -setup { test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup { cleanup -} -constraints {winVista testfile testchmod knownMsvcBug} -body { +} -constraints {win testfile testchmod knownMsvcBug notInCIenv} -body { file mkdir td1 testchmod 0 td1 testfile rmdir td1 @@ -693,7 +671,7 @@ test winFCmd-6.8 {TclpRemoveDirectory: RemoveDirectory fails} -setup { } -result {1 {tf1 ENOTDIR}} test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { cleanup -} -constraints {winVista testfile testchmod knownMsvcBug} -body { +} -constraints {win testfile testchmod knownMsvcBug notInCIenv} -body { file mkdir td1 testchmod 0 td1 testfile rmdir td1 @@ -704,14 +682,14 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { } -result {td1 EACCES} test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { cleanup -} -constraints {win testfile} -body { +} -constraints {win testfile notInCIenv} -body { testfile rmdir / # WinXP returns EEXIST, WinNT seems to return EACCES. No policy # decision has been made as to which is correct. } -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$} test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { cleanup -} -constraints {winVista testfile testchmod knownMsvcBug} -body { +} -constraints {win testfile testchmod knownMsvcBug notInCIenv} -body { file mkdir td1 testchmod 0 td1 testfile rmdir td1 @@ -940,7 +918,7 @@ test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup { } -result {} test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup { cleanup -} -constraints {winVista testfile testchmod knownMsvcBug} -body { +} -constraints {win testfile testchmod knownMsvcBug notInCIenv} -body { file mkdir td1/td2 testchmod 0 td1 testfile rmdir -force td1 @@ -1053,15 +1031,7 @@ test winFCmd-12.4 {ConvertFileNameFormat} -constraints {win} -setup { test winFCmd-12.5 {ConvertFileNameFormat: absolute path} -body { list [file attributes / -longname] [file attributes \\ -longname] } -constraints {win} -result {/ /} -test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup { - catch {file delete -force -- c:/TclTmpC.1} -} -constraints {win winXP} -body { - createfile c:/TclTmpC.1 {} - string tolower [file attributes c:/TclTmpC.1 -longname] -} -cleanup { - file delete -force -- c:/TclTmpC.1 -} -result [string tolower {c:/TclTmpC.1}] -test winFCmd-12.6.2 {ConvertFileNameFormat: absolute path with drive (in temp folder)} -setup { +test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive (in temp folder)} -setup { catch {file delete -force -- $::env(TEMP)/td1} } -constraints {win} -body { createfile $::env(TEMP)/td1 {} @@ -1129,7 +1099,7 @@ test winFCmd-15.2 {SetWinFileAttributes - archive} -constraints {win} -setup { } -cleanup { cleanup } -result {{} 1} -test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win} -setup { +test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win notInCIenv} -setup { cleanup } -body { createfile td1 {} @@ -1137,7 +1107,7 @@ test winFCmd-15.3 {SetWinFileAttributes - archive} -constraints {win} -setup { } -cleanup { cleanup } -result {{} 0} -test winFCmd-15.4 {SetWinFileAttributes - hidden} -constraints {win} -setup { +test winFCmd-15.4 {SetWinFileAttributes - hidden} -constraints {win notInCIenv} -setup { cleanup } -body { createfile td1 {} @@ -1170,7 +1140,7 @@ test winFCmd-15.7 {SetWinFileAttributes - readonly} -setup { } -cleanup { cleanup } -result {{} 0} -test winFCmd-15.8 {SetWinFileAttributes - system} -constraints {win} -setup { +test winFCmd-15.8 {SetWinFileAttributes - system} -constraints {win notInCIenv} -setup { cleanup } -body { createfile td1 {} diff --git a/tests/winFile.test b/tests/winFile.test index b288063..0c13a0e 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -4,20 +4,19 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." - return +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* } -namespace import -force ::tcltest::* ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint notNTFS 0 @@ -25,6 +24,7 @@ testConstraint notNTFS 0 if {[testConstraint testvolumetype]} { testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}] } +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] test winFile-1.1 {TclpGetUserHome} -constraints {win} -body { glob ~nosuchuser @@ -151,7 +151,7 @@ if {[testConstraint win]} { test winFile-4.0 { Enhanced NTFS user/group permissions: test no acccess } -constraints { - win notNTFS + win notNTFS notWine } -setup { set owner [getuser $fname] set user $::env(USERDOMAIN)\\$::env(USERNAME) @@ -166,7 +166,7 @@ test winFile-4.0 { test winFile-4.1 { Enhanced NTFS user/group permissions: test readable only } -constraints { - win notNTFS + win notNTFS notWine } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -177,7 +177,7 @@ test winFile-4.1 { test winFile-4.2 { Enhanced NTFS user/group permissions: test writable only } -constraints { - win notNTFS + win notNTFS notWine } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { diff --git a/tests/winNotify.test b/tests/winNotify.test index 3e9aa29..52502a2 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.test @@ -4,19 +4,19 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testeventloop [expr {[info commands testeventloop] != {}}] diff --git a/tests/winPipe.test b/tests/winPipe.test index 7e01c5f..28d4f5b 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -6,26 +6,31 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output (except for one message) means no errors were found. # -# Copyright (c) 1996 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest -namespace import -force ::tcltest::* +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} unset -nocomplain path catch { ::tcltest::loadTestedCommands - package require -exact Tcltest [info patchlevel] - set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] + package require -exact tcl::test [info patchlevel] + set ::tcltestlib [info loaded {} Tcltest] } set org_pwd [pwd] set bindir [file join $org_pwd [file dirname [info nameofexecutable]]] set cat32 [file join $bindir cat32.exe] +testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] + + # several test-cases here expect current directory == [temporaryDirectory]: cd [temporaryDirectory] @@ -169,7 +174,7 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \ {win exec cat32} { set f [open "|[list $cat32]" r+] puts $f $big - puts $f \032 + puts $f \x1A flush $f set r [read $f 64] catch {close $f} @@ -195,7 +200,7 @@ test winpipe-4.1 {Tcl_WaitPid} {win exec cat32} { vwait x list $result $x [contents $path(stderr)] } "{$big} 1 stderr32" -test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} { +test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -203,7 +208,7 @@ test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec test set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] } {1 1 SIGFPE} -test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept} { +test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -211,7 +216,7 @@ test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec tes set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] } {1 1 SIGSEGV} -test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept} { +test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -219,7 +224,7 @@ test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec test set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] } {1 1 SIGILL} -test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept} { +test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept notWine} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] puts $f "load $::tcltestlib Tcltest" @@ -517,7 +522,7 @@ test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: check injection on s } -result {} test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (jointly)} \ --constraints {win exec} -body { +-constraints {win exec notWine} -body { _testExecArgs 0 \ [list START {*}$injectList END] \ [list "START\"" {*}$injectList END] \ @@ -526,7 +531,7 @@ test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: check injection on s } -result {} test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (command/jointly args)} \ --constraints {win exec} -body { +-constraints {win exec notWine} -body { _testExecArgs 2 \ [list START {*}$injectList END] \ [list "START\"" {*}$injectList END] \ @@ -535,7 +540,7 @@ test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: check injection on s } -result {} test winpipe-8.5 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (random mix)} \ --constraints {win exec} -body { +-constraints {win exec notWine} -body { set lst {} set maps { {\&|^<>!()%} diff --git a/tests/winTime.test b/tests/winTime.test index dbaa14c..ae1797d 100644 --- a/tests/winTime.test +++ b/tests/winTime.test @@ -4,22 +4,24 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1997 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] +catch [list package require -exact tcl::test [info patchlevel]] testConstraint testwinclock [llength [info commands testwinclock]] -testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}] +# Some things fail under all Continuous Integration systems for subtle reasons +# such as CI often running with elevated privileges in a container. +testConstraint notInCIenv [expr {![info exists ::env(CI)]}] # The next two tests will crash on Windows if the check for negative # clock values is not done properly. @@ -41,7 +43,7 @@ test winTime-1.2 {TclpGetDate} {win} { # with the Windows clock. 30 sec really isn't enough, # but how much time does a tester have patience for? -test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock knownMsvcBug} { +test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock notInCIenv} { # May fail due to OS/hardware discrepancies. See: # http://support.microsoft.com/default.aspx?scid=kb;en-us;274323 set failed {} diff --git a/tests/zipfs.test b/tests/zipfs.test index 2ecbdfa..bf9c969 100644 --- a/tests/zipfs.test +++ b/tests/zipfs.test @@ -4,14 +4,14 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1996-1998 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -20,18 +20,13 @@ testConstraint zipfs [expr { }] testConstraint zipfslib 1 -# Removed in tip430 - zipfs is no longer a static package -#test zipfs-0.0 {zipfs basics} -constraints zipfs -body { -# load {} zipfs -#} -result {} - set ziproot [zipfs root] set CWD [pwd] set tmpdir [file join $CWD tmp] file mkdir $tmpdir test zipfs-0.0 {zipfs basics} -constraints zipfs -body { - package require zipfs + package require tcl::zipfs } -result {2.0} test zipfs-0.1 {zipfs basics} -constraints zipfs -body { expr {${ziproot} in [file volumes]} @@ -44,7 +39,7 @@ if {![string match ${ziproot}* $tcl_library]} { # Hack the environment to pretend we did pull tcl_library from a zip # archive ### - set tclzip [file join $CWD [::tcl::pkgconfig get zipfile,runtime]] + set tclzip [file join $CWD libtcl[info patchlevel].zip] testConstraint zipfslib [file isfile $tclzip] if {[testConstraint zipfslib]} { zipfs mount /lib/tcl $tclzip @@ -275,6 +270,137 @@ test zipfs-3.4 {zipfs in child interpreters} -constraints zipfs -setup { } -returnCodes error -cleanup { interp delete $safe } -result {not allowed to invoke subcommand mkzip of zipfs} + +test zipfs-4.1 {zipfs lmkimg} -constraints zipfs -setup { + set baseImage [makeFile "return sourceWorking\n\x1A" base] + set targetImage [makeFile "" target] + set addFile [makeFile "return mountWorking" add.data] + file delete $targetImage +} -body { + zipfs lmkimg $targetImage [list $addFile test/add.tcl] {} $baseImage + zipfs mount ziptest $targetImage + try { + list [source $targetImage] [source //zipfs:/ziptest/test/add.tcl] + } finally { + zipfs unmount ziptest + } +} -cleanup { + removeFile $baseImage + removeFile $targetImage + removeFile $addFile +} -result {sourceWorking mountWorking} +test zipfs-4.2 {zipfs lmkimg: making an image from an image} -constraints zipfs -setup { + set baseImage [makeFile "return sourceWorking\n\x1A" base_image.tcl] + set midImage [makeFile "" mid_image.tcl] + set targetImage [makeFile "" target_image.tcl] + set addFile [makeFile "return mountWorking" add.data] + file delete $midImage $targetImage +} -body { + zipfs lmkimg $midImage [list $addFile test/ko.tcl] {} $baseImage + zipfs lmkimg $targetImage [list $addFile test/ok.tcl] {} $midImage + zipfs mount ziptest $targetImage + try { + list [glob -tails -directory //zipfs://ziptest/test *.tcl] \ + [if {[file size $midImage] == [file size $targetImage]} { + string cat equal + } else { + list mid=[file size $midImage] target=[file size $targetImage] + }] + } finally { + zipfs unmount ziptest + } +} -cleanup { + removeFile $baseImage + removeFile $midImage + removeFile $targetImage + removeFile $addFile +} -result {ok.tcl equal} +test zipfs-4.3 {zipfs lmkimg: stripping password} -constraints zipfs -setup { + set baseImage [makeFile "return sourceWorking\n\x1A" base_image.tcl] + set midImage [makeFile "" mid_image.tcl] + set targetImage [makeFile "" target_image.tcl] + set addFile [makeFile "return mountWorking" add.data] + file delete $midImage $targetImage +} -body { + set pass gorp + zipfs lmkimg $midImage [list $addFile test/add.tcl] $pass $baseImage + zipfs lmkimg $targetImage [list $addFile test/ok.tcl] {} $midImage + zipfs mount ziptest $targetImage + try { + glob -tails -directory //zipfs://ziptest/test *.tcl + } finally { + zipfs unmount ziptest + } +} -cleanup { + removeFile $baseImage + removeFile $midImage + removeFile $targetImage + removeFile $addFile +} -result {ok.tcl} +test zipfs-4.4 {zipfs lmkimg: final password} -constraints zipfs -setup { + set baseImage [makeFile "return sourceWorking\n\x1A" base_image.tcl] + set midImage [makeFile "" mid_image.tcl] + set targetImage [makeFile "" target_image.tcl] + set addFile [makeFile "return mountWorking" add.data] + file delete $midImage $targetImage +} -body { + set pass gorp + zipfs lmkimg $midImage [list $addFile test/add.tcl] {} $baseImage + zipfs lmkimg $targetImage [list $addFile test/ok.tcl] $pass $midImage + zipfs mount ziptest $targetImage + try { + glob -tails -directory //zipfs://ziptest/test *.tcl + } finally { + zipfs unmount ziptest + } +} -cleanup { + removeFile $baseImage + removeFile $midImage + removeFile $targetImage + removeFile $addFile +} -result {ok.tcl} +test zipfs-4.5 {zipfs lmkimg: making image from mounted} -constraints zipfs -setup { + set baseImage [makeFile "return sourceWorking\n\x1A" base_image.tcl] + set midImage [makeFile "" mid_image.tcl] + set targetImage [makeFile "" target_image.tcl] + set addFile [makeFile "return mountWorking" add.data] + file delete $midImage $targetImage +} -body { + zipfs lmkimg $midImage [list $addFile test/add.tcl] {} $baseImage + zipfs mount ziptest $midImage + set f [glob -directory //zipfs://ziptest/test *.tcl] + zipfs lmkimg $targetImage [list $f test/ok.tcl] {} $midImage + zipfs unmount ziptest + zipfs mount ziptest $targetImage + list $f [glob -directory //zipfs://ziptest/test *.tcl] +} -cleanup { + zipfs unmount ziptest + removeFile $baseImage + removeFile $midImage + removeFile $targetImage + removeFile $addFile +} -result {//zipfs://ziptest/test/add.tcl //zipfs://ziptest/test/ok.tcl} + +test zipfs-5.1 {zipfs mount_data: short data} -constraints zipfs -body { + zipfs mount_data gorp {} +} -returnCodes error -result {bad zip data} +test zipfs-5.2 {zipfs mount_data: short data} -constraints zipfs -body { + zipfs mount_data gorp gorpGORPgorp +} -returnCodes error -result {bad zip data} +test zipfs-5.3 {zipfs mount_data: short data} -constraints zipfs -body { + set data PK\x03\x04..................................... + append data PK\x01\x02..................................... + append data PK\x05\x06..................................... + zipfs mount_data gorp $data +} -returnCodes error -result {bad zip data} +test zipfs-5.4 {zipfs mount_data: bad arg count} -constraints zipfs -body { + zipfs mount_data gorp {} foobar +} -returnCodes error -result {wrong # args: should be "zipfs mount_data ?mountpoint? ?data?"} + +test zipfs-6.1 {zipfs mkkey} -constraints zipfs -body { + binary scan [zipfs mkkey gorp] cu* x + return $x +} -result {224 226 111 103 4 80 75 90 90} ::tcltest::cleanupTests return diff --git a/tests/zlib.test b/tests/zlib.test index c2f7825..7de6d64 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -4,14 +4,14 @@ # commands. Sourcing this file into Tcl runs the tests and generates output # for errors. No output means no errors were found. # -# Copyright (c) 1996-1998 by Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright © 1996-1998 Sun Microsystems, Inc. +# Copyright © 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {"::tcltest" ni [namespace children]} { - package require tcltest 2.1 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -34,7 +34,7 @@ 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 + package present tcl::zlib } -result 2.0.1 test zlib-2.1 {zlib compress/decompress} zlib { @@ -140,7 +140,7 @@ test zlib-7.7 {zlib stream: Bug 25842c161} -constraints zlib -body { } -result "" # Also causes Tk Bug 10f2e7872b test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup { - expr srand(12345) + expr {srand(12345)} set randdata {} for {set i 0} {$i<6001} {incr i} { append randdata [binary format c [expr {int(256*rand())}]] @@ -451,7 +451,7 @@ test zlib-8.16 {Bug 3603553: buffer transfer with large writes} -setup { # Actual data isn't very important; needs to be substantially larger than # the internal buffer (32kB) and incompressible. set largeData {} - for {set i 0;expr srand(1)} {$i < 100000} {incr i} { + for {set i 0;expr {srand(1)}} {$i < 100000} {incr i} { append largeData [lindex "a b c d e f g h i j k l m n o p" \ [expr {int(16*rand())}]] } @@ -920,7 +920,7 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints { rename zlibRead {} } -result {error {invalid block type}} -test zlib-11.1 "Bug #3390073: mis-appled gzip filtering" -setup { +test zlib-11.1 "Bug #3390073: mis-applied gzip filtering" -setup { set file [makeFile {} test.input] } -constraints zlib -body { set f [open $file wb] @@ -934,7 +934,7 @@ test zlib-11.1 "Bug #3390073: mis-appled gzip filtering" -setup { } -cleanup { removeFile $file } -result {1000 0} -test zlib-11.2 "Bug #3390073: mis-appled gzip filtering" -setup { +test zlib-11.2 "Bug #3390073: mis-applied gzip filtering" -setup { set file [makeFile {} test.input] } -constraints zlib -body { set f [open $file wb] @@ -1005,6 +1005,86 @@ test zlib-12.2 {Patrick Dunnigan's issue} -constraints zlib -setup { removeFile $filesrc removeFile $filedst } -result 56 + +set zlibbinf "" +proc _zlibbinf {} { + # inlined zlib.bin file creator: + variable zlibbinf + if {$zlibbinf eq ""} { + set zlibbinf [makeFile {} test-zlib-13.bin] + set f [open $zlibbinf wb] + puts -nonewline $f [zlib decompress [binary decode base64 { + eJx7e+6s1+EAgYaLjK3ratptGmOck0vT/y/ZujHAd0qJelDBXfUPJ3tfrtLbpX+wOOFHmtn03/tizm + /+tXROXU3d203b79p5X6/0cvUyFzTsqOj4sa9r8SrZI5zT7265e2Xzq595Fb9LbpgffVy7cZaJ/d15 + 4U9L7LLM2vdqut8+aSU/r6q9Ltv6+T9mBhTgIK97bH33m/O1C1eBwf9FDKNgaIDaj9wA+5hToA== + }]] + close $f + } + return $zlibbinf +} +test zlib-13.1 {Ticket [8af92dfb66] - zlib stream mis-expansion} -constraints zlib -setup { + set pathin [_zlibbinf] + set chanin [open $pathin rb] + set pathout [makeFile {} test-zlib-13.deflated] + set chanout [open $pathout wb] + zlib push inflate $chanin + fcopy $chanin $chanout + close $chanin + close $chanout +} -body { + file size $pathout +} -cleanup { + removeFile $pathout + unset chanin pathin chanout pathout +} -result 458752 + +test zlib-13.2 {Ticket [f70ce1fead] - zlib multi-stream expansion} -constraints zlib -setup { + # Start from the basic asset + set pathin [_zlibbinf] + set chanin [open $pathin rb] + # Create a multi-stream by copying the asset twice into it. + set pathout [makeFile {} test-zlib-13.multi] + set chanout [open $pathout wb] + fcopy $chanin $chanout + seek $chanin 0 start + fcopy $chanin $chanout + close $chanin + close $chanout + # The multi-stream file shall be our input + set pathin $pathout + set chanin [open $pathin rb] + # And our destinations + set pathout1 [makeFile {} test-zlib-13.multi-1] + set pathout2 [makeFile {} test-zlib-13.multi-2] +} -body { + # Decode first stream + set chanout [open $pathout1 wb] + zlib push inflate $chanin + fcopy $chanin $chanout + chan pop $chanin + close $chanout + # Decode second stream + set chanout [open $pathout2 wb] + zlib push inflate $chanin + fcopy $chanin $chanout + chan pop $chanin + close $chanout + # + list [file size $pathout1] [file size $pathout2] +} -cleanup { + close $chanin + removeFile $pathout + removeFile $pathout1 + removeFile $pathout2 + unset chanin pathin chanout pathout pathout1 pathout2 +} -result {458752 458752} + +if {$zlibbinf ne ""} { + removeFile $zlibbinf +} +unset zlibbinf +rename _zlibbinf {} + ::tcltest::cleanupTests return |